Using M::R solved this problem before it was encountered

[p5sagit/Class-Accessor-Grouped.git] / benchmark / accessors

BEGIN {
  my @missing;
  for (qw/
    strictures
    Class::Accessor::Grouped
    Class::XSAccessor
    Class::Accessor::Fast
    Class::Accessor::Fast::XS
    Class::XSAccessor::Compat
    Moose
    Mouse
    Mousse
    Moo
    Dumbbench
  /) {
    eval "require $_" or push @missing, $_;
  }

  if (@missing) {
    die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
      join ("\n", @missing);
  }
}


use strictures 1;
use Benchmark::Dumb ':all';

{
  package Bench::Accessor::GrandParent;
  use strictures 1;

  use base 'Class::Accessor::Grouped';
  __PACKAGE__->mk_group_accessors ('inherited', 'cag_inhp');
  __PACKAGE__->cag_inhp('initial parent value');

  package Bench::Accessor::Parent;
  use strictures 1;
  use base 'Bench::Accessor::GrandParent';

  package Bench::Accessor;

  use strictures 1;

  our @ISA;

  use base qw/Bench::Accessor::Parent Class::Accessor::Grouped Class::Accessor::Fast/;
  use Class::XSAccessor { accessors => [ 'xsa' ] };

  {
    local $Class::Accessor::Grouped::USE_XS = 0;
    __PACKAGE__->mk_group_accessors ('simple', 'cag');
  }
  {
    local $Class::Accessor::Grouped::USE_XS = 1;
    __PACKAGE__->mk_group_accessors ('simple', 'cag_xs');
  }

  __PACKAGE__->mk_group_accessors ('inherited', 'cag_inh');
  __PACKAGE__->cag_inh('initial value');

  __PACKAGE__->mk_accessors('caf');

  {
    require Class::Accessor::Fast::XS;
    local @ISA = 'Class::Accessor::Fast::XS';
    __PACKAGE__->mk_accessors ('caf_xs');
  }

  {
    require Class::XSAccessor::Compat;
    local @ISA = 'Class::XSAccessor::Compat';
    __PACKAGE__->mk_accessors ('caf_xsa');
  }

  sub handmade {
    no warnings;
    no strict;
    @_ > 1 ? $_[0]->{handmade} = $_[1] : $_[0]->{handmade};
  }

}
my $bench_objs = {
  base => bless ({}, 'Bench::Accessor')
};

sub _add_moose_task {
  my ($tasks, $name, $class) = @_;
  my $meth = lc($name);

  my $gen_class = "Bench::Accessor::$class";
  eval <<"EOC";
package $gen_class;
use $class;
has $meth => (is => 'rw');
# some moosey thingies can not do this
eval { __PACKAGE__->meta->make_immutable };
EOC

  $bench_objs->{$name} = $gen_class->new;
  _add_task ($tasks, $name, $meth, $name);
}

sub _add_task {
  my ($tasks, $name, $meth, $slot) = @_;

  # we precompile the desired amount of loops so that the loop itself
  # does not get in the way with some sort of optimization or whatnot

  use Devel::Dwarn;
#  Dwarn { $meth => $bench_objs->{$slot}->can($meth) };

  my $perl;
  for (1 .. 100) {
    $perl .= "
      \$::init_val = \$bench_objs->{$slot}->$meth;
      \$bench_objs->{$slot}->$meth($_);
      \$bench_objs->{$slot}->$meth(\$bench_objs->{$slot}->$meth + $_);
      \$bench_objs->{$slot}->$meth(undef);
    ";
  }

  $tasks->{$name} = eval "sub { use warnings; use strict; $perl } " or die $@;

  # prime things up (have the task run a couple times)
  $tasks->{$name}->() for (1..5);
}

my $tasks = {
#  'direct' => sub {
#    $bench_objs->{base}{direct} = 1;
#    $bench_objs->{base}{direct} = $bench_objs->{base}{direct} + 1;
#  }
};

for (qw/CAG CAG_XS CAG_INH CAG_INHP CAF CAF_XS CAF_XSA XSA HANDMADE/) {
  _add_task ($tasks, $_, lc($_), 'base');
}

my $moose_based = {
  moOse => 'Moose',
  moo_XS => 'Moo',
  moUse_XS => 'Mouse',
  moUse => 'Mousse',
};
for (keys %$moose_based) {
  _add_moose_task ($tasks, $_, $moose_based->{$_})
}

{
  no warnings 'once';
  local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
  _add_moose_task ($tasks, moo => 'Moo');
}

#delete $tasks->{$_} for grep { $_ !~ /CAG/ } keys %$tasks;

for (1 .. 3) {
  print "Perl $], take $_:\n";
#  DB::enable_profile();
  cmpthese ( '50.0001', $tasks );
#  DB::disable_profile();
  print "\n";
}