Commit | Line | Data |
8019c4d8 |
1 | BEGIN { |
2 | my @missing; |
3 | for (qw/ |
396618fc |
4 | strictures |
8019c4d8 |
5 | Class::Accessor::Grouped |
6 | Class::XSAccessor |
7 | Class::Accessor::Fast |
8 | Class::Accessor::Fast::XS |
71eea8e1 |
9 | Class::XSAccessor::Compat |
8019c4d8 |
10 | Moose |
11 | Mouse |
af71d687 |
12 | Mousse |
13 | Moo |
396618fc |
14 | Dumbbench |
8019c4d8 |
15 | /) { |
16 | eval "require $_" or push @missing, $_; |
17 | } |
18 | |
19 | if (@missing) { |
20 | die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n", |
21 | join ("\n", @missing); |
22 | } |
23 | } |
24 | |
25 | |
396618fc |
26 | use strictures 1; |
27 | use Benchmark::Dumb ':all'; |
8019c4d8 |
28 | |
29 | { |
396618fc |
30 | package Bench::Accessor::GrandParent; |
31 | use strictures 1; |
32 | |
33 | use base 'Class::Accessor::Grouped'; |
34 | __PACKAGE__->mk_group_accessors ('inherited', 'cag_inhp'); |
35 | __PACKAGE__->cag_inhp('initial parent value'); |
36 | |
37 | package Bench::Accessor::Parent; |
38 | use strictures 1; |
39 | use base 'Bench::Accessor::GrandParent'; |
40 | |
8019c4d8 |
41 | package Bench::Accessor; |
42 | |
43 | use strictures 1; |
44 | |
45 | our @ISA; |
46 | |
396618fc |
47 | use base qw/Bench::Accessor::Parent Class::Accessor::Grouped Class::Accessor::Fast/; |
8019c4d8 |
48 | use Class::XSAccessor { accessors => [ 'xsa' ] }; |
49 | |
50 | { |
51 | local $Class::Accessor::Grouped::USE_XS = 0; |
52 | __PACKAGE__->mk_group_accessors ('simple', 'cag'); |
53 | } |
54 | { |
55 | local $Class::Accessor::Grouped::USE_XS = 1; |
56 | __PACKAGE__->mk_group_accessors ('simple', 'cag_xs'); |
57 | } |
52e85101 |
58 | |
59 | __PACKAGE__->mk_group_accessors ('inherited', 'cag_inh'); |
60 | __PACKAGE__->cag_inh('initial value'); |
61 | |
8019c4d8 |
62 | __PACKAGE__->mk_accessors('caf'); |
63 | |
64 | { |
65 | require Class::Accessor::Fast::XS; |
66 | local @ISA = 'Class::Accessor::Fast::XS'; |
67 | __PACKAGE__->mk_accessors ('caf_xs'); |
68 | } |
69 | |
71eea8e1 |
70 | { |
71 | require Class::XSAccessor::Compat; |
72 | local @ISA = 'Class::XSAccessor::Compat'; |
73 | __PACKAGE__->mk_accessors ('caf_xsa'); |
74 | } |
75 | |
8019c4d8 |
76 | sub handmade { |
396618fc |
77 | no warnings; |
78 | no strict; |
8019c4d8 |
79 | @_ > 1 ? $_[0]->{handmade} = $_[1] : $_[0]->{handmade}; |
80 | } |
81 | |
82 | } |
83 | my $bench_objs = { |
84 | base => bless ({}, 'Bench::Accessor') |
85 | }; |
86 | |
87 | sub _add_moose_task { |
88 | my ($tasks, $name, $class) = @_; |
89 | my $meth = lc($name); |
90 | |
91 | my $gen_class = "Bench::Accessor::$class"; |
92 | eval <<"EOC"; |
93 | package $gen_class; |
94 | use $class; |
95 | has $meth => (is => 'rw'); |
af71d687 |
96 | # some moosey thingies can not do this |
97 | eval { __PACKAGE__->meta->make_immutable }; |
8019c4d8 |
98 | EOC |
99 | |
100 | $bench_objs->{$name} = $gen_class->new; |
101 | _add_task ($tasks, $name, $meth, $name); |
102 | } |
103 | |
104 | sub _add_task { |
105 | my ($tasks, $name, $meth, $slot) = @_; |
106 | |
52e85101 |
107 | # we precompile the desired amount of loops so that the loop itself |
108 | # does not get in the way with some sort of optimization or whatnot |
109 | |
396618fc |
110 | use Devel::Dwarn; |
111 | # Dwarn { $meth => $bench_objs->{$slot}->can($meth) }; |
112 | |
af71d687 |
113 | my $perl; |
396618fc |
114 | for (1 .. 100) { |
af71d687 |
115 | $perl .= " |
52e85101 |
116 | \$::init_val = \$bench_objs->{$slot}->$meth; |
af71d687 |
117 | \$bench_objs->{$slot}->$meth($_); |
118 | \$bench_objs->{$slot}->$meth(\$bench_objs->{$slot}->$meth + $_); |
396618fc |
119 | \$bench_objs->{$slot}->$meth(undef); |
af71d687 |
120 | "; |
121 | } |
122 | |
396618fc |
123 | $tasks->{$name} = eval "sub { use warnings; use strict; $perl } " or die $@; |
124 | |
125 | # prime things up (have the task run a couple times) |
126 | $tasks->{$name}->() for (1..5); |
8019c4d8 |
127 | } |
128 | |
129 | my $tasks = { |
130 | # 'direct' => sub { |
131 | # $bench_objs->{base}{direct} = 1; |
132 | # $bench_objs->{base}{direct} = $bench_objs->{base}{direct} + 1; |
133 | # } |
134 | }; |
135 | |
396618fc |
136 | for (qw/CAG CAG_XS CAG_INH CAG_INHP CAF CAF_XS CAF_XSA XSA HANDMADE/) { |
8019c4d8 |
137 | _add_task ($tasks, $_, lc($_), 'base'); |
138 | } |
139 | |
140 | my $moose_based = { |
141 | moOse => 'Moose', |
af71d687 |
142 | moo_XS => 'Moo', |
143 | moUse_XS => 'Mouse', |
144 | moUse => 'Mousse', |
8019c4d8 |
145 | }; |
146 | for (keys %$moose_based) { |
147 | _add_moose_task ($tasks, $_, $moose_based->{$_}) |
148 | } |
149 | |
af71d687 |
150 | { |
151 | no warnings 'once'; |
152 | local $Method::Generate::Accessor::CAN_HAZ_XS = 0; |
153 | _add_moose_task ($tasks, moo => 'Moo'); |
154 | } |
8019c4d8 |
155 | |
396618fc |
156 | #delete $tasks->{$_} for grep { $_ !~ /CAG/ } keys %$tasks; |
157 | |
158 | for (1 .. 3) { |
8019c4d8 |
159 | print "Perl $], take $_:\n"; |
396618fc |
160 | # DB::enable_profile(); |
161 | cmpthese ( '50.0001', $tasks ); |
162 | # DB::disable_profile(); |
8019c4d8 |
163 | print "\n"; |
164 | } |