File Coverage

blib/lib/Benchmark/CSV.pm

Criterion	Covered	Total	%
statement	100	113	88.5
branch	34	54	62.9
condition	3	5	60.0
subroutine	20	20	100.0
pod	5	8	62.5
total	162	200	81.0

use 5.006;    # our
use strict;
use warnings;

package Benchmark::CSV;

our $VERSION = '0.001002';

use Path::Tiny;
use Carp qw( croak carp );
use Time::HiRes qw( gettimeofday tv_interval );
use IO::Handle;
use List::Util qw( shuffle );

# ABSTRACT: Report raw timing results in CSV-style format for advanced processing.

our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY

sub new {
  my ( $self, @rest ) = @_;
  return bless { ref $rest[0] ? %{ $rest[0] } : @rest }, $self;
}

sub output_fh {
  my $nargs = ( my ( $self, $value ) = @_ );
  if ( $nargs >= 2 ) {
    croak 'Cant set output_fh after finalization' if $self->{finalized};
    return ( $self->{output_fh} = $value );
  }
  return $self->{output_fh} if $self->{output_fh};
  if ( not $self->{output} ) {
    return ( $self->{output_fh} = \*STDOUT );
  }
  return ( $self->{output_fh} = Path::Tiny::path( $self->{output} )->openw );
}

sub sample_size {
  my $nargs = ( my ( $self, $value ) = @_ );
  if ( $nargs >= 2 ) {
    croak 'Cant set sample_size after finalization' if $self->{finalized};
    return ( $self->{sample_size} = $value );
  }
  return $self->{sample_size} if defined $self->{sample_size};
  return ( $self->{sample_size} = 1 );
}





sub scale_values {
  my $nargs = ( my ( $self, $value ) = @_ );
  if ( $nargs >= 2 ) {
    croak 'Cant set scale_values after finalization' if $self->{finalized};
    return ( $self->{scale_values} = $value );
  }
  return $self->{scale_values} if exists $self->{scale_values};
  return ( $self->{scale_values} = undef );
}





sub per_second {
  my $nargs = ( my ( $self, $value ) = @_ );
  if ( $nargs >= 2 ) {
    croak 'Cant set per_second after finalization' if $self->{finalized};
    $self->{per_second_values} = $value;
  }
  return $self->{per_second} if exists $self->{per_second};
  return ( $self->{per_second} = undef );
}

sub add_instance {
  my $nargs = ( my ( $self, $name, $method ) = @_ );
  croak 'Too few arguments to ->add_instance( name => sub { })' if $nargs < 3;
  croak 'Cant add instances after execution/finalization' if $self->{finalized};
  $self->{instances} ||= {};
  croak "Cant add instance $name more than once" if exists $self->{instances}->{$name};
  $self->{instances}->{$name} = $method;
  return;
}

# These are hard to use as a default due to linux things.
my $hires_gettime_methods = {
  ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars);

  'hires_cputime_process' => {

    # bits/time.h
    # CLOCK_PROCESS_CPUTIME_ID = 2
    start => q[my $start = Time::HiRes::clock_gettime(2)],
    stop  => q[my $stop  = Time::HiRes::clock_gettime(2)],
    diff  => q[ ( $stop - $start )],
  },
  'hires_cputime_thread' => {

    # bits/time.h
    # CLOCK_THREAD_CPUTIME_ID = 3
    start => q[my $start = Time::HiRes::clock_gettime(3)],
    stop  => q[my $stop  = Time::HiRes::clock_gettime(3)],
    diff  => q[ ( $stop - $start )],
  },
};
my $timing_methods = {
  ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars);
  'hires_wall' => {
    start => q[my $start = [ gettimeofday ]],
    stop  => q[my $stop = [ gettimeofday ]],
    diff  => q[tv_interval( $start, [ gettimeofday ])],
  },

  # These are all bad because they're very imprecise :(
  'times' => {
    start => q[my (@start) = times],
    stop  => q[my (@stop)  = times],
    diff  => q[ ( $stop[0]+$stop[1] ) - ( $start[0]+$start[1] ) ],
  },
  'times_user' => {
    start => q[my (@start) = times],
    stop  => q[my (@stop)  = times],
    diff  => q[ ( $stop[0] - $start[0] ) ],
  },
  'times_system' => {
    start => q[my (@start) = times],
    stop  => q[my (@stop)  = times],
    diff  => q[ ( $stop[1] - $start[1] ) ],
  },
};
if ( Time::HiRes->can('clock_gettime') ) {
  $timing_methods = { %{$timing_methods}, %{$hires_gettime_methods} };
}





sub timing_method {
  my $nargs = ( my ( $self, $method ) = @_ );
  if ( $nargs >= 2 ) {
    croak 'Cant add instances after execution/finalization' if $self->{finalized};
    if ( not exists $timing_methods->{$method} ) {
      croak "No such timing method $method";
    }
    return ( $self->{timing_method} = $method );
  }
  return $self->{timing_method} if $self->{timing_method};
  return ( $self->{timing_method} = 'hires_wall' );
}

sub _timing_method {
  my ($self) = @_;
  return $timing_methods->{ $self->timing_method };
}

sub _compile_timer {
  ## no critic (Variables::ProhibitUnusedVarsStricter)
  my ( $self, $name, $code, $sample_size ) = @_;
  ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars);
  my $run_one = q[ $code->(); ];
  my $run_batch = join qq[\n], map { $run_one } 1 .. $sample_size;
  my ( $starter, $stopper, $diff ) = map { $self->_timing_method->{$_} } qw( start stop diff );
  my $sub;
  if ( $self->per_second and $self->scale_values ) {
    $diff = "( ( $diff > 0 ) ? (( 1 / $diff ) * $sample_size ) : 0 )";
  }
  elsif ( $self->per_second ) {
    $diff = "( ( $diff > 0  ) ? ( 1 / $diff ) : 0 )";
  }
  elsif ( $self->scale_values ) {
    $diff = "( $diff /  $sample_size )";
  }

  my $build_sub = <<"EOF";
  \$sub = sub {
    $starter;
    $run_batch;
    $stopper;
    return ( \$name, sprintf '%f', ( $diff ));
  };
  1
EOF
  local $@ = undef;
  ## no critic (BuiltinFunctions::ProhibitStringyEval, Lax::ProhibitStringyEval::ExceptForRequire)
  if ( not eval $build_sub ) {
    carp $build_sub;
    croak $@;
  }
  return $sub;
}

sub _write_header {
  my ($self) = @_;
  return if $self->{headers_written};
  $self->output_fh->printf( "%s\n", join q[,], sort keys %{ $self->{instances} } );
  $self->{headers_written} = 1;
  $self->{finalized}       = 1;
  return;
}

sub _write_result {
  my ( $self, $result ) = @_;
  $self->output_fh->printf( "%s\n", join q[,], map { $result->{$_} } sort keys %{$result} );
  return;
}

sub run_iterations {
  my $nargs = ( my ( $self, $count ) = @_ );
  croak 'Arguments missing to ->run_iterations( num )' if $nargs < 2;
  $self->_write_header;
  my $sample_size = $self->sample_size;
  my $timers      = {};
  for my $instance ( keys %{ $self->{instances} } ) {
    $timers->{$instance} = $self->_compile_timer( $instance, $self->{instances}->{$instance}, $sample_size );
  }
  my @timer_names = keys %{$timers};
  for ( 1 .. ( $count / $sample_size ) ) {
    $self->_write_result( +{ map { $timers->{$_}->() } shuffle @timer_names } );
  }
  $self->output_fh->flush;
  return;
}

1;

__END__