benchmark/accessors

   1 use strictures 1;
   2
   3 BEGIN {
   4   my @missing;
   5   for (qw/
   6     Class::Accessor::Grouped
   7     Class::XSAccessor
   8     Class::Accessor::Fast
   9     Class::Accessor::Fast::XS
  10     Class::XSAccessor::Compat
  11     Moose
  12     Mouse
  13     Mousse
  14     Moo
  15   /) {
  16     eval "require $_" or push @missing, $_;
  17   }
  18
  19   if (@missing) {
  20     die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
  21       join ("\n", @missing);
  22   }
  23 }
  24
  25
  26 use Benchmark qw/:hireswallclock cmpthese/;
  27
  28 {
  29   package Bench::Accessor;
  30
  31   use strictures 1;
  32
  33   our @ISA;
  34
  35   use base qw/Class::Accessor::Grouped Class::Accessor::Fast/;
  36   use Class::XSAccessor { accessors => [ 'xsa' ] };
  37
  38   {
  39     local $Class::Accessor::Grouped::USE_XS = 0;
  40     __PACKAGE__->mk_group_accessors ('simple', 'cag');
  41   }
  42   {
  43     local $Class::Accessor::Grouped::USE_XS = 1;
  44     __PACKAGE__->mk_group_accessors ('simple', 'cag_xs');
  45   }
  46
  47   __PACKAGE__->mk_group_accessors ('inherited', 'cag_inh');
  48   __PACKAGE__->cag_inh('initial value');
  49
  50   __PACKAGE__->mk_accessors('caf');
  51
  52   {
  53     require Class::Accessor::Fast::XS;
  54     local @ISA = 'Class::Accessor::Fast::XS';
  55     __PACKAGE__->mk_accessors ('caf_xs');
  56   }
  57
  58   {
  59     require Class::XSAccessor::Compat;
  60     local @ISA = 'Class::XSAccessor::Compat';
  61     __PACKAGE__->mk_accessors ('caf_xsa');
  62   }
  63
  64   sub handmade {
  65     @_ > 1 ? $_[0]->{handmade} = $_[1] : $_[0]->{handmade};
  66   }
  67
  68 }
  69 my $bench_objs = {
  70   base => bless ({}, 'Bench::Accessor')
  71 };
  72
  73 sub _add_moose_task {
  74   my ($tasks, $name, $class) = @_;
  75   my $meth = lc($name);
  76
  77   my $gen_class = "Bench::Accessor::$class";
  78   eval <<"EOC";
  79 package $gen_class;
  80 use $class;
  81 has $meth => (is => 'rw');
  82 # some moosey thingies can not do this
  83 eval { __PACKAGE__->meta->make_immutable };
  84 EOC
  85
  86   $bench_objs->{$name} = $gen_class->new;
  87   _add_task ($tasks, $name, $meth, $name);
  88 }
  89
  90 sub _add_task {
  91   my ($tasks, $name, $meth, $slot) = @_;
  92
  93   # we precompile the desired amount of loops so that the loop itself
  94   # does not get in the way with some sort of optimization or whatnot
  95
  96   my $perl;
  97   for (1 .. 1000) {
  98     $perl .= "
  99       \$::init_val = \$bench_objs->{$slot}->$meth;
 100       \$bench_objs->{$slot}->$meth($_);
 101       \$bench_objs->{$slot}->$meth(\$bench_objs->{$slot}->$meth + $_);
 102     ";
 103   }
 104
 105   $tasks->{$name} = eval "sub { $perl } " or die $@;
 106 }
 107
 108 my $tasks = {
 109 #  'direct' => sub {
 110 #    $bench_objs->{base}{direct} = 1;
 111 #    $bench_objs->{base}{direct} = $bench_objs->{base}{direct} + 1;
 112 #  }
 113 };
 114
 115 for (qw/CAG CAG_XS CAG_INH CAF CAF_XS CAF_XSA XSA HANDMADE/) {
 116   _add_task ($tasks, $_, lc($_), 'base');
 117 }
 118
 119 my $moose_based = {
 120   moOse => 'Moose',
 121   moo_XS => 'Moo',
 122   moUse_XS => 'Mouse',
 123   moUse => 'Mousse',
 124 };
 125 for (keys %$moose_based) {
 126   _add_moose_task ($tasks, $_, $moose_based->{$_})
 127 }
 128
 129 {
 130   no warnings 'once';
 131   local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
 132   _add_moose_task ($tasks, moo => 'Moo');
 133 }
 134
 135 for (1 .. 5) {
 136   print "Perl $], take $_:\n";
 137   cmpthese ( -1, $tasks );
 138   print "\n";
 139 }