#!/usr/bin/perl -w
use strict;
use lib '../lib';
use Benchmark;
use Cwd;
use Fcntl qw( O_RDWR O_CREAT );
use Getopt::Long;
use MLDBM qw( DB_File Storable );
use Proc::ProcessTable;
use File::Path;
use File::Spec;
my %tests =
( print =>
{ code =>
sub { call_comp( '/comps/print.mas', title => 'print', integer => 1000 ) },
description =>
'Calls $m->print many times.',
},
one_comp =>
{ code =>
sub { call_comp( '/comps/comp.mas' ) },
description =>
'Calls a single component',
},
large =>
{ code =>
sub { call_comp( '/comps/large.mas' ) },
description =>
'Calls a very large text-only component',
},
);
my %flags =
(
test => {type => ':s',
descr => 'Specify one or more tests to perform.',
default => []},
profile =>
{descr => '(Not implemented)'},
reps => {type => ':i',
descr => 'Number of times to repeat each test. Defaults to 1000.',
default => 1000},
save => {descr => 'Saves information to result_history.db (an MLDBM DB_File).'},
cvs_tag =>
{type => ':s',
descr => 'A CVS tag (like "-r release-1-1-5") to check out in lib/ first.'},
tag => {type => ':s',
descr => 'Specifies a tag to save to result_history.db. '.
'Default is $HTML::Mason::VERSION or --cvs_tag value.'},
clear_cache =>
{descr => 'Will clear on-disk cache first. Useful for exercising the compiler.'},
help => {descr => 'Prints this message and exits.'},
);
my %opts;
$opts{$_} = $flags{$_}{default}
foreach grep exists($flags{$_}{default}), keys %flags;
{
local $^W;
GetOptions( \%opts, map "$_$flags{$_}{type}", keys %flags );
}
if ( $opts{help} )
{
usage();
exit;
}
die "$0 must be run from inside the benchmarks/ directory\n"
unless -e 'comps' and -d 'comps';
my $large_comp = File::Spec->catfile( 'comps', 'large.mas' );
# Don't check this into CVS because it's big:
unless ( -e $large_comp )
{
open my $fh, ">$large_comp" or die "Can't create $large_comp: $!";
print $fh 'x' x 79, "\n" for 1..30_000; # 80 * 30_000 = 2.4 MB
}
if ($opts{cvs_tag})
{
my $cwd = cwd();
my $lib = File::Spec->catdir( $cwd, '..', 'lib' );
print "chdir $lib\n";
chdir $lib or die "Can't chdir($lib): $!";
my $cmd = "cvs update $opts{cvs_tag}";
print "$cmd\n";
open my($fh), "$cmd |" or die "Can't execute '$cmd': $!";
print while <$fh>;
close $fh or die "Can't close command: $!";
$opts{tag} ||= $opts{cvs_tag};
chdir $cwd or die "Can't chdir($lib): $!";
}
# Do this only after updating lib/ to proper CVS version
require HTML::Mason;
$opts{tag} ||= $HTML::Mason::VERSION;
# Clear out the mason-data directory, otherwise we might include
# compilation in one run and not the next
my $data_dir = File::Spec->rel2abs( File::Spec->catdir( cwd, 'mason-data' ) );
rmtree($data_dir) if $opts{clear_cache};
foreach my $test ( @{ $opts{test} } )
{
unless ( exists $tests{$test} )
{
print "\n*** Invalid test: $test\n";
usage();
exit;
}
}
my $interp =
HTML::Mason::Interp->new( comp_root => File::Spec->rel2abs(cwd),
data_dir => $data_dir,
);
my ($proc) = grep { $_->pid == $$ } @{ Proc::ProcessTable->new->table };
print "\n";
foreach my $name ( @{ $opts{test} } )
{
my $results = Benchmark::timethis( $opts{reps}, $tests{$name}{code}, $name );
my $per_sec = sprintf( '%.2f', $opts{reps} / ($results->[1] + $results->[2]) );
my $rss = sprintf( '%.2f', ( $proc->rss / 1024 ) );
my $size = sprintf( '%.2f', ( $proc->size / 1024 ) );
# my ($rss, $vsz) = `ps -eo rss,vsz -p $$` =~ /(\d+)\s+(\d+)/;
print " Real mem: $rss MB\n";
print "Virtual mem: $size MB\n";
if ( $opts{save} )
{
my %save;
tie %save, 'MLDBM', 'result_history.db', O_CREAT | O_RDWR, 0644
or die "Cannot tie to result_history.db: $!";
my $tag = $opts{tag};
my $old = $save{$tag};
$old->{$name} ||= [];
push @{ $old->{$name} }, $per_sec;
$save{$tag} = $old;
}
}
print "\n";
sub call_comp
{
my ($comp, @args) = @_;
my $out;
$interp->out_method(\$out);
$interp->exec( $comp, @args );
}
sub usage
{
my $comps;
foreach my $name ( sort keys %tests )
{
$comps .= sprintf( " %-10s %s\n", $name, $tests{$name}{description} );
}
my $opts;
foreach my $name ( sort keys %flags )
{
$opts .= sprintf " %13s %s\n", "--$name", $flags{$name}{descr};
}
print <<"EOF";
Usage: $0 <options>
$opts
Valid tests include:
$comps
EOF
}