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     my $show_counts = 1;
  90     GetOptionsFromArray(\@ARGV, 'counts!', \$show_counts)
  91         or pod2usage();
  92     pod2usage('$0: no command specified') if (@ARGV < 1);
  93
  94     # always flush
  95     $| = 1;
  96
  97     print STDERR "Testing \"all\" in @ARGV:\n";
  98
  99     $pid = open(my $fh, "-|");
 100     if (!$pid) {
 101         # child
 102         setpgrp();
 103         open STDERR, '>&STDOUT' or die("Can't dup stdout: $!\n");
 104         exec(@ARGV);
 105         exit 126; # just in case
 106     }
 107
 108     # parent
 109     my $allstart = time();
 110     local $SIG{INT} = sub { bigkill($pid); };
 111     local $SIG{TERM} = sub { bigkill($pid); };
 112     local $SIG{ALRM} = sub {
 113         print STDERR "Alarm timed out!  No test results for too long.\n";
 114         bigkill($pid);
 115     };
 116
 117     my ($gpasses, $gfails) = (0,0);
 118     while (<$fh>)
 119     {
 120         chomp;
 121         s/\r//g;
 122
 123         if (/^\s*Testing "(.*)" in (.*):\s*$/)
 124         {
 125             alarm(120);
 126             my ($sect, $file) = ($1, $2);
 127
 128             endsect();
 129
 130             printf("! %s  %s: ", $file, $sect);
 131             @log = ();
 132             $start = $stop;
 133         }
 134         elsif (/^!\s*(.*?)\s+(\S+)\s*$/)
 135         {
 136             alarm(120);
 137
 138             my ($name, $result) = ($1, $2);
 139             my $pass = ($result eq "ok");
 140
 141             if (!$start) {
 142                 printf("\n! Startup: ");
 143                 $start = time();
 144             }
 145
 146             push @log, resultline($name, $result);
 147
 148             if (!$pass) {
 149                 $gfails++;
 150                 if (@log) {
 151                     print "\n" . join("\n", @log) . "\n";
 152                     @log = ();
 153                 }
 154             } else {
 155                 $gpasses++;
 156                 print ".";
 157             }
 158         }
 159         else
 160         {
 161             push @log, $_;
 162         }
 163     }
 164
 165     endsect();
 166
 167     my $newpid = waitpid($pid, 0);
 168     if ($newpid != $pid) {
 169         die("waitpid returned '$newpid', expected '$pid'\n");
 170     }
 171
 172     my $code = $?;
 173     my $ret = ($code >> 8);
 174
 175     # return death-from-signal exits as >128.  This is what bash does if you ran
 176     # the program directly.
 177     if ($code && !$ret) { $ret = $code | 128; }
 178
 179     if ($ret && @log) {
 180         print "\n" . join("\n", @log) . "\n";
 181     }
 182
 183     if ($code != 0) {
 184         print resultline("Program returned non-zero exit code ($ret)", "FAILED");
 185     }
 186
 187     print "\n";
 188     if ($show_counts) {
 189         my $gtotal = $gpasses + $gfails;
 190         printf("WvTest: %d test%s, %d failure%s\n",
 191                $gtotal, $gtotal==1 ? "" : "s",
 192                $gfails, $gfails==1 ? "" : "s");
 193     }
 194     printf("WvTest: result code $ret, total time %s\n",
 195            mstime(time() - $allstart, 2000, 5000));
 196     return ($ret ? $ret : ($gfails ? 125 : 0));
 197 }
 198
 199 sub report()
 200 {
 201     my ($gpasses, $gfails) = (0,0);
 202     for my $f (@ARGV)
 203     {
 204         my $fh;
 205         open($fh, '<:crlf', $f) or die "Unable to open $f: $!";
 206         while (<$fh>)
 207         {
 208             chomp;
 209             s/\r//g;
 210
 211             if (/^\s*Testing "(.*)" in (.*):\s*$/) {
 212                 @log = ();
 213             }
 214             elsif (/^!\s*(.*?)\s+(\S+)\s*$/) {
 215                 my ($name, $result) = ($1, $2);
 216                 my $pass = ($result eq "ok");
 217                 push @log, resultline($name, $result);
 218                 if (!$pass) {
 219                     $gfails++;
 220                     if (@log) {
 221                         print "\n" . join("\n", @log) . "\n";
 222                         @log = ();
 223                     }
 224                 } else {
 225                     $gpasses++;
 226                 }
 227             }
 228             else
 229             {
 230                 push @log, $_;
 231             }
 232         }
 233     }
 234     my $gtotal = $gpasses + $gfails;
 235     printf("\nWvTest: %d test%s, %d failure%s\n",
 236            $gtotal, $gtotal == 1 ? "" : "s",
 237            $gfails, $gfails == 1 ? "" : "s");
 238     return ($gfails ? 125 : 0);
 239 }
 240
 241 my ($show_help, $show_manual);
 242 Getopt::Long::Configure('no_permute');
 243 GetOptionsFromArray(\@ARGV,
 244                     'help|?' => \$show_help,
 245                     'man' => \$show_manual) or pod2usage();
 246 Getopt::Long::Configure('permute');
 247 pod2usage(-verbose => 1, -exitval => 0) if $show_help;
 248 pod2usage(-verbose => 2, -exitval => 0) if $show_manual;
 249 pod2usage(-msg => "$0: no action specified", -verbose => 1) if (@ARGV < 1);
 250
 251 my $action = $ARGV[0];
 252 shift @ARGV;
 253 if ($action eq 'run') { exit run(); }
 254 elsif ($action  eq 'watch') { run(); }
 255 elsif ($action  eq 'report') { exit report(); }
 256 else { pod2usage(-msg => "$0: invalid action $action", -verbose => 1); }
 257
 258 __END__
 259
 260 =head1 NAME
 261
 262 wvtest - the dumbest cross-platform test framework that could possibly work
 263
 264 =head1 SYNOPSIS
 265
 266   wvtest [GLOBAL...] run [RUN_OPT...] [--] command [arg...]
 267   wvtest [GLOBAL...] watch [RUN_OPT...] [--] command [arg...]
 268   wvtest [GLOBAL...] report [logfile...]
 269
 270   GLOBAL:
 271     --help, -?       display brief help message and exit
 272     --man            display full documentation
 273   RUN_OPT:
 274     --[no-]counts    [don't] show success/failure counts
 275
 276 =head1 DESCRIPTION
 277
 278 B<wvtest run some-tests> will run some-tests and report on the result.
 279 This should work fine as long as some-tests doesn't run any sub-tests
 280 in parallel.
 281
 282 If you'd like to run your tests in parallel, use B<watch> and
 283 B<report> as described in the EXAMPLES below.
 284
 285 =head1 EXAMPLES
 286
 287   # Fine if ./tests doesn't produce any output in parallel.
 288   wvtest run ./tests
 289
 290   # Use watch and report for parallel tests.
 291   wvtest watch --no-counts \
 292     sh -c '(test-1 2>&1 | tee test-1.log)& (test-2 2>&1 | tee test-2.log)&'
 293   wvtest report test-1.log test-2.log
 294
 295 =cut