Gestionnaire de fichiers - Editer - /usr/share/automake-1.13/tap-driver.pl
Arrière
#! /usr/bin/env perl # Copyright (C) 2011-2013 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see <http://www.gnu.org/licenses/>. # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # This file is maintained in Automake, please report # bugs to <bug-automake@gnu.org> or send patches to # <automake-patches@gnu.org>. # ---------------------------------- # # Imports, static data, and setup. # # ---------------------------------- # use warnings FATAL => 'all'; use strict; use Getopt::Long (); use TAP::Parser; my $VERSION = '2012-02-01.19'; # UTC my $ME = "tap-driver.pl"; my $USAGE = <<'END'; Usage: tap-driver --test-name=NAME --log-file=PATH --trs-file=PATH [--expect-failure={yes|no}] [--color-tests={yes|no}] [--enable-hard-errors={yes|no}] [--ignore-exit] [--diagnostic-string=STRING] [--merge|--no-merge] [--comments|--no-comments] [--] TEST-COMMAND The `--test-name', `--log-file' and `--trs-file' options are mandatory. END my $HELP = "$ME: TAP-aware test driver for Automake testsuite harness." . "\n" . $USAGE; # Keep this in sync with `lib/am/check.am:$(am__tty_colors)'. my %COLOR = ( red => "\e[0;31m", grn => "\e[0;32m", lgn => "\e[1;32m", blu => "\e[1;34m", mgn => "\e[0;35m", brg => "\e[1m", std => "\e[m", ); # It's important that NO_PLAN evaluates "false" as a boolean. use constant NO_PLAN => 0; use constant EARLY_PLAN => 1; use constant LATE_PLAN => 2; # ------------------- # # Global variables. # # ------------------- # my $testno = 0; # Number of test results seen so far. my $bailed_out = 0; # Whether a "Bail out!" directive has been seen. my $parser; # TAP parser object (will be initialized later). # Whether the TAP plan has been seen or not, and if yes, which kind # it is ("early" is seen before any test result, "late" otherwise). my $plan_seen = NO_PLAN; # ----------------- # # Option parsing. # # ----------------- # my %cfg = ( "color-tests" => 0, "expect-failure" => 0, "merge" => 0, "comments" => 0, "ignore-exit" => 0, ); my $test_script_name = undef; my $log_file = undef; my $trs_file = undef; my $diag_string = "#"; Getopt::Long::GetOptions ( 'help' => sub { print $HELP; exit 0; }, 'version' => sub { print "$ME $VERSION\n"; exit 0; }, 'test-name=s' => \$test_script_name, 'log-file=s' => \$log_file, 'trs-file=s' => \$trs_file, 'color-tests=s' => \&bool_opt, 'expect-failure=s' => \&bool_opt, 'enable-hard-errors=s' => sub {}, # No-op. 'diagnostic-string=s' => \$diag_string, 'comments' => sub { $cfg{"comments"} = 1; }, 'no-comments' => sub { $cfg{"comments"} = 0; }, 'merge' => sub { $cfg{"merge"} = 1; }, 'no-merge' => sub { $cfg{"merge"} = 0; }, 'ignore-exit' => sub { $cfg{"ignore-exit"} = 1; }, ) or exit 1; # ------------- # # Prototypes. # # ------------- # sub add_test_result ($); sub bool_opt ($$); sub colored ($$); sub copy_in_global_log (); sub decorate_result ($); sub extract_tap_comment ($); sub finish (); sub get_global_test_result (); sub get_test_exit_message (); sub get_test_results (); sub handle_tap_bailout ($); sub handle_tap_plan ($); sub handle_tap_result ($); sub is_null_string ($); sub main (@); sub must_recheck (); sub report ($;$); sub setup_io (); sub setup_parser (@); sub stringify_result_obj ($); sub testsuite_error ($); sub trap_perl_warnings_and_errors (); sub write_test_results (); sub yn ($); # -------------- # # Subroutines. # # -------------- # sub bool_opt ($$) { my ($opt, $val) = @_; if ($val =~ /^(?:y|yes)\z/i) { $cfg{$opt} = 1; } elsif ($val =~ /^(?:n|no)\z/i) { $cfg{$opt} = 0; } else { die "$ME: invalid argument '$val' for option '$opt'\n"; } } # If the given string is undefined or empty, return true, otherwise # return false. This function is useful to avoid pitfalls like: # if ($message) { print "$message\n"; } # which wouldn't print anything if $message is the literal "0". sub is_null_string ($) { my $str = shift; return ! (defined $str and length $str); } # Convert a boolean to a "yes"/"no" string. sub yn ($) { my $bool = shift; return $bool ? "yes" : "no"; } TEST_RESULTS : { my (@test_results_list, %test_results_seen); sub add_test_result ($) { my $res = shift; push @test_results_list, $res; $test_results_seen{$res} = 1; } sub get_test_results () { return @test_results_list; } # Whether the test script should be re-run by "make recheck". sub must_recheck () { return grep { !/^(?:XFAIL|PASS|SKIP)$/ } (keys %test_results_seen); } # Whether the content of the log file associated to this test should # be copied into the "global" test-suite.log. sub copy_in_global_log () { return grep { not $_ eq "PASS" } (keys %test_results_seen); } # FIXME: this can certainly be improved ... sub get_global_test_result () { return "ERROR" if $test_results_seen{"ERROR"}; return "FAIL" if $test_results_seen{"FAIL"} || $test_results_seen{"XPASS"}; return "SKIP" if scalar keys %test_results_seen == 1 && $test_results_seen{"SKIP"}; return "PASS"; } } sub write_test_results () { open RES, ">", $trs_file or die "$ME: opening $trs_file: $!\n"; print RES ":global-test-result: " . get_global_test_result . "\n"; print RES ":recheck: " . yn (must_recheck) . "\n"; print RES ":copy-in-global-log: " . yn (copy_in_global_log) . "\n"; foreach my $result (get_test_results) { print RES ":test-result: $result\n"; } close RES or die "$ME: closing $trs_file: $!\n"; } sub trap_perl_warnings_and_errors () { $SIG{__WARN__} = $SIG{__DIE__} = sub { # Be sure to send the warning/error message to the original stderr # (presumably the console), not into the log file. open STDERR, ">&OLDERR"; die @_; } } sub setup_io () { # Redirect stderr and stdout to a temporary log file. Save the # original stdout stream, since we need it to print testsuite # progress output. Save original stderr stream, so that we can # redirect warning and error messages from perl there. open LOG, ">", $log_file or die "$ME: opening $log_file: $!\n"; open OLDOUT, ">&STDOUT" or die "$ME: duplicating stdout: $!\n"; open OLDERR, ">&STDERR" or die "$ME: duplicating stdout: $!\n"; *OLDERR = *OLDERR; # To pacify a "used only once" warning. trap_perl_warnings_and_errors; open STDOUT, ">&LOG" or die "$ME: redirecting stdout: $!\n"; open STDERR, ">&LOG" or die "$ME: redirecting stderr: $!\n"; } sub setup_parser (@) { local $@ = ''; eval { $parser = TAP::Parser->new ({exec => \@_, merge => $cfg{merge}}) }; if ($@ ne '') { # Don't use the error message in $@ as set by TAP::Parser, since # currently it's both too generic (at the point of being basically # useless) and quite long. report "ERROR", "- couldn't execute test script"; finish; } } sub get_test_exit_message () { my $wstatus = $parser->wait; # Watch out for possible internal errors. die "$ME: couldn't get the exit status of the TAP producer" unless defined $wstatus; # Return an undefined value if the producer exited with success. return unless $wstatus; # Otherwise, determine whether it exited with error or was terminated # by a signal. use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG); if (WIFEXITED ($wstatus)) { return sprintf "exited with status %d", WEXITSTATUS ($wstatus); } elsif (WIFSIGNALED ($wstatus)) { return sprintf "terminated by signal %d", WTERMSIG ($wstatus); } else { return "terminated abnormally"; } } sub stringify_result_obj ($) { my $result_obj = shift; my $COOKED_PASS = $cfg{"expect-failure"} ? "XPASS": "PASS"; my $COOKED_FAIL = $cfg{"expect-failure"} ? "XFAIL": "FAIL"; if ($result_obj->is_unplanned || $result_obj->number != $testno) { return "ERROR"; } elsif ($plan_seen == LATE_PLAN) { return "ERROR"; } elsif (!$result_obj->directive) { return $result_obj->is_ok ? $COOKED_PASS: $COOKED_FAIL; } elsif ($result_obj->has_todo) { return $result_obj->is_actual_ok ? "XPASS" : "XFAIL"; } elsif ($result_obj->has_skip) { return $result_obj->is_ok ? "SKIP" : $COOKED_FAIL; } die "$ME: INTERNAL ERROR"; # NOTREACHED } sub colored ($$) { my ($color_name, $text) = @_; return $COLOR{$color_name} . $text . $COLOR{'std'}; } sub decorate_result ($) { my $result = shift; return $result unless $cfg{"color-tests"}; my %color_for_result = ( "ERROR" => 'mgn', "PASS" => 'grn', "XPASS" => 'red', "FAIL" => 'red', "XFAIL" => 'lgn', "SKIP" => 'blu', ); if (my $color = $color_for_result{$result}) { return colored ($color, $result); } else { return $result; # Don't colorize unknown stuff. } } sub report ($;$) { my ($msg, $result, $explanation) = (undef, @_); if ($result =~ /^(?:X?(?:PASS|FAIL)|SKIP|ERROR)/) { $msg = ": $test_script_name"; add_test_result $result; } elsif ($result eq "#") { $msg = " $test_script_name:"; } else { die "$ME: INTERNAL ERROR"; # NOTREACHED } $msg .= " $explanation" if defined $explanation; $msg .= "\n"; # Output on console might be colorized. print OLDOUT decorate_result ($result) . $msg; # Log the result in the log file too, to help debugging (this is # especially true when said result is a TAP error or "Bail out!"). print $result . $msg; } sub testsuite_error ($) { report "ERROR", "- $_[0]"; } sub handle_tap_result ($) { $testno++; my $result_obj = shift; my $test_result = stringify_result_obj $result_obj; my $string = $result_obj->number; my $description = $result_obj->description; $string .= " $description" unless is_null_string $description; if ($plan_seen == LATE_PLAN) { $string .= " # AFTER LATE PLAN"; } elsif ($result_obj->is_unplanned) { $string .= " # UNPLANNED"; } elsif ($result_obj->number != $testno) { $string .= " # OUT-OF-ORDER (expecting $testno)"; } elsif (my $directive = $result_obj->directive) { $string .= " # $directive"; my $explanation = $result_obj->explanation; $string .= " $explanation" unless is_null_string $explanation; } report $test_result, $string; } sub handle_tap_plan ($) { my $plan = shift; if ($plan_seen) { # Error, only one plan per stream is acceptable. testsuite_error "multiple test plans"; return; } # The TAP plan can come before or after *all* the TAP results; we speak # respectively of an "early" or a "late" plan. If we see the plan line # after at least one TAP result has been seen, assume we have a late # plan; in this case, any further test result seen after the plan will # be flagged as an error. $plan_seen = ($testno >= 1 ? LATE_PLAN : EARLY_PLAN); # If $testno > 0, we have an error ("too many tests run") that will be # automatically dealt with later, so don't worry about it here. If # $plan_seen is true, we have an error due to a repeated plan, and that # has already been dealt with above. Otherwise, we have a valid "plan # with SKIP" specification, and should report it as a particular kind # of SKIP result. if ($plan->directive && $testno == 0) { my $explanation = is_null_string ($plan->explanation) ? undef : "- " . $plan->explanation; report "SKIP", $explanation; } } sub handle_tap_bailout ($) { my ($bailout, $msg) = ($_[0], "Bail out!"); $bailed_out = 1; $msg .= " " . $bailout->explanation unless is_null_string $bailout->explanation; testsuite_error $msg; } sub extract_tap_comment ($) { my $line = shift; if (index ($line, $diag_string) == 0) { # Strip leading `$diag_string' from `$line'. $line = substr ($line, length ($diag_string)); # And strip any leading and trailing whitespace left. $line =~ s/(?:^\s*|\s*$)//g; # Return what is left (if any). return $line; } return ""; } sub finish () { write_test_results; close LOG or die "$ME: closing $log_file: $!\n"; exit 0; } sub main (@) { setup_io; setup_parser @_; while (defined (my $cur = $parser->next)) { # Verbatim copy any input line into the log file. print $cur->raw . "\n"; # Parsing of TAP input should stop after a "Bail out!" directive. next if $bailed_out; if ($cur->is_plan) { handle_tap_plan ($cur); } elsif ($cur->is_test) { handle_tap_result ($cur); } elsif ($cur->is_bailout) { handle_tap_bailout ($cur); } elsif ($cfg{comments}) { my $comment = extract_tap_comment ($cur->raw); report "#", "$comment" if length $comment; } } # A "Bail out!" directive should cause us to ignore any following TAP # error, as well as a non-zero exit status from the TAP producer. if (!$bailed_out) { if (!$plan_seen) { testsuite_error "missing test plan"; } elsif ($parser->tests_planned != $parser->tests_run) { my ($planned, $run) = ($parser->tests_planned, $parser->tests_run); my $bad_amount = $run > $planned ? "many" : "few"; testsuite_error (sprintf "too %s tests run (expected %d, got %d)", $bad_amount, $planned, $run); } if (!$cfg{"ignore-exit"}) { my $msg = get_test_exit_message (); testsuite_error $msg if $msg; } } finish; } # ----------- # # Main code. # # ----------- # main @ARGV; # Local Variables: # perl-indent-level: 2 # perl-continued-statement-offset: 2 # perl-continued-brace-offset: 0 # perl-brace-offset: 0 # perl-brace-imaginary-offset: 0 # perl-label-offset: -2 # cperl-indent-level: 2 # cperl-brace-offset: 0 # cperl-continued-brace-offset: 0 # cperl-label-offset: -2 # cperl-extra-newline-before-brace: t # cperl-merge-trailing-else: nil # cperl-continued-statement-offset: 2 # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "my $VERSION = " # time-stamp-format: "'%:y-%02m-%02d.%02H'" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End:
| ver. 1.4 |
Github
|
.
| PHP 8.0.30 | Génération de la page: 0.07 |
proxy
|
phpinfo
|
Réglages