Merge branch 'maint'
[platform/upstream/automake.git] / 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: