lib/tap-driver.pl

   1 #! /usr/bin/env perl
   2 # Copyright (C) 2011 Free Software Foundation, Inc.
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2, or (at your option)
   7 # any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17 # As a special exception to the GNU General Public License, if you
  18 # distribute this file as part of a program that contains a
  19 # configuration script generated by Autoconf, you may include it under
  20 # the same distribution terms that you use for the rest of that program.
  21
  22 # This file is maintained in Automake, please report
  23 # bugs to <bug-automake@gnu.org> or send patches to
  24 # <automake-patches@gnu.org>.
  25
  26 # ---------------------------------- #
  27 #  Imports, static data, and setup.  #
  28 # ---------------------------------- #
  29
  30 use warnings FATAL => 'all';
  31 use strict;
  32 use Getopt::Long ();
  33 use TAP::Parser;
  34
  35 my $VERSION = '2011-09-07.15'; # UTC
  36
  37 my $ME = "tap-driver.pl";
  38
  39 my $USAGE = <<'END';
  40 Usage:
  41   tap-driver --test-name=NAME --log-file=PATH --trs-file=PATH
  42              [--expect-failure={yes|no}] [--color-tests={yes|no}]
  43              [--enable-hard-errors={yes|no}] [--ignore-exit]
  44              [--diagnostic-string=STRING] [--merge|--no-merge]
  45              [--comments|--no-comments] [--] TEST-COMMAND
  46 The `--test-name', `--log-file' and `--trs-file' options are mandatory.
  47 END
  48
  49 my $HELP = "$ME: TAP-aware test driver for Automake testsuite harness." .
  50            "\n" . $USAGE;
  51
  52 # Keep this in sync with `lib/am/check.am:$(am__tty_colors)'.
  53 my %COLOR = (
  54   red => "\e[0;31m",
  55   grn => "\e[0;32m",
  56   lgn => "\e[1;32m",
  57   blu => "\e[1;34m",
  58   mgn => "\e[0;35m",
  59   brg => "\e[1m",
  60   std => "\e[m",
  61 );
  62
  63 # It's important that NO_PLAN evaluates "false" as a boolean.
  64 use constant NO_PLAN => 0;
  65 use constant EARLY_PLAN => 1;
  66 use constant LATE_PLAN => 2;
  67
  68 # ------------------- #
  69 #  Global variables.  #
  70 # ------------------- #
  71
  72 my $testno = 0;     # Number of test results seen so far.
  73 my $bailed_out = 0; # Whether a "Bail out!" directive has been seen.
  74 my $parser;         # TAP parser object (will be initialized later).
  75
  76 # Whether the TAP plan has been seen or not, and if yes, which kind
  77 # it is ("early" is seen before any test result, "late" otherwise).
  78 my $plan_seen = NO_PLAN;
  79
  80 # ----------------- #
  81 #  Option parsing.  #
  82 # ----------------- #
  83
  84 my %cfg = (
  85   "color-tests" => 0,
  86   "expect-failure" => 0,
  87   "merge" => 0,
  88   "comments" => 0,
  89   "ignore-exit" => 0,
  90 );
  91
  92 my $test_script_name = undef;
  93 my $log_file = undef;
  94 my $trs_file = undef;
  95 my $diag_string = "#";
  96
  97 Getopt::Long::GetOptions
  98   (
  99     'help' => sub { print $HELP; exit 0; },
 100     'version' => sub { print "$ME $VERSION\n"; exit 0; },
 101     'test-name=s' => \$test_script_name,
 102     'log-file=s' => \$log_file,
 103     'trs-file=s' => \$trs_file,
 104     'color-tests=s'  => \&bool_opt,
 105     'expect-failure=s'  => \&bool_opt,
 106     'enable-hard-errors=s' => sub {}, # No-op.
 107     'diagnostic-string=s' => \$diag_string,
 108     'comments' => sub { $cfg{"comments"} = 1; },
 109     'no-comments' => sub { $cfg{"comments"} = 0; },
 110     'merge' => sub { $cfg{"merge"} = 1; },
 111     'no-merge' => sub { $cfg{"merge"} = 0; },
 112     'ignore-exit' => sub { $cfg{"ignore-exit"} = 1; },
 113   ) or exit 1;
 114
 115 # ------------- #
 116 #  Prototypes.  #
 117 # ------------- #
 118
 119 sub add_test_result ($);
 120 sub bool_opt ($$);
 121 sub colored ($$);
 122 sub copy_in_global_log ();
 123 sub decorate_result ($);
 124 sub extract_tap_comment ($);
 125 sub get_global_test_result ();
 126 sub get_test_exit_message ();
 127 sub get_test_results ();
 128 sub handle_tap_bailout ($);
 129 sub handle_tap_plan ($);
 130 sub handle_tap_result ($);
 131 sub is_null_string ($);
 132 sub main (@);
 133 sub must_recheck ();
 134 sub report ($;$);
 135 sub start (@);
 136 sub stringify_result_obj ($);
 137 sub testsuite_error ($);
 138 sub trap_perl_warnings_and_errors ();
 139 sub write_test_results ();
 140 sub yn ($);
 141
 142 # -------------- #
 143 #  Subroutines.  #
 144 # -------------- #
 145
 146 sub bool_opt ($$)
 147 {
 148   my ($opt, $val) = @_;
 149   if ($val =~ /^(?:y|yes)\z/i)
 150     {
 151       $cfg{$opt} = 1;
 152     }
 153   elsif ($val =~ /^(?:n|no)\z/i)
 154     {
 155       $cfg{$opt} = 0;
 156     }
 157   else
 158     {
 159       die "$ME: invalid argument '$val' for option '$opt'\n";
 160     }
 161 }
 162
 163 # If the given string is undefined or empty, return true, otherwise
 164 # return false.  This function is useful to avoid pitfalls like:
 165 #   if ($message) { print "$message\n"; }
 166 # which wouldn't print anything if $message is the literal "0".
 167 sub is_null_string ($)
 168 {
 169   my $str = shift;
 170   return ! (defined $str and length $str);
 171 }
 172
 173 # Convert a boolean to a "yes"/"no" string.
 174 sub yn ($)
 175 {
 176   my $bool = shift;
 177   return $bool ? "yes" : "no";
 178 }
 179
 180 TEST_RESULTS :
 181 {
 182   my (@test_results_list, %test_results_seen);
 183
 184   sub add_test_result ($)
 185   {
 186     my $res = shift;
 187     push @test_results_list, $res;
 188     $test_results_seen{$res} = 1;
 189   }
 190
 191   sub get_test_results ()
 192   {
 193     return @test_results_list;
 194   }
 195
 196   # Whether the test script should be re-run by "make recheck".
 197   sub must_recheck ()
 198   {
 199     return grep { !/^(?:XFAIL|PASS|SKIP)$/ } (keys %test_results_seen);
 200   }
 201
 202   # Whether the content of the log file associated to this test should
 203   # be copied into the "global" test-suite.log.
 204   sub copy_in_global_log ()
 205   {
 206     return grep { not $_ eq "PASS" } (keys %test_results_seen);
 207   }
 208
 209   # FIXME: this can certainly be improved ...
 210   sub get_global_test_result ()
 211   {
 212     return "ERROR"
 213       if $test_results_seen{"ERROR"};
 214     return "FAIL"
 215       if $test_results_seen{"FAIL"} || $test_results_seen{"XPASS"};
 216     return "SKIP"
 217       if scalar keys %test_results_seen == 1 && $test_results_seen{"SKIP"};
 218     return "PASS";
 219   }
 220
 221 }
 222
 223 sub write_test_results ()
 224 {
 225   open RES, ">", $trs_file or die "$ME: opening $trs_file: $!\n";
 226   print RES ":global-test-result: " . get_global_test_result . "\n";
 227   print RES ":recheck: " . yn (must_recheck) . "\n";
 228   print RES ":copy-in-global-log: " . yn (copy_in_global_log) . "\n";
 229   foreach my $result (get_test_results)
 230     {
 231       print RES ":test-result: $result\n";
 232     }
 233   close RES or die "$ME: closing $trs_file: $!\n";
 234 }
 235
 236 sub trap_perl_warnings_and_errors ()
 237 {
 238   $SIG{__WARN__} = $SIG{__DIE__} = sub
 239     {
 240       # Be sure to send the warning/error message to the original stderr
 241       # (presumably the console), not into the log file.
 242       open STDERR, ">&OLDERR";
 243       die @_;
 244     }
 245 }
 246
 247 sub start (@)
 248 {
 249   # Redirect stderr and stdout to a temporary log file.  Save the
 250   # original stdout stream, since we need it to print testsuite
 251   # progress output. Save original stderr stream, so that we can
 252   # redirect warning and error messages from perl there.
 253   open LOG, ">", $log_file or die "$ME: opening $log_file: $!\n";
 254   open OLDOUT, ">&STDOUT" or die "$ME: duplicating stdout: $!\n";
 255   open OLDERR, ">&STDERR" or die "$ME: duplicating stdout: $!\n";
 256   *OLDERR = *OLDERR; # To pacify a "used only once" warning.
 257   trap_perl_warnings_and_errors;
 258   open STDOUT, ">&LOG" or die "$ME: redirecting stdout: $!\n";
 259   open STDERR, ">&LOG" or die "$ME: redirecting stderr: $!\n";
 260   $parser = TAP::Parser->new ({ exec => \@_, merge => $cfg{merge} });
 261 }
 262
 263 sub get_test_exit_message ()
 264 {
 265   my $wstatus = $parser->wait;
 266   # Watch out for possible internal errors.
 267   die "$ME: couldn't get the exit ststus of the TAP producer"
 268     unless defined $wstatus;
 269   # Return an undefined value if the producer exited with success.
 270   return unless $wstatus;
 271   # Otherwise, determine whether it exited with error or was terminated
 272   # by a signal.
 273   use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
 274   if (WIFEXITED ($wstatus))
 275         {
 276       return sprintf "exited with status %d", WEXITSTATUS ($wstatus);
 277         }
 278   elsif (WIFSIGNALED ($wstatus))
 279         {
 280       return sprintf "terminated by signal %d", WTERMSIG ($wstatus);
 281         }
 282   else
 283         {
 284           return "terminated abnormally";
 285         }
 286 }
 287
 288 sub stringify_result_obj ($)
 289 {
 290   my $result_obj = shift;
 291   my $COOKED_PASS = $cfg{"expect-failure"} ? "XPASS": "PASS";
 292   my $COOKED_FAIL = $cfg{"expect-failure"} ? "XFAIL": "FAIL";
 293   if ($result_obj->is_unplanned || $result_obj->number != $testno)
 294     {
 295       return "ERROR";
 296     }
 297   elsif ($plan_seen == LATE_PLAN)
 298     {
 299       return "ERROR";
 300     }
 301   elsif (!$result_obj->directive)
 302     {
 303       return $result_obj->is_ok ? $COOKED_PASS: $COOKED_FAIL;
 304     }
 305   elsif ($result_obj->has_todo)
 306     {
 307       return $result_obj->is_actual_ok ? "XPASS" : "XFAIL";
 308     }
 309   elsif ($result_obj->has_skip)
 310     {
 311       return $result_obj->is_ok ? "SKIP" : $COOKED_FAIL;
 312     }
 313   die "$ME: INTERNAL ERROR"; # NOTREACHED
 314 }
 315
 316 sub colored ($$)
 317 {
 318   my ($color_name, $text) = @_;
 319   return $COLOR{$color_name} . $text . $COLOR{'std'};
 320 }
 321
 322 sub decorate_result ($)
 323 {
 324   my $result = shift;
 325   return $result unless $cfg{"color-tests"};
 326   my %color_for_result =
 327     (
 328       "ERROR" => 'mgn',
 329       "PASS"  => 'grn',
 330       "XPASS" => 'red',
 331       "FAIL"  => 'red',
 332       "XFAIL" => 'lgn',
 333       "SKIP"  => 'blu',
 334     );
 335   if (my $color = $color_for_result{$result})
 336     {
 337       return colored ($color, $result);
 338     }
 339   else
 340     {
 341       return $result; # Don't colorize unknown stuff.
 342     }
 343 }
 344
 345 sub report ($;$)
 346 {
 347   my ($msg, $result, $explanation) = (undef, @_);
 348   if ($result =~ /^(?:X?(?:PASS|FAIL)|SKIP|ERROR)/)
 349     {
 350       $msg = ": $test_script_name";
 351       add_test_result $result;
 352     }
 353   elsif ($result eq "#")
 354     {
 355       $msg = " $test_script_name:";
 356     }
 357   else
 358     {
 359       die "$ME: INTERNAL ERROR"; # NOTREACHED
 360     }
 361   $msg .= " $explanation" if defined $explanation;
 362   $msg .= "\n";
 363   # Output on console might be colorized.
 364   print OLDOUT decorate_result ($result) . $msg;
 365   # Log the result in the log file too, to help debugging (this is
 366   # especially true when said result is a TAP error or "Bail out!").
 367   print $result . $msg;
 368 }
 369
 370 sub testsuite_error ($)
 371 {
 372   report "ERROR", "- $_[0]";
 373 }
 374
 375 sub handle_tap_result ($)
 376 {
 377   $testno++;
 378   my $result_obj = shift;
 379
 380   my $test_result = stringify_result_obj $result_obj;
 381   my $string = $result_obj->number;
 382
 383   my $description = $result_obj->description;
 384   $string .= " $description"
 385     unless is_null_string $description;
 386
 387   if ($plan_seen == LATE_PLAN)
 388     {
 389       $string .= " # AFTER LATE PLAN";
 390     }
 391   elsif ($result_obj->is_unplanned)
 392     {
 393       $string .= " # UNPLANNED";
 394     }
 395   elsif ($result_obj->number != $testno)
 396     {
 397       $string .= " # OUT-OF-ORDER (expecting $testno)";
 398     }
 399   elsif (my $directive = $result_obj->directive)
 400     {
 401       $string .= " # $directive";
 402       my $explanation = $result_obj->explanation;
 403       $string .= " $explanation"
 404         unless is_null_string $explanation;
 405     }
 406
 407   report $test_result, $string;
 408 }
 409
 410 sub handle_tap_plan ($)
 411 {
 412   my $plan = shift;
 413   if ($plan_seen)
 414     {
 415       # Error, only one plan per stream is acceptable.
 416       testsuite_error "multiple test plans";
 417       return;
 418     }
 419   # The TAP plan can come before or after *all* the TAP results; we speak
 420   # respectively of an "early" or a "late" plan.  If we see the plan line
 421   # after at least one TAP result has been seen, assume we have a late
 422   # plan; in this case, any further test result seen after the plan will
 423   # be flagged as an error.
 424   $plan_seen = ($testno >= 1 ? LATE_PLAN : EARLY_PLAN);
 425   # If $testno > 0, we have an error ("too many tests run") that will be
 426   # automatically dealt with later, so don't worry about it here.  If
 427   # $plan_seen is true, we have an error due to a repeated plan, and that
 428   # has already been dealt with above.  Otherwise, we have a valid "plan
 429   # with SKIP" specification, and should report it as a particular kind
 430   # of SKIP result.
 431   if ($plan->directive && $testno == 0)
 432     {
 433       my $explanation = is_null_string ($plan->explanation) ?
 434                         undef : "- " . $plan->explanation;
 435       report "SKIP", $explanation;
 436     }
 437 }
 438
 439 sub handle_tap_bailout ($)
 440 {
 441   my ($bailout, $msg) = ($_[0], "Bail out!");
 442   $bailed_out = 1;
 443   $msg .= " " . $bailout->explanation
 444     unless is_null_string $bailout->explanation;
 445   testsuite_error $msg;
 446 }
 447
 448 sub extract_tap_comment ($)
 449 {
 450   my $line = shift;
 451   if (index ($line, $diag_string) == 0)
 452     {
 453       # Strip leading `$diag_string' from `$line'.
 454       $line = substr ($line, length ($diag_string));
 455       # And strip any leading and trailing whitespace left.
 456       $line =~ s/(?:^\s*|\s*$)//g;
 457       # Return what is left (if any).
 458       return $line;
 459     }
 460   return "";
 461 }
 462
 463 sub main (@)
 464 {
 465   start @_;
 466
 467   while (defined (my $cur = $parser->next))
 468     {
 469       # Verbatim copy any input line into the log file.
 470       print $cur->raw . "\n";
 471       # Parsing of TAP input should stop after a "Bail out!" directive.
 472       next if $bailed_out;
 473
 474       if ($cur->is_plan)
 475         {
 476           handle_tap_plan ($cur);
 477         }
 478       elsif ($cur->is_test)
 479         {
 480           handle_tap_result ($cur);
 481         }
 482       elsif ($cur->is_bailout)
 483         {
 484           handle_tap_bailout ($cur);
 485         }
 486       elsif ($cfg{comments})
 487         {
 488           my $comment = extract_tap_comment ($cur->raw);
 489           report "#", "$comment" if length $comment;
 490        }
 491     }
 492   # A "Bail out!" directive should cause us to ignore any following TAP
 493   # error, as well as a non-zero exit status from the TAP producer.
 494   if (!$bailed_out)
 495     {
 496       if (!$plan_seen)
 497         {
 498           testsuite_error "missing test plan";
 499         }
 500       elsif ($parser->tests_planned != $parser->tests_run)
 501         {
 502           my ($planned, $run) = ($parser->tests_planned, $parser->tests_run);
 503           my $bad_amount = $run > $planned ? "many" : "few";
 504           testsuite_error (sprintf "too %s tests run (expected %d, got %d)",
 505                                    $bad_amount, $planned, $run);
 506         }
 507       if (!$cfg{"ignore-exit"})
 508         {
 509           my $msg = get_test_exit_message ();
 510           testsuite_error $msg if $msg;
 511         }
 512     }
 513   write_test_results;
 514   close LOG or die "$ME: closing $log_file: $!\n";
 515   exit 0;
 516 }
 517
 518 # ----------- #
 519 #  Main code. #
 520 # ----------- #
 521
 522 main @ARGV;
 523
 524 # Local Variables:
 525 # perl-indent-level: 2
 526 # perl-continued-statement-offset: 2
 527 # perl-continued-brace-offset: 0
 528 # perl-brace-offset: 0
 529 # perl-brace-imaginary-offset: 0
 530 # perl-label-offset: -2
 531 # cperl-indent-level: 2
 532 # cperl-brace-offset: 0
 533 # cperl-continued-brace-offset: 0
 534 # cperl-label-offset: -2
 535 # cperl-extra-newline-before-brace: t
 536 # cperl-merge-trailing-else: nil
 537 # cperl-continued-statement-offset: 2
 538 # eval: (add-hook 'write-file-hooks 'time-stamp)
 539 # time-stamp-start: "my $VERSION = "
 540 # time-stamp-format: "'%:y-%02m-%02d.%02H'"
 541 # time-stamp-time-zone: "UTC"
 542 # time-stamp-end: "; # UTC"
 543 # End: