File Coverage

blib/lib/Benchmark/Forking.pm

Criterion	Covered	Total	%
statement	29	31	93.5
branch	5	8	62.5
condition			n/a
subroutine	9	11	81.8
pod	3	4	75.0
total	46	54	85.1

package Benchmark::Forking;

$VERSION = 1.01;

use Benchmark;
require Exporter;

use strict;
use vars qw( $Enabled $RunLoop );

sub import   { enable(); Exporter::export_to_level('Benchmark', 1, @_) }
sub unimport { disable() }

sub enable   { $Enabled = 1 }
sub disable  { $Enabled = 0 }
sub enabled  { ( $#_ > 0 ) ? $Enabled = $_[1] : $Enabled }

# The runloop sub uses a special open() call that causes our process to fork,
# with a filehandle acting as an IO channel from the child back to the parent.
# The child runs the timing loop and prints the values from the Benchmark
# result object to its STDOUT, then it exits, terminating the child process.
# The output from the child appears in the main process' FORK handle, which
# is read, re-blessed to form a proper Benchmark result object, and returned.

sub runloop {
  $Enabled or return &$RunLoop;

  if ( not open( FORK, '-|' ) ) {
    print join "\n", @{ &$RunLoop };
    exit;
  } else {
    my @td = ;
    close( FORK ) or die $!;
    return bless \@td, 'Benchmark';
  }
}

# The BEGIN block captures a reference to the normal Benchmark runloop sub to
# be called by the wrapper, then installs our sub in the original's place.

BEGIN {
  $Enabled = 1;
  $RunLoop = \&Benchmark::runloop;
  no strict 'refs';
  local $^W; # avoid sub redefined warning
  *{'Benchmark::runloop'} = \&runloop;
}

1;

__END__