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