Commit | Line | Data |
8019c4d8 |
1 | use strictures 1; |
2 | |
3 | BEGIN { |
4 | my @missing; |
5 | for (qw/ |
6 | Class::Accessor::Grouped |
7 | Class::XSAccessor |
8 | Class::Accessor::Fast |
9 | Class::Accessor::Fast::XS |
10 | Moose |
11 | Mouse |
12 | /) { |
13 | eval "require $_" or push @missing, $_; |
14 | } |
15 | |
16 | if (@missing) { |
17 | die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n", |
18 | join ("\n", @missing); |
19 | } |
20 | } |
21 | |
22 | |
23 | use Benchmark qw/:hireswallclock cmpthese/; |
24 | |
25 | { |
26 | package Bench::Accessor; |
27 | |
28 | use strictures 1; |
29 | |
30 | our @ISA; |
31 | |
32 | use base qw/Class::Accessor::Grouped Class::Accessor::Fast/; |
33 | use Class::XSAccessor { accessors => [ 'xsa' ] }; |
34 | |
35 | { |
36 | local $Class::Accessor::Grouped::USE_XS = 0; |
37 | __PACKAGE__->mk_group_accessors ('simple', 'cag'); |
38 | } |
39 | { |
40 | local $Class::Accessor::Grouped::USE_XS = 1; |
41 | __PACKAGE__->mk_group_accessors ('simple', 'cag_xs'); |
42 | } |
43 | __PACKAGE__->mk_accessors('caf'); |
44 | |
45 | { |
46 | require Class::Accessor::Fast::XS; |
47 | local @ISA = 'Class::Accessor::Fast::XS'; |
48 | __PACKAGE__->mk_accessors ('caf_xs'); |
49 | } |
50 | |
51 | sub handmade { |
52 | @_ > 1 ? $_[0]->{handmade} = $_[1] : $_[0]->{handmade}; |
53 | } |
54 | |
55 | } |
56 | my $bench_objs = { |
57 | base => bless ({}, 'Bench::Accessor') |
58 | }; |
59 | |
60 | sub _add_moose_task { |
61 | my ($tasks, $name, $class) = @_; |
62 | my $meth = lc($name); |
63 | |
64 | my $gen_class = "Bench::Accessor::$class"; |
65 | eval <<"EOC"; |
66 | package $gen_class; |
67 | use $class; |
68 | has $meth => (is => 'rw'); |
69 | __PACKAGE__->meta->make_immutable; |
70 | EOC |
71 | |
72 | $bench_objs->{$name} = $gen_class->new; |
73 | _add_task ($tasks, $name, $meth, $name); |
74 | } |
75 | |
76 | sub _add_task { |
77 | my ($tasks, $name, $meth, $slot) = @_; |
78 | |
79 | $tasks->{$name} = eval "sub { |
80 | for (my \$i = 0; \$i < 100; \$i++) { |
81 | \$bench_objs->{$slot}->$meth(1); |
82 | \$bench_objs->{$slot}->$meth(\$bench_objs->{$slot}->$meth + 1); |
83 | } |
84 | }"; |
85 | } |
86 | |
87 | my $tasks = { |
88 | # 'direct' => sub { |
89 | # $bench_objs->{base}{direct} = 1; |
90 | # $bench_objs->{base}{direct} = $bench_objs->{base}{direct} + 1; |
91 | # } |
92 | }; |
93 | |
94 | for (qw/CAG CAG_XS CAF CAF_XS XSA HANDMADE/) { |
95 | _add_task ($tasks, $_, lc($_), 'base'); |
96 | } |
97 | |
98 | my $moose_based = { |
99 | moOse => 'Moose', |
100 | ($ENV{MOUSE_PUREPERL} ? 'moUse' : 'moUse_XS') => 'Mouse', |
101 | }; |
102 | for (keys %$moose_based) { |
103 | _add_moose_task ($tasks, $_, $moose_based->{$_}) |
104 | } |
105 | |
106 | |
107 | for (1, 2) { |
108 | print "Perl $], take $_:\n"; |
109 | cmpthese ( -1, $tasks ); |
110 | print "\n"; |
111 | } |