This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Benchmark.t: avoid ultra-lightweight code
[perl5.git] / lib / Benchmark.t
CommitLineData
0e74ff8e
JH
1#!./perl -w
2
3BEGIN {
4 chdir 't' if -d 't';
53aa2791 5 @INC = ('../lib');
0e74ff8e
JH
6}
7
8use warnings;
9use strict;
10use vars qw($foo $bar $baz $ballast);
9eba9e10 11use Test::More tests => 195;
0e74ff8e
JH
12
13use Benchmark qw(:all);
14
8a753380 15my $DELTA = 0.4;
0e74ff8e
JH
16
17# Some timing ballast
18sub fib {
19 my $n = shift;
20 return $n if $n < 2;
21 fib($n-1) + fib($n-2);
22}
23$ballast = 15;
24
53aa2791 25my $All_Pattern =
0e74ff8e 26 qr/(\d+) +wallclock secs? +\( *(-?\d+\.\d\d) +usr +(-?\d+\.\d\d) +sys +\+ +(-?\d+\.\d\d) +cusr +(-?\d+\.\d\d) +csys += +(-?\d+\.\d\d) +CPU\)/;
53aa2791 27my $Noc_Pattern =
0e74ff8e 28 qr/(\d+) +wallclock secs? +\( *(-?\d+\.\d\d) +usr +\+ +(-?\d+\.\d\d) +sys += +(-?\d+\.\d\d) +CPU\)/;
53aa2791 29my $Nop_Pattern =
0e74ff8e 30 qr/(\d+) +wallclock secs? +\( *(-?\d+\.\d\d) +cusr +\+ +(-?\d+\.\d\d) +csys += +\d+\.\d\d +CPU\)/;
98dc9551 31# Please don't trust the matching parentheses to be useful in this :-)
53aa2791 32my $Default_Pattern = qr/$All_Pattern|$Noc_Pattern/;
0e74ff8e 33
8a753380
DM
34# see if the ratio of two integer values is within (1+$delta)
35
36sub cmp_delta {
37 my ($min, $max, $delta) = @_;
38 ($min, $max) = ($max, $min) if $max < $min;
39 return 0 if $min < 1; # avoid / 0
40 return $max/$min <= (1+$delta);
41}
42
0e74ff8e
JH
43my $t0 = new Benchmark;
44isa_ok ($t0, 'Benchmark', "Ensure we can create a benchmark object");
45
46# We use the benchmark object once we've done some work:
47
48isa_ok(timeit(5, sub {++$foo}), 'Benchmark', "timeit CODEREF");
49is ($foo, 5, "benchmarked code was run 5 times");
50
51isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval");
52is ($bar, 5, "benchmarked code was run 5 times");
53
f265d4df
AS
54# is coderef called with spurious arguments?
55timeit( 1, sub { $foo = @_ });
56is ($foo, 0, "benchmarked code called without arguments");
57
58
1ebabb47 59print "# Burning CPU to benchmark things; will take time...\n";
0e74ff8e
JH
60
61# We need to do something fairly slow in the coderef.
62# Same coderef. Same place in memory.
63my $coderef = sub {$baz += fib($ballast)};
64
65# The default is three.
66$baz = 0;
67my $threesecs = countit(0, $coderef);
68isa_ok($threesecs, 'Benchmark', "countit 0, CODEREF");
69isnt ($baz, 0, "benchmarked code was run");
70my $in_threesecs = $threesecs->iters;
d684718b 71print "# in_threesecs=$in_threesecs iterations\n";
0e74ff8e 72ok ($in_threesecs > 0, "iters returned positive iterations");
0d66b88d
DM
73my $cpu3 = $threesecs->[1]; # user
74my $sys3 = $threesecs->[2]; # sys
75cmp_ok($cpu3+$sys3, '>=', 3.0, "3s cpu3 is at least 3s");
bb6c6e4b
DM
76my $in_threesecs_adj = $in_threesecs;
77$in_threesecs_adj *= (3/$cpu3); # adjust because may not have run for exactly 3s
78print "# in_threesecs_adj=$in_threesecs_adj adjusted iterations\n";
0e74ff8e 79
58747404 80my $estimate = int (100 * $in_threesecs_adj / 3) / 100;
0e74ff8e
JH
81print "# from the 3 second run estimate $estimate iterations in 1 second...\n";
82$baz = 0;
83my $onesec = countit(1, $coderef);
84isa_ok($onesec, 'Benchmark', "countit 1, CODEREF");
85isnt ($baz, 0, "benchmarked code was run");
86my $in_onesec = $onesec->iters;
d684718b 87print "# in_onesec=$in_onesec iterations\n";
0e74ff8e 88ok ($in_onesec > 0, "iters returned positive iterations");
0d66b88d
DM
89my $cpu1 = $onesec->[1]; # user
90my $sys1 = $onesec->[2]; # sys
91cmp_ok($cpu1+$sys1, '>=', 1.0, "is cpu1 is at least 1s");
bb6c6e4b
DM
92my $in_onesec_adj = $in_onesec;
93$in_onesec_adj *= (1/$cpu1); # adjust because may not have run for exactly 1s
94print "# in_onesec_adj=$in_onesec_adj adjusted iterations\n";
0e74ff8e 95
0e74ff8e
JH
96
97# I found that the eval'ed version was 3 times faster than the coderef.
98# (now it has a different ballast value)
99$baz = 0;
100my $again = countit(1, '$baz += fib($ballast)');
101isa_ok($onesec, 'Benchmark', "countit 1, eval");
102isnt ($baz, 0, "benchmarked code was run");
103my $in_again = $again->iters;
104print "# $in_again iterations\n";
105ok ($in_again > 0, "iters returned positive iterations");
106
107
108my $t1 = new Benchmark;
109isa_ok ($t1, 'Benchmark', "Create another benchmark object now we're finished");
110
111my $diff = timediff ($t1, $t0);
112isa_ok ($diff, 'Benchmark', "Get the time difference");
113isa_ok (timesum ($t0, $t1), 'Benchmark', "check timesum");
114
115my $default = timestr ($diff);
116isnt ($default, '', 'timestr ($diff)');
117my $auto = timestr ($diff, 'auto');
118is ($auto, $default, 'timestr ($diff, "auto") matches timestr ($diff)');
119
120{
121 my $all = timestr ($diff, 'all');
53aa2791 122 like ($all, $All_Pattern, 'timestr ($diff, "all")');
0e74ff8e
JH
123 print "# $all\n";
124
53aa2791 125 my ($wallclock, $usr, $sys, $cusr, $csys, $cpu) = $all =~ $All_Pattern;
0e74ff8e 126
98dc9551 127 is (timestr ($diff, 'none'), '', "none suppresses output");
0e74ff8e
JH
128
129 my $noc = timestr ($diff, 'noc');
bd9f0ebf 130 like ($noc, qr/$wallclock +wallclock secs? +\( *$usr +usr +\+ +$sys +sys += +\d+\.\d\d +CPU\)/, 'timestr ($diff, "noc")');
0e74ff8e
JH
131
132 my $nop = timestr ($diff, 'nop');
133 like ($nop, qr/$wallclock +wallclock secs? +\( *$cusr +cusr +\+ +$csys +csys += +\d+\.\d\d +CPU\)/, 'timestr ($diff, "nop")');
134
135 if ($auto eq $noc) {
136 pass ('"auto" is "noc"');
137 } else {
138 is ($auto, $all, '"auto" isn\'t "noc", so should be eq to "all"');
139 }
140
141 like (timestr ($diff, 'all', 'E'),
142 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"]');
143}
144
145my $out = tie *OUT, 'TieOut';
146
147my $iterations = 3;
148
149$foo = 0;
150select(OUT);
151my $got = timethis($iterations, sub {++$foo});
152select(STDOUT);
153isa_ok($got, 'Benchmark', "timethis CODEREF");
154is ($foo, $iterations, "benchmarked code was run $iterations times");
155
156$got = $out->read();
157like ($got, qr/^timethis $iterations/, 'default title');
53aa2791 158like ($got, $Default_Pattern, 'default format is all or noc');
0e74ff8e
JH
159
160$bar = 0;
161select(OUT);
162$got = timethis($iterations, '++$bar');
163select(STDOUT);
164isa_ok($got, 'Benchmark', "timethis eval");
165is ($bar, $iterations, "benchmarked code was run $iterations times");
166
167$got = $out->read();
168like ($got, qr/^timethis $iterations/, 'default title');
53aa2791 169like ($got, $Default_Pattern, 'default format is all or noc');
0e74ff8e
JH
170
171my $title = 'lies, damn lies and benchmarks';
172$foo = 0;
173select(OUT);
174$got = timethis($iterations, sub {++$foo}, $title);
175select(STDOUT);
176isa_ok($got, 'Benchmark', "timethis with title");
177is ($foo, $iterations, "benchmarked code was run $iterations times");
178
179$got = $out->read();
180like ($got, qr/^$title:/, 'specify title');
53aa2791 181like ($got, $Default_Pattern, 'default format is all or noc');
0e74ff8e
JH
182
183# default is auto, which is all or noc. nop can never match the default
184$foo = 0;
185select(OUT);
186$got = timethis($iterations, sub {++$foo}, $title, 'nop');
187select(STDOUT);
188isa_ok($got, 'Benchmark', "timethis with format");
189is ($foo, $iterations, "benchmarked code was run $iterations times");
190
191$got = $out->read();
192like ($got, qr/^$title:/, 'specify title');
53aa2791 193like ($got, $Nop_Pattern, 'specify format as nop');
0e74ff8e
JH
194
195{
196 $foo = 0;
197 select(OUT);
198 my $start = time;
199 $got = timethis(-2, sub {$foo+= fib($ballast)}, $title, 'none');
200 my $end = time;
201 select(STDOUT);
202 isa_ok($got, 'Benchmark',
203 "timethis, at least 2 seconds with format 'none'");
204 ok ($foo > 0, "benchmarked code was run");
205 ok ($end - $start > 1, "benchmarked code ran for over 1 second");
206
207 $got = $out->read();
208 # Remove any warnings about having too few iterations.
209 $got =~ s/\(warning:[^\)]+\)//gs;
210 $got =~ s/^[ \t\n]+//s; # Remove all the whitespace from the beginning
211
212 is ($got, '', "format 'none' should suppress output");
213}
214
215$foo = $bar = $baz = 0;
216select(OUT);
217$got = timethese($iterations, { Foo => sub {++$foo}, Bar => '++$bar',
218 Baz => sub {++$baz} });
219select(STDOUT);
220is(ref ($got), 'HASH', "timethese should return a hashref");
221isa_ok($got->{Foo}, 'Benchmark', "Foo value");
222isa_ok($got->{Bar}, 'Benchmark', "Bar value");
223isa_ok($got->{Baz}, 'Benchmark', "Baz value");
224eq_set([keys %$got], [qw(Foo Bar Baz)], 'should be exactly three objects');
225is ($foo, $iterations, "Foo code was run $iterations times");
226is ($bar, $iterations, "Bar code was run $iterations times");
227is ($baz, $iterations, "Baz code was run $iterations times");
228
229$got = $out->read();
230# Remove any warnings about having too few iterations.
231$got =~ s/\(warning:[^\)]+\)//gs;
232
233like ($got, qr/timing $iterations iterations of\s+Bar\W+Baz\W+Foo\W*?\.\.\./s,
234 'check title');
235# Remove the title
236$got =~ s/.*\.\.\.//s;
237like ($got, qr/\bBar\b.*\bBaz\b.*\bFoo\b/s, 'check output is in sorted order');
53aa2791
MS
238like ($got, $Default_Pattern, 'should find default format somewhere');
239
240
241{ # ensure 'use strict' does not leak from Benchmark.pm into benchmarked code
242 no strict;
243 select OUT;
244
245 eval {
246 timethese( 1,
247 { undeclared_var => q{ $i++; $i-- },
248 symbolic_ref => q{ $bar = 42;
249 $foo = 'bar';
250 $q = ${$foo} },
251 },
252 'none'
253 );
254
255 };
256 is( $@, '', q{no strict leakage in name => 'code'} );
257
258 eval {
259 timethese( 1,
260 { undeclared_var => sub { $i++; $i-- },
261 symbolic_ref => sub { $bar = 42;
262 $foo = 'bar';
263 return ${$foo} },
264 },
265 'none'
266 );
267 };
268 is( $@, '', q{no strict leakage in name => sub { code }} );
269
270 # clear out buffer
271 $out->read;
272}
273
0e74ff8e
JH
274
275my $code_to_test = { Foo => sub {$foo+=fib($ballast-2)},
276 Bar => sub {$bar+=fib($ballast)}};
277# Keep these for later.
278my $results;
279{
280 $foo = $bar = 0;
281 select(OUT);
282 my $start = times;
283 $results = timethese(-0.1, $code_to_test, 'none');
284 my $end = times;
285 select(STDOUT);
286
287 is(ref ($results), 'HASH', "timethese should return a hashref");
288 isa_ok($results->{Foo}, 'Benchmark', "Foo value");
289 isa_ok($results->{Bar}, 'Benchmark', "Bar value");
290 eq_set([keys %$results], [qw(Foo Bar)], 'should be exactly two objects');
291 ok ($foo > 0, "Foo code was run");
292 ok ($bar > 0, "Bar code was run");
293
294 ok (($end - $start) > 0.1, "benchmarked code ran for over 0.1 seconds");
295
296 $got = $out->read();
297 # Remove any warnings about having too few iterations.
298 $got =~ s/\(warning:[^\)]+\)//gs;
299 is ($got =~ tr/ \t\n//c, 0, "format 'none' should suppress output");
300}
301my $graph_dissassembly =
302 qr!^[ \t]+(\S+)[ \t]+(\w+)[ \t]+(\w+)[ \t]* # Title line
303 \n[ \t]*(\w+)[ \t]+([0-9.]+(?:/s)?)[ \t]+(-+)[ \t]+(-?\d+%)[ \t]*
304 \n[ \t]*(\w+)[ \t]+([0-9.]+(?:/s)?)[ \t]+(-?\d+%)[ \t]+(-+)[ \t]*$!xm;
305
306sub check_graph_consistency {
307 my ( $ratetext, $slowc, $fastc,
308 $slowr, $slowratet, $slowslow, $slowfastt,
309 $fastr, $fastratet, $fastslowt, $fastfast)
310 = @_;
ca55f232 311 note("calling check_graph_consistency from line " . (caller(1))[2]);
23c50b23
NC
312 my $all_passed = 1;
313 $all_passed
314 &= is ($slowc, $slowr, "left col tag should be top row tag");
315 $all_passed
316 &= is ($fastc, $fastr, "right col tag should be bottom row tag");
317 $all_passed &=
318 like ($slowslow, qr/^-+/, "should be dash for comparing slow with slow");
319 $all_passed
320 &= is ($slowslow, $fastfast, "slow v slow should be same as fast v fast");
0e74ff8e
JH
321 my $slowrate = $slowratet;
322 my $fastrate = $fastratet;
323 my ($slow_is_rate, $fast_is_rate);
324 unless ($slow_is_rate = $slowrate =~ s!/s!!) {
325 # Slow is expressed as iters per second.
326 $slowrate = 1/$slowrate if $slowrate;
327 }
328 unless ($fast_is_rate = $fastrate =~ s!/s!!) {
329 # Fast is expressed as iters per second.
330 $fastrate = 1/$fastrate if $fastrate;
331 }
332 if ($ratetext =~ /rate/i) {
23c50b23
NC
333 $all_passed
334 &= ok ($slow_is_rate, "slow should be expressed as a rate");
335 $all_passed
336 &= ok ($fast_is_rate, "fast should be expressed as a rate");
0e74ff8e 337 } else {
23c50b23
NC
338 $all_passed &=
339 ok (!$slow_is_rate, "slow should be expressed as a iters per second");
340 $all_passed &=
341 ok (!$fast_is_rate, "fast should be expressed as a iters per second");
0e74ff8e
JH
342 }
343
344 (my $slowfast = $slowfastt) =~ s!%!!;
345 (my $fastslow = $fastslowt) =~ s!%!!;
346 if ($slowrate < $fastrate) {
347 pass ("slow rate is less than fast rate");
07e88136
JH
348 unless (ok ($slowfast <= 0 && $slowfast >= -100,
349 "slowfast should be less than or equal to zero, and >= -100")) {
2d684b7a 350 print STDERR "# slowfast $slowfast\n";
23c50b23
NC
351 $all_passed = 0;
352 }
353 unless (ok ($fastslow > 0, "fastslow should be > 0")) {
e5967bfd 354 print STDERR "# fastslow $fastslow\n";
23c50b23
NC
355 $all_passed = 0;
356 }
0e74ff8e 357 } else {
23c50b23
NC
358 $all_passed
359 &= is ($slowrate, $fastrate,
360 "slow rate isn't less than fast rate, so should be the same");
620b59a5
JH
361 # In OpenBSD the $slowfast is sometimes a really, really, really
362 # small number less than zero, and this gets stringified as -0.
23c50b23 363 $all_passed
620b59a5 364 &= like ($slowfast, qr/^-?0$/, "slowfast should be zero");
23c50b23 365 $all_passed
620b59a5 366 &= like ($fastslow, qr/^-?0$/, "fastslow should be zero");
0e74ff8e 367 }
23c50b23 368 return $all_passed;
0e74ff8e
JH
369}
370
371sub check_graph_vs_output {
372 my ($chart, $got) = @_;
373 my ( $ratetext, $slowc, $fastc,
374 $slowr, $slowratet, $slowslow, $slowfastt,
375 $fastr, $fastratet, $fastslowt, $fastfast)
376 = $got =~ $graph_dissassembly;
23c50b23
NC
377 my $all_passed
378 = check_graph_consistency ( $ratetext, $slowc, $fastc,
379 $slowr, $slowratet, $slowslow, $slowfastt,
380 $fastr, $fastratet, $fastslowt, $fastfast);
381 $all_passed
382 &= is_deeply ($chart, [['', $ratetext, $slowc, $fastc],
383 [$slowr, $slowratet, $slowslow, $slowfastt],
384 [$fastr, $fastratet, $fastslowt, $fastfast]],
385 "check the chart layout matches the formatted output");
386 unless ($all_passed) {
387 print STDERR "# Something went wrong there. I got this chart:\n";
388 print STDERR "# $_\n" foreach split /\n/, $got;
389 }
0e74ff8e
JH
390}
391
392sub check_graph {
393 my ($title, $row1, $row2) = @_;
394 is (scalar @$title, 4, "Four entries in title row");
395 is (scalar @$row1, 4, "Four entries in first row");
396 is (scalar @$row2, 4, "Four entries in second row");
397 is (shift @$title, '', "First entry of output graph should be ''");
398 check_graph_consistency (@$title, @$row1, @$row2);
399}
400
401{
402 select(OUT);
403 my $start = times;
59000498
DM
404 my $chart = cmpthese( -0.1, { a => "\$i = sqrt(\$i++) * sqrt(\$i)",
405 b => "\$i = sqrt(\$i++)",
406 }, "auto" ) ;
0e74ff8e
JH
407 my $end = times;
408 select(STDOUT);
409 ok (($end - $start) > 0.05, "benchmarked code ran for over 0.05 seconds");
410
411 $got = $out->read();
412 # Remove any warnings about having too few iterations.
413 $got =~ s/\(warning:[^\)]+\)//gs;
414
415 like ($got, qr/running\W+a\W+b.*?for at least 0\.1 CPU second/s,
416 'check title');
417 # Remove the title
418 $got =~ s/.*\.\.\.//s;
53aa2791 419 like ($got, $Default_Pattern, 'should find default format somewhere');
0e74ff8e
JH
420 like ($got, $graph_dissassembly, "Should find the output graph somewhere");
421 check_graph_vs_output ($chart, $got);
422}
423
8962dfd6
A
424# Not giving auto should suppress timethese results.
425{
426 select(OUT);
427 my $start = times;
59000498
DM
428 my $chart = cmpthese( -0.1, { a => "\$i = sqrt(\$i++) * sqrt(\$i)",
429 b => "\$i = sqrt(\$i++)" });
8962dfd6
A
430 my $end = times;
431 select(STDOUT);
432 ok (($end - $start) > 0.05, "benchmarked code ran for over 0.05 seconds");
433
434 $got = $out->read();
435 # Remove any warnings about having too few iterations.
436 $got =~ s/\(warning:[^\)]+\)//gs;
437
438 unlike ($got, qr/running\W+a\W+b.*?for at least 0\.1 CPU second/s,
439 'should not have title');
440 # Remove the title
441 $got =~ s/.*\.\.\.//s;
53aa2791 442 unlike ($got, $Default_Pattern, 'should not find default format somewhere');
8962dfd6
A
443 like ($got, $graph_dissassembly, "Should find the output graph somewhere");
444 check_graph_vs_output ($chart, $got);
445}
446
0e74ff8e
JH
447{
448 $foo = $bar = 0;
449 select(OUT);
450 my $chart = cmpthese( 10, $code_to_test, 'nop' ) ;
451 select(STDOUT);
452 ok ($foo > 0, "Foo code was run");
453 ok ($bar > 0, "Bar code was run");
454
455 $got = $out->read();
456 # Remove any warnings about having too few iterations.
457 $got =~ s/\(warning:[^\)]+\)//gs;
458 like ($got, qr/timing 10 iterations of\s+Bar\W+Foo\W*?\.\.\./s,
459 'check title');
460 # Remove the title
461 $got =~ s/.*\.\.\.//s;
53aa2791 462 like ($got, $Nop_Pattern, 'specify format as nop');
0e74ff8e
JH
463 like ($got, $graph_dissassembly, "Should find the output graph somewhere");
464 check_graph_vs_output ($chart, $got);
465}
466
467{
468 $foo = $bar = 0;
469 select(OUT);
470 my $chart = cmpthese( 10, $code_to_test, 'none' ) ;
471 select(STDOUT);
472 ok ($foo > 0, "Foo code was run");
473 ok ($bar > 0, "Bar code was run");
474
475 $got = $out->read();
476 # Remove any warnings about having too few iterations.
477 $got =~ s/\(warning:[^\)]+\)//gs;
478 $got =~ s/^[ \t\n]+//s; # Remove all the whitespace from the beginning
479 is ($got, '', "format 'none' should suppress output");
480 is (ref $chart, 'ARRAY', "output should be an array ref");
481 # Some of these will go bang if the preceding test fails. There will be
482 # a big clue as to why, from the previous test's diagnostic
483 is (ref $chart->[0], 'ARRAY', "output should be an array of arrays");
484 check_graph (@$chart);
485}
486
487{
488 $foo = $bar = 0;
489 select(OUT);
490 my $chart = cmpthese( $results ) ;
491 select(STDOUT);
492 is ($foo, 0, "Foo code was not run");
493 is ($bar, 0, "Bar code was not run");
494
495 $got = $out->read();
496 ok ($got !~ /\.\.\./s, 'check that there is no title');
497 like ($got, $graph_dissassembly, "Should find the output graph somewhere");
498 check_graph_vs_output ($chart, $got);
499}
500
501{
502 $foo = $bar = 0;
503 select(OUT);
504 my $chart = cmpthese( $results, 'none' ) ;
505 select(STDOUT);
506 is ($foo, 0, "Foo code was not run");
507 is ($bar, 0, "Bar code was not run");
508
509 $got = $out->read();
510 is ($got, '', "'none' should suppress all output");
511 is (ref $chart, 'ARRAY', "output should be an array ref");
512 # Some of these will go bang if the preceding test fails. There will be
513 # a big clue as to why, from the previous test's diagnostic
514 is (ref $chart->[0], 'ARRAY', "output should be an array of arrays");
515 check_graph (@$chart);
516}
517
518###}my $out = tie *OUT, 'TieOut'; my ($got); ###
519
520my $debug = tie *STDERR, 'TieOut';
521
522$bar = 0;
523isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval");
524is ($bar, 5, "benchmarked code was run 5 times");
525is ($debug->read(), '', "There was no debug output");
526
527Benchmark->debug(1);
528
529$bar = 0;
530select(OUT);
531$got = timeit(5, '++$bar');
532select(STDOUT);
533isa_ok($got, 'Benchmark', "timeit eval");
534is ($bar, 5, "benchmarked code was run 5 times");
535is ($out->read(), '', "There was no STDOUT output with debug enabled");
536isnt ($debug->read(), '', "There was STDERR debug output with debug enabled");
537
538Benchmark->debug(0);
539
540$bar = 0;
541isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval");
542is ($bar, 5, "benchmarked code was run 5 times");
543is ($debug->read(), '', "There was no debug output debug disabled");
544
545undef $debug;
546untie *STDERR;
547
548# To check the cache we are poking where we don't belong, inside the namespace.
98dc9551 549# The way benchmark is written we can't actually check whether the cache is
0e74ff8e
JH
550# being used, merely what's become cached.
551
552clearallcache();
53aa2791 553my @before_keys = keys %Benchmark::Cache;
0e74ff8e
JH
554$bar = 0;
555isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval");
556is ($bar, 5, "benchmarked code was run 5 times");
53aa2791 557my @after5_keys = keys %Benchmark::Cache;
0e74ff8e
JH
558$bar = 0;
559isa_ok(timeit(10, '++$bar'), 'Benchmark', "timeit eval");
560is ($bar, 10, "benchmarked code was run 10 times");
53aa2791 561ok (!eq_array ([keys %Benchmark::Cache], \@after5_keys), "10 differs from 5");
0e74ff8e
JH
562
563clearcache(10);
564# Hash key order will be the same if there are the same keys.
53aa2791 565is_deeply ([keys %Benchmark::Cache], \@after5_keys,
0e74ff8e
JH
566 "cleared 10, only cached results for 5 should remain");
567
568clearallcache();
53aa2791 569is_deeply ([keys %Benchmark::Cache], \@before_keys,
0e74ff8e
JH
570 "back to square 1 when we clear the cache again?");
571
572
53aa2791
MS
573{ # Check usage error messages
574 my %usage = %Benchmark::_Usage;
575 delete $usage{runloop}; # not public, not worrying about it just now
576
577 my @takes_no_args = qw(clearallcache disablecache enablecache);
578
579 my %cmpthese = ('forgot {}' => 'cmpthese( 42, foo => sub { 1 } )',
580 'not result' => 'cmpthese(42)',
581 'array ref' => 'cmpthese( 42, [ foo => sub { 1 } ] )',
582 );
583 while( my($name, $code) = each %cmpthese ) {
584 eval $code;
585 is( $@, $usage{cmpthese}, "cmpthese usage: $name" );
586 }
587
588 my %timethese = ('forgot {}' => 'timethese( 42, foo => sub { 1 } )',
589 'no code' => 'timethese(42)',
590 'array ref' => 'timethese( 42, [ foo => sub { 1 } ] )',
591 );
592
593 while( my($name, $code) = each %timethese ) {
594 eval $code;
595 is( $@, $usage{timethese}, "timethese usage: $name" );
596 }
597
598
599 while( my($func, $usage) = each %usage ) {
600 next if grep $func eq $_, @takes_no_args;
601 eval "$func()";
602 is( $@, $usage, "$func usage: no args" );
603 }
604
605 foreach my $func (@takes_no_args) {
606 eval "$func(42)";
f695f0e6 607 is( $@, $usage{$func}, "$func usage: with args" );
53aa2791
MS
608 }
609}
610
611
0e74ff8e
JH
612package TieOut;
613
614sub TIEHANDLE {
615 my $class = shift;
616 bless(\( my $ref = ''), $class);
617}
618
619sub PRINT {
620 my $self = shift;
621 $$self .= join('', @_);
622}
623
624sub PRINTF {
625 my $self = shift;
626 $$self .= sprintf shift, @_;
627}
628
629sub read {
630 my $self = shift;
631 return substr($$self, 0, length($$self), '');
632}