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   my @missing;
  22   for (qw/
  23     Moose
  24     Moo
  25     Mouse
  26     Mousse
  27     Class::XSAccessor
  28   /) {
  29     eval "require $_" or push @missing, $_;
  30   }
  31
  32   if (@missing) {
  33     die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
  34       join ("\n", @missing);
  35   }
  36 }
  37
  38 use Method::Generate::Accessor; # need to pre-load for the XS shut-off to work
  39
  40 $usage->die if $opts->{help};
  41
  42 my $attrs_to_bench = {
  43   plain =>              q|is => 'rw'                                                      |,
  44   ro =>                 q|is => 'ro'                                                      |,
  45   default =>            q|is => 'rw', default => sub { {} }                               |,
  46   lazy_default =>       q|is => 'rw', lazy => 1, default => sub { {} }                    |,
  47   lazy_default_qsub =>  q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |,
  48 };
  49
  50 my $class_types;
  51
  52 if ($opts->{bench} =~ /all|pp/) {
  53   {
  54     local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
  55     _add_moosey_has (moo => 'Moo');
  56   }
  57
  58   _add_moosey_has (moose => 'Moose');
  59   _add_moosey_has (mouse => 'Mousse')
  60 }
  61
  62 if ($opts->{bench} =~ /all|xs/) {
  63   if (! $Method::Generate::Accessor::CAN_HAZ_XS)
  64   {
  65     die "Requested XS benchmarks but XS isn't available in Method::Generate::Accessor";
  66   }
  67
  68   _add_moosey_has (moo_XS => 'Moo');
  69   _add_moosey_has (mouse_XS => 'Mouse')
  70 }
  71
  72
  73 # Actual Benchmarking
  74 for (1, 2) {
  75   print "Perl $], take $_:\n";
  76
  77   my $objects;
  78
  79   for my $use_attrs (0, 1) {
  80     for my $attr (keys %$attrs_to_bench) {
  81       printf "\n\nBenching %s ( %s )\n====================\n",
  82         $attr,
  83         $use_attrs
  84           ? ($opts->{reuse} ? '' : 'new() and ' ) . 'get/set/get cycle'
  85           : 'new() only'
  86         ,
  87       ;
  88
  89       cmpthese ( -1, { map {
  90         my $type = $_;
  91         "${type}->$attr" => sub {
  92           $objects->{$type} = $class_types->{$type}->new
  93             unless ( $use_attrs && $opts->{reuse} );
  94
  95           for (1 .. $opts->{iterations} ) {
  96             my $init = $objects->{$type}->$attr;
  97             $objects->{$type}->$attr('foo') unless $attr eq 'ro';
  98             my $set = $objects->{$type}->$attr;
  99           }
 100         };
 101       } keys %$class_types } );
 102     }
 103   }
 104 }
 105
 106 exit 0; # the end
 107
 108 sub _add_moosey_has {
 109   my ($name, $base) = @_;
 110
 111   my $class = "Bench::${name}";
 112
 113   my $perl = "package $class; use $base;";
 114
 115   for my $attr (keys %$attrs_to_bench) {
 116     $perl .= "has $attr => ($attrs_to_bench->{$attr});";
 117
 118     $class_types->{$name} = $class;
 119   }
 120
 121   $perl .= 'eval { __PACKAGE__->meta->make_immutable };';
 122
 123   eval $perl;
 124   die $@ if $@;
 125 }