benchmark/object_factory

   1 use strictures 1;
   2
   3 use Benchmark qw/:hireswallclock cmpthese/;
   4 use Getopt::Long::Descriptive;
   5
   6 use Config;
   7
   8 my $attrs_to_bench = {
   9   plain =>              q|is => 'rw'                                                      |,
  10   ro =>                 q|is => 'ro'                                                      |,
  11   default =>            q|is => 'rw', default => sub { {} }                               |,
  12   lazy_default =>       q|is => 'rw', lazy => 1, default => sub { {} }                    |,
  13   lazy_default_qsub =>  q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |,
  14 };
  15
  16 my $cycles = {
  17   1 => 'get',
  18   2 => 'get/set/get',
  19 };
  20
  21 my ($opts, $usage) = describe_options(
  22   '%c: %o' =>
  23   [ 'help|h'          => 'Print usage message and exit' ],
  24   [ 'bench|b:s'       => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ],
  25   [ 'lib|l:s@'        => 'Bench against specific lib(s), runs same benches against multiple targets, excluding non-moo benches' ],
  26   [ 'attr|a:s@'       => 'Which attributes to benchmark (must be defined in-file)' ],
  27   [ 'cycle|c:i'       => 'Which cycle to run 1 - get, 2 - get/set/get (def 1)', { default => 1 } ],
  28   [ 'iterations|i:i'  => 'How many iterations in each bench run (def 1000)', { default => 1000 } ],
  29   [ 'totalruns|total|t:i' => 'How many times to rerun the whole benchmark (def 1)', { default => 1 } ],
  30   [ 'reuse|r'         => 'Reuse the object between attribute usage runs' ],
  31   { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] },
  32 );
  33
  34 $usage->die if $opts->{help};
  35
  36 if ($opts->{attr}) {
  37   my %to_bench = map { $_ => 1 } map { split /\s*,\s*/, $_ } @{$opts->{attr}};
  38
  39   for (keys %to_bench) {
  40     die "No such attr '$_'\n" unless $attrs_to_bench->{$_};
  41   }
  42
  43   for (keys %$attrs_to_bench) {
  44     delete $attrs_to_bench->{$_} unless $to_bench{$_};
  45   }
  46 }
  47
  48 my @libs = map { split /\s*:\s*/, $_ } @{$opts->{lib}}
  49   if ($opts->{lib});
  50
  51 if (@libs) {
  52   my $myself = $$;
  53
  54   for my $lib (@libs) {
  55     $ENV{PERL5LIB} = join ($Config{path_sep}, $lib, @INC);
  56
  57     my $pid = fork();
  58     die "Unable to fork: $!" unless defined $pid;
  59
  60     if ($pid) {
  61       wait;
  62     }
  63     else {
  64       print "Benchmarking with $lib\n";
  65       last;
  66     }
  67   }
  68
  69   exit 0 if $$ == $myself;
  70 }
  71
  72 require Method::Generate::Accessor; # need to pre-load for the XS shut-off to work
  73
  74 my $class_types;
  75
  76 if ($opts->{bench} =~ /all|pp/) {
  77   {
  78     local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
  79     _add_moosey_has (moo => 'Moo');
  80   }
  81
  82   _add_moosey_has (moose => 'Moose') unless @libs;
  83   _add_moosey_has (mouse => 'Mousse') unless @libs;
  84 }
  85
  86 if ($opts->{bench} =~ /all|xs/) {
  87   if (! $Method::Generate::Accessor::CAN_HAZ_XS)
  88   {
  89     die "Requested XS benchmarks but XS isn't available in Method::Generate::Accessor";
  90   }
  91
  92   _add_moosey_has (moo_XS => 'Moo');
  93   _add_moosey_has (mouse_XS => 'Mouse') unless @libs;
  94 }
  95
  96
  97 # Actual Benchmarking
  98 for (1 .. $opts->{totalruns} ) {
  99   print "Perl $], take $_:\n";
 100
 101   my $objects;
 102
 103   for my $use_attrs (0, 1) {
 104     for my $attr (keys %$attrs_to_bench) {
 105       printf "\n\nBenching %s ( %s )\n====================\n",
 106         $attr,
 107         $use_attrs
 108           ? sprintf '%s%s cycle', ($opts->{reuse} ? '' : 'new() and ' ), $cycles->{$opts->{cycle}}
 109           : 'new() only'
 110         ,
 111       ;
 112
 113       cmpthese ( -1, { map {
 114         my $type = $_;
 115         "${type}->$attr" => sub {
 116           $objects->{$type} = $class_types->{$type}->new
 117             unless ( $use_attrs && $opts->{reuse} );
 118
 119           for (1 .. $opts->{iterations} ) {
 120             if ($opts->{cycle} == 1) {
 121               my $init = $objects->{$type}->$attr;
 122             }
 123             elsif ($opts->{cycle} == 2) {
 124               my $init = $objects->{$type}->$attr;
 125               $objects->{$type}->$attr('foo') unless $attr eq 'ro';
 126               my $set = $objects->{$type}->$attr;
 127             }
 128           }
 129         };
 130       } keys %$class_types } );
 131     }
 132   }
 133
 134   print "\n\n\n";
 135 }
 136
 137 exit 0; # the end
 138
 139 sub _add_moosey_has {
 140   my ($name, $base) = @_;
 141
 142   my $class = "Bench::${name}";
 143
 144   my $perl = "package $class; use $base;";
 145
 146   for my $attr (keys %$attrs_to_bench) {
 147     $perl .= "has $attr => ($attrs_to_bench->{$attr});";
 148
 149     $class_types->{$name} = $class;
 150   }
 151
 152   $perl .= 'eval { __PACKAGE__->meta->make_immutable };';
 153
 154   eval $perl;
 155   die $@ if $@;
 156 }