Merge branch 'jk/t0002-simplify' into jch
[git] / t / perf / aggregate.perl
1 #!/usr/bin/perl
2
3 use lib '../../perl/build/lib';
4 use strict;
5 use warnings;
6 use JSON;
7 use Git;
8
9 sub get_times {
10         my $name = shift;
11         open my $fh, "<", $name or return undef;
12         my $line = <$fh>;
13         return undef if not defined $line;
14         close $fh or die "cannot close $name: $!";
15         $line =~ /^(?:(\d+):)?(\d+):(\d+(?:\.\d+)?) (\d+(?:\.\d+)?) (\d+(?:\.\d+)?)$/
16                 or die "bad input line: $line";
17         my $rt = ((defined $1 ? $1 : 0.0)*60+$2)*60+$3;
18         return ($rt, $4, $5);
19 }
20
21 sub format_times {
22         my ($r, $u, $s, $firstr) = @_;
23         if (!defined $r) {
24                 return "<missing>";
25         }
26         my $out = sprintf "%.2f(%.2f+%.2f)", $r, $u, $s;
27         if (defined $firstr) {
28                 if ($firstr > 0) {
29                         $out .= sprintf " %+.1f%%", 100.0*($r-$firstr)/$firstr;
30                 } elsif ($r == 0) {
31                         $out .= " =";
32                 } else {
33                         $out .= " +inf";
34                 }
35         }
36         return $out;
37 }
38
39 my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests,
40     $codespeed, $subsection, $reponame);
41 while (scalar @ARGV) {
42         my $arg = $ARGV[0];
43         my $dir;
44         if ($arg eq "--codespeed") {
45                 $codespeed = 1;
46                 shift @ARGV;
47                 next;
48         }
49         if ($arg eq "--subsection") {
50                 shift @ARGV;
51                 $subsection = $ARGV[0];
52                 shift @ARGV;
53                 if (! $subsection) {
54                         die "empty subsection";
55                 }
56                 next;
57         }
58         if ($arg eq "--reponame") {
59                 shift @ARGV;
60                 $reponame = $ARGV[0];
61                 shift @ARGV;
62                 if (! $reponame) {
63                         die "empty reponame";
64                 }
65                 next;
66         }
67         last if -f $arg or $arg eq "--";
68         if (! -d $arg) {
69                 my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
70                 $dir = "build/".$rev;
71         } else {
72                 $arg =~ s{/*$}{};
73                 $dir = $arg;
74                 $dirabbrevs{$dir} = $dir;
75         }
76         push @dirs, $dir;
77         $dirnames{$dir} = $arg;
78         my $prefix = $dir;
79         $prefix =~ tr/^a-zA-Z0-9/_/c;
80         $prefixes{$dir} = $prefix . '.';
81         shift @ARGV;
82 }
83
84 if (not @dirs) {
85         @dirs = ('.');
86 }
87 $dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
88 $prefixes{'.'} = '';
89
90 shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
91
92 @tests = @ARGV;
93 if (not @tests) {
94         @tests = glob "p????-*.sh";
95 }
96
97 my $resultsdir = "test-results";
98
99 if (! $subsection and
100     exists $ENV{GIT_PERF_SUBSECTION} and
101     $ENV{GIT_PERF_SUBSECTION} ne "") {
102         $subsection = $ENV{GIT_PERF_SUBSECTION};
103 }
104
105 if ($subsection) {
106         $resultsdir .= "/" . $subsection;
107 }
108
109 my @subtests;
110 my %shorttests;
111 for my $t (@tests) {
112         $t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
113         my $n = $2;
114         my $fname = "$resultsdir/$t.subtests";
115         open my $fp, "<", $fname or die "cannot open $fname: $!";
116         for (<$fp>) {
117                 chomp;
118                 /^(\d+)$/ or die "malformed subtest line: $_";
119                 push @subtests, "$t.$1";
120                 $shorttests{"$t.$1"} = "$n.$1";
121         }
122         close $fp or die "cannot close $fname: $!";
123 }
124
125 sub read_descr {
126         my $name = shift;
127         open my $fh, "<", $name or return "<error reading description>";
128         binmode $fh, ":utf8" or die "PANIC on binmode: $!";
129         my $line = <$fh>;
130         close $fh or die "cannot close $name";
131         chomp $line;
132         return $line;
133 }
134
135 sub have_duplicate {
136         my %seen;
137         for (@_) {
138                 return 1 if exists $seen{$_};
139                 $seen{$_} = 1;
140         }
141         return 0;
142 }
143 sub have_slash {
144         for (@_) {
145                 return 1 if m{/};
146         }
147         return 0;
148 }
149
150 sub print_default_results {
151         my %descrs;
152         my $descrlen = 4; # "Test"
153         for my $t (@subtests) {
154                 $descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
155                 $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
156         }
157
158         my %newdirabbrevs = %dirabbrevs;
159         while (!have_duplicate(values %newdirabbrevs)) {
160                 %dirabbrevs = %newdirabbrevs;
161                 last if !have_slash(values %dirabbrevs);
162                 %newdirabbrevs = %dirabbrevs;
163                 for (values %newdirabbrevs) {
164                         s{^[^/]*/}{};
165                 }
166         }
167
168         my %times;
169         my @colwidth = ((0)x@dirs);
170         for my $i (0..$#dirs) {
171                 my $d = $dirs[$i];
172                 my $w = length (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
173                 $colwidth[$i] = $w if $w > $colwidth[$i];
174         }
175         for my $t (@subtests) {
176                 my $firstr;
177                 for my $i (0..$#dirs) {
178                         my $d = $dirs[$i];
179                         $times{$prefixes{$d}.$t} = [get_times("$resultsdir/$prefixes{$d}$t.times")];
180                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
181                         my $w = length format_times($r,$u,$s,$firstr);
182                         $colwidth[$i] = $w if $w > $colwidth[$i];
183                         $firstr = $r unless defined $firstr;
184                 }
185         }
186         my $totalwidth = 3*@dirs+$descrlen;
187         $totalwidth += $_ for (@colwidth);
188
189         printf "%-${descrlen}s", "Test";
190         for my $i (0..$#dirs) {
191                 my $d = $dirs[$i];
192                 printf "   %-$colwidth[$i]s", (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
193         }
194         print "\n";
195         print "-"x$totalwidth, "\n";
196         for my $t (@subtests) {
197                 printf "%-${descrlen}s", $descrs{$t};
198                 my $firstr;
199                 for my $i (0..$#dirs) {
200                         my $d = $dirs[$i];
201                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
202                         printf "   %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
203                         $firstr = $r unless defined $firstr;
204                 }
205                 print "\n";
206         }
207 }
208
209 sub print_codespeed_results {
210         my ($subsection) = @_;
211
212         my $project = "Git";
213
214         my $executable = `uname -s -m`;
215         chomp $executable;
216
217         if ($subsection) {
218                 $executable .= ", " . $subsection;
219         }
220
221         my $environment;
222         if ($reponame) {
223                 $environment = $reponame;
224         } elsif (exists $ENV{GIT_PERF_REPO_NAME} and $ENV{GIT_PERF_REPO_NAME} ne "") {
225                 $environment = $ENV{GIT_PERF_REPO_NAME};
226         } elsif (exists $ENV{GIT_TEST_INSTALLED} and $ENV{GIT_TEST_INSTALLED} ne "") {
227                 $environment = $ENV{GIT_TEST_INSTALLED};
228                 $environment =~ s|/bin-wrappers$||;
229         } else {
230                 $environment = `uname -r`;
231                 chomp $environment;
232         }
233
234         my @data;
235
236         for my $t (@subtests) {
237                 for my $d (@dirs) {
238                         my $commitid = $prefixes{$d};
239                         $commitid =~ s/^build_//;
240                         $commitid =~ s/\.$//;
241                         my ($result_value, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.times");
242
243                         my %vals = (
244                                 "commitid" => $commitid,
245                                 "project" => $project,
246                                 "branch" => $dirnames{$d},
247                                 "executable" => $executable,
248                                 "benchmark" => $shorttests{$t} . " " . read_descr("$resultsdir/$t.descr"),
249                                 "environment" => $environment,
250                                 "result_value" => $result_value,
251                             );
252                         push @data, \%vals;
253                 }
254         }
255
256         print to_json(\@data, {utf8 => 1, pretty => 1, canonical => 1}), "\n";
257 }
258
259 binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
260
261 if ($codespeed) {
262         print_codespeed_results($subsection);
263 } else {
264         print_default_results();
265 }