Benchmark.t revision 7c478bd95313f5f23a4c958a745db2134aa03244
#!./perl -w
BEGIN {
chdir 't' if -d 't';
}
use warnings;
use strict;
my $delta = 0.4;
# Some timing ballast
sub fib {
my $n = shift;
return $n if $n < 2;
}
$ballast = 15;
my $All_Pattern =
qr/(\d+) +wallclock secs? +\( *(-?\d+\.\d\d) +usr +(-?\d+\.\d\d) +sys +\+ +(-?\d+\.\d\d) +cusr +(-?\d+\.\d\d) +csys += +(-?\d+\.\d\d) +CPU\)/;
my $Noc_Pattern =
qr/(\d+) +wallclock secs? +\( *(-?\d+\.\d\d) +usr +\+ +(-?\d+\.\d\d) +sys += +(-?\d+\.\d\d) +CPU\)/;
my $Nop_Pattern =
# Please don't trust the matching parenthises to be useful in this :-)
# We use the benchmark object once we've done some work:
print "# Burning CPU to benchmark things will take time...\n";
# We need to do something fairly slow in the coderef.
# Same coderef. Same place in memory.
# The default is three.
$baz = 0;
print "# $in_threesecs iterations\n";
print "# from the 3 second run estimate $estimate iterations in 1 second...\n";
$baz = 0;
print "# $in_onesec iterations\n";
{
my $difference = $in_onesec - $estimate;
}
# I found that the eval'ed version was 3 times faster than the coderef.
# (now it has a different ballast value)
$baz = 0;
print "# $in_again iterations\n";
{
like ($noc, qr/$wallclock +wallclock secs? +\( *$usr +usr +\+ +$sys +sys += +$cpu +CPU\)/, 'timestr ($diff, "noc")');
like ($nop, qr/$wallclock +wallclock secs? +\( *$cusr +cusr +\+ +$csys +csys += +\d+\.\d\d +CPU\)/, 'timestr ($diff, "nop")');
} else {
}
qr/(\d+) +wallclock secs? +\( *\d\.\d+E[-+]?\d\d\d? +usr +\d\.\d+E[-+]?\d\d\d? +sys +\+ +\d\.\d+E[-+]?\d\d\d? +cusr +\d\.\d+E[-+]?\d\d\d? +csys += +\d\.\d+E[-+]?\d\d\d? +CPU\)/, 'timestr ($diff, "all", "E") [sprintf format of "E"]');
}
my $iterations = 3;
$foo = 0;
select(OUT);
select(STDOUT);
$bar = 0;
select(OUT);
select(STDOUT);
my $title = 'lies, damn lies and benchmarks';
$foo = 0;
select(OUT);
select(STDOUT);
# default is auto, which is all or noc. nop can never match the default
$foo = 0;
select(OUT);
select(STDOUT);
{
$foo = 0;
my $start = time;
my $end = time;
"timethis, at least 2 seconds with format 'none'");
# Remove any warnings about having too few iterations.
$got =~ s/^[ \t\n]+//s; # Remove all the whitespace from the beginning
}
select(OUT);
# Remove any warnings about having too few iterations.
like ($got, qr/timing $iterations iterations of\s+Bar\W+Baz\W+Foo\W*?\.\.\./s,
'check title');
# Remove the title
$got =~ s/.*\.\.\.//s;
{ # ensure 'use strict' does not leak from Benchmark.pm into benchmarked code
select OUT;
eval {
timethese( 1,
symbolic_ref => q{ $bar = 42;
$q = ${$foo} },
},
'none'
);
};
eval {
timethese( 1,
symbolic_ref => sub { $bar = 42;
return ${$foo} },
},
'none'
);
};
# clear out buffer
$out->read;
}
# Keep these for later.
my $results;
{
my $start = times;
my $end = times;
# Remove any warnings about having too few iterations.
}
my $graph_dissassembly =
\n[ \t]*(\w+)[ \t]+([0-9.]+(?:/s)?)[ \t]+(-+)[ \t]+(-?\d+%)[ \t]*
sub check_graph_consistency {
= @_;
my $all_passed = 1;
$all_passed &=
my $slowrate = $slowratet;
my $fastrate = $fastratet;
# Slow is expressed as iters per second.
}
# Fast is expressed as iters per second.
}
} else {
$all_passed &=
$all_passed &=
}
"slowfast should be less than or equal to zero, and >= -100")) {
$all_passed = 0;
}
$all_passed = 0;
}
} else {
"slow rate isn't less than fast rate, so should be the same");
# In OpenBSD the $slowfast is sometimes a really, really, really
# small number less than zero, and this gets stringified as -0.
}
return $all_passed;
}
sub check_graph_vs_output {
= $got =~ $graph_dissassembly;
my $all_passed
[$slowr, $slowratet, $slowslow, $slowfastt],
[$fastr, $fastratet, $fastslowt, $fastfast]],
"check the chart layout matches the formatted output");
}
}
sub check_graph {
}
{
my $start = times;
my $end = times;
# Remove any warnings about having too few iterations.
'check title');
# Remove the title
$got =~ s/.*\.\.\.//s;
}
# Not giving auto should suppress timethese results.
{
my $start = times;
my $end = times;
# Remove any warnings about having too few iterations.
'should not have title');
# Remove the title
$got =~ s/.*\.\.\.//s;
}
{
# Remove any warnings about having too few iterations.
'check title');
# Remove the title
$got =~ s/.*\.\.\.//s;
}
{
# Remove any warnings about having too few iterations.
$got =~ s/^[ \t\n]+//s; # Remove all the whitespace from the beginning
# Some of these will go bang if the preceding test fails. There will be
# a big clue as to why, from the previous test's diagnostic
}
{
}
{
# Some of these will go bang if the preceding test fails. There will be
# a big clue as to why, from the previous test's diagnostic
}
###}my $out = tie *OUT, 'TieOut'; my ($got); ###
$bar = 0;
$bar = 0;
$bar = 0;
# To check the cache we are poking where we don't belong, inside the namespace.
# The way benchmark is written We can't actually check whehter the cache is
# being used, merely what's become cached.
my @before_keys = keys %Benchmark::Cache;
$bar = 0;
my @after5_keys = keys %Benchmark::Cache;
$bar = 0;
# Hash key order will be the same if there are the same keys.
is_deeply ([keys %Benchmark::Cache], \@after5_keys,
"cleared 10, only cached results for 5 should remain");
is_deeply ([keys %Benchmark::Cache], \@before_keys,
"back to square 1 when we clear the cache again?");
{ # Check usage error messages
'not result' => 'cmpthese(42)',
'array ref' => 'cmpthese( 42, [ foo => sub { 1 } ] )',
);
eval $code;
}
'no code' => 'timethese(42)',
'array ref' => 'timethese( 42, [ foo => sub { 1 } ] )',
);
eval $code;
}
next if grep $func eq $_, @takes_no_args;
}
}
}
sub TIEHANDLE {
my $class = shift;
}
sub PRINT {
my $self = shift;
}
sub PRINTF {
my $self = shift;
}
sub read {
my $self = shift;
}