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