1#!/usr/bin/env perl 2 3use strict; 4use warnings; 5use File::Temp qw/ tempdir /; 6use IO::Handle; 7 8$|=1; 9 10my $verbose = 1; 11 12# both flags below default to $verbose. 13# 0 means nothing is printed. 14# 1 means that failed (or pending) outputs are printed. 15# Passed outputs are not printed. 16# 2 means that all outputs are printed. 17my $print_outputs_on_normal_exit; 18my $print_outputs_on_interrupt; 19 20my $use_color = 1; 21 22my $tmpdir = tempdir( CLEANUP => 1 ); 23 24my %archive=(); 25my @live=(); 26 27my $tests_pending = 0; 28my $tests_passed = 0; 29my $tests_skipped = 0; 30my $tests_failed = 0; 31my $total_tests='?'; 32 33my $csi = { 34 alert => "\033[01;31m", # bold red 35 failure => "\033[01;31m", # bold red 36 success => "\033[01;32m", # bold green 37 starting => "\033[01;33m", # bold yellow 38 skipped => "\033[01;37m", # bold gray 39 normal => "\033[00;39m\033[00m", # black 40}; 41 42while (defined($_ = shift @ARGV)) { 43 if (/^-nc$/) { $csi->{$_}='' for keys %$csi; } 44 elsif (/^-v$/) { $verbose++; } 45 elsif (/^-q$/) { $verbose--; } 46 else { 47 die "unexpected arg\n"; 48 } 49} 50 51if (!defined($print_outputs_on_interrupt)) { 52 $print_outputs_on_interrupt = $verbose; 53} 54if (!defined($print_outputs_on_normal_exit)) { 55 $print_outputs_on_normal_exit = $verbose; 56} 57 58 59sub sformat { 60 my $n = shift @_; 61 if (!defined($n)) { 62 # return sprintf("%3s %12s", "", ""); 63 return " "; 64 } 65 my $title = $archive{$n}->{'title'}; 66 # $title = substr($title, -12); 67 return sprintf("%3d: %s", $n, $title); 68} 69 70sub short_global_status { 71 my @tcounts = map { 72 $_->[1] >= 1 ? 73 $csi->{$_->[0]} . 74 sprintf("%3d", $_->[1]) . 75 $csi->{'normal'} 76 : 77 sprintf("%3d", $_->[1]) 78 } ( 79 ['starting', $tests_pending], 80 ['success', $tests_passed], 81 ['failure', $tests_failed], 82 ['skipped', $tests_skipped] 83 ); 84 return join(" ", @tcounts); 85} 86 87sub print_live { 88 my $n = shift @_; 89 my $color = shift @_; 90 my $ex=''; 91 my @txs=(); 92 for (@live) { 93 my $tx = defined($_) ? sprintf("%3d", $_) : " "; 94 if (defined($_) && $_ == $n && defined($color)) { 95 $ex = "$csi->{$color}$tx: $archive{$n}->{'title'}$csi->{'normal'}"; 96 $tx = "$csi->{$color}$tx$csi->{'normal'}"; 97 } 98 push @txs, $tx; 99 } 100 my $tests = "[" . short_global_status . " / $total_tests ]"; 101 $tests .= " " . join(" ", @txs); 102 $tests .= " $ex" if $ex; 103 print "$tests\n" unless ($verbose < 0 && defined($color) && $color eq 'starting'); 104} 105 106sub put_to_live_slot { 107 my $n = shift @_; 108 my $color = shift @_; 109 my $i; 110 for($i = 0 ; $i < scalar @live ; $i++) { 111 if (!defined($live[$i])) { 112 $live[$i]=$n; 113 last; 114 } 115 } 116 if ($i == scalar @live) { 117 push @live, $n; 118 } 119 print_live($n, $color); 120} 121 122sub remove_from_live_slot { 123 my $n = shift @_; 124 my $color = shift @_; 125 my $i; 126 for($i = 0 ; $i < scalar @live ; $i++) { 127 if (defined($live[$i]) && $live[$i] == $n) { 128 last; 129 } 130 } 131 die "unexpected test number $i, not currently running:\n$_" if $i == scalar @live; 132 print_live($n, $color); 133 $live[$i]=undef; 134} 135 136sub print_all_outputs { 137 my $interrupt = scalar @_; 138 return if $interrupt && $print_outputs_on_interrupt == 0; 139 return if !$interrupt && $print_outputs_on_normal_exit == 0; 140 for my $n (sort { $a <=> $b } keys %archive) { 141 my $outcome=$archive{$n}->{'outcome'}; 142 my $passed = defined($outcome) && $outcome =~ /Passed/; 143 my $skipped = defined($outcome) && $outcome =~ /Skipped/; 144 if ($passed || $skipped) { 145 next if $interrupt && $print_outputs_on_interrupt <= 1; 146 next if !$interrupt && $print_outputs_on_normal_exit <= 1; 147 } 148 my $pending = ($interrupt && !defined($outcome)); 149 next if ($verbose >= 3 && !$pending); 150 open F, "$tmpdir/$n.out"; 151 while (defined($_=<F>)) { 152 print; 153 } 154 close F; 155 if ($pending) { 156 print "Note: test $n was interrupted\n"; 157 } 158 print "\n"; 159 } 160} 161 162sub sigint { 163 my $sig = shift @_; 164 print "\n$csi->{'alert'}Testing was interrupted$csi->{'normal'}\n"; 165 print_all_outputs($sig); 166 print "\n$csi->{'starting'}Note: testing was interrupted$csi->{'normal'}\n"; 167 print "[" . short_global_status . "]\n"; 168 my $all_pending = ''; 169 my $all_failed = ''; 170 for my $n (keys %archive) { 171 my $outcome=$archive{$n}->{'outcome'}; 172 my $title=$archive{$n}->{'title'}; 173 my $passed = defined($outcome) && $outcome =~ /Passed/; 174 my $skipped = defined($outcome) && $outcome =~ /Skipped/; 175 next if $passed || $skipped; 176 if ($outcome) { 177 $all_failed .= sprintf("%3d", $n) . ": $title\n"; 178 } else { 179 $all_pending .= sprintf("%3d", $n) . ": $title\n"; 180 } 181 } 182 if ($all_pending ne '') { 183 print "$csi->{'starting'}=== $tests_pending interrupted tests ===\n$all_pending$csi->{'normal'}"; 184 } 185 if ($all_failed ne '') { 186 print "$csi->{'failure'}=== $tests_failed failed tests ===\n$all_failed$csi->{'normal'}"; 187 } 188 exit 1; 189} 190 191 192sub hexdump { 193 my $str = shift @_; 194 195 return "[ZERO-LENGTH STRING]\n" unless length $str; 196 197 # split input up into 16-byte chunks: 198 my @chunks = $str =~ /([\0-\377]{1,16})/g; 199 # format and print: 200 my @print; 201 for (@chunks) { 202 my $hex = unpack "H*", $_; 203 tr/ -~/./c; # mask non-print chars 204 $hex =~ s/(..)(?!$)/$1 /g; # insert spaces in hex 205 # make sure our hex output has the correct length 206 $hex .= ' ' x ( length($hex) < 48 ? 48 - length($hex) : 0 ); 207 push @print, "$hex $_\n"; 208 } 209 wantarray ? @print : join '', @print; 210} 211 212$SIG{'INT'} = \&sigint; 213 214while (<>) { 215 next if /^test \d+$/; 216 next if /^$/; 217 if (/^\s+Start\s+(\d+): (.*)$/) { 218 my $n = $1; 219 my $title = $2; 220 die "unexpected test number $n, already running:\n$_" if $archive{$n}; 221 open(my $fh, ">", "$tmpdir/$n.out"); 222 $archive{$n} = { 223 title=>$title, 224 data=>"", 225 fd=>$fh 226 }; 227 print $fh $_; 228 print $fh "\n"; 229 $fh->flush(); 230 $tests_pending++; 231 put_to_live_slot($n, 'starting'); 232 next; 233 } elsif (/^(\d+):\s?/) { 234 my $n=$1; 235 die "unexpected data from stdin:\n$_" unless $archive{$1}; 236 my $fh = $archive{$n}->{'fd'}; 237 print $fh $_; 238 $fh->flush(); 239 } elsif (/^\s*\d+\/(\d+) Test\s+\#(\d+):\s+(\S+) \.*(.*)/) { 240 $total_tests=$1; 241 my $n = $2; 242 my $title = $3; 243 my $outcome = $4; 244 die "unexpected test number $n, not currently running:\n$_" unless $archive{$n}; 245 die "unexpected test title, does not match: \"$archive{$n}->{'title'}\"\n$_" unless $archive{$n}->{'title'} eq $title; 246 $archive{$n}->{'outcome'}=$outcome; 247 my $fh = $archive{$n}->{'fd'}; 248 print $fh "\n"; 249 print $fh $_; 250 close $fh; 251 delete $archive{$n}->{'fd'}; 252 if ($verbose >= 3) { 253 # print the full test contents. 254 open F, "$tmpdir/$n.out"; 255 while (defined($_=<F>)) { 256 print; 257 } 258 close F; 259 } 260 $tests_pending--; 261 my $color; 262 if ($outcome =~ /Passed/) { 263 $tests_passed++; 264 $color='success'; 265 } elsif ($outcome =~ /Skipped/) { 266 $tests_skipped++; 267 $color='skipped'; 268 } else { 269 $tests_failed++; 270 $color='failure'; 271 } 272 remove_from_live_slot($n, $color); 273 } elsif (/\s*\d+% tests/ || /The following/) { 274 die "unexpected final text, some tests are still running: @live\n$_" if scalar grep { defined($_) } @live; 275 my $tailmsg = $_; 276 print_all_outputs; 277 if ($verbose >= 0) { 278 print "\n"; 279 print $tailmsg; 280 while (<>) { 281 print; 282 } 283 } else { 284 # consume output, so that we avoid the dreaded broken pipe 285 while (<>) {} 286 } 287 last; 288 } elsif (scalar @live == 0) { 289 next; 290 } else { 291 die "unexpected data from stdin:\n$_\n" . hexdump($_); 292 } 293} 294