From: Peter Rabbitson <ribasushi@cpan.org>
Date: Wed, 10 Nov 2010 03:00:34 +0000 (+0100)
Subject: Initial benchmark (totally incomplete)
X-Git-Tag: 0.009001~46
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6f8df574ed1cc6bdb40c0ff908d65a2383112526;hp=d245e4714583b34043a5ba8b1c206295c197278b;p=gitmo%2FMoo.git

Initial benchmark (totally incomplete)
---

diff --git a/benchmark/class_factory b/benchmark/class_factory
new file mode 100644
index 0000000..a31724a
--- /dev/null
+++ b/benchmark/class_factory
@@ -0,0 +1,105 @@
+use strictures 1;
+
+use Benchmark qw/:hireswallclock cmpthese/;
+use Getopt::Long::Descriptive;
+
+
+my ($opts, $usage);
+BEGIN {
+  ($opts, $usage) = describe_options(
+    '%c: %o' =>
+    [ 'help|h'          => 'Print usage message and exit' ],
+    [ 'classes|c:i'     => 'How many classes to create per benchmark cycle (def 10)', { default => 10 } ],
+    [ 'accessors|a:i'   => 'How many accessors to create per class (def 100)', { default => 100 } ],
+    [ 'pregenerate|p:i' => 'For how many maximum benchmark cycles should we prepare (def 1000)', { default => 1000 } ],
+    [ 'unique|u'        => 'Make accessor names globally unique (instead of just per class)' ],
+    [ 'bench|b:s'       => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ],
+    { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] },
+  );
+
+  # can not change this runtime, thus in-block
+  $ENV{MOUSE_PUREPERL} = 1 if $opts->{bench} eq 'pp';
+
+  my @missing;
+  for (qw/
+    Moose
+    Moo
+    Mouse
+  /) {
+    eval "require $_" or push @missing, $_;
+  }
+
+  if (@missing) {
+    die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
+      join ("\n", @missing);
+  }
+}
+
+use Method::Generate::Accessor; # need to pre-load for the XS shutoff to work
+
+$usage->die if $opts->{help};
+
+my $counters;
+my $tasks = {};
+
+if ($opts->{bench} =~ /all|pp/) {
+  {
+    local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
+    _add_moosey_has (moo => 'Moo');
+  }
+
+  _add_moosey_has (moose => 'Moose');
+  _add_moosey_has (mouse => 'Mouse')
+    if $ENV{MOUSE_PUREPERL};
+}
+
+if ($opts->{bench} =~ /all|xs/) {
+  {
+    local $Method::Generate::Accessor::CAN_HAZ_XS = 1;
+    _add_moosey_has (moo_XS => 'Moo');
+  }
+  _add_moosey_has (mouse_XS => 'Mouse')
+    unless $ENV{MOUSE_PUREPERL};
+}
+
+# run each task once, prime whatever caches there may be
+$_->() for values %$tasks;
+
+# Actual Benchmarking
+for (1, 2) {
+  print "Perl $], take $_:\n";
+  cmpthese ( -1, $tasks );
+  print "\n";
+}
+
+exit 0; # the end
+
+sub _add_moosey_has {
+  my ($name, $base) = @_;
+
+  my @for_eval;
+
+  # need to pre-gen stuff so that the class names will differ for every bench run
+  for (1 .. $opts->{pregenerate}) {
+    my $perl;
+    for ( 1.. $opts->{classes} ) {
+      my $class = "Bench::${base}::" . ++$counters->{class};
+      $perl .= "package $class; use $base;";
+      for ( 1.. $opts->{accessors} ) {
+        my $attr = 'attribute_' . ++$counters->{acc};
+        $perl .= "has $attr => ( is => rw );";
+      }
+
+      $counters->{accessors} = 0
+        unless $opts->{unique};
+    }
+
+    push @for_eval, $perl;
+  }
+
+  $tasks->{$name} = sub {
+    my $code = shift @for_eval
+      or die "Ran out of pre-generated stuff, raise -p\n";
+    eval $code;
+  };
+}