benchmark/class_factory

   1 use strictures 1;
   2
   3 use Benchmark qw/:hireswallclock cmpthese/;
   4 use Getopt::Long::Descriptive;
   5
   6
   7 my ($opts, $usage);
   8 BEGIN {
   9   ($opts, $usage) = describe_options(
  10     '%c: %o' =>
  11     [ 'help|h'          => 'Print usage message and exit' ],
  12     [ 'classes|c:i'     => 'How many classes to create per benchmark cycle (def 10)', { default => 10 } ],
  13     [ 'accessors|a:i'   => 'How many accessors to create per class (def 100)', { default => 100 } ],
  14     [ 'pregenerate|p:i' => 'For how many maximum benchmark cycles should we prepare (def 1000)', { default => 1000 } ],
  15     [ 'unique|u'        => 'Make accessor names globally unique (instead of just per class)' ],
  16     [ 'bench|b:s'       => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ],
  17     { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] },
  18   );
  19
  20   # can not change this runtime, thus in-block
  21   $ENV{MOUSE_PUREPERL} = 1 if $opts->{bench} eq 'pp';
  22
  23   my @missing;
  24   for (qw/
  25     Moose
  26     Moo
  27     Mouse
  28   /) {
  29     eval "require $_" or push @missing, $_;
  30   }
  31
  32   if (@missing) {
  33     die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
  34       join ("\n", @missing);
  35   }
  36 }
  37
  38 use Method::Generate::Accessor; # need to pre-load for the XS shutoff to work
  39
  40 $usage->die if $opts->{help};
  41
  42 my $counters;
  43 my $tasks = {};
  44
  45 if ($opts->{bench} =~ /all|pp/) {
  46   {
  47     local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
  48     _add_moosey_has (moo => 'Moo');
  49   }
  50
  51   _add_moosey_has (moose => 'Moose');
  52   _add_moosey_has (mouse => 'Mouse')
  53     if $ENV{MOUSE_PUREPERL};
  54 }
  55
  56 if ($opts->{bench} =~ /all|xs/) {
  57   {
  58     local $Method::Generate::Accessor::CAN_HAZ_XS = 1;
  59     _add_moosey_has (moo_XS => 'Moo');
  60   }
  61   _add_moosey_has (mouse_XS => 'Mouse')
  62     unless $ENV{MOUSE_PUREPERL};
  63 }
  64
  65 # run each task once, prime whatever caches there may be
  66 $_->() for values %$tasks;
  67
  68 # Actual Benchmarking
  69 for (1, 2) {
  70   print "Perl $], take $_:\n";
  71   cmpthese ( -1, $tasks );
  72   print "\n";
  73 }
  74
  75 exit 0; # the end
  76
  77 sub _add_moosey_has {
  78   my ($name, $base) = @_;
  79
  80   my @for_eval;
  81
  82   # need to pre-gen stuff so that the class names will differ for every bench run
  83   for (1 .. $opts->{pregenerate}) {
  84     my $perl;
  85     for ( 1.. $opts->{classes} ) {
  86       my $class = "Bench::${base}::" . ++$counters->{class};
  87       $perl .= "package $class; use $base;";
  88       for ( 1.. $opts->{accessors} ) {
  89         my $attr = 'attribute_' . ++$counters->{acc};
  90         $perl .= "has $attr => ( is => rw );";
  91       }
  92
  93       $counters->{accessors} = 0
  94         unless $opts->{unique};
  95     }
  96
  97     push @for_eval, $perl;
  98   }
  99
 100   $tasks->{$name} = sub {
 101     my $code = shift @for_eval
 102       or die "Ran out of pre-generated stuff, raise -p\n";
 103     eval $code;
 104   };
 105 }