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   __PACKAGE__->mk_accessors('caf');
  47
  48   {
  49     require Class::Accessor::Fast::XS;
  50     local @ISA = 'Class::Accessor::Fast::XS';
  51     __PACKAGE__->mk_accessors ('caf_xs');
  52   }
  53
  54   {
  55     require Class::XSAccessor::Compat;
  56     local @ISA = 'Class::XSAccessor::Compat';
  57     __PACKAGE__->mk_accessors ('caf_xsa');
  58   }
  59
  60   sub handmade {
  61     @_ > 1 ? $_[0]->{handmade} = $_[1] : $_[0]->{handmade};
  62   }
  63
  64 }
  65 my $bench_objs = {
  66   base => bless ({}, 'Bench::Accessor')
  67 };
  68
  69 sub _add_moose_task {
  70   my ($tasks, $name, $class) = @_;
  71   my $meth = lc($name);
  72
  73   my $gen_class = "Bench::Accessor::$class";
  74   eval <<"EOC";
  75 package $gen_class;
  76 use $class;
  77 has $meth => (is => 'rw');
  78 # some moosey thingies can not do this
  79 eval { __PACKAGE__->meta->make_immutable };
  80 EOC
  81
  82   $bench_objs->{$name} = $gen_class->new;
  83   _add_task ($tasks, $name, $meth, $name);
  84 }
  85
  86 sub _add_task {
  87   my ($tasks, $name, $meth, $slot) = @_;
  88
  89   my $perl;
  90   for (1 .. 1000) {
  91     $perl .= "
  92       \$bench_objs->{$slot}->$meth($_);
  93       \$bench_objs->{$slot}->$meth(\$bench_objs->{$slot}->$meth + $_);
  94     ";
  95   }
  96
  97   $tasks->{$name} = eval "sub { $perl } ";
  98 }
  99
 100 my $tasks = {
 101 #  'direct' => sub {
 102 #    $bench_objs->{base}{direct} = 1;
 103 #    $bench_objs->{base}{direct} = $bench_objs->{base}{direct} + 1;
 104 #  }
 105 };
 106
 107 for (qw/CAG CAG_XS CAF CAF_XS CAF_XSA XSA HANDMADE/) {
 108   _add_task ($tasks, $_, lc($_), 'base');
 109 }
 110
 111 my $moose_based = {
 112   moOse => 'Moose',
 113   moo_XS => 'Moo',
 114   moUse_XS => 'Mouse',
 115   moUse => 'Mousse',
 116 };
 117 for (keys %$moose_based) {
 118   _add_moose_task ($tasks, $_, $moose_based->{$_})
 119 }
 120
 121 {
 122   no warnings 'once';
 123   local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
 124   _add_moose_task ($tasks, moo => 'Moo');
 125 }
 126
 127 for (1 .. 5) {
 128   print "Perl $], take $_:\n";
 129   cmpthese ( -1, $tasks );
 130   print "\n";
 131 }