mirror of
https://github.com/git/git.git
synced 2024-10-30 22:07:53 +01:00
31cd128372
aggregate.perl did not work when Git.pm is not installed to a directory contained in the default Perl library path list or PERLLIB. This commit prepends the Perl library path of the current Git source tree to enable this. Note that this commit adds a hard-coded relative path use lib '../../perl/blib/lib'; instead of the flexible environment-based variant use lib (split(/:/, $ENV{GITPERLLIB})); which is used in tests written in Perl. The hard-coded variant is used because the whole performance test framework does it that way (and GITPERLLIB is not set there). Signed-off-by: Stephan Beyer <s-beyer@gmx.net> Signed-off-by: Junio C Hamano <gitster@pobox.com>
167 lines
3.8 KiB
Perl
Executable file
167 lines
3.8 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
|
|
use lib '../../perl/blib/lib';
|
|
use strict;
|
|
use warnings;
|
|
use Git;
|
|
|
|
sub get_times {
|
|
my $name = shift;
|
|
open my $fh, "<", $name or return undef;
|
|
my $line = <$fh>;
|
|
return undef if not defined $line;
|
|
close $fh or die "cannot close $name: $!";
|
|
$line =~ /^(?:(\d+):)?(\d+):(\d+(?:\.\d+)?) (\d+(?:\.\d+)?) (\d+(?:\.\d+)?)$/
|
|
or die "bad input line: $line";
|
|
my $rt = ((defined $1 ? $1 : 0.0)*60+$2)*60+$3;
|
|
return ($rt, $4, $5);
|
|
}
|
|
|
|
sub format_times {
|
|
my ($r, $u, $s, $firstr) = @_;
|
|
if (!defined $r) {
|
|
return "<missing>";
|
|
}
|
|
my $out = sprintf "%.2f(%.2f+%.2f)", $r, $u, $s;
|
|
if (defined $firstr) {
|
|
if ($firstr > 0) {
|
|
$out .= sprintf " %+.1f%%", 100.0*($r-$firstr)/$firstr;
|
|
} elsif ($r == 0) {
|
|
$out .= " =";
|
|
} else {
|
|
$out .= " +inf";
|
|
}
|
|
}
|
|
return $out;
|
|
}
|
|
|
|
my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests);
|
|
while (scalar @ARGV) {
|
|
my $arg = $ARGV[0];
|
|
my $dir;
|
|
last if -f $arg or $arg eq "--";
|
|
if (! -d $arg) {
|
|
my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
|
|
$dir = "build/".$rev;
|
|
} else {
|
|
$arg =~ s{/*$}{};
|
|
$dir = $arg;
|
|
$dirabbrevs{$dir} = $dir;
|
|
}
|
|
push @dirs, $dir;
|
|
$dirnames{$dir} = $arg;
|
|
my $prefix = $dir;
|
|
$prefix =~ tr/^a-zA-Z0-9/_/c;
|
|
$prefixes{$dir} = $prefix . '.';
|
|
shift @ARGV;
|
|
}
|
|
|
|
if (not @dirs) {
|
|
@dirs = ('.');
|
|
}
|
|
$dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
|
|
$prefixes{'.'} = '';
|
|
|
|
shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
|
|
|
|
@tests = @ARGV;
|
|
if (not @tests) {
|
|
@tests = glob "p????-*.sh";
|
|
}
|
|
|
|
my @subtests;
|
|
my %shorttests;
|
|
for my $t (@tests) {
|
|
$t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
|
|
my $n = $2;
|
|
my $fname = "test-results/$t.subtests";
|
|
open my $fp, "<", $fname or die "cannot open $fname: $!";
|
|
for (<$fp>) {
|
|
chomp;
|
|
/^(\d+)$/ or die "malformed subtest line: $_";
|
|
push @subtests, "$t.$1";
|
|
$shorttests{"$t.$1"} = "$n.$1";
|
|
}
|
|
close $fp or die "cannot close $fname: $!";
|
|
}
|
|
|
|
sub read_descr {
|
|
my $name = shift;
|
|
open my $fh, "<", $name or return "<error reading description>";
|
|
my $line = <$fh>;
|
|
close $fh or die "cannot close $name";
|
|
chomp $line;
|
|
return $line;
|
|
}
|
|
|
|
my %descrs;
|
|
my $descrlen = 4; # "Test"
|
|
for my $t (@subtests) {
|
|
$descrs{$t} = $shorttests{$t}.": ".read_descr("test-results/$t.descr");
|
|
$descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
|
|
}
|
|
|
|
sub have_duplicate {
|
|
my %seen;
|
|
for (@_) {
|
|
return 1 if exists $seen{$_};
|
|
$seen{$_} = 1;
|
|
}
|
|
return 0;
|
|
}
|
|
sub have_slash {
|
|
for (@_) {
|
|
return 1 if m{/};
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
my %newdirabbrevs = %dirabbrevs;
|
|
while (!have_duplicate(values %newdirabbrevs)) {
|
|
%dirabbrevs = %newdirabbrevs;
|
|
last if !have_slash(values %dirabbrevs);
|
|
%newdirabbrevs = %dirabbrevs;
|
|
for (values %newdirabbrevs) {
|
|
s{^[^/]*/}{};
|
|
}
|
|
}
|
|
|
|
my %times;
|
|
my @colwidth = ((0)x@dirs);
|
|
for my $i (0..$#dirs) {
|
|
my $d = $dirs[$i];
|
|
my $w = length (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
|
|
$colwidth[$i] = $w if $w > $colwidth[$i];
|
|
}
|
|
for my $t (@subtests) {
|
|
my $firstr;
|
|
for my $i (0..$#dirs) {
|
|
my $d = $dirs[$i];
|
|
$times{$prefixes{$d}.$t} = [get_times("test-results/$prefixes{$d}$t.times")];
|
|
my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
|
|
my $w = length format_times($r,$u,$s,$firstr);
|
|
$colwidth[$i] = $w if $w > $colwidth[$i];
|
|
$firstr = $r unless defined $firstr;
|
|
}
|
|
}
|
|
my $totalwidth = 3*@dirs+$descrlen;
|
|
$totalwidth += $_ for (@colwidth);
|
|
|
|
printf "%-${descrlen}s", "Test";
|
|
for my $i (0..$#dirs) {
|
|
my $d = $dirs[$i];
|
|
printf " %-$colwidth[$i]s", (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
|
|
}
|
|
print "\n";
|
|
print "-"x$totalwidth, "\n";
|
|
for my $t (@subtests) {
|
|
printf "%-${descrlen}s", $descrs{$t};
|
|
my $firstr;
|
|
for my $i (0..$#dirs) {
|
|
my $d = $dirs[$i];
|
|
my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
|
|
printf " %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
|
|
$firstr = $r unless defined $firstr;
|
|
}
|
|
print "\n";
|
|
}
|