2012-02-17 11:25:09 +01:00
|
|
|
#!/usr/bin/perl
|
|
|
|
|
Makefile: replace perl/Makefile.PL with simple make rules
Replace the perl/Makefile.PL and the fallback perl/Makefile used under
NO_PERL_MAKEMAKER=NoThanks with a much simpler implementation heavily
inspired by how the i18n infrastructure's build process works[1].
The reason for having the Makefile.PL in the first place is that it
was initially[2] building a perl C binding to interface with libgit,
this functionality, that was removed[3] before Git.pm ever made it to
the master branch.
We've since since started maintaining a fallback perl/Makefile, as
MakeMaker wouldn't work on some platforms[4]. That's just the tip of
the iceberg. We have the PM.stamp hack in the top-level Makefile[5] to
detect whether we need to regenerate the perl/perl.mak, which I fixed
just recently to deal with issues like the perl version changing from
under us[6].
There is absolutely no reason for why this needs to be so complex
anymore. All we're getting out of this elaborate Rube Goldberg machine
was copying perl/* to perl/blib/* as we do a string-replacement on
the *.pm files to hardcode @@LOCALEDIR@@ in the source, as well as
pod2man-ing Git.pm & friends.
So replace the whole thing with something that's pretty much a copy of
how we generate po/build/**.mo from po/*.po, just with a small sed(1)
command instead of msgfmt. As that's being done rename the files
from *.pm to *.pmc just to indicate that they're generated (see
"perldoc -f require").
While I'm at it, change the fallback for Error.pm from being something
where we'll ship our own Error.pm if one doesn't exist at build time
to one where we just use a Git::Error wrapper that'll always prefer
the system-wide Error.pm, only falling back to our own copy if it
really doesn't exist at runtime. It's now shipped as
Git::FromCPAN::Error, making it easy to add other modules to
Git::FromCPAN::* in the future if that's needed.
Functional changes:
* This will not always install into perl's idea of its global
"installsitelib". This only potentially matters for packagers that
need to expose Git.pm for non-git use, and as explained in the
INSTALL file there's a trivial workaround.
* The scripts themselves will 'use lib' the target directory, but if
INSTLIBDIR is set it overrides it. It doesn't have to be this way,
it could be set in addition to INSTLIBDIR, but my reading of [7] is
that this is the desired behavior.
* We don't build man pages for all of the perl modules as we used to,
only Git(3pm). As discussed on-list[8] that we were building
installed manpages for purely internal APIs like Git::I18N or
private-Error.pm was always a bug anyway, and all the Git::SVN::*
ones say they're internal APIs.
There are apparently external users of Git.pm, but I don't expect
there to be any of the others.
As a side-effect of these general changes the perl documentation
now only installed by install-{doc,man}, not a mere "install" as
before.
1. 5e9637c629 ("i18n: add infrastructure for translating Git with
gettext", 2011-11-18)
2. b1edc53d06 ("Introduce Git.pm (v4)", 2006-06-24)
3. 18b0fc1ce1 ("Git.pm: Kill Git.xs for now", 2006-09-23)
4. f848718a69 ("Make perl/ build procedure ActiveState friendly.",
2006-12-04)
5. ee9be06770 ("perl: detect new files in MakeMaker builds",
2012-07-27)
6. c59c4939c2 ("perl: regenerate perl.mak if perl -V changes",
2017-03-29)
7. 0386dd37b1 ("Makefile: add PERLLIB_EXTRA variable that adds to
default perl path", 2013-11-15)
8. 87bmjjv1pu.fsf@evledraar.booking.com ("Re: [PATCH] Makefile:
replace perl/Makefile.PL with simple make rules"
Signed-off-by: Ævar Arnfjörð Bjarmason <avarab@gmail.com>
Signed-off-by: Junio C Hamano <gitster@pobox.com>
2017-12-10 22:13:33 +01:00
|
|
|
use lib '../../perl/build/lib';
|
2012-02-17 11:25:09 +01:00
|
|
|
use strict;
|
|
|
|
use warnings;
|
2018-01-05 10:12:22 +01:00
|
|
|
use JSON;
|
2018-04-25 18:10:25 +02:00
|
|
|
use Getopt::Long;
|
2012-02-17 11:25:09 +01:00
|
|
|
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: $!";
|
2018-08-17 22:56:37 +02:00
|
|
|
# times
|
|
|
|
if ($line =~ /^(?:(\d+):)?(\d+):(\d+(?:\.\d+)?) (\d+(?:\.\d+)?) (\d+(?:\.\d+)?)$/) {
|
|
|
|
my $rt = ((defined $1 ? $1 : 0.0)*60+$2)*60+$3;
|
|
|
|
return ($rt, $4, $5);
|
|
|
|
# size
|
|
|
|
} elsif ($line =~ /^\d+$/) {
|
|
|
|
return $&;
|
|
|
|
} else {
|
|
|
|
die "bad input line: $line";
|
|
|
|
}
|
2012-02-17 11:25:09 +01:00
|
|
|
}
|
|
|
|
|
2018-08-17 22:55:24 +02:00
|
|
|
sub relative_change {
|
|
|
|
my ($r, $firstr) = @_;
|
|
|
|
if ($firstr > 0) {
|
|
|
|
return sprintf "%+.1f%%", 100.0*($r-$firstr)/$firstr;
|
|
|
|
} elsif ($r == 0) {
|
|
|
|
return "=";
|
|
|
|
} else {
|
|
|
|
return "+inf";
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2012-02-17 11:25:09 +01:00
|
|
|
sub format_times {
|
|
|
|
my ($r, $u, $s, $firstr) = @_;
|
2018-08-17 22:56:37 +02:00
|
|
|
# no value means we did not finish the test
|
2012-02-17 11:25:09 +01:00
|
|
|
if (!defined $r) {
|
|
|
|
return "<missing>";
|
|
|
|
}
|
2018-08-17 22:56:37 +02:00
|
|
|
# a single value means we have a size, not times
|
|
|
|
if (!defined $u) {
|
|
|
|
return format_size($r, $firstr);
|
|
|
|
}
|
|
|
|
# otherwise, we have real/user/system times
|
2012-02-17 11:25:09 +01:00
|
|
|
my $out = sprintf "%.2f(%.2f+%.2f)", $r, $u, $s;
|
2018-08-17 22:55:24 +02:00
|
|
|
$out .= ' ' . relative_change($r, $firstr) if defined $firstr;
|
2012-02-17 11:25:09 +01:00
|
|
|
return $out;
|
|
|
|
}
|
|
|
|
|
2018-04-25 18:10:25 +02:00
|
|
|
sub usage {
|
|
|
|
print <<EOT;
|
|
|
|
./aggregate.perl [options] [--] [<dir_or_rev>...] [--] [<test_script>...] >
|
|
|
|
|
|
|
|
Options:
|
|
|
|
--codespeed * Format output for Codespeed
|
|
|
|
--reponame <str> * Send given reponame to codespeed
|
|
|
|
--sort-by <str> * Sort output (only "regression" criteria is supported)
|
|
|
|
--subsection <str> * Use results from given subsection
|
|
|
|
|
|
|
|
EOT
|
|
|
|
exit(1);
|
|
|
|
}
|
|
|
|
|
2018-08-17 22:56:37 +02:00
|
|
|
sub human_size {
|
|
|
|
my $n = shift;
|
|
|
|
my @units = ('', qw(K M G));
|
|
|
|
while ($n > 900 && @units > 1) {
|
|
|
|
$n /= 1000;
|
|
|
|
shift @units;
|
|
|
|
}
|
|
|
|
return $n unless length $units[0];
|
|
|
|
return sprintf '%.1f%s', $n, $units[0];
|
|
|
|
}
|
|
|
|
|
|
|
|
sub format_size {
|
|
|
|
my ($size, $first) = @_;
|
|
|
|
# match the width of a time: 0.00(0.00+0.00)
|
|
|
|
my $out = sprintf '%15s', human_size($size);
|
|
|
|
$out .= ' ' . relative_change($size, $first) if defined $first;
|
|
|
|
return $out;
|
|
|
|
}
|
|
|
|
|
2018-02-01 11:14:32 +01:00
|
|
|
my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests,
|
2018-03-26 09:24:31 +02:00
|
|
|
$codespeed, $sortby, $subsection, $reponame);
|
2018-04-25 18:10:25 +02:00
|
|
|
|
|
|
|
Getopt::Long::Configure qw/ require_order /;
|
|
|
|
|
|
|
|
my $rc = GetOptions("codespeed" => \$codespeed,
|
|
|
|
"reponame=s" => \$reponame,
|
|
|
|
"sort-by=s" => \$sortby,
|
|
|
|
"subsection=s" => \$subsection);
|
|
|
|
usage() unless $rc;
|
|
|
|
|
2012-02-17 11:25:09 +01:00
|
|
|
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";
|
|
|
|
}
|
|
|
|
|
2017-09-23 21:55:56 +02:00
|
|
|
my $resultsdir = "test-results";
|
2018-02-01 11:14:32 +01:00
|
|
|
|
|
|
|
if (! $subsection and
|
|
|
|
exists $ENV{GIT_PERF_SUBSECTION} and
|
|
|
|
$ENV{GIT_PERF_SUBSECTION} ne "") {
|
|
|
|
$subsection = $ENV{GIT_PERF_SUBSECTION};
|
|
|
|
}
|
|
|
|
|
|
|
|
if ($subsection) {
|
|
|
|
$resultsdir .= "/" . $subsection;
|
2017-09-23 21:55:56 +02:00
|
|
|
}
|
|
|
|
|
2012-02-17 11:25:09 +01:00
|
|
|
my @subtests;
|
|
|
|
my %shorttests;
|
|
|
|
for my $t (@tests) {
|
|
|
|
$t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
|
|
|
|
my $n = $2;
|
2017-09-23 21:55:56 +02:00
|
|
|
my $fname = "$resultsdir/$t.subtests";
|
2012-02-17 11:25:09 +01:00
|
|
|
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>";
|
2017-04-21 21:44:28 +02:00
|
|
|
binmode $fh, ":utf8" or die "PANIC on binmode: $!";
|
2012-02-17 11:25:09 +01:00
|
|
|
my $line = <$fh>;
|
|
|
|
close $fh or die "cannot close $name";
|
|
|
|
chomp $line;
|
|
|
|
return $line;
|
|
|
|
}
|
|
|
|
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
2018-03-26 09:24:30 +02:00
|
|
|
sub display_dir {
|
|
|
|
my ($d) = @_;
|
|
|
|
return exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d};
|
|
|
|
}
|
|
|
|
|
2018-01-05 10:12:21 +01:00
|
|
|
sub print_default_results {
|
|
|
|
my %descrs;
|
|
|
|
my $descrlen = 4; # "Test"
|
|
|
|
for my $t (@subtests) {
|
|
|
|
$descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
|
|
|
|
$descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
|
2012-02-17 11:25:09 +01:00
|
|
|
}
|
|
|
|
|
2018-01-05 10:12:21 +01:00
|
|
|
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);
|
2012-02-17 11:25:09 +01:00
|
|
|
for my $i (0..$#dirs) {
|
2018-03-26 09:24:30 +02:00
|
|
|
my $w = length display_dir($dirs[$i]);
|
2012-02-17 11:25:09 +01:00
|
|
|
$colwidth[$i] = $w if $w > $colwidth[$i];
|
|
|
|
}
|
2018-01-05 10:12:21 +01:00
|
|
|
for my $t (@subtests) {
|
|
|
|
my $firstr;
|
|
|
|
for my $i (0..$#dirs) {
|
|
|
|
my $d = $dirs[$i];
|
2018-08-17 22:56:37 +02:00
|
|
|
my $base = "$resultsdir/$prefixes{$d}$t";
|
|
|
|
$times{$prefixes{$d}.$t} = [];
|
|
|
|
foreach my $type (qw(times size)) {
|
|
|
|
if (-e "$base.$type") {
|
|
|
|
$times{$prefixes{$d}.$t} = [get_times("$base.$type")];
|
|
|
|
last;
|
|
|
|
}
|
|
|
|
}
|
2018-01-05 10:12:21 +01:00
|
|
|
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);
|
2017-04-21 21:44:28 +02:00
|
|
|
|
2018-01-05 10:12:21 +01:00
|
|
|
printf "%-${descrlen}s", "Test";
|
2012-02-17 11:25:09 +01:00
|
|
|
for my $i (0..$#dirs) {
|
2018-03-26 09:24:30 +02:00
|
|
|
printf " %-$colwidth[$i]s", display_dir($dirs[$i]);
|
2012-02-17 11:25:09 +01:00
|
|
|
}
|
|
|
|
print "\n";
|
2018-01-05 10:12:21 +01:00
|
|
|
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";
|
|
|
|
}
|
2012-02-17 11:25:09 +01:00
|
|
|
}
|
2018-01-05 10:12:21 +01:00
|
|
|
|
2018-03-26 09:24:31 +02:00
|
|
|
sub print_sorted_results {
|
|
|
|
my ($sortby) = @_;
|
|
|
|
|
|
|
|
if ($sortby ne "regression") {
|
2018-04-25 18:10:25 +02:00
|
|
|
print "Only 'regression' is supported as '--sort-by' argument\n";
|
|
|
|
usage();
|
2018-03-26 09:24:31 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
my @evolutions;
|
|
|
|
for my $t (@subtests) {
|
|
|
|
my ($prevr, $prevu, $prevs, $prevrev);
|
|
|
|
for my $i (0..$#dirs) {
|
|
|
|
my $d = $dirs[$i];
|
|
|
|
my ($r, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.times");
|
|
|
|
if ($i > 0 and defined $r and defined $prevr and $prevr > 0) {
|
|
|
|
my $percent = 100.0 * ($r - $prevr) / $prevr;
|
|
|
|
push @evolutions, { "percent" => $percent,
|
|
|
|
"test" => $t,
|
|
|
|
"prevrev" => $prevrev,
|
|
|
|
"rev" => $d,
|
|
|
|
"prevr" => $prevr,
|
|
|
|
"r" => $r,
|
|
|
|
"prevu" => $prevu,
|
|
|
|
"u" => $u,
|
|
|
|
"prevs" => $prevs,
|
|
|
|
"s" => $s};
|
|
|
|
}
|
|
|
|
($prevr, $prevu, $prevs, $prevrev) = ($r, $u, $s, $d);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
my @sorted_evolutions = sort { $b->{percent} <=> $a->{percent} } @evolutions;
|
|
|
|
|
|
|
|
for my $e (@sorted_evolutions) {
|
|
|
|
printf "%+.1f%%", $e->{percent};
|
|
|
|
print " " . $e->{test};
|
|
|
|
print " " . format_times($e->{prevr}, $e->{prevu}, $e->{prevs});
|
|
|
|
print " " . format_times($e->{r}, $e->{u}, $e->{s});
|
|
|
|
print " " . display_dir($e->{prevrev});
|
|
|
|
print " " . display_dir($e->{rev});
|
|
|
|
print "\n";
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2018-01-05 10:12:22 +01:00
|
|
|
sub print_codespeed_results {
|
2018-02-01 11:14:32 +01:00
|
|
|
my ($subsection) = @_;
|
2018-01-05 10:12:22 +01:00
|
|
|
|
|
|
|
my $project = "Git";
|
|
|
|
|
|
|
|
my $executable = `uname -s -m`;
|
|
|
|
chomp $executable;
|
|
|
|
|
2018-02-01 11:14:32 +01:00
|
|
|
if ($subsection) {
|
|
|
|
$executable .= ", " . $subsection;
|
2018-01-05 10:12:22 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
my $environment;
|
2018-02-01 11:14:33 +01:00
|
|
|
if ($reponame) {
|
|
|
|
$environment = $reponame;
|
|
|
|
} elsif (exists $ENV{GIT_PERF_REPO_NAME} and $ENV{GIT_PERF_REPO_NAME} ne "") {
|
2018-01-05 10:12:22 +01:00
|
|
|
$environment = $ENV{GIT_PERF_REPO_NAME};
|
|
|
|
} elsif (exists $ENV{GIT_TEST_INSTALLED} and $ENV{GIT_TEST_INSTALLED} ne "") {
|
|
|
|
$environment = $ENV{GIT_TEST_INSTALLED};
|
|
|
|
$environment =~ s|/bin-wrappers$||;
|
|
|
|
} else {
|
|
|
|
$environment = `uname -r`;
|
|
|
|
chomp $environment;
|
|
|
|
}
|
|
|
|
|
|
|
|
my @data;
|
|
|
|
|
|
|
|
for my $t (@subtests) {
|
|
|
|
for my $d (@dirs) {
|
|
|
|
my $commitid = $prefixes{$d};
|
|
|
|
$commitid =~ s/^build_//;
|
|
|
|
$commitid =~ s/\.$//;
|
|
|
|
my ($result_value, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.times");
|
|
|
|
|
|
|
|
my %vals = (
|
|
|
|
"commitid" => $commitid,
|
|
|
|
"project" => $project,
|
|
|
|
"branch" => $dirnames{$d},
|
|
|
|
"executable" => $executable,
|
|
|
|
"benchmark" => $shorttests{$t} . " " . read_descr("$resultsdir/$t.descr"),
|
|
|
|
"environment" => $environment,
|
|
|
|
"result_value" => $result_value,
|
|
|
|
);
|
|
|
|
push @data, \%vals;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2018-02-01 11:14:34 +01:00
|
|
|
print to_json(\@data, {utf8 => 1, pretty => 1, canonical => 1}), "\n";
|
2018-01-05 10:12:22 +01:00
|
|
|
}
|
|
|
|
|
2018-01-05 10:12:21 +01:00
|
|
|
binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
|
|
|
|
|
2018-01-05 10:12:22 +01:00
|
|
|
if ($codespeed) {
|
2018-02-01 11:14:32 +01:00
|
|
|
print_codespeed_results($subsection);
|
2018-03-26 09:24:31 +02:00
|
|
|
} elsif (defined $sortby) {
|
|
|
|
print_sorted_results($sortby);
|
2018-01-05 10:12:22 +01:00
|
|
|
} else {
|
|
|
|
print_default_results();
|
|
|
|
}
|