lib/tap-driver.pl

   1 #! /usr/bin/env perl
   2 # Copyright (C) 2011-2012 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 = '2012-02-01.19'; # 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 finish ();
 126 sub get_global_test_result ();
 127 sub get_test_exit_message ();
 128 sub get_test_results ();
 129 sub handle_tap_bailout ($);
 130 sub handle_tap_plan ($);
 131 sub handle_tap_result ($);
 132 sub is_null_string ($);
 133 sub main (@);
 134 sub must_recheck ();
 135 sub report ($;$);
 136 sub setup_io ();
 137 sub setup_parser (@);
 138 sub stringify_result_obj ($);
 139 sub testsuite_error ($);
 140 sub trap_perl_warnings_and_errors ();
 141 sub write_test_results ();
 142 sub yn ($);
 143
 144 # -------------- #
 145 #  Subroutines.  #
 146 # -------------- #
 147
 148 sub bool_opt ($$)
 149 {
 150   my ($opt, $val) = @_;
 151   if ($val =~ /^(?:y|yes)\z/i)
 152     {
 153       $cfg{$opt} = 1;
 154     }
 155   elsif ($val =~ /^(?:n|no)\z/i)
 156     {
 157       $cfg{$opt} = 0;
 158     }
 159   else
 160     {
 161       die "$ME: invalid argument '$val' for option '$opt'\n";
 162     }
 163 }
 164
 165 # If the given string is undefined or empty, return true, otherwise
 166 # return false.  This function is useful to avoid pitfalls like:
 167 #   if ($message) { print "$message\n"; }
 168 # which wouldn't print anything if $message is the literal "0".
 169 sub is_null_string ($)
 170 {
 171   my $str = shift;
 172   return ! (defined $str and length $str);
 173 }
 174
 175 # Convert a boolean to a "yes"/"no" string.
 176 sub yn ($)
 177 {
 178   my $bool = shift;
 179   return $bool ? "yes" : "no";
 180 }
 181
 182 TEST_RESULTS :
 183 {
 184   my (@test_results_list, %test_results_seen);
 185
 186   sub add_test_result ($)
 187   {
 188     my $res = shift;
 189     push @test_results_list, $res;
 190     $test_results_seen{$res} = 1;
 191   }
 192
 193   sub get_test_results ()
 194   {
 195     return @test_results_list;
 196   }
 197
 198   # Whether the test script should be re-run by "make recheck".
 199   sub must_recheck ()
 200   {
 201     return grep { !/^(?:XFAIL|PASS|SKIP)$/ } (keys %test_results_seen);
 202   }
 203
 204   # Whether the content of the log file associated to this test should
 205   # be copied into the "global" test-suite.log.
 206   sub copy_in_global_log ()
 207   {
 208     return grep { not $_ eq "PASS" } (keys %test_results_seen);
 209   }
 210
 211   # FIXME: this can certainly be improved ...
 212   sub get_global_test_result ()
 213   {
 214     return "ERROR"
 215       if $test_results_seen{"ERROR"};
 216     return "FAIL"
 217       if $test_results_seen{"FAIL"} || $test_results_seen{"XPASS"};
 218     return "SKIP"
 219       if scalar keys %test_results_seen == 1 && $test_results_seen{"SKIP"};
 220     return "PASS";
 221   }
 222
 223 }
 224
 225 sub write_test_results ()
 226 {
 227   open RES, ">", $trs_file or die "$ME: opening $trs_file: $!\n";
 228   print RES ":global-test-result: " . get_global_test_result . "\n";
 229   print RES ":recheck: " . yn (must_recheck) . "\n";
 230   print RES ":copy-in-global-log: " . yn (copy_in_global_log) . "\n";
 231   foreach my $result (get_test_results)
 232     {
 233       print RES ":test-result: $result\n";
 234     }
 235   close RES or die "$ME: closing $trs_file: $!\n";
 236 }
 237
 238 sub trap_perl_warnings_and_errors ()
 239 {
 240   $SIG{__WARN__} = $SIG{__DIE__} = sub
 241     {
 242       # Be sure to send the warning/error message to the original stderr
 243       # (presumably the console), not into the log file.
 244       open STDERR, ">&OLDERR";
 245       die @_;
 246     }
 247 }
 248
 249 sub setup_io ()
 250 {
 251   # Redirect stderr and stdout to a temporary log file.  Save the
 252   # original stdout stream, since we need it to print testsuite
 253   # progress output. Save original stderr stream, so that we can
 254   # redirect warning and error messages from perl there.
 255   open LOG, ">", $log_file or die "$ME: opening $log_file: $!\n";
 256   open OLDOUT, ">&STDOUT" or die "$ME: duplicating stdout: $!\n";
 257   open OLDERR, ">&STDERR" or die "$ME: duplicating stdout: $!\n";
 258   *OLDERR = *OLDERR; # To pacify a "used only once" warning.
 259   trap_perl_warnings_and_errors;
 260   open STDOUT, ">&LOG" or die "$ME: redirecting stdout: $!\n";
 261   open STDERR, ">&LOG" or die "$ME: redirecting stderr: $!\n";
 262 }
 263
 264 sub setup_parser (@)
 265 {
 266   local $@ = '';
 267   eval { $parser = TAP::Parser->new ({exec => \@_, merge => $cfg{merge}}) };
 268   if ($@ ne '')
 269     {
 270       # Don't use the error message in $@ as set by TAP::Parser, since
 271       # currently it's both too generic (at the point of being basically
 272       # useless) and quite long.
 273       report "ERROR", "- couldn't execute test script";
 274       finish;
 275     }
 276 }
 277
 278 sub get_test_exit_message ()
 279 {
 280   my $wstatus = $parser->wait;
 281   # Watch out for possible internal errors.
 282   die "$ME: couldn't get the exit status of the TAP producer"
 283     unless defined $wstatus;
 284   # Return an undefined value if the producer exited with success.
 285   return unless $wstatus;
 286   # Otherwise, determine whether it exited with error or was terminated
 287   # by a signal.
 288   use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
 289   if (WIFEXITED ($wstatus))
 290   {
 291     return sprintf "exited with status %d", WEXITSTATUS ($wstatus);
 292   }
 293   elsif (WIFSIGNALED ($wstatus))
 294     {
 295       return sprintf "terminated by signal %d", WTERMSIG ($wstatus);
 296     }
 297   else
 298     {
 299       return "terminated abnormally";
 300     }
 301 }
 302
 303 sub stringify_result_obj ($)
 304 {
 305   my $result_obj = shift;
 306   my $COOKED_PASS = $cfg{"expect-failure"} ? "XPASS": "PASS";
 307   my $COOKED_FAIL = $cfg{"expect-failure"} ? "XFAIL": "FAIL";
 308   if ($result_obj->is_unplanned || $result_obj->number != $testno)
 309     {
 310       return "ERROR";
 311     }
 312   elsif ($plan_seen == LATE_PLAN)
 313     {
 314       return "ERROR";
 315     }
 316   elsif (!$result_obj->directive)
 317     {
 318       return $result_obj->is_ok ? $COOKED_PASS: $COOKED_FAIL;
 319     }
 320   elsif ($result_obj->has_todo)
 321     {
 322       return $result_obj->is_actual_ok ? "XPASS" : "XFAIL";
 323     }
 324   elsif ($result_obj->has_skip)
 325     {
 326       return $result_obj->is_ok ? "SKIP" : $COOKED_FAIL;
 327     }
 328   die "$ME: INTERNAL ERROR"; # NOTREACHED
 329 }
 330
 331 sub colored ($$)
 332 {
 333   my ($color_name, $text) = @_;
 334   return $COLOR{$color_name} . $text . $COLOR{'std'};
 335 }
 336
 337 sub decorate_result ($)
 338 {
 339   my $result = shift;
 340   return $result unless $cfg{"color-tests"};
 341   my %color_for_result =
 342     (
 343       "ERROR" => 'mgn',
 344       "PASS"  => 'grn',
 345       "XPASS" => 'red',
 346       "FAIL"  => 'red',
 347       "XFAIL" => 'lgn',
 348       "SKIP"  => 'blu',
 349     );
 350   if (my $color = $color_for_result{$result})
 351     {
 352       return colored ($color, $result);
 353     }
 354   else
 355     {
 356       return $result; # Don't colorize unknown stuff.
 357     }
 358 }
 359
 360 sub report ($;$)
 361 {
 362   my ($msg, $result, $explanation) = (undef, @_);
 363   if ($result =~ /^(?:X?(?:PASS|FAIL)|SKIP|ERROR)/)
 364     {
 365       $msg = ": $test_script_name";
 366       add_test_result $result;
 367     }
 368   elsif ($result eq "#")
 369     {
 370       $msg = " $test_script_name:";
 371     }
 372   else
 373     {
 374       die "$ME: INTERNAL ERROR"; # NOTREACHED
 375     }
 376   $msg .= " $explanation" if defined $explanation;
 377   $msg .= "\n";
 378   # Output on console might be colorized.
 379   print OLDOUT decorate_result ($result) . $msg;
 380   # Log the result in the log file too, to help debugging (this is
 381   # especially true when said result is a TAP error or "Bail out!").
 382   print $result . $msg;
 383 }
 384
 385 sub testsuite_error ($)
 386 {
 387   report "ERROR", "- $_[0]";
 388 }
 389
 390 sub handle_tap_result ($)
 391 {
 392   $testno++;
 393   my $result_obj = shift;
 394
 395   my $test_result = stringify_result_obj $result_obj;
 396   my $string = $result_obj->number;
 397
 398   my $description = $result_obj->description;
 399   $string .= " $description"
 400     unless is_null_string $description;
 401
 402   if ($plan_seen == LATE_PLAN)
 403     {
 404       $string .= " # AFTER LATE PLAN";
 405     }
 406   elsif ($result_obj->is_unplanned)
 407     {
 408       $string .= " # UNPLANNED";
 409     }
 410   elsif ($result_obj->number != $testno)
 411     {
 412       $string .= " # OUT-OF-ORDER (expecting $testno)";
 413     }
 414   elsif (my $directive = $result_obj->directive)
 415     {
 416       $string .= " # $directive";
 417       my $explanation = $result_obj->explanation;
 418       $string .= " $explanation"
 419         unless is_null_string $explanation;
 420     }
 421
 422   report $test_result, $string;
 423 }
 424
 425 sub handle_tap_plan ($)
 426 {
 427   my $plan = shift;
 428   if ($plan_seen)
 429     {
 430       # Error, only one plan per stream is acceptable.
 431       testsuite_error "multiple test plans";
 432       return;
 433     }
 434   # The TAP plan can come before or after *all* the TAP results; we speak
 435   # respectively of an "early" or a "late" plan.  If we see the plan line
 436   # after at least one TAP result has been seen, assume we have a late
 437   # plan; in this case, any further test result seen after the plan will
 438   # be flagged as an error.
 439   $plan_seen = ($testno >= 1 ? LATE_PLAN : EARLY_PLAN);
 440   # If $testno > 0, we have an error ("too many tests run") that will be
 441   # automatically dealt with later, so don't worry about it here.  If
 442   # $plan_seen is true, we have an error due to a repeated plan, and that
 443   # has already been dealt with above.  Otherwise, we have a valid "plan
 444   # with SKIP" specification, and should report it as a particular kind
 445   # of SKIP result.
 446   if ($plan->directive && $testno == 0)
 447     {
 448       my $explanation = is_null_string ($plan->explanation) ?
 449                         undef : "- " . $plan->explanation;
 450       report "SKIP", $explanation;
 451     }
 452 }
 453
 454 sub handle_tap_bailout ($)
 455 {
 456   my ($bailout, $msg) = ($_[0], "Bail out!");
 457   $bailed_out = 1;
 458   $msg .= " " . $bailout->explanation
 459     unless is_null_string $bailout->explanation;
 460   testsuite_error $msg;
 461 }
 462
 463 sub extract_tap_comment ($)
 464 {
 465   my $line = shift;
 466   if (index ($line, $diag_string) == 0)
 467     {
 468       # Strip leading `$diag_string' from `$line'.
 469       $line = substr ($line, length ($diag_string));
 470       # And strip any leading and trailing whitespace left.
 471       $line =~ s/(?:^\s*|\s*$)//g;
 472       # Return what is left (if any).
 473       return $line;
 474     }
 475   return "";
 476 }
 477
 478 sub finish ()
 479 {
 480   write_test_results;
 481   close LOG or die "$ME: closing $log_file: $!\n";
 482   exit 0;
 483 }
 484
 485 sub main (@)
 486 {
 487   setup_io;
 488   setup_parser @_;
 489
 490   while (defined (my $cur = $parser->next))
 491     {
 492       # Verbatim copy any input line into the log file.
 493       print $cur->raw . "\n";
 494       # Parsing of TAP input should stop after a "Bail out!" directive.
 495       next if $bailed_out;
 496
 497       if ($cur->is_plan)
 498         {
 499           handle_tap_plan ($cur);
 500         }
 501       elsif ($cur->is_test)
 502         {
 503           handle_tap_result ($cur);
 504         }
 505       elsif ($cur->is_bailout)
 506         {
 507           handle_tap_bailout ($cur);
 508         }
 509       elsif ($cfg{comments})
 510         {
 511           my $comment = extract_tap_comment ($cur->raw);
 512           report "#", "$comment" if length $comment;
 513        }
 514     }
 515   # A "Bail out!" directive should cause us to ignore any following TAP
 516   # error, as well as a non-zero exit status from the TAP producer.
 517   if (!$bailed_out)
 518     {
 519       if (!$plan_seen)
 520         {
 521           testsuite_error "missing test plan";
 522         }
 523       elsif ($parser->tests_planned != $parser->tests_run)
 524         {
 525           my ($planned, $run) = ($parser->tests_planned, $parser->tests_run);
 526           my $bad_amount = $run > $planned ? "many" : "few";
 527           testsuite_error (sprintf "too %s tests run (expected %d, got %d)",
 528                                    $bad_amount, $planned, $run);
 529         }
 530       if (!$cfg{"ignore-exit"})
 531         {
 532           my $msg = get_test_exit_message ();
 533           testsuite_error $msg if $msg;
 534         }
 535     }
 536   finish;
 537 }
 538
 539 # ----------- #
 540 #  Main code. #
 541 # ----------- #
 542
 543 main @ARGV;
 544
 545 # Local Variables:
 546 # perl-indent-level: 2
 547 # perl-continued-statement-offset: 2
 548 # perl-continued-brace-offset: 0
 549 # perl-brace-offset: 0
 550 # perl-brace-imaginary-offset: 0
 551 # perl-label-offset: -2
 552 # cperl-indent-level: 2
 553 # cperl-brace-offset: 0
 554 # cperl-continued-brace-offset: 0
 555 # cperl-label-offset: -2
 556 # cperl-extra-newline-before-brace: t
 557 # cperl-merge-trailing-else: nil
 558 # cperl-continued-statement-offset: 2
 559 # eval: (add-hook 'write-file-hooks 'time-stamp)
 560 # time-stamp-start: "my $VERSION = "
 561 # time-stamp-format: "'%:y-%02m-%02d.%02H'"
 562 # time-stamp-time-zone: "UTC"
 563 # time-stamp-end: "; # UTC"
 564 # End: