benchmark/object_factory

   1 use strictures 1;
   2
   3 use Benchmark qw/:hireswallclock cmpthese/;
   4 use Getopt::Long::Descriptive;
   5
   6 use Config;
   7 $ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
   8
   9
  10 my ($opts, $usage);
  11 BEGIN {
  12   ($opts, $usage) = describe_options(
  13     '%c: %o' =>
  14     [ 'help|h'          => 'Print usage message and exit' ],
  15     [ 'bench|b:s'       => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ],
  16     [ 'iterations|i:i'  => 'How many iterations in each bench run (def 1000)', { default => 1000 } ],
  17     [ 'reuse|r'         => 'Reuse the object between benchmark runs' ],
  18     { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] },
  19   );
  20
  21   # can not change this runtime, thus in-block
  22   $ENV{MOUSE_PUREPERL} = 1 if $opts->{bench} eq 'pp';
  23
  24   my @missing;
  25   for (qw/
  26     Moose
  27     Moo
  28     Mouse
  29   /) {
  30     eval "require $_" or push @missing, $_;
  31   }
  32
  33   if (@missing) {
  34     die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
  35       join ("\n", @missing);
  36   }
  37 }
  38
  39 use Method::Generate::Accessor; # need to pre-load for the XS shut-off to work
  40
  41 $usage->die if $opts->{help};
  42
  43 my $attrs_to_bench = {
  44   plain =>              q|is => 'rw'                                                      |,
  45   lazy_default =>       q|is => 'rw', lazy => 1, default => sub { {} }                    |,
  46   lazy_default_qsub =>  q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |,
  47 };
  48
  49 my $class_types;
  50
  51 if ($opts->{bench} =~ /all|pp/) {
  52   {
  53     local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
  54     _add_moosey_has (moo => 'Moo');
  55   }
  56
  57   _add_moosey_has (moose => 'Moose');
  58   _add_moosey_has (mouse => 'Mouse')
  59     if $ENV{MOUSE_PUREPERL};
  60 }
  61
  62 if ($opts->{bench} =~ /all|xs/) {
  63   {
  64     local $Method::Generate::Accessor::CAN_HAZ_XS = 1;
  65     _add_moosey_has (moo_XS => 'Moo');
  66   }
  67   _add_moosey_has (mouse_XS => 'Mouse')
  68     unless $ENV{MOUSE_PUREPERL};
  69 }
  70
  71
  72 # Actual Benchmarking
  73 for (1, 2) {
  74   print "Perl $], take $_:\n";
  75
  76   my $objects;
  77
  78   print "\n\nBenching new()\n====================\n";
  79
  80   cmpthese ( -1, { map {
  81     my $type = $_;
  82     "${type}->new" => sub {
  83       $objects->{$type} = $class_types->{$type}->new
  84         for (1 .. $opts->{iterations});
  85     }
  86   } keys %$class_types } );
  87
  88   for my $attr (keys %$attrs_to_bench) {
  89     print "\n\nBenching $attr\n====================\n";
  90
  91     cmpthese ( -1, { map {
  92       my $type = $_;
  93       "${type}->$attr" => sub {
  94         $objects->{$type} = $class_types->{$type}->new
  95           unless $opts->{reuse};
  96
  97         for (1 .. $opts->{iterations} ) {
  98           my $init = $objects->{$type}->$attr;
  99           $objects->{$type}->$attr('foo');
 100           my $set = $objects->{$type}->$attr;
 101         }
 102       }
 103     } keys %$objects } );
 104   }
 105 }
 106
 107 exit 0; # the end
 108
 109 sub _add_moosey_has {
 110   my ($name, $base) = @_;
 111
 112   my $class = "Bench::${name}";
 113
 114   my $perl = "package $class; use $base;";
 115
 116   for my $attr (keys %$attrs_to_bench) {
 117     $perl .= "has $attr => ($attrs_to_bench->{$attr});";
 118
 119     $class_types->{$name} = $class;
 120   }
 121
 122   $perl .= 'eval { __PACKAGE__->meta->make_immutable };';
 123
 124   eval $perl;
 125   die $@ if $@;
 126 }