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