Commit | Line | Data |
421104c9 |
1 | use strictures 1; |
2 | |
3 | use Benchmark qw/:hireswallclock cmpthese/; |
4 | use Getopt::Long::Descriptive; |
5 | |
6 | use Config; |
7 | $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); |
8 | |
9 | |
10 | my ($opts, $usage); |
11 | BEGIN { |
12 | ($opts, $usage) = describe_options( |
13 | '%c: %o' => |
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/] }, |
19 | ); |
20 | |
421104c9 |
21 | my @missing; |
22 | for (qw/ |
23 | Moose |
24 | Moo |
25 | Mouse |
47402ac5 |
26 | Mousse |
642c5e75 |
27 | Class::XSAccessor |
421104c9 |
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 shut-off to work |
39 | |
40 | $usage->die if $opts->{help}; |
41 | |
42 | my $attrs_to_bench = { |
43 | plain => q|is => 'rw' |, |
2c40fd5a |
44 | ro => q|is => 'ro' |, |
45 | default => q|is => 'rw', default => sub { {} } |, |
421104c9 |
46 | lazy_default => q|is => 'rw', lazy => 1, default => sub { {} } |, |
47 | lazy_default_qsub => q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |, |
48 | }; |
49 | |
50 | my $class_types; |
51 | |
52 | if ($opts->{bench} =~ /all|pp/) { |
53 | { |
54 | local $Method::Generate::Accessor::CAN_HAZ_XS = 0; |
55 | _add_moosey_has (moo => 'Moo'); |
56 | } |
57 | |
58 | _add_moosey_has (moose => 'Moose'); |
47402ac5 |
59 | _add_moosey_has (mouse => 'Mousse') |
421104c9 |
60 | } |
61 | |
62 | if ($opts->{bench} =~ /all|xs/) { |
642c5e75 |
63 | if (! $Method::Generate::Accessor::CAN_HAZ_XS) |
421104c9 |
64 | { |
642c5e75 |
65 | die "Requested XS benchmarks but XS isn't available in Method::Generate::Accessor"; |
421104c9 |
66 | } |
642c5e75 |
67 | |
68 | _add_moosey_has (moo_XS => 'Moo'); |
421104c9 |
69 | _add_moosey_has (mouse_XS => 'Mouse') |
421104c9 |
70 | } |
71 | |
72 | |
73 | # Actual Benchmarking |
74 | for (1, 2) { |
75 | print "Perl $], take $_:\n"; |
76 | |
77 | my $objects; |
78 | |
80080483 |
79 | for my $use_attrs (0, 1) { |
80 | for my $attr (keys %$attrs_to_bench) { |
81 | printf "\n\nBenching %s ( %s )\n====================\n", |
82 | $attr, |
83 | $use_attrs |
84 | ? ($opts->{reuse} ? '' : 'new() and ' ) . 'get/set/get cycle' |
85 | : 'new() only' |
86 | , |
87 | ; |
88 | |
89 | cmpthese ( -1, { map { |
90 | my $type = $_; |
91 | "${type}->$attr" => sub { |
92 | $objects->{$type} = $class_types->{$type}->new |
93 | unless ( $use_attrs && $opts->{reuse} ); |
94 | |
95 | for (1 .. $opts->{iterations} ) { |
96 | my $init = $objects->{$type}->$attr; |
97 | $objects->{$type}->$attr('foo') unless $attr eq 'ro'; |
98 | my $set = $objects->{$type}->$attr; |
99 | } |
100 | }; |
101 | } keys %$class_types } ); |
421104c9 |
102 | } |
421104c9 |
103 | } |
104 | } |
105 | |
106 | exit 0; # the end |
107 | |
108 | sub _add_moosey_has { |
109 | my ($name, $base) = @_; |
110 | |
111 | my $class = "Bench::${name}"; |
112 | |
113 | my $perl = "package $class; use $base;"; |
114 | |
115 | for my $attr (keys %$attrs_to_bench) { |
116 | $perl .= "has $attr => ($attrs_to_bench->{$attr});"; |
117 | |
118 | $class_types->{$name} = $class; |
119 | } |
120 | |
121 | $perl .= 'eval { __PACKAGE__->meta->make_immutable };'; |
122 | |
123 | eval $perl; |
124 | die $@ if $@; |
125 | } |