File Coverage

blib/lib/Benchmark/ProgressBar.pm

Criterion	Covered	Total	%
statement	19	63	30.1
branch	0	32	0.0
condition	0	17	0.0
subroutine	7	9	77.7
pod	1	2	50.0
total	27	123	21.9

# $Id$

package Benchmark::ProgressBar;
use strict;
use warnings;
use Benchmark;
use Term::ProgressBar;
our $VERSION = '0.00001';

sub import {
    Benchmark->export_to_level(1, @_);
}

package # hide from PAUSE
    Benchmark;
use strict;
no warnings 'redefine';

my $default_for = 3;
my $min_for     = 0.1;

our $ProgressTitle;

sub runloop {
    my($n, $c) = @_;

    $n+=0; # force numeric now, so garbage won't creep into the eval
    croak "negative loopcount $n" if $n<0;
    confess usage unless defined $c;
    my($t0, $t1, $td); # before, after, difference

    # find package of caller so we can execute code there
    my($curpack) = caller(0);
    my($i, $pack)= 0;
    while (($pack) = caller(++$i)) {
    last if $pack ne $curpack;
    }

    my $progress = Term::ProgressBar->new({ count => $n, remove => 1, name => $ProgressTitle || "progress" });
    my ($subcode, $subref);
    if (ref $c eq 'CODE') {
    $subcode = "sub { for (1 .. $n) { local \$_; package $pack;
        \$progress->update(\$_);
        &\$c; } }";
        $subref  = eval $subcode;
    }
    else {
    $subcode = "sub { for (1 .. $n) { local \$_; package $pack;
        \$progress->update(\$_);
 $c;} }";
        $subref  = _doeval($subcode);
    }
    croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@;
    print STDERR "runloop $n '$subcode'\n" if $Benchmark::Debug;

    # Give one more line so that the progress bar is easier on the eye
    #print "\n";

    # Wait for the user timer to tick.  This makes the error range more like
    # -0.01, +0.  If we don't wait, then it's more like -0.01, +0.01.  This
    # may not seem important, but it significantly reduces the chances of
    # getting a too low initial $n in the initial, 'find the minimum' loop
    # in &countit.  This, in turn, can reduce the number of calls to
    # &runloop a lot, and thus reduce additive errors.
    my $tbase = Benchmark->new(0)->[1];
    while ( ( $t0 = Benchmark->new(0) )->[1] == $tbase ) {} ;
    $subref->();
    $t1 = Benchmark->new($n);
    $td = &timediff($t1, $t0);
    timedebug("runloop:",$td);
    $td;
}

sub timethis{
    my($n, $code, $title, $style) = @_;
    my($t, $forn);

    die usage unless defined $code and
                     (!ref $code or ref $code eq 'CODE');

    local $ProgressTitle = $title;
    if ( $n > 0 ) {
	croak "non-integer loopcount $n, stopped" if int($n)<$n;
	$t = timeit($n, $code);
	$title = "timethis $n" unless defined $title;
    } else {
	my $fort  = n_to_for( $n );
	$t     = countit( $fort, $code );
	$title = "timethis for $fort" unless defined $title;
	$forn  = $t->[-1];
    }
    local $| = 1;
    $style = "" unless defined $style;
    printf("%10s: ", $title) unless $style eq 'none';
    print timestr($t, $style, $Benchmark::Default_Format),"\n" unless $style eq 'none';

    $n = $forn if defined $forn;

    # A conservative warning to spot very silly tests.
    # Don't assume that your benchmark is ok simply because
    # you don't get this warning!
    print "            (warning: too few iterations for a reliable count)\n"
	if     $n < $Benchmark::Min_Count
	    || ($t->real < 1 && $n < 1000)
	    || $t->cpu_a < $Benchmark::Min_CPU;
    $t;
}



1;

__END__