) {
print RES $_;
}
close(V);
close(RES) || die "Can't write: $!";
}
}
my $factor = $opt_c;
unless ($factor) {
$factor = `$^X cpu_factor`;
chomp($factor);
die "Can't calculate cpu speed factor" unless $factor;
}
file("$dir/CPU_FACTOR", "$factor\n");
# Try to run tests
die "No test directory found" unless -d 't';
my @tests;
use File::Find;
find(sub { /\.t$/ && push(@tests, $File::Find::name) }, "benchmarks");
if ($opt_t) {
@tests = grep /$opt_t/o, @tests;
}
@tests = sort @tests;
# Try to run the empty test in order to time the loop
my %empty_cycles;
for my $p (@perls) {
$p->{empty_cycles} = ($empty_cycles{$p->{path}} ||= do {
my $empty_cycles;
$p->run_cmd(*P, "empty.t", $factor);
while () {
next unless /^Cycles-Per-Sec:\s*(\S+)/;
$empty_cycles = int($1);
last;
}
close(P);
die "Could not determine empty test speed for $p->{path}"
unless $empty_cycles;
$empty_cycles;
});
$p->{point_sum} = 0;
}
# heading
print INDEX "
\n";
print INDEX " \n | | \n";
print "\n";
print " " x 20;
for my $p (@perls) {
printf "%8s", $p->{label};
my $h = htmlesc($p->{label});
my $overlib_attr = "";
if ($use_overlib && $p->{name}) {
$overlib_attr = qq( onmouseover="return overlib('$p->{name}');" onmouseout="return nd();");
}
print INDEX qq( $h | \n);
}
print "\n";
print INDEX "
\n";
print " " x 20;
for my $p (@perls) {
printf "%8s", ("-" x max(3, length($p->{label})));
}
print "\n";
my $test;
for $test (@tests) {
unless (open(T, $test)) {
warn "Can't open $test: $!";
next;
}
my $name = $test;
$name =~ s,^benchmarks/,,;
$name =~ s,\.t$,,;
my $save_file = "$dir/$name/test.txt";
mkpath(dirname($save_file), 0, 0755);
open(SAVE, ">$save_file") || die "Can't create $save_file: $!";
(my $save_file_link = $save_file) =~ s,^\Q$dir\E/,,;
$save_file_link = htmlesc($save_file_link);
my %prop;
while () {
print SAVE $_;
next unless /^\#\s*(\w+)\s*:\s*(.*)/;
my($k,$v) = (lc($1), $2);
if (defined $prop{$k}) {
$prop{$k} .= "\n$v";
} else {
$prop{$k} = $v;
}
}
close(T);
close(SAVE) || die "Can't write $save_file: $!";
printf "%-20s", $name;
my $overlib_attr = "";
if ($use_overlib && $prop{name}) {
$overlib_attr = qq( onmouseover="return overlib('$prop{name}');" onmouseout="return nd();");
}
print INDEX qq( \n | ) . htmlesc($name) . " | \n";
my $scale;
my $p;
for my $p (@perls) {
if ($p->{version} < $prop{'require'}) {
# Can't run test
printf "%8s", "N/A";
print INDEX " N/A | \n";
next;
}
my $res_file = "$dir/$name/" . $p->{label} . ".txt";
mkpath(dirname($res_file), 0, 0755);
open(RES, ">$res_file") || die "Can't create $res_file: $!";
(my $res_file_link = $res_file) =~ s,^\Q$dir\E/,,;
$res_file_link = htmlesc($res_file_link);
my $points;
my $popup_text = "";
$p->run_cmd(*P, $test, $factor, $p->{empty_cycles});
while () {
print RES $_;
if (/^Bench-Points:\s+(\S+)/) {
$points = $1;
}
if (/^(?:\w+-Time|CPU|Cycles-Per-Sec|Loop-Overhead):/) {
$popup_text .= "
" if length($popup_text);
$popup_text .= $_;
chomp($popup_text);
}
}
close(P);
close(RES);
my $overlib_attr = "";
if ($use_overlib) {
$overlib_attr = qq( onmouseover="return overlib('$popup_text');" onmouseout="return nd();");
}
# present results
unless (defined $points) {
printf "%8s", "-";
print INDEX qq(
?? | \n);
next;
}
unless ($opt_s) {
unless (defined $scale) {
$scale = 100 / $points;
}
$points *= $scale;
}
printf "%8.0f", $points;
printf INDEX qq( %.0f | \n), $res_file_link, $overlib_attr, $points;
$p->{point_sum} += $points;
$p->{no_tests}++;
}
print INDEX "
\n";
print "\n";
}
print "\n";
printf "%-20s", "AVERAGE";
for my $p (@perls) {
printf "%8.0f", $p->{point_sum} / $p->{no_tests};
}
print INDEX "
\n";
print INDEX "Higer numbers are better. 200 is twice as fast as 100.
\n";
print INDEX "Configuration summary
\n";
print INDEX "Test ran on a $^O machine";
if ($^O ne "MSWin32") {
my $uname = `uname -a`;
if ($uname) {
print INDEX qq( that reports its uname as ") . htmlesc($uname) . qq(");
}
}
print INDEX ".\n";
print INDEX " Test run completed at " . substr(time2iso(), 11) . ".\n";
print INDEX "
\n";
print INDEX "\n";
print INDEX " \n | | \n";
for my $p (@perls) {
my $h = htmlesc($p->{label});
print INDEX qq( $h | \n);
}
for my $k ("name", "version", "path") {
print INDEX "
\n | $k | \n";
for my $p (@perls) {
print INDEX " " . htmlesc($p->{$k}) . " | \n";
}
print INDEX "
\n";
}
print INDEX " \n";
for my $k (sort keys %config_summary) {
print INDEX " \n | " . htmlesc($k) . " | \n";
for my $lab (map $_->{label}, @perls) {
my $v = $config_summary{$k}{$lab};
$v = "" unless defined($v);
my $len = length($v);
$v = $len ? htmlesc($v) : " ";
$v = "$v" if $len > 40;
print INDEX " $v | \n";
}
print INDEX "
\n";
}
print INDEX "
\n";
print INDEX "\n\n";
close(INDEX) || die "Can't write $dir/index.html\n";
my $index_url = abs_path($dir);
if ($^O eq "MSWin32") {
$index_url =~ s,\\,/,g;
$index_url =~ s,^([A-Za-z]):,/$1|,;
}
$index_url = "file://$index_url/index.html";
print "\n\nResults saved in $index_url\n";
sub usage
{
$0 =~ s,.*/,,;
die "Usage: $0 [options] [lab1=] [lab2=]...
Recognized options:
-s don't scale numbers (so that first perl is always 100)
-t only tests that match regex are timed
-c use this factor to scale tests instead of running the
'cpu_factor' program to determine it.
-d where to save results
";
}
sub max
{
my $max = shift;
while (@_) {
my $n = shift;
$max = $n if $n > $max;
}
return $max;
}
sub file {
my $name = shift;
if (@_) {
my $content = shift;
open(my $f, ">", $name) || die "Can't create '$name': $!";
binmode($f);
print $f $content;
close($f) || die "Can't write to '$name': $!";
if (@_) {
my $mode = shift;
change_mode($mode, $name);
}
}
else {
open(my $f, "<", $name) || return undef;
binmode($f);
local $/;
return scalar <$f>;
}
}
sub link_or_copy {
my $f = shift;
link($f, "$dir/$f") || do {
require File::Copy;
File::Copy::copy($f, $f);
}
}
sub htmlesc {
my $str = shift;
$str =~ s/&/&/g;
$str =~ s/ $path, label => $label }, $class;
$self->run_cmd(*V, '-e', 'print qq(This is perl ), $]+0, qq(\n)');
my $version = ;
close V or die "closing pipe from perl: exit code $?";
chomp $version;
unless ($version =~ /^This is perl (\d+.\d+)/) {
die "$path does not appear to be a working perl";
}
$self->{version} = $1;
$self->run_cmd(*V, '-v');
while () {
if (/^This is perl, v(\S+)/) {
$self->{name} = "perl-$1";
}
if (/^Binary build (\d+.*) provided by ActiveState/) {
$self->{name} .= " build $1";
$self->{name} =~ s/^perl/ActivePerl/;
}
}
close(V);
if ($self->{version} >= 5) {
# The perl should have Configure support. Try to extract
# some key settings
my $prog = 'use Config; Config::config_vars(qw(cc ccversion gccversion optimize ccflags usethreads use64bitint use64bitall usemymalloc))';
$self->run_cmd(*CONFIG, '-e', $prog);
while () {
next unless /^(\w+)='([^']+)'/; #' #
$self->{config}{$1} = $2;
}
close(CONFIG);
}
return $self;
}
my $ld_path = Cwd::extLibpath() if $^O eq 'os2';
$ld_path .= ';' if $ld_path and $^O eq 'os2';
sub cmd
{
my $self = shift;
my $path = $self->{path};
(my $pdir = $path) =~ s,[/\\][^/\\]+$,/,;
if (-d "$pdir/lib") {
# uninstalled perl
Cwd::extLibpath_set("$ld_path$pdir") if $^O eq 'os2'; # Find DLL
($path, '-I', "$pdir/lib");
} else {
$path;
}
}
sub run_cmd
{
my $self = shift;
my @cmd = $self->cmd;
my $fh = shift;
my @args = map {/\s/ ? "'$_'" : $_} @_;
open($fh, "@cmd @args |") or die "Cannot pipe from '@cmd @args': $!";
}
}