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   /) {
  14     eval "require $_" or push @missing, $_;
  15   }
  16
  17   if (@missing) {
  18     die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
  19       join ("\n", @missing);
  20   }
  21 }
  22
  23
  24 use Benchmark qw/:hireswallclock cmpthese/;
  25
  26 {
  27   package Bench::Accessor;
  28
  29   use strictures 1;
  30
  31   our @ISA;
  32
  33   use base qw/Class::Accessor::Grouped Class::Accessor::Fast/;
  34   use Class::XSAccessor { accessors => [ 'xsa' ] };
  35
  36   {
  37     local $Class::Accessor::Grouped::USE_XS = 0;
  38     __PACKAGE__->mk_group_accessors ('simple', 'cag');
  39   }
  40   {
  41     local $Class::Accessor::Grouped::USE_XS = 1;
  42     __PACKAGE__->mk_group_accessors ('simple', 'cag_xs');
  43   }
  44   __PACKAGE__->mk_accessors('caf');
  45
  46   {
  47     require Class::Accessor::Fast::XS;
  48     local @ISA = 'Class::Accessor::Fast::XS';
  49     __PACKAGE__->mk_accessors ('caf_xs');
  50   }
  51
  52   {
  53     require Class::XSAccessor::Compat;
  54     local @ISA = 'Class::XSAccessor::Compat';
  55     __PACKAGE__->mk_accessors ('caf_xsa');
  56   }
  57
  58   sub handmade {
  59     @_ > 1 ? $_[0]->{handmade} = $_[1] : $_[0]->{handmade};
  60   }
  61
  62 }
  63 my $bench_objs = {
  64   base => bless ({}, 'Bench::Accessor')
  65 };
  66
  67 sub _add_moose_task {
  68   my ($tasks, $name, $class) = @_;
  69   my $meth = lc($name);
  70
  71   my $gen_class = "Bench::Accessor::$class";
  72   eval <<"EOC";
  73 package $gen_class;
  74 use $class;
  75 has $meth => (is => 'rw');
  76 __PACKAGE__->meta->make_immutable;
  77 EOC
  78
  79   $bench_objs->{$name} = $gen_class->new;
  80   _add_task ($tasks, $name, $meth, $name);
  81 }
  82
  83 sub _add_task {
  84   my ($tasks, $name, $meth, $slot) = @_;
  85
  86   $tasks->{$name} = eval "sub {
  87     for (my \$i = 0; \$i < 100; \$i++) {
  88       \$bench_objs->{$slot}->$meth(1);
  89       \$bench_objs->{$slot}->$meth(\$bench_objs->{$slot}->$meth + 1);
  90     }
  91   }";
  92 }
  93
  94 my $tasks = {
  95 #  'direct' => sub {
  96 #    $bench_objs->{base}{direct} = 1;
  97 #    $bench_objs->{base}{direct} = $bench_objs->{base}{direct} + 1;
  98 #  }
  99 };
 100
 101 for (qw/CAG CAG_XS CAF CAF_XS CAF_XSA XSA HANDMADE/) {
 102   _add_task ($tasks, $_, lc($_), 'base');
 103 }
 104
 105 my $moose_based = {
 106   moOse => 'Moose',
 107   ($ENV{MOUSE_PUREPERL} ? 'moUse' : 'moUse_XS') => 'Mouse',
 108 };
 109 for (keys %$moose_based) {
 110   _add_moose_task ($tasks, $_, $moose_based->{$_})
 111 }
 112
 113
 114 for (1, 2) {
 115   print "Perl $], take $_:\n";
 116   cmpthese ( -1, $tasks );
 117   print "\n";
 118 }