1#! /usr/bin/env perl
2# Copyright (C) 2011-2021 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
30use warnings FATAL => 'all';
31use strict;
32use Getopt::Long ();
33use TAP::Parser;
34
35my $VERSION = '2013-12-24.15'; # UTC
36
37my $ME = "tap-driver.pl";
38
39my $USAGE = <<'END';
40Usage:
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
46The '--test-name', '--log-file' and '--trs-file' options are mandatory.
47END
48
49my $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)'.
53my %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.
64use constant NO_PLAN => 0;
65use constant EARLY_PLAN => 1;
66use constant LATE_PLAN => 2;
67
68# ------------------- #
69#  Global variables.  #
70# ------------------- #
71
72my $testno = 0;     # Number of test results seen so far.
73my $bailed_out = 0; # Whether a "Bail out!" directive has been seen.
74my $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).
78my $plan_seen = NO_PLAN;
79
80# ----------------- #
81#  Option parsing.  #
82# ----------------- #
83
84my %cfg = (
85  "color-tests" => 0,
86  "expect-failure" => 0,
87  "merge" => 0,
88  "comments" => 0,
89  "ignore-exit" => 0,
90);
91
92my $test_script_name = undef;
93my $log_file = undef;
94my $trs_file = undef;
95my $diag_string = "#";
96
97Getopt::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
119sub add_test_result ($);
120sub bool_opt ($$);
121sub colored ($$);
122sub copy_in_global_log ();
123sub decorate_result ($);
124sub extract_tap_comment ($);
125sub finish ();
126sub get_global_test_result ();
127sub get_test_exit_message ();
128sub get_test_results ();
129sub handle_tap_bailout ($);
130sub handle_tap_plan ($);
131sub handle_tap_result ($);
132sub is_null_string ($);
133sub main (@);
134sub must_recheck ();
135sub report ($;$);
136sub setup_io ();
137sub setup_parser (@);
138sub stringify_result_obj ($);
139sub testsuite_error ($);
140sub trap_perl_warnings_and_errors ();
141sub write_test_results ();
142sub yn ($);
143
144# -------------- #
145#  Subroutines.  #
146# -------------- #
147
148sub 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".
169sub 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.
176sub yn ($)
177{
178  my $bool = shift;
179  return $bool ? "yes" : "no";
180}
181
182TEST_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  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
224sub 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
237sub 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
248sub 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
263sub 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
277sub 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
302sub 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
330sub colored ($$)
331{
332  my ($color_name, $text) = @_;
333  return $COLOR{$color_name} . $text . $COLOR{'std'};
334}
335
336sub 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
359sub 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
384sub testsuite_error ($)
385{
386  report "ERROR", "- $_[0]";
387}
388
389sub 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
424sub 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
453sub 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
462sub 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
477sub finish ()
478{
479  write_test_results;
480  close LOG or die "$ME: closing $log_file: $!\n";
481  exit 0;
482}
483
484sub 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
542main @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)
559# time-stamp-start: "my $VERSION = "
560# time-stamp-format: "'%:y-%02m-%02d.%02H'"
561# time-stamp-time-zone: "UTC0"
562# time-stamp-end: "; # UTC"
563# End:
564