"Fossies" - the Fresh Open Source Software Archive

Member "bup-0.30/wvtest" (28 Sep 2019, 8504 Bytes) of package /linux/privat/bup-0.30.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "wvtest": 0.29.3_vs_0.30.

    1 #!/usr/bin/env perl
    2 #
    3 # WvTest:
    4 #   Copyright (C) 2007-2009 Versabanq Innovations Inc. and contributors.
    5 #   Copyright (C) 2015 Rob Browning <rlb@defaultvalue.org>
    6 #       Licensed under the GNU Library General Public License, version 2.
    7 #       See the included file named LICENSE for license information.
    8 #
    9 use strict;
   10 use warnings;
   11 use Getopt::Long qw(GetOptionsFromArray :config no_ignore_case bundling);
   12 use Pod::Usage;
   13 use Time::HiRes qw(time);
   14 
   15 my $per_test_warn_time = 100000;  # upstream was 500
   16 my $per_test_bad_time = 100000;  # upstream was 1000
   17 my $overall_test_warn_time = 100000;  # upstream was 2000
   18 my $overall_test_bad_time = 100000;  # upstream was 5000
   19 
   20 my $pid;
   21 my $istty = -t STDOUT;
   22 my @log = ();
   23 
   24 sub bigkill($)
   25 {
   26     my $pid = shift;
   27 
   28     if (@log) {
   29     print "\n" . join("\n", @log) . "\n";
   30     }
   31 
   32     print STDERR "\n! Killed by signal    FAILED\n";
   33 
   34     ($pid > 0) || die("pid is '$pid'?!\n");
   35 
   36     local $SIG{CHLD} = sub { }; # this will wake us from sleep() faster
   37     kill 15, $pid;
   38     sleep(2);
   39 
   40     if ($pid > 1) {
   41     kill 9, -$pid;
   42     }
   43     kill 9, $pid;
   44 
   45     exit(125);
   46 }
   47 
   48 sub colourize($)
   49 {
   50     my $result = shift;
   51     my $pass = ($result eq "ok");
   52 
   53     if ($istty) {
   54     my $colour = $pass ? "\e[32;1m" : "\e[31;1m";
   55     return "$colour$result\e[0m";
   56     } else {
   57     return $result;
   58     }
   59 }
   60 
   61 sub mstime($$$)
   62 {
   63     my ($floatsec, $warntime, $badtime) = @_;
   64     my $ms = int($floatsec * 1000);
   65     my $str = sprintf("%d.%03ds", $ms/1000, $ms % 1000);
   66 
   67     if ($istty && $ms > $badtime) {
   68         return "\e[31;1m$str\e[0m";
   69     } elsif ($istty && $ms > $warntime) {
   70         return "\e[33;1m$str\e[0m";
   71     } else {
   72         return "$str";
   73     }
   74 }
   75 
   76 sub resultline($$)
   77 {
   78     my ($name, $result) = @_;
   79     return sprintf("! %-65s %s", $name, colourize($result));
   80 }
   81 
   82 my ($start, $stop);
   83 
   84 sub endsect()
   85 {
   86     $stop = time();
   87     if ($start) {
   88     printf " %s %s\n",
   89             mstime($stop - $start, $per_test_warn_time, $per_test_bad_time),
   90             colourize("ok");
   91     }
   92 }
   93 
   94 sub run
   95 {
   96     # dup_msgs should be true when "watching".  In that case all top
   97     # level wvtest protocol messages should be duplicated to stderr so
   98     # that they can be safely captured for report to process later.
   99     my ($dup_msgs) = @_;
  100     my $show_counts = 1;
  101     GetOptionsFromArray(\@ARGV, 'counts!', \$show_counts)
  102         or pod2usage();
  103     pod2usage('$0: no command specified') if (@ARGV < 1);
  104 
  105     # always flush
  106     $| = 1;
  107 
  108     {
  109         my $msg = "Testing \"all\" in @ARGV:\n";
  110         print $msg;
  111         print STDERR $msg if $dup_msgs;
  112     }
  113 
  114     $pid = open(my $fh, "-|");
  115     if (!$pid) {
  116         # child
  117         setpgrp();
  118         open STDERR, '>&STDOUT' or die("Can't dup stdout: $!\n");
  119         exec(@ARGV);
  120         exit 126; # just in case
  121     }
  122 
  123     # parent
  124     my $allstart = time();
  125     local $SIG{INT} = sub { bigkill($pid); };
  126     local $SIG{TERM} = sub { bigkill($pid); };
  127     local $SIG{ALRM} = sub {
  128         print STDERR resultline('Alarm timed out!  No test results for too long.\n',
  129                                 'FAILED');
  130         bigkill($pid);
  131     };
  132 
  133     my ($gpasses, $gfails) = (0,0);
  134     while (<$fh>)
  135     {
  136         chomp;
  137         s/\r//g;
  138 
  139         if (/^\s*Testing "(.*)" in (.*):\s*$/)
  140         {
  141             alarm(300);
  142             my ($sect, $file) = ($1, $2);
  143 
  144             endsect();
  145 
  146             printf("! %s  %s: ", $file, $sect);
  147             @log = ();
  148             $start = $stop;
  149         }
  150         elsif (/^!\s*(.*?)\s+(\S+)\s*$/)
  151         {
  152             alarm(300);
  153 
  154             my ($name, $result) = ($1, $2);
  155             my $pass = ($result eq "ok");
  156 
  157             if (!$start) {
  158                 printf("\n! Startup: ");
  159                 $start = time();
  160             }
  161 
  162             push @log, resultline($name, $result);
  163 
  164             if (!$pass) {
  165                 $gfails++;
  166                 if (@log) {
  167                     print "\n" . join("\n", @log) . "\n";
  168                     @log = ();
  169                 }
  170             } else {
  171                 $gpasses++;
  172                 print ".";
  173             }
  174         }
  175         else
  176         {
  177             push @log, $_;
  178         }
  179     }
  180 
  181     endsect();
  182 
  183     my $newpid = waitpid($pid, 0);
  184     if ($newpid != $pid) {
  185         die("waitpid returned '$newpid', expected '$pid'\n");
  186     }
  187 
  188     my $code = $?;
  189     my $ret = ($code >> 8);
  190 
  191     # return death-from-signal exits as >128.  This is what bash does if you ran
  192     # the program directly.
  193     if ($code && !$ret) { $ret = $code | 128; }
  194 
  195     if ($ret && @log) {
  196         print "\n" . join("\n", @log) . "\n";
  197     }
  198 
  199     if ($code != 0) {
  200         my $msg = resultline("Program returned non-zero exit code ($ret)",
  201                              'FAILED');
  202         print $msg;
  203         print STDERR "$msg\n" if $dup_msgs;
  204     }
  205 
  206     print "\n";
  207     if ($show_counts) {
  208         my $gtotal = $gpasses + $gfails;
  209         my $msg = sprintf("WvTest: %d test%s, %d failure%s\n",
  210                           $gtotal, $gtotal == 1 ? "" : "s", $gfails,
  211                           $gfails == 1 ? "" : "s");
  212         print $msg;
  213         print STDERR $msg if $dup_msgs;
  214     }
  215     {
  216         my $msg = sprintf("WvTest: result code $ret, total time %s\n",
  217                           mstime(time() - $allstart,
  218                                  $overall_test_warn_time,
  219                                  $overall_test_bad_time));
  220         print $msg;
  221         print STDERR $msg if $dup_msgs;
  222     }
  223     return ($ret ? $ret : ($gfails ? 125 : 0));
  224 }
  225 
  226 sub report()
  227 {
  228     my ($gpasses, $gfails) = (0,0);
  229     for my $f (@ARGV)
  230     {
  231         my $fh;
  232         open($fh, '<:crlf', $f) or die "Unable to open $f: $!";
  233         while (<$fh>)
  234         {
  235             chomp;
  236             s/\r//g;
  237 
  238             if (/^\s*Testing "(.*)" in (.*):\s*$/) {
  239                 @log = ();
  240             }
  241             elsif (/^!\s*(.*?)\s+(\S+)\s*$/) {
  242                 my ($name, $result) = ($1, $2);
  243                 my $pass = ($result eq "ok");
  244                 push @log, resultline($name, $result);
  245                 if (!$pass) {
  246                     $gfails++;
  247                     if (@log) {
  248                         print "\n" . join("\n", @log) . "\n";
  249                         @log = ();
  250                     }
  251                 } else {
  252                     $gpasses++;
  253                 }
  254             }
  255             else
  256             {
  257                 push @log, $_;
  258             }
  259         }
  260     }
  261     my $gtotal = $gpasses + $gfails;
  262     printf("\nWvTest: %d test%s, %d failure%s\n",
  263            $gtotal, $gtotal == 1 ? "" : "s",
  264            $gfails, $gfails == 1 ? "" : "s");
  265     return ($gfails ? 125 : 0);
  266 }
  267 
  268 my ($show_help, $show_manual);
  269 Getopt::Long::Configure('no_permute');
  270 GetOptionsFromArray(\@ARGV,
  271                     'help|?' => \$show_help,
  272                     'man' => \$show_manual) or pod2usage();
  273 Getopt::Long::Configure('permute');
  274 pod2usage(-verbose => 1, -exitval => 0) if $show_help;
  275 pod2usage(-verbose => 2, -exitval => 0) if $show_manual;
  276 pod2usage(-msg => "$0: no action specified", -verbose => 1) if (@ARGV < 1);
  277 
  278 my $action = $ARGV[0];
  279 shift @ARGV;
  280 if ($action eq 'run') { exit run(0); }
  281 elsif ($action  eq 'watch') { run(1); }
  282 elsif ($action  eq 'report') { exit report(); }
  283 else { pod2usage(-msg => "$0: invalid action $action", -verbose => 1); }
  284 
  285 __END__
  286 
  287 =head1 NAME
  288 
  289 wvtest - the dumbest cross-platform test framework that could possibly work
  290 
  291 =head1 SYNOPSIS
  292 
  293   wvtest [GLOBAL...] run [RUN_OPT...] [--] command [arg...]
  294   wvtest [GLOBAL...] watch [RUN_OPT...] [--] command [arg...]
  295   wvtest [GLOBAL...] report [logfile...]
  296 
  297   GLOBAL:
  298     --help, -?       display brief help message and exit
  299     --man            display full documentation
  300   RUN_OPT:
  301     --[no-]counts    [don't] show success/failure counts
  302 
  303 =head1 DESCRIPTION
  304 
  305 B<wvtest run some-tests> will run some-tests and report on the result.
  306 This should work fine as long as some-tests doesn't run any sub-tests
  307 in parallel.
  308 
  309 If you'd like to run your tests in parallel, use B<watch> and
  310 B<report> as described in the EXAMPLES below.
  311 
  312 =head1 EXAMPLES
  313 
  314   # Fine if ./tests doesn't produce any output in parallel.
  315   wvtest run ./tests
  316 
  317   # Use watch and report for parallel tests.  Note that watch's stderr will
  318   # include copies of any top level messages - reporting non-zero
  319   # test command exits, etc., and so must be included in the report arguments.
  320   wvtest watch --no-counts \
  321     "sh -c '(test-1 2>&1 | tee test-1.log)& (test-2 2>&1 | tee test-2.log)&'" \
  322     2>test-3.log \
  323   wvtest report test-1.log test-2.log test-3.log
  324 
  325 =cut