3 use Benchmark qw/:hireswallclock cmpthese/;
4 use Getopt::Long::Descriptive;
9 plain => q|is => 'rw' |,
11 default => q|is => 'rw', default => sub { {} } |,
12 lazy_default => q|is => 'rw', lazy => 1, default => sub { {} } |,
13 lazy_default_qsub => q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |,
21 my ($opts, $usage) = describe_options(
23 [ 'help|h' => 'Print usage message and exit' ],
24 [ 'bench|b:s' => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ],
25 [ 'lib|l:s@' => 'Bench against specific lib(s), runs same benches against multiple targets, excluding non-moo benches' ],
26 [ 'attr|a:s@' => 'Which attributes to benchmark (must be defined in-file)' ],
27 [ 'cycle|c:i' => 'Which cycle to run 1 - get, 2 - get/set/get (def 1)', { default => 1 } ],
28 [ 'iterations|i:i' => 'How many iterations in each bench run (def 1000)', { default => 1000 } ],
29 [ 'totalruns|total|t:i' => 'How many times to rerun the whole benchmark (def 1)', { default => 1 } ],
30 [ 'reuse|r' => 'Reuse the object between attribute usage runs' ],
31 { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] },
34 $usage->die if $opts->{help};
37 my %to_bench = map { $_ => 1 } map { split /\s*,\s*/, $_ } @{$opts->{attr}};
39 for (keys %to_bench) {
40 die "No such attr '$_'\n" unless $attrs_to_bench->{$_};
43 for (keys %$attrs_to_bench) {
44 delete $attrs_to_bench->{$_} unless $to_bench{$_};
48 my @libs = map { split /\s*:\s*/, $_ } @{$opts->{lib}}
55 $ENV{PERL5LIB} = join ($Config{path_sep}, $lib, @INC);
58 die "Unable to fork: $!" unless defined $pid;
64 print "Benchmarking with $lib\n";
69 exit 0 if $$ == $myself;
72 require Method::Generate::Accessor; # need to pre-load for the XS shut-off to work
76 if ($opts->{bench} =~ /all|pp/) {
78 local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
79 _add_moosey_has (moo => 'Moo');
82 _add_moosey_has (moose => 'Moose') unless @libs;
83 _add_moosey_has (mouse => 'Mousse') unless @libs;
86 if ($opts->{bench} =~ /all|xs/) {
87 if (! $Method::Generate::Accessor::CAN_HAZ_XS)
89 die "Requested XS benchmarks but XS isn't available in Method::Generate::Accessor";
92 _add_moosey_has (moo_XS => 'Moo');
93 _add_moosey_has (mouse_XS => 'Mouse') unless @libs;
98 for (1 .. $opts->{totalruns} ) {
99 print "Perl $], take $_:\n";
103 for my $use_attrs (0, 1) {
104 for my $attr (keys %$attrs_to_bench) {
105 printf "\n\nBenching %s ( %s )\n====================\n",
108 ? sprintf '%s%s cycle', ($opts->{reuse} ? '' : 'new() and ' ), $cycles->{$opts->{cycle}}
113 cmpthese ( -1, { map {
115 "${type}->$attr" => sub {
116 $objects->{$type} = $class_types->{$type}->new
117 unless ( $use_attrs && $opts->{reuse} );
119 for (1 .. $opts->{iterations} ) {
120 if ($opts->{cycle} == 1) {
121 my $init = $objects->{$type}->$attr;
123 elsif ($opts->{cycle} == 2) {
124 my $init = $objects->{$type}->$attr;
125 $objects->{$type}->$attr('foo') unless $attr eq 'ro';
126 my $set = $objects->{$type}->$attr;
130 } keys %$class_types } );
139 sub _add_moosey_has {
140 my ($name, $base) = @_;
142 my $class = "Bench::${name}";
144 my $perl = "package $class; use $base;";
146 for my $attr (keys %$attrs_to_bench) {
147 $perl .= "has $attr => ($attrs_to_bench->{$attr});";
149 $class_types->{$name} = $class;
152 $perl .= 'eval { __PACKAGE__->meta->make_immutable };';