X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=benchmark%2Fobject_factory;h=c539c142861ce8188a7c9d20033ebd9c691bf00e;hb=refs%2Ftags%2Fv1.003001;hp=ed834795c633e523468bb1a369b4a830004af295;hpb=47402ac5d24dcb502064cd5785551b15c36ee4ec;p=gitmo%2FMoo.git diff --git a/benchmark/object_factory b/benchmark/object_factory index ed83479..c539c14 100644 --- a/benchmark/object_factory +++ b/benchmark/object_factory @@ -4,45 +4,72 @@ use Benchmark qw/:hireswallclock cmpthese/; use Getopt::Long::Descriptive; use Config; -$ENV{PERL5LIB} = join ($Config{path_sep}, @INC); - - -my ($opts, $usage); -BEGIN { - ($opts, $usage) = describe_options( - '%c: %o' => - [ 'help|h' => 'Print usage message and exit' ], - [ 'bench|b:s' => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ], - [ 'iterations|i:i' => 'How many iterations in each bench run (def 1000)', { default => 1000 } ], - [ 'reuse|r' => 'Reuse the object between benchmark runs' ], - { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] }, - ); - - my @missing; - for (qw/ - Moose - Moo - Mouse - Mousse - /) { - eval "require $_" or push @missing, $_; + +my $attrs_to_bench = { + plain => q|is => 'rw' |, + ro => q|is => 'ro' |, + default => q|is => 'rw', default => sub { {} } |, + lazy_default => q|is => 'rw', lazy => 1, default => sub { {} } |, + lazy_default_qsub => q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |, +}; + +my $cycles = { + 1 => 'get', + 2 => 'get/set/get', +}; + +my ($opts, $usage) = describe_options( + '%c: %o' => + [ 'help|h' => 'Print usage message and exit' ], + [ 'bench|b:s' => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ], + [ 'lib|l:s@' => 'Bench against specific lib(s), runs same benches against multiple targets, excluding non-moo benches' ], + [ 'attr|a:s@' => 'Which attributes to benchmark (must be defined in-file)' ], + [ 'cycle|c:i' => 'Which cycle to run 1 - get, 2 - get/set/get (def 1)', { default => 1 } ], + [ 'iterations|i:i' => 'How many iterations in each bench run (def 1000)', { default => 1000 } ], + [ 'totalruns|total|t:i' => 'How many times to rerun the whole benchmark (def 1)', { default => 1 } ], + [ 'reuse|r' => 'Reuse the object between attribute usage runs' ], + { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] }, +); + +$usage->die if $opts->{help}; + +if ($opts->{attr}) { + my %to_bench = map { $_ => 1 } map { split /\s*,\s*/, $_ } @{$opts->{attr}}; + + for (keys %to_bench) { + die "No such attr '$_'\n" unless $attrs_to_bench->{$_}; } - if (@missing) { - die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n", - join ("\n", @missing); + for (keys %$attrs_to_bench) { + delete $attrs_to_bench->{$_} unless $to_bench{$_}; } } -use Method::Generate::Accessor; # need to pre-load for the XS shut-off to work +my @libs = map { split /\s*:\s*/, $_ } @{$opts->{lib}} + if ($opts->{lib}); -$usage->die if $opts->{help}; +if (@libs) { + my $myself = $$; -my $attrs_to_bench = { - plain => q|is => 'rw' |, - lazy_default => q|is => 'rw', lazy => 1, default => sub { {} } |, - lazy_default_qsub => q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |, -}; + for my $lib (@libs) { + $ENV{PERL5LIB} = join ($Config{path_sep}, $lib, @INC); + + my $pid = fork(); + die "Unable to fork: $!" unless defined $pid; + + if ($pid) { + wait; + } + else { + print "Benchmarking with $lib\n"; + last; + } + } + + exit 0 if $$ == $myself; +} + +require Method::Generate::Accessor; # need to pre-load for the XS shut-off to work my $class_types; @@ -52,52 +79,59 @@ if ($opts->{bench} =~ /all|pp/) { _add_moosey_has (moo => 'Moo'); } - _add_moosey_has (moose => 'Moose'); - _add_moosey_has (mouse => 'Mousse') + _add_moosey_has (moose => 'Moose') unless @libs; + _add_moosey_has (mouse => 'Mousse') unless @libs; } if ($opts->{bench} =~ /all|xs/) { + if (! $Method::Generate::Accessor::CAN_HAZ_XS) { - local $Method::Generate::Accessor::CAN_HAZ_XS = 1; - _add_moosey_has (moo_XS => 'Moo'); + die "Requested XS benchmarks but XS isn't available in Method::Generate::Accessor"; } - _add_moosey_has (mouse_XS => 'Mouse') + + _add_moosey_has (moo_XS => 'Moo'); + _add_moosey_has (mouse_XS => 'Mouse') unless @libs; } # Actual Benchmarking -for (1, 2) { +for (1 .. $opts->{totalruns} ) { print "Perl $], take $_:\n"; my $objects; - print "\n\nBenching new()\n====================\n"; - - cmpthese ( -1, { map { - my $type = $_; - "${type}->new" => sub { - $objects->{$type} = $class_types->{$type}->new - for (1 .. $opts->{iterations}); + for my $use_attrs (0, 1) { + for my $attr (keys %$attrs_to_bench) { + printf "\n\nBenching %s ( %s )\n====================\n", + $attr, + $use_attrs + ? sprintf '%s%s cycle', ($opts->{reuse} ? '' : 'new() and ' ), $cycles->{$opts->{cycle}} + : 'new() only' + , + ; + + cmpthese ( -1, { map { + my $type = $_; + "${type}->$attr" => sub { + $objects->{$type} = $class_types->{$type}->new + unless ( $use_attrs && $opts->{reuse} ); + + for (1 .. $opts->{iterations} ) { + if ($opts->{cycle} == 1) { + my $init = $objects->{$type}->$attr; + } + elsif ($opts->{cycle} == 2) { + my $init = $objects->{$type}->$attr; + $objects->{$type}->$attr('foo') unless $attr eq 'ro'; + my $set = $objects->{$type}->$attr; + } + } + }; + } keys %$class_types } ); } - } keys %$class_types } ); - - for my $attr (keys %$attrs_to_bench) { - print "\n\nBenching $attr\n====================\n"; - - cmpthese ( -1, { map { - my $type = $_; - "${type}->$attr" => sub { - $objects->{$type} = $class_types->{$type}->new - unless $opts->{reuse}; - - for (1 .. $opts->{iterations} ) { - my $init = $objects->{$type}->$attr; - $objects->{$type}->$attr('foo'); - my $set = $objects->{$type}->$attr; - } - } - } keys %$objects } ); } + + print "\n\n\n"; } exit 0; # the end