Win32: move environment functions
[git/dscho.git] / t / perf / aggregate.perl
blob15f7fc1b8015114883bc36d1e35dffd730721e52
1 #!/usr/bin/perl
3 use strict;
4 use warnings;
5 use Git;
7 sub 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);
19 sub format_times {
20 my ($r, $u, $s, $firstr) = @_;
21 if (!defined $r) {
22 return "<missing>";
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";
34 return $out;
37 my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests);
38 while (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;
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;
58 if (not @dirs) {
59 @dirs = ('.');
61 $dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
62 $prefixes{'.'} = '';
64 shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
66 @tests = @ARGV;
67 if (not @tests) {
68 @tests = glob "p????-*.sh";
71 my @subtests;
72 my %shorttests;
73 for 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";
84 close $fp or die "cannot close $fname: $!";
87 sub 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;
96 my %descrs;
97 my $descrlen = 4; # "Test"
98 for my $t (@subtests) {
99 $descrs{$t} = $shorttests{$t}.": ".read_descr("test-results/$t.descr");
100 $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
103 sub have_duplicate {
104 my %seen;
105 for (@_) {
106 return 1 if exists $seen{$_};
107 $seen{$_} = 1;
109 return 0;
111 sub have_slash {
112 for (@_) {
113 return 1 if m{/};
115 return 0;
118 my %newdirabbrevs = %dirabbrevs;
119 while (!have_duplicate(values %newdirabbrevs)) {
120 %dirabbrevs = %newdirabbrevs;
121 last if !have_slash(values %dirabbrevs);
122 %newdirabbrevs = %dirabbrevs;
123 for (values %newdirabbrevs) {
124 s{^[^/]*/}{};
128 my %times;
129 my @colwidth = ((0)x@dirs);
130 for 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];
135 for 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;
146 my $totalwidth = 3*@dirs+$descrlen;
147 $totalwidth += $_ for (@colwidth);
149 printf "%-${descrlen}s", "Test";
150 for my $i (0..$#dirs) {
151 my $d = $dirs[$i];
152 printf " %-$colwidth[$i]s", (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
154 print "\n";
155 print "-"x$totalwidth, "\n";
156 for 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;
165 print "\n";