wvtest

   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