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