1#!/usr/bin/perl
2
3use strict;
4use warnings;
5use Git;
6
7sub get_times {
8 my $name = shift;
9 open my $fh, "<", $name or return undef;
10 my $line = <$fh>;
11 return undef if not defined $line;
12 close $fh or die "cannot close $name: $!";
13 $line =~ /^(?:(\d+):)?(\d+):(\d+(?:\.\d+)?) (\d+(?:\.\d+)?) (\d+(?:\.\d+)?)$/
14 or die "bad input line: $line";
15 my $rt = ((defined $1 ? $1 : 0.0)*60+$2)*60+$3;
16 return ($rt, $4, $5);
17}
18
19sub format_times {
20 my ($r, $u, $s, $firstr) = @_;
21 if (!defined $r) {
22 return "<missing>";
23 }
24 my $out = sprintf "%.2f(%.2f+%.2f)", $r, $u, $s;
25 if (defined $firstr) {
26 if ($firstr > 0) {
27 $out .= sprintf " %+.1f%%", 100.0*($r-$firstr)/$firstr;
28 } elsif ($r == 0) {
29 $out .= " =";
30 } else {
31 $out .= " +inf";
32 }
33 }
34 return $out;
35}
36
37my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests);
38while (scalar @ARGV) {
39 my $arg = $ARGV[0];
40 my $dir;
41 last if -f $arg or $arg eq "--";
42 if (! -d $arg) {
43 my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
44 $dir = "build/".$rev;
45 } else {
46 $arg =~ s{/*$}{};
47 $dir = $arg;
48 $dirabbrevs{$dir} = $dir;
49 }
50 push @dirs, $dir;
51 $dirnames{$dir} = $arg;
52 my $prefix = $dir;
53 $prefix =~ tr/^a-zA-Z0-9/_/c;
54 $prefixes{$dir} = $prefix . '.';
55 shift @ARGV;
56}
57
58if (not @dirs) {
59 @dirs = ('.');
60}
61$dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
62$prefixes{'.'} = '';
63
64shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
65
66@tests = @ARGV;
67if (not @tests) {
68 @tests = glob "p????-*.sh";
69}
70
71my @subtests;
72my %shorttests;
73for my $t (@tests) {
74 $t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
75 my $n = $2;
76 my $fname = "test-results/$t.subtests";
77 open my $fp, "<", $fname or die "cannot open $fname: $!";
78 for (<$fp>) {
79 chomp;
80 /^(\d+)$/ or die "malformed subtest line: $_";
81 push @subtests, "$t.$1";
82 $shorttests{"$t.$1"} = "$n.$1";
83 }
84 close $fp or die "cannot close $fname: $!";
85}
86
87sub read_descr {
88 my $name = shift;
89 open my $fh, "<", $name or return "<error reading description>";
90 my $line = <$fh>;
91 close $fh or die "cannot close $name";
92 chomp $line;
93 return $line;
94}
95
96my %descrs;
97my $descrlen = 4; # "Test"
98for my $t (@subtests) {
99 $descrs{$t} = $shorttests{$t}.": ".read_descr("test-results/$t.descr");
100 $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
101}
102
103sub have_duplicate {
104 my %seen;
105 for (@_) {
106 return 1 if exists $seen{$_};
107 $seen{$_} = 1;
108 }
109 return 0;
110}
111sub have_slash {
112 for (@_) {
113 return 1 if m{/};
114 }
115 return 0;
116}
117
118my %newdirabbrevs = %dirabbrevs;
119while (!have_duplicate(values %newdirabbrevs)) {
120 %dirabbrevs = %newdirabbrevs;
121 last if !have_slash(values %dirabbrevs);
122 %newdirabbrevs = %dirabbrevs;
123 for (values %newdirabbrevs) {
124 s{^[^/]*/}{};
125 }
126}
127
128my %times;
129my @colwidth = ((0)x@dirs);
130for my $i (0..$#dirs) {
131 my $d = $dirs[$i];
132 my $w = length (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
133 $colwidth[$i] = $w if $w > $colwidth[$i];
134}
135for my $t (@subtests) {
136 my $firstr;
137 for my $i (0..$#dirs) {
138 my $d = $dirs[$i];
139 $times{$prefixes{$d}.$t} = [get_times("test-results/$prefixes{$d}$t.times")];
140 my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
141 my $w = length format_times($r,$u,$s,$firstr);
142 $colwidth[$i] = $w if $w > $colwidth[$i];
143 $firstr = $r unless defined $firstr;
144 }
145}
146my $totalwidth = 3*@dirs+$descrlen;
147$totalwidth += $_ for (@colwidth);
148
149printf "%-${descrlen}s", "Test";
150for my $i (0..$#dirs) {
151 my $d = $dirs[$i];
152 printf " %-$colwidth[$i]s", (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
153}
154print "\n";
155print "-"x$totalwidth, "\n";
156for my $t (@subtests) {
157 printf "%-${descrlen}s", $descrs{$t};
158 my $firstr;
159 for my $i (0..$#dirs) {
160 my $d = $dirs[$i];
161 my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
162 printf " %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
163 $firstr = $r unless defined $firstr;
164 }
165 print "\n";
166}