benchmark.pl

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