| 1 | #!/usr/bin/perl -w | ||
| 2 | # | ||
| 3 | # WvTest: | ||
| 4 | # Copyright (C)2007-2009 Versabanq Innovations Inc. and contributors. | ||
| 5 | # Licensed under the GNU Library General Public License, version 2. | ||
| 6 | # See the included file named LICENSE for license information. | ||
| 7 | # | ||
| 8 | use strict; | ||
| 9 | use Time::HiRes qw(time); | ||
| 10 | |||
| 11 | # always flush | ||
| 12 | $| = 1; | ||
| 13 | |||
| 14 | if (@ARGV < 1) { | ||
| 15 | print STDERR "Usage: $0 <command line...>\n"; | ||
| 16 | exit 127; | ||
| 17 | } | ||
| 18 | |||
| 19 | print STDERR "Testing \"all\" in @ARGV:\n"; | ||
| 20 | |||
| 21 | my $pid = open(my $fh, "-|"); | ||
| 22 | if (!$pid) { | ||
| 23 | # child | ||
| 24 | setpgrp(); | ||
| 25 | open STDERR, '>&STDOUT' or die("Can't dup stdout: $!\n"); | ||
| 26 | exec(@ARGV); | ||
| 27 | exit 126; # just in case | ||
| 28 | } | ||
| 29 | |||
| 30 | my $istty = -t STDOUT; | ||
| 31 | my @log = (); | ||
| 32 | my ($gpasses, $gfails) = (0,0); | ||
| 33 | |||
| 34 | sub bigkill($) | ||
| 35 | { | ||
| 36 | my $pid = shift; | ||
| 37 | |||
| 38 | if (@log) { | ||
| 39 | print "\n" . join("\n", @log) . "\n"; | ||
| 40 | } | ||
| 41 | |||
| 42 | print STDERR "\n! Killed by signal FAILED\n"; | ||
| 43 | |||
| 44 | ($pid > 0) || die("pid is '$pid'?!\n"); | ||
| 45 | |||
| 46 | local $SIG{CHLD} = sub { }; # this will wake us from sleep() faster | ||
| 47 | kill 15, $pid; | ||
| 48 | sleep(2); | ||
| 49 | |||
| 50 | if ($pid > 1) { | ||
| 51 | kill 9, -$pid; | ||
| 52 | } | ||
| 53 | kill 9, $pid; | ||
| 54 | |||
| 55 | exit(125); | ||
| 56 | } | ||
| 57 | |||
| 58 | # parent | ||
| 59 | local $SIG{INT} = sub { bigkill($pid); }; | ||
| 60 | local $SIG{TERM} = sub { bigkill($pid); }; | ||
| 61 | local $SIG{ALRM} = sub { | ||
| 62 | print STDERR "Alarm timed out! No test results for too long.\n"; | ||
| 63 | bigkill($pid); | ||
| 64 | }; | ||
| 65 | |||
| 66 | sub colourize($) | ||
| 67 | { | ||
| 68 | my $result = shift; | ||
| 69 | my $pass = ($result eq "ok"); | ||
| 70 | |||
| 71 | if ($istty) { | ||
| 72 | my $colour = $pass ? "\e[32;1m" : "\e[31;1m"; | ||
| 73 | return "$colour$result\e[0m"; | ||
| 74 | } else { | ||
| 75 | return $result; | ||
| 76 | } | ||
| 77 | } | ||
| 78 | |||
| 79 | sub mstime($$$) | ||
| 80 | { | ||
| 81 | my ($floatsec, $warntime, $badtime) = @_; | ||
| 82 | my $ms = int($floatsec * 1000); | ||
| 83 | my $str = sprintf("%d.%03ds", $ms/1000, $ms % 1000); | ||
| 84 | |||
| 85 | if ($istty && $ms > $badtime) { | ||
| 86 | return "\e[31;1m$str\e[0m"; | ||
| 87 | } elsif ($istty && $ms > $warntime) { | ||
| 88 | return "\e[33;1m$str\e[0m"; | ||
| 89 | } else { | ||
| 90 | return "$str"; | ||
| 91 | } | ||
| 92 | } | ||
| 93 | |||
| 94 | sub resultline($$) | ||
| 95 | { | ||
| 96 | my ($name, $result) = @_; | ||
| 97 | return sprintf("! %-65s %s", $name, colourize($result)); | ||
| 98 | } | ||
| 99 | |||
| 100 | my $allstart = time(); | ||
| 101 | my ($start, $stop); | ||
| 102 | |||
| 103 | sub endsect() | ||
| 104 | { | ||
| 105 | $stop = time(); | ||
| 106 | if ($start) { | ||
| 107 | printf " %s %s\n", mstime($stop - $start, 500, 1000), colourize("ok"); | ||
| 108 | } | ||
| 109 | } | ||
| 110 | |||
| 111 | while (<$fh>) | ||
| 112 | { | ||
| 113 | chomp; | ||
| 114 | s/\r//g; | ||
| 115 | |||
| 116 | if (/^\s*Testing "(.*)" in (.*):\s*$/) | ||
| 117 | { | ||
| 118 | alarm(120); | ||
| 119 | my ($sect, $file) = ($1, $2); | ||
| 120 | |||
| 121 | endsect(); | ||
| 122 | |||
| 123 | printf("! %s %s: ", $file, $sect); | ||
| 124 | @log = (); | ||
| 125 | $start = $stop; | ||
| 126 | } | ||
| 127 | elsif (/^!\s*(.*?)\s+(\S+)\s*$/) | ||
| 128 | { | ||
| 129 | alarm(120); | ||
| 130 | |||
| 131 | my ($name, $result) = ($1, $2); | ||
| 132 | my $pass = ($result eq "ok"); | ||
| 133 | |||
| 134 | if (!$start) { | ||
| 135 | printf("\n! Startup: "); | ||
| 136 | $start = time(); | ||
| 137 | } | ||
| 138 | |||
| 139 | push @log, resultline($name, $result); | ||
| 140 | |||
| 141 | if (!$pass) { | ||
| 142 | $gfails++; | ||
| 143 | if (@log) { | ||
| 144 | print "\n" . join("\n", @log) . "\n"; | ||
| 145 | @log = (); | ||
| 146 | } | ||
| 147 | } else { | ||
| 148 | $gpasses++; | ||
| 149 | print "."; | ||
| 150 | } | ||
| 151 | } | ||
| 152 | else | ||
| 153 | { | ||
| 154 | push @log, $_; | ||
| 155 | } | ||
| 156 | } | ||
| 157 | |||
| 158 | endsect(); | ||
| 159 | |||
| 160 | my $newpid = waitpid($pid, 0); | ||
| 161 | if ($newpid != $pid) { | ||
| 162 | die("waitpid returned '$newpid', expected '$pid'\n"); | ||
| 163 | } | ||
| 164 | |||
| 165 | my $code = $?; | ||
| 166 | my $ret = ($code >> 8); | ||
| 167 | |||
| 168 | # return death-from-signal exits as >128. This is what bash does if you ran | ||
| 169 | # the program directly. | ||
| 170 | if ($code && !$ret) { $ret = $code | 128; } | ||
| 171 | |||
| 172 | if ($ret && @log) { | ||
| 173 | print "\n" . join("\n", @log) . "\n"; | ||
| 174 | } | ||
| 175 | |||
| 176 | if ($code != 0) { | ||
| 177 | print resultline("Program returned non-zero exit code ($ret)", "FAILED"); | ||
| 178 | } | ||
| 179 | |||
| 180 | my $gtotal = $gpasses+$gfails; | ||
| 181 | printf("\nWvTest: %d test%s, %d failure%s, total time %s.\n", | ||
| 182 | $gtotal, $gtotal==1 ? "" : "s", | ||
| 183 | $gfails, $gfails==1 ? "" : "s", | ||
| 184 | mstime(time() - $allstart, 2000, 5000)); | ||
| 185 | print STDERR "\nWvTest result code: $ret\n"; | ||
| 186 | exit( $ret ? $ret : ($gfails ? 125 : 0) ); | ||
| 187 |