contrib/tap-driver.pl

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