update repo to point to github

[gitmo/Moo.git] / benchmark / object_factory

diff --git a/benchmark/object_factory b/benchmark/object_factory
index dae129d..c539c14 100644 (file)
--- a/benchmark/object_factory
+++ b/benchmark/object_factory
@@ -4,46 +4,72 @@ use Benchmark qw/:hireswallclock cmpthese/;
 use Getopt::Long::Descriptive;
 
 use Config;
-$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
-
-
-my ($opts, $usage);
-BEGIN {
-  ($opts, $usage) = describe_options(
-    '%c: %o' =>
-    [ 'help|h'          => 'Print usage message and exit' ],
-    [ 'bench|b:s'       => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ],
-    [ 'iterations|i:i'  => 'How many iterations in each bench run (def 1000)', { default => 1000 } ],
-    [ 'reuse|r'         => 'Reuse the object between benchmark runs' ],
-    { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] },
-  );
-
-  my @missing;
-  for (qw/
-    Moose
-    Moo
-    Mouse
-    Mousse
-    Class::XSAccessor
-  /) {
-    eval "require $_" or push @missing, $_;
+
+my $attrs_to_bench = {
+  plain =>              q|is => 'rw'                                                      |,
+  ro =>                 q|is => 'ro'                                                      |,
+  default =>            q|is => 'rw', default => sub { {} }                               |,
+  lazy_default =>       q|is => 'rw', lazy => 1, default => sub { {} }                    |,
+  lazy_default_qsub =>  q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |,
+};
+
+my $cycles = {
+  1 => 'get',
+  2 => 'get/set/get',
+};
+
+my ($opts, $usage) = describe_options(
+  '%c: %o' =>
+  [ 'help|h'          => 'Print usage message and exit' ],
+  [ 'bench|b:s'       => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ],
+  [ 'lib|l:s@'        => 'Bench against specific lib(s), runs same benches against multiple targets, excluding non-moo benches' ],
+  [ 'attr|a:s@'       => 'Which attributes to benchmark (must be defined in-file)' ],
+  [ 'cycle|c:i'       => 'Which cycle to run 1 - get, 2 - get/set/get (def 1)', { default => 1 } ],
+  [ 'iterations|i:i'  => 'How many iterations in each bench run (def 1000)', { default => 1000 } ],
+  [ 'totalruns|total|t:i' => 'How many times to rerun the whole benchmark (def 1)', { default => 1 } ],
+  [ 'reuse|r'         => 'Reuse the object between attribute usage runs' ],
+  { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] },
+);
+
+$usage->die if $opts->{help};
+
+if ($opts->{attr}) {
+  my %to_bench = map { $_ => 1 } map { split /\s*,\s*/, $_ } @{$opts->{attr}};
+
+  for (keys %to_bench) {
+    die "No such attr '$_'\n" unless $attrs_to_bench->{$_};
   }
 
-  if (@missing) {
-    die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
-      join ("\n", @missing);
+  for (keys %$attrs_to_bench) {
+    delete $attrs_to_bench->{$_} unless $to_bench{$_};
   }
 }
 
-use Method::Generate::Accessor; # need to pre-load for the XS shut-off to work
+my @libs = map { split /\s*:\s*/, $_ } @{$opts->{lib}}
+  if ($opts->{lib});
 
-$usage->die if $opts->{help};
+if (@libs) {
+  my $myself = $$;
 
-my $attrs_to_bench = {
-  plain =>              q|is => 'rw'                                                      |,
-  lazy_default =>       q|is => 'rw', lazy => 1, default => sub { {} }                    |,
-  lazy_default_qsub =>  q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |,
-};
+  for my $lib (@libs) {
+    $ENV{PERL5LIB} = join ($Config{path_sep}, $lib, @INC);
+
+    my $pid = fork();
+    die "Unable to fork: $!" unless defined $pid;
+
+    if ($pid) {
+      wait;
+    }
+    else {
+      print "Benchmarking with $lib\n";
+      last;
+    }
+  }
+
+  exit 0 if $$ == $myself;
+}
+
+require Method::Generate::Accessor; # need to pre-load for the XS shut-off to work
 
 my $class_types;
 
@@ -53,8 +79,8 @@ if ($opts->{bench} =~ /all|pp/) {
     _add_moosey_has (moo => 'Moo');
   }
 
-  _add_moosey_has (moose => 'Moose');
-  _add_moosey_has (mouse => 'Mousse')
+  _add_moosey_has (moose => 'Moose') unless @libs;
+  _add_moosey_has (mouse => 'Mousse') unless @libs;
 }
 
 if ($opts->{bench} =~ /all|xs/) {
@@ -64,43 +90,48 @@ if ($opts->{bench} =~ /all|xs/) {
   }
 
   _add_moosey_has (moo_XS => 'Moo');
-  _add_moosey_has (mouse_XS => 'Mouse')
+  _add_moosey_has (mouse_XS => 'Mouse') unless @libs;
 }
 
 
 # Actual Benchmarking
-for (1, 2) {
+for (1 .. $opts->{totalruns} ) {
   print "Perl $], take $_:\n";
 
   my $objects;
 
-  print "\n\nBenching new()\n====================\n";
-
-  cmpthese ( -1, { map {
-    my $type = $_;
-    "${type}->new" => sub {
-      $objects->{$type} = $class_types->{$type}->new
-        for (1 .. $opts->{iterations});
+  for my $use_attrs (0, 1) {
+    for my $attr (keys %$attrs_to_bench) {
+      printf "\n\nBenching %s ( %s )\n====================\n",
+        $attr,
+        $use_attrs
+          ? sprintf '%s%s cycle', ($opts->{reuse} ? '' : 'new() and ' ), $cycles->{$opts->{cycle}}
+          : 'new() only'
+        ,
+      ;
+
+      cmpthese ( -1, { map {
+        my $type = $_;
+        "${type}->$attr" => sub {
+          $objects->{$type} = $class_types->{$type}->new
+            unless ( $use_attrs && $opts->{reuse} );
+
+          for (1 .. $opts->{iterations} ) {
+            if ($opts->{cycle} == 1) {
+              my $init = $objects->{$type}->$attr;
+            }
+            elsif ($opts->{cycle} == 2) {
+              my $init = $objects->{$type}->$attr;
+              $objects->{$type}->$attr('foo') unless $attr eq 'ro';
+              my $set = $objects->{$type}->$attr;
+            }
+          }
+        };
+      } keys %$class_types } );
     }
-  } keys %$class_types } );
-
-  for my $attr (keys %$attrs_to_bench) {
-    print "\n\nBenching $attr\n====================\n";
-
-    cmpthese ( -1, { map {
-      my $type = $_;
-      "${type}->$attr" => sub {
-        $objects->{$type} = $class_types->{$type}->new
-          unless $opts->{reuse};
-
-        for (1 .. $opts->{iterations} ) {
-          my $init = $objects->{$type}->$attr;
-          $objects->{$type}->$attr('foo');
-          my $set = $objects->{$type}->$attr;
-        }
-      }
-    } keys %$objects } );
   }
+
+  print "\n\n\n";
 }
 
 exit 0; # the end