3 use Benchmark qw/:hireswallclock cmpthese/;
4 use Getopt::Long::Descriptive;
7 $ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
12 ($opts, $usage) = describe_options(
14 [ 'help|h' => 'Print usage message and exit' ],
15 [ 'bench|b:s' => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ],
16 [ 'iterations|i:i' => 'How many iterations in each bench run (def 1000)', { default => 1000 } ],
17 [ 'reuse|r' => 'Reuse the object between benchmark runs' ],
18 { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] },
29 eval "require $_" or push @missing, $_;
33 die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
34 join ("\n", @missing);
38 use Method::Generate::Accessor; # need to pre-load for the XS shut-off to work
40 $usage->die if $opts->{help};
42 my $attrs_to_bench = {
43 plain => q|is => 'rw' |,
44 lazy_default => q|is => 'rw', lazy => 1, default => sub { {} } |,
45 lazy_default_qsub => q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |,
50 if ($opts->{bench} =~ /all|pp/) {
52 local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
53 _add_moosey_has (moo => 'Moo');
56 _add_moosey_has (moose => 'Moose');
57 _add_moosey_has (mouse => 'Mousse')
60 if ($opts->{bench} =~ /all|xs/) {
61 if (! $Method::Generate::Accessor::CAN_HAZ_XS)
63 die "Requested XS benchmarks but XS isn't available in Method::Generate::Accessor";
66 _add_moosey_has (moo_XS => 'Moo');
67 _add_moosey_has (mouse_XS => 'Mouse')
73 print "Perl $], take $_:\n";
77 print "\n\nBenching new()\n====================\n";
79 cmpthese ( -1, { map {
81 "${type}->new" => sub {
82 $objects->{$type} = $class_types->{$type}->new
83 for (1 .. $opts->{iterations});
85 } keys %$class_types } );
87 for my $attr (keys %$attrs_to_bench) {
88 print "\n\nBenching $attr\n====================\n";
90 cmpthese ( -1, { map {
92 "${type}->$attr" => sub {
93 $objects->{$type} = $class_types->{$type}->new
94 unless $opts->{reuse};
96 for (1 .. $opts->{iterations} ) {
97 my $init = $objects->{$type}->$attr;
98 $objects->{$type}->$attr('foo');
99 my $set = $objects->{$type}->$attr;
102 } keys %$objects } );
108 sub _add_moosey_has {
109 my ($name, $base) = @_;
111 my $class = "Bench::${name}";
113 my $perl = "package $class; use $base;";
115 for my $attr (keys %$attrs_to_bench) {
116 $perl .= "has $attr => ($attrs_to_bench->{$attr});";
118 $class_types->{$name} = $class;
121 $perl .= 'eval { __PACKAGE__->meta->make_immutable };';