1#!./perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = ('../lib'); 6} 7 8use warnings; 9use strict; 10our ($foo, $bar, $baz, $ballast); 11use Test::More; 12 13use Benchmark qw(:all); 14 15my $DELTA = 0.4; 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 25my $All_Pattern = 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\)/; 27my $Noc_Pattern = 28 qr/(\d+) +wallclock secs? +\( *(-?\d+\.\d\d) +usr +\+ +(-?\d+\.\d\d) +sys += +(-?\d+\.\d\d) +CPU\)/; 29my $Nop_Pattern = 30 qr/(\d+) +wallclock secs? +\( *(-?\d+\.\d\d) +cusr +\+ +(-?\d+\.\d\d) +csys += +\d+\.\d\d +CPU\)/; 31# Please don't trust the matching parentheses to be useful in this :-) 32my $Default_Pattern = qr/$All_Pattern|$Noc_Pattern/; 33 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 43sub splatter { 44 my ($message) = @_; 45 my $splatter = <<~'EOF_SPLATTER'; 46 Please file a ticket to report this. Our bug tracker can be found at 47 48 https://github.com/Perl/perl5/issues 49 50 Make sure you include the full output of perl -V, also uname -a, 51 and the version details for the C compiler you are using are 52 very helpful. 53 54 Please also try compiling and running the C program that can 55 be found at 56 57 https://github.com/Perl/perl5/issues/20839#issuecomment-1439286875 58 59 and provide the results (or compile errors) as part of your 60 bug report. 61 62 EOF_SPLATTER 63 64 if ( $message =~ s/\.\.\.//) { 65 $splatter =~ s/Please/please/; 66 } 67 die $message, $splatter; 68} 69 70{ 71 # Benchmark may end up "looping forever" if time() or times() are 72 # broken such that they do not return different values over time. 73 # The following crude test is intended to ensure that we can rely 74 # on them and be confident that we won't infinite loop in the 75 # following tests. 76 # 77 # You can simulate a broken time or times() function by setting 78 # the appropriate env var to a true value: 79 # 80 # time() -> SIMULATE_BROKEN_TIME_FUNCTION 81 # times() -> SIMULATE_BROKEN_TIMES_FUNCTION 82 # 83 # If you have a very fast box you may need to set the FAST_CPU env 84 # var to a number larger than 1 to require these tests to perform 85 # more iterations to see the time actually tick over. (You could 86 # also set it to a value between 0 and 1 to speed this up, but I 87 # don't see why you would...) 88 # 89 # See https://github.com/Perl/perl5/issues/20839 for the ticket 90 # that motivated this test. - Yves 91 92 my @times0; 93 for ( 1 .. 3 ) { 94 my $end_time = time + 1; 95 my $count = 0; 96 my $scale = $ENV{FAST_CPU} || 1; 97 my $count_threshold = 20_000; 98 while ( $ENV{SIMULATE_BROKEN_TIME_FUNCTION} || time < $end_time ) { 99 my $x = 0.0; 100 for ( 1 .. 10_000 ) { 101 $x += sqrt(time); 102 } 103 if (++$count > $count_threshold * $scale) { 104 last; 105 } 106 } 107 cmp_ok($count,"<",$count_threshold * $scale, 108 "expecting \$count < ($count_threshold * $scale)") 109 or splatter(<<~'EOF_SPLATTER'); 110 Either this system is extremely fast, or the time() function 111 is broken. 112 113 If you think this system is extremely fast you may scale up the 114 number of iterations allowed by this test by setting FAST_CPU=N 115 in the environment. Higher N will allow more ops-per-second 116 before we decide time() is broken. 117 118 If setting a higher FAST_CPU value does not fix this problem then ... 119 EOF_SPLATTER 120 push @times0, $ENV{SIMULATE_BROKEN_TIMES_FUNCTION} ? 0 : (times)[0]; 121 } 122 isnt("@times0", "0 0 0", "Make sure times() does not always return 0.") 123 or splatter("It appears you have a broken a times() function.\n\n"); 124} 125 126my $t0 = new Benchmark; 127isa_ok ($t0, 'Benchmark', "Ensure we can create a benchmark object"); 128 129# We use the benchmark object once we've done some work: 130 131isa_ok(timeit(5, sub {++$foo}), 'Benchmark', "timeit CODEREF"); 132is ($foo, 5, "benchmarked code was run 5 times"); 133 134isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval"); 135is ($bar, 5, "benchmarked code was run 5 times"); 136 137# is coderef called with spurious arguments? 138timeit( 1, sub { $foo = @_ }); 139is ($foo, 0, "benchmarked code called without arguments"); 140 141 142print "# Burning CPU to benchmark things; will take time...\n"; 143 144# We need to do something fairly slow in the coderef. 145# Same coderef. Same place in memory. 146my $coderef = sub {$baz += fib($ballast)}; 147 148# The default is three. 149$baz = 0; 150my $threesecs = countit(0, $coderef); 151isa_ok($threesecs, 'Benchmark', "countit 0, CODEREF"); 152isnt ($baz, 0, "benchmarked code was run"); 153my $in_threesecs = $threesecs->iters; 154print "# in_threesecs=$in_threesecs iterations\n"; 155cmp_ok($in_threesecs, '>', 0, "iters returned positive iterations"); 156my $cpu3 = $threesecs->[1]; # user 157my $sys3 = $threesecs->[2]; # sys 158cmp_ok($cpu3+$sys3, '>=', 3.0, "3s cpu3 is at least 3s"); 159my $in_threesecs_adj = $in_threesecs; 160$in_threesecs_adj *= (3/$cpu3); # adjust because may not have run for exactly 3s 161print "# in_threesecs_adj=$in_threesecs_adj adjusted iterations\n"; 162 163my $estimate = int (100 * $in_threesecs_adj / 3) / 100; 164print "# from the 3 second run estimate $estimate iterations in 1 second...\n"; 165$baz = 0; 166my $onesec = countit(1, $coderef); 167isa_ok($onesec, 'Benchmark', "countit 1, CODEREF"); 168isnt ($baz, 0, "benchmarked code was run"); 169my $in_onesec = $onesec->iters; 170print "# in_onesec=$in_onesec iterations\n"; 171cmp_ok($in_onesec, '>', 0, "iters returned positive iterations"); 172my $cpu1 = $onesec->[1]; # user 173my $sys1 = $onesec->[2]; # sys 174cmp_ok($cpu1+$sys1, '>=', 1.0, "is cpu1 is at least 1s"); 175my $in_onesec_adj = $in_onesec; 176$in_onesec_adj *= (1/$cpu1); # adjust because may not have run for exactly 1s 177print "# in_onesec_adj=$in_onesec_adj adjusted iterations\n"; 178 179 180# I found that the eval'ed version was 3 times faster than the coderef. 181# (now it has a different ballast value) 182$baz = 0; 183my $again = countit(1, '$baz += fib($ballast)'); 184isa_ok($onesec, 'Benchmark', "countit 1, eval"); 185isnt ($baz, 0, "benchmarked code was run"); 186my $in_again = $again->iters; 187print "# $in_again iterations\n"; 188cmp_ok($in_again, '>', 0, "iters returned positive iterations"); 189 190 191my $t1 = new Benchmark; 192isa_ok ($t1, 'Benchmark', "Create another benchmark object now we're finished"); 193 194my $diff = timediff ($t1, $t0); 195isa_ok ($diff, 'Benchmark', "Get the time difference"); 196isa_ok (timesum ($t0, $t1), 'Benchmark', "check timesum"); 197 198my $default = timestr ($diff); 199isnt ($default, '', 'timestr ($diff)'); 200my $auto = timestr ($diff, 'auto'); 201is ($auto, $default, 'timestr ($diff, "auto") matches timestr ($diff)'); 202 203{ 204 my $all = timestr ($diff, 'all'); 205 like ($all, $All_Pattern, 'timestr ($diff, "all")'); 206 print "# $all\n"; 207 208 my ($wallclock, $usr, $sys, $cusr, $csys, $cpu) = $all =~ $All_Pattern; 209 210 is (timestr ($diff, 'none'), '', "none suppresses output"); 211 212 my $noc = timestr ($diff, 'noc'); 213 like ($noc, qr/$wallclock +wallclock secs? +\( *$usr +usr +\+ +$sys +sys += +\d+\.\d\d +CPU\)/, 'timestr ($diff, "noc")'); 214 215 my $nop = timestr ($diff, 'nop'); 216 like ($nop, qr/$wallclock +wallclock secs? +\( *$cusr +cusr +\+ +$csys +csys += +\d+\.\d\d +CPU\)/, 'timestr ($diff, "nop")'); 217 218 if ($auto eq $noc) { 219 pass ('"auto" is "noc"'); 220 } else { 221 is ($auto, $all, '"auto" isn\'t "noc", so should be eq to "all"'); 222 } 223 224 like (timestr ($diff, 'all', 'E'), 225 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"]'); 226} 227 228my $out = tie *OUT, 'TieOut'; 229 230my $iterations = 100; 231 232$foo = 0; 233select(OUT); 234my $got = timethis($iterations, sub {++$foo}); 235select(STDOUT); 236isa_ok($got, 'Benchmark', "timethis CODEREF"); 237is ($foo, $iterations, "benchmarked code was run $iterations times"); 238 239$got = $out->read(); 240like ($got, qr/^timethis $iterations/, 'default title'); 241like ($got, $Default_Pattern, 'default format is all or noc'); 242 243$bar = 0; 244select(OUT); 245$got = timethis($iterations, '++$bar'); 246select(STDOUT); 247isa_ok($got, 'Benchmark', "timethis eval"); 248is ($bar, $iterations, "benchmarked code was run $iterations times"); 249 250$got = $out->read(); 251like ($got, qr/^timethis $iterations/, 'default title'); 252like ($got, $Default_Pattern, 'default format is all or noc'); 253 254my $title = 'lies, damn lies and benchmarks'; 255$foo = 0; 256select(OUT); 257$got = timethis($iterations, sub {++$foo}, $title); 258select(STDOUT); 259isa_ok($got, 'Benchmark', "timethis with title"); 260is ($foo, $iterations, "benchmarked code was run $iterations times"); 261 262$got = $out->read(); 263like ($got, qr/^$title:/, 'specify title'); 264like ($got, $Default_Pattern, 'default format is all or noc'); 265 266# default is auto, which is all or noc. nop can never match the default 267$foo = 0; 268select(OUT); 269$got = timethis($iterations, sub {++$foo}, $title, 'nop'); 270select(STDOUT); 271isa_ok($got, 'Benchmark', "timethis with format"); 272is ($foo, $iterations, "benchmarked code was run $iterations times"); 273 274$got = $out->read(); 275like ($got, qr/^$title:/, 'specify title'); 276like ($got, $Nop_Pattern, 'specify format as nop'); 277 278{ 279 $foo = 0; 280 select(OUT); 281 my $start = time; 282 $got = timethis(-2, sub {$foo+= fib($ballast)}, $title, 'none'); 283 my $end = time; 284 select(STDOUT); 285 isa_ok($got, 'Benchmark', 286 "timethis, at least 2 seconds with format 'none'"); 287 cmp_ok($foo, '>', 0, "benchmarked code was run"); 288 cmp_ok($end - $start, '>', 1, "benchmarked code ran for over 1 second"); 289 290 $got = $out->read(); 291 # Remove any warnings about having too few iterations. 292 $got =~ s/\(warning:[^\)]+\)//gs; 293 $got =~ s/^[ \t\n]+//s; # Remove all the whitespace from the beginning 294 295 is ($got, '', "format 'none' should suppress output"); 296} 297 298$foo = $bar = $baz = 0; 299select(OUT); 300$got = timethese($iterations, { Foo => sub {++$foo}, Bar => '++$bar', 301 Baz => sub {++$baz} }); 302select(STDOUT); 303is(ref ($got), 'HASH', "timethese should return a hashref"); 304isa_ok($got->{Foo}, 'Benchmark', "Foo value"); 305isa_ok($got->{Bar}, 'Benchmark', "Bar value"); 306isa_ok($got->{Baz}, 'Benchmark', "Baz value"); 307is_deeply([sort keys %$got], [sort qw(Foo Bar Baz)], 'should be exactly three objects'); 308is ($foo, $iterations, "Foo code was run $iterations times"); 309is ($bar, $iterations, "Bar code was run $iterations times"); 310is ($baz, $iterations, "Baz code was run $iterations times"); 311 312$got = $out->read(); 313# Remove any warnings about having too few iterations. 314$got =~ s/\(warning:[^\)]+\)//gs; 315 316like ($got, qr/timing $iterations iterations of\s+Bar\W+Baz\W+Foo\W*?\.\.\./s, 317 'check title'); 318# Remove the title 319$got =~ s/.*\.\.\.//s; 320like ($got, qr/\bBar\b.*\bBaz\b.*\bFoo\b/s, 'check output is in sorted order'); 321like ($got, $Default_Pattern, 'should find default format somewhere'); 322 323 324{ # ensure 'use strict' does not leak from Benchmark.pm into benchmarked code 325 no strict; 326 select OUT; 327 328 eval { 329 timethese( 1, 330 { undeclared_var => q{ $i++; $i-- }, 331 symbolic_ref => q{ $bar = 42; 332 $foo = 'bar'; 333 $q = ${$foo} }, 334 }, 335 'none' 336 ); 337 338 }; 339 is( $@, '', q{no strict leakage in name => 'code'} ); 340 341 eval { 342 timethese( 1, 343 { undeclared_var => sub { $i++; $i-- }, 344 symbolic_ref => sub { $bar = 42; 345 $foo = 'bar'; 346 return ${$foo} }, 347 }, 348 'none' 349 ); 350 }; 351 is( $@, '', q{no strict leakage in name => sub { code }} ); 352 353 # clear out buffer 354 $out->read; 355} 356 357 358my $code_to_test = { Foo => sub {$foo+=fib($ballast-2)}, 359 Bar => sub {$bar+=fib($ballast)}}; 360# Keep these for later. 361my $results; 362{ 363 $foo = $bar = 0; 364 select(OUT); 365 my $start = times; 366 $results = timethese(-0.1, $code_to_test, 'none'); 367 my $end = times; 368 select(STDOUT); 369 370 is(ref ($results), 'HASH', "timethese should return a hashref"); 371 isa_ok($results->{Foo}, 'Benchmark', "Foo value"); 372 isa_ok($results->{Bar}, 'Benchmark', "Bar value"); 373 is_deeply([sort keys %$results], [sort qw(Foo Bar)], 'should be exactly two objects'); 374 cmp_ok($foo, '>', 0, "Foo code was run"); 375 cmp_ok($bar, '>', 0, "Bar code was run"); 376 377 cmp_ok($end-$start, '>', 0.1, "benchmarked code ran for over 0.1 seconds"); 378 379 $got = $out->read(); 380 # Remove any warnings about having too few iterations. 381 $got =~ s/\(warning:[^\)]+\)//gs; 382 is ($got =~ tr/ \t\n//c, 0, "format 'none' should suppress output"); 383} 384my $graph_dissassembly = 385 qr!^[ \t]+(\S+)[ \t]+(\w+)[ \t]+(\w+)[ \t]* # Title line 386 \n[ \t]*(\w+)[ \t]+([0-9.]+(?:/s)?)[ \t]+(-+)[ \t]+(-?\d+%)[ \t]* 387 \n[ \t]*(\w+)[ \t]+([0-9.]+(?:/s)?)[ \t]+(-?\d+%)[ \t]+(-+)[ \t]*$!xm; 388 389sub check_graph_consistency { 390 my ( $ratetext, $slowc, $fastc, 391 $slowr, $slowratet, $slowslow, $slowfastt, 392 $fastr, $fastratet, $fastslowt, $fastfast) 393 = @_; 394 note("calling check_graph_consistency from line " . (caller(1))[2]); 395 my $all_passed = 1; 396 $all_passed 397 &= is ($slowc, $slowr, "left col tag should be top row tag"); 398 $all_passed 399 &= is ($fastc, $fastr, "right col tag should be bottom row tag"); 400 $all_passed &= 401 like ($slowslow, qr/^-+/, "should be dash for comparing slow with slow"); 402 $all_passed 403 &= is ($slowslow, $fastfast, "slow v slow should be same as fast v fast"); 404 my $slowrate = $slowratet; 405 my $fastrate = $fastratet; 406 my ($slow_is_rate, $fast_is_rate); 407 unless ($slow_is_rate = $slowrate =~ s!/s!!) { 408 # Slow is expressed as iters per second. 409 $slowrate = 1/$slowrate if $slowrate; 410 } 411 unless ($fast_is_rate = $fastrate =~ s!/s!!) { 412 # Fast is expressed as iters per second. 413 $fastrate = 1/$fastrate if $fastrate; 414 } 415 if ($ratetext =~ /rate/i) { 416 $all_passed 417 &= ok ($slow_is_rate, "slow should be expressed as a rate"); 418 $all_passed 419 &= ok ($fast_is_rate, "fast should be expressed as a rate"); 420 } else { 421 $all_passed &= 422 ok (!$slow_is_rate, "slow should be expressed as a iters per second"); 423 $all_passed &= 424 ok (!$fast_is_rate, "fast should be expressed as a iters per second"); 425 } 426 427 (my $slowfast = $slowfastt) =~ s!%!!; 428 (my $fastslow = $fastslowt) =~ s!%!!; 429 if ($slowrate < $fastrate) { 430 pass ("slow rate is less than fast rate"); 431 unless (ok ($slowfast <= 0 && $slowfast >= -100, 432 "slowfast should be less than or equal to zero, and >= -100")) { 433 diag("slowfast=$slowfast"); 434 $all_passed = 0; 435 } 436 unless (cmp_ok($fastslow, '>', 0, "fastslow should be > 0")) { 437 $all_passed = 0; 438 } 439 } else { 440 $all_passed 441 &= is ($slowrate, $fastrate, 442 "slow rate isn't less than fast rate, so should be the same"); 443 # In OpenBSD the $slowfast is sometimes a really, really, really 444 # small number less than zero, and this gets stringified as -0. 445 $all_passed 446 &= like ($slowfast, qr/^-?0$/, "slowfast should be zero"); 447 $all_passed 448 &= like ($fastslow, qr/^-?0$/, "fastslow should be zero"); 449 } 450 return $all_passed; 451} 452 453sub check_graph_vs_output { 454 my ($chart, $got) = @_; 455 my ( $ratetext, $slowc, $fastc, 456 $slowr, $slowratet, $slowslow, $slowfastt, 457 $fastr, $fastratet, $fastslowt, $fastfast) 458 = $got =~ $graph_dissassembly; 459 my $all_passed 460 = check_graph_consistency ( $ratetext, $slowc, $fastc, 461 $slowr, $slowratet, $slowslow, $slowfastt, 462 $fastr, $fastratet, $fastslowt, $fastfast); 463 $all_passed 464 &= is_deeply ($chart, [['', $ratetext, $slowc, $fastc], 465 [$slowr, $slowratet, $slowslow, $slowfastt], 466 [$fastr, $fastratet, $fastslowt, $fastfast]], 467 "check the chart layout matches the formatted output"); 468 unless ($all_passed) { 469 diag("Something went wrong there. I got this chart:\n$got"); 470 } 471} 472 473sub check_graph { 474 my ($title, $row1, $row2) = @_; 475 is (scalar @$title, 4, "Four entries in title row"); 476 is (scalar @$row1, 4, "Four entries in first row"); 477 is (scalar @$row2, 4, "Four entries in second row"); 478 is (shift @$title, '', "First entry of output graph should be ''"); 479 check_graph_consistency (@$title, @$row1, @$row2); 480} 481 482{ 483 select(OUT); 484 my $start = times; 485 my $chart = cmpthese( -0.1, { a => "\$i = sqrt(\$i++) * sqrt(\$i) for 1..10", 486 b => "\$i = sqrt(\$i++)", 487 }, "auto" ) ; 488 my $end = times; 489 select(STDOUT); 490 cmp_ok($end - $start, '>', 0.05, 491 "benchmarked code ran for over 0.05 seconds"); 492 493 $got = $out->read(); 494 # Remove any warnings about having too few iterations. 495 $got =~ s/\(warning:[^\)]+\)//gs; 496 497 like ($got, qr/running\W+a\W+b.*?for at least 0\.1 CPU second/s, 498 'check title'); 499 # Remove the title 500 $got =~ s/.*\.\.\.//s; 501 like ($got, $Default_Pattern, 'should find default format somewhere'); 502 like ($got, $graph_dissassembly, "Should find the output graph somewhere"); 503 check_graph_vs_output ($chart, $got); 504} 505 506# Not giving auto should suppress timethese results. 507{ 508 select(OUT); 509 my $start = times; 510 my $chart = cmpthese( -0.1, { a => "\$i = sqrt(\$i++) * sqrt(\$i) for 1..10", 511 b => "\$i = sqrt(\$i++)" }); 512 my $end = times; 513 select(STDOUT); 514 cmp_ok($end - $start, '>', 0.05, 515 "benchmarked code ran for over 0.05 seconds"); 516 517 $got = $out->read(); 518 # Remove any warnings about having too few iterations. 519 $got =~ s/\(warning:[^\)]+\)//gs; 520 521 unlike ($got, qr/running\W+a\W+b.*?for at least 0\.1 CPU second/s, 522 'should not have title'); 523 # Remove the title 524 $got =~ s/.*\.\.\.//s; 525 unlike ($got, $Default_Pattern, 'should not find default format somewhere'); 526 like ($got, $graph_dissassembly, "Should find the output graph somewhere"); 527 check_graph_vs_output ($chart, $got); 528} 529 530{ 531 $foo = $bar = 0; 532 select(OUT); 533 my $chart = cmpthese($iterations, $code_to_test, 'nop' ) ; 534 select(STDOUT); 535 cmp_ok($foo, '>', 0, "Foo code was run"); 536 cmp_ok($bar, '>', 0, "Bar code was run"); 537 538 $got = $out->read(); 539 # Remove any warnings about having too few iterations. 540 $got =~ s/\(warning:[^\)]+\)//gs; 541 like ($got, qr/timing $iterations iterations of\s+Bar\W+Foo\W*?\.\.\./s, 542 'check title'); 543 # Remove the title 544 $got =~ s/.*\.\.\.//s; 545 like ($got, $Nop_Pattern, 'specify format as nop'); 546 like ($got, $graph_dissassembly, "Should find the output graph somewhere"); 547 check_graph_vs_output ($chart, $got); 548} 549 550{ 551 $foo = $bar = 0; 552 select(OUT); 553 my $chart = cmpthese($iterations, $code_to_test, 'none' ) ; 554 select(STDOUT); 555 cmp_ok($foo, '>', 0, "Foo code was run"); 556 cmp_ok($bar, '>', 0, "Bar code was run"); 557 558 $got = $out->read(); 559 # Remove any warnings about having too few iterations. 560 $got =~ s/\(warning:[^\)]+\)//gs; 561 $got =~ s/^[ \t\n]+//s; # Remove all the whitespace from the beginning 562 is ($got, '', "format 'none' should suppress output"); 563 is (ref $chart, 'ARRAY', "output should be an array ref"); 564 # Some of these will go bang if the preceding test fails. There will be 565 # a big clue as to why, from the previous test's diagnostic 566 is (ref $chart->[0], 'ARRAY', "output should be an array of arrays"); 567 check_graph (@$chart); 568} 569 570# this is a repeat of the above test, but with the timing and charting 571# steps split. 572 573{ 574 $foo = $bar = 0; 575 select(OUT); 576 my $res = timethese($iterations, $code_to_test, 'none' ) ; 577 my $chart = cmpthese($res, 'none' ) ; 578 select(STDOUT); 579 cmp_ok($foo, '>', 0, "Foo code was run"); 580 cmp_ok($bar, '>', 0, "Bar code was run"); 581 582 $got = $out->read(); 583 # Remove any warnings about having too few iterations. 584 $got =~ s/\(warning:[^\)]+\)//gs; 585 $got =~ s/^[ \t\n]+//s; # Remove all the whitespace from the beginning 586 is ($got, '', "format 'none' should suppress output"); 587 is (ref $chart, 'ARRAY', "output should be an array ref"); 588 # Some of these will go bang if the preceding test fails. There will be 589 # a big clue as to why, from the previous test's diagnostic 590 is (ref $chart->[0], 'ARRAY', "output should be an array of arrays"); 591 use Data::Dumper; 592 check_graph(@$chart) 593 or diag(Data::Dumper->Dump([$res, $chart], ['$res', '$chart'])); 594} 595 596{ 597 $foo = $bar = 0; 598 select(OUT); 599 my $chart = cmpthese( $results ) ; 600 select(STDOUT); 601 is ($foo, 0, "Foo code was not run"); 602 is ($bar, 0, "Bar code was not run"); 603 604 $got = $out->read(); 605 unlike($got, qr/\.\.\./s, 'check that there is no title'); 606 like ($got, $graph_dissassembly, "Should find the output graph somewhere"); 607 check_graph_vs_output ($chart, $got); 608} 609 610{ 611 $foo = $bar = 0; 612 select(OUT); 613 my $chart = cmpthese( $results, 'none' ) ; 614 select(STDOUT); 615 is ($foo, 0, "Foo code was not run"); 616 is ($bar, 0, "Bar code was not run"); 617 618 $got = $out->read(); 619 is ($got, '', "'none' should suppress all output"); 620 is (ref $chart, 'ARRAY', "output should be an array ref"); 621 # Some of these will go bang if the preceding test fails. There will be 622 # a big clue as to why, from the previous test's diagnostic 623 is (ref $chart->[0], 'ARRAY', "output should be an array of arrays"); 624 check_graph (@$chart); 625} 626 627###}my $out = tie *OUT, 'TieOut'; my ($got); ### 628 629my $debug = tie *STDERR, 'TieOut'; 630 631$bar = 0; 632isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval"); 633is ($bar, 5, "benchmarked code was run 5 times"); 634is ($debug->read(), '', "There was no debug output"); 635 636Benchmark->debug(1); 637 638$bar = 0; 639select(OUT); 640$got = timeit(5, '++$bar'); 641select(STDOUT); 642isa_ok($got, 'Benchmark', "timeit eval"); 643is ($bar, 5, "benchmarked code was run 5 times"); 644is ($out->read(), '', "There was no STDOUT output with debug enabled"); 645isnt ($debug->read(), '', "There was STDERR debug output with debug enabled"); 646 647Benchmark->debug(0); 648 649$bar = 0; 650isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval"); 651is ($bar, 5, "benchmarked code was run 5 times"); 652is ($debug->read(), '', "There was no debug output debug disabled"); 653 654undef $debug; 655untie *STDERR; 656 657# To check the cache we are poking where we don't belong, inside the namespace. 658# The way benchmark is written we can't actually check whether the cache is 659# being used, merely what's become cached. 660 661clearallcache(); 662my @before_keys = keys %Benchmark::Cache; 663$bar = 0; 664isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval"); 665is ($bar, 5, "benchmarked code was run 5 times"); 666my @after5_keys = keys %Benchmark::Cache; 667$bar = 0; 668isa_ok(timeit(10, '++$bar'), 'Benchmark', "timeit eval"); 669is ($bar, 10, "benchmarked code was run 10 times"); 670cmp_ok (scalar keys %Benchmark::Cache, '>', scalar @after5_keys, "10 differs from 5"); 671 672clearcache(10); 673# Hash key order will be the same if there are the same keys. 674is_deeply ([keys %Benchmark::Cache], \@after5_keys, 675 "cleared 10, only cached results for 5 should remain"); 676 677clearallcache(); 678is_deeply ([keys %Benchmark::Cache], \@before_keys, 679 "back to square 1 when we clear the cache again?"); 680 681 682{ # Check usage error messages 683 my %usage = %Benchmark::_Usage; 684 delete $usage{runloop}; # not public, not worrying about it just now 685 686 my @takes_no_args = qw(clearallcache disablecache enablecache); 687 688 my %cmpthese = ('forgot {}' => 'cmpthese( 42, foo => sub { 1 } )', 689 'not result' => 'cmpthese(42)', 690 'array ref' => 'cmpthese( 42, [ foo => sub { 1 } ] )', 691 ); 692 while( my($name, $code) = each %cmpthese ) { 693 eval $code; 694 is( $@, $usage{cmpthese}, "cmpthese usage: $name" ); 695 } 696 697 my %timethese = ('forgot {}' => 'timethese( 42, foo => sub { 1 } )', 698 'no code' => 'timethese(42)', 699 'array ref' => 'timethese( 42, [ foo => sub { 1 } ] )', 700 ); 701 702 while( my($name, $code) = each %timethese ) { 703 eval $code; 704 is( $@, $usage{timethese}, "timethese usage: $name" ); 705 } 706 707 708 while( my($func, $usage) = each %usage ) { 709 next if grep $func eq $_, @takes_no_args; 710 eval "$func()"; 711 is( $@, $usage, "$func usage: no args" ); 712 } 713 714 foreach my $func (@takes_no_args) { 715 eval "$func(42)"; 716 is( $@, $usage{$func}, "$func usage: with args" ); 717 } 718} 719 720done_testing(); 721 722package TieOut; 723 724sub TIEHANDLE { 725 my $class = shift; 726 bless(\( my $ref = ''), $class); 727} 728 729sub PRINT { 730 my $self = shift; 731 $$self .= join('', @_); 732} 733 734sub PRINTF { 735 my $self = shift; 736 $$self .= sprintf shift, @_; 737} 738 739sub read { 740 my $self = shift; 741 return substr($$self, 0, length($$self), ''); 742} 743