Release commit for 1.000008
[gitmo/Moo.git] / benchmark / class_factory
CommitLineData
6f8df574 1use strictures 1;
2
3use Benchmark qw/:hireswallclock cmpthese/;
4use Getopt::Long::Descriptive;
5
2cd5e970 6use Config;
7$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
8
6f8df574 9
10my ($opts, $usage);
11BEGIN {
12 ($opts, $usage) = describe_options(
13 '%c: %o' =>
14 [ 'help|h' => 'Print usage message and exit' ],
15 [ 'classes|c:i' => 'How many classes to create per benchmark cycle (def 10)', { default => 10 } ],
2cd5e970 16 [ 'accessors|a:i' => 'How many accessors/attributes of each type to create per class (def 10)', { default => 10 } ],
17 [ 'subprocess|startup|s' => 'Run the code in a subprocess to benchmark actual time spent on compilation' ],
18 [ 'pregenerate|p:i' => 'How many bench-runs to pre-generate for compilation in case --subprocess is not used (def 1000)', { default => 1000} ],
19 [ 'run|r' => 'Use each accessor at runtime (get/set/get cycle)' ],
6f8df574 20 [ 'unique|u' => 'Make accessor names globally unique (instead of just per class)' ],
21 [ 'bench|b:s' => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ],
22 { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] },
23 );
24
25 # can not change this runtime, thus in-block
26 $ENV{MOUSE_PUREPERL} = 1 if $opts->{bench} eq 'pp';
27
28 my @missing;
29 for (qw/
30 Moose
31 Moo
32 Mouse
33 /) {
34 eval "require $_" or push @missing, $_;
35 }
36
37 if (@missing) {
38 die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
39 join ("\n", @missing);
40 }
41}
42
2cd5e970 43use Method::Generate::Accessor; # need to pre-load for the XS shut-off to work
6f8df574 44
45$usage->die if $opts->{help};
46
2cd5e970 47$opts->{pregenerate} = 1 if $opts->{subprocess};
48
6f8df574 49my $counters;
50my $tasks = {};
51
2cd5e970 52my $attrs_to_bench = {
53 plain => q|is => 'rw'|,
54 lazy_default => q|is => 'rw', lazy => 1, default => sub { {} }|,
55 lazy_default_qsub => q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} }|,
56};
57
58for (keys %$attrs_to_bench) {
59 if ($opts->{bench} =~ /all|pp/) {
60 {
61 local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
62 _add_moosey_has (moo => 'Moo', $_);
63 }
6f8df574 64
2cd5e970 65 _add_moosey_has (moose => 'Moose', $_);
66 _add_moosey_has (mouse => 'Mouse', $_)
67 if $ENV{MOUSE_PUREPERL};
68 }
6f8df574 69
2cd5e970 70 if ($opts->{bench} =~ /all|xs/) {
71 {
72 local $Method::Generate::Accessor::CAN_HAZ_XS = 1;
73 _add_moosey_has (moo_XS => 'Moo', $_);
74 }
75 _add_moosey_has (mouse_XS => 'Mouse', $_)
76 unless $ENV{MOUSE_PUREPERL};
6f8df574 77 }
6f8df574 78}
79
80# run each task once, prime whatever caches there may be
81$_->() for values %$tasks;
82
83# Actual Benchmarking
84for (1, 2) {
85 print "Perl $], take $_:\n";
2cd5e970 86
87 # if forking must run for certain number of cycles, cputime doesn't work
18a09449 88 foreach my $type (sort keys %$attrs_to_bench) {
89 print "Benchming ${type}:\n";
90 my %these = map { (split ' ', $_)[0] => $tasks->{$_} }
91 grep /${type}$/, keys %$tasks;
92 cmpthese ( $opts->{subprocess} ? 15 : -1 , \%these );
93 }
6f8df574 94 print "\n";
95}
96
97exit 0; # the end
98
99sub _add_moosey_has {
2cd5e970 100 my ($name, $base, $attr_type) = @_;
6f8df574 101
2cd5e970 102 my @to_eval;
103
104 for (1 .. $opts->{pregenerate} ) {
105 my $perl = 'use Sub::Quote;';
6f8df574 106
6f8df574 107 for ( 1.. $opts->{classes} ) {
2cd5e970 108 my $class = "Bench::${base}_" . ++$counters->{class};
6f8df574 109 $perl .= "package $class; use $base;";
2cd5e970 110
111 my @attr_names;
6f8df574 112 for ( 1.. $opts->{accessors} ) {
2cd5e970 113 my $attr = "attribute_${attr_type}" . ++$counters->{acc};
114 push @attr_names, $attr;
115 $perl .= "has $attr => ($attrs_to_bench->{$attr_type});";
6f8df574 116 }
117
2cd5e970 118 $perl .= '__PACKAGE__->meta->make_immutable;'
c9b16e36 119 if $name !~ /^moo(_XS)?$/;
2cd5e970 120
6f8df574 121 $counters->{accessors} = 0
122 unless $opts->{unique};
2cd5e970 123
124 if ($opts->{run}) {
4ce62c03 125 $perl .= "\$::obj = $class->new;";
126 $perl .= "\$::foo = \$::obj->$_; \$::obj->$_(1); \$::foo = \$::obj->$_;"
2cd5e970 127 for @attr_names;
128 }
6f8df574 129 }
130
2cd5e970 131 push @to_eval, $perl;
6f8df574 132 }
133
2cd5e970 134 $tasks->{"$name $attr_type"} = $opts->{subprocess}
135 ? sub {
136 open (my $subproc, '|-', $^X, '-');
137 print $subproc $to_eval[0];
138 close $subproc;
139 }
140 : sub {
141 eval shift @to_eval;
142 }
143 ;
6f8df574 144}