From: Peter Rabbitson Date: Fri, 10 Sep 2010 17:46:29 +0000 (+0000) Subject: Fix braindead ro/wo accessor breakage when CXSA is available X-Git-Tag: v0.09006~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8019c4d86e5cea699b25d7eeb30c6fb7550f7298;p=p5sagit%2FClass-Accessor-Grouped.git Fix braindead ro/wo accessor breakage when CXSA is available Better control on whether to use CXSA or not (global var and envvar) Rewrite tests so that PP and XS codepaths are fully tested Bump Test::More for subtests functionality Add benchmark and XS discussion to POD --- diff --git a/Changes b/Changes index a4ae4e4..ed79c69 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,10 @@ Revision history for Class::Accessor::Grouped. + - Fix bugs in ro/wo accessor generation when XSAccessor is + being used + - Better Class::XSAccessor usage control - introducing + $ENV{CAG_USE_XS} and $Class::Accessor::Grouped::USE_XS + 0.09005 Wed Sep 1 04:00:00 2010 - Again, remove Class::XSAccessor for Win32 sine it still breaks diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index b379b89..8efd2a2 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -38,3 +38,5 @@ Build.bat # Avoid author test files. \bpod_spelling.t$ + +benchmark.pl diff --git a/Makefile.PL b/Makefile.PL index 4921ca4..e4588f6 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -15,6 +15,7 @@ requires 'Class::Inspector'; requires 'Sub::Name' => '0.04'; test_requires 'Sub::Identify'; +test_requires 'Test::More' => '0.94'; test_requires 'Test::Exception'; clean_files "Class-Accessor-Grouped-* t/var"; diff --git a/benchmark.pl b/benchmark.pl new file mode 100644 index 0000000..74716b2 --- /dev/null +++ b/benchmark.pl @@ -0,0 +1,111 @@ +use strictures 1; + +BEGIN { + my @missing; + for (qw/ + Class::Accessor::Grouped + Class::XSAccessor + Class::Accessor::Fast + Class::Accessor::Fast::XS + Moose + Mouse + /) { + eval "require $_" or push @missing, $_; + } + + if (@missing) { + die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n", + join ("\n", @missing); + } +} + + +use Benchmark qw/:hireswallclock cmpthese/; + +{ + package Bench::Accessor; + + use strictures 1; + + our @ISA; + + use base qw/Class::Accessor::Grouped Class::Accessor::Fast/; + use Class::XSAccessor { accessors => [ 'xsa' ] }; + + { + local $Class::Accessor::Grouped::USE_XS = 0; + __PACKAGE__->mk_group_accessors ('simple', 'cag'); + } + { + local $Class::Accessor::Grouped::USE_XS = 1; + __PACKAGE__->mk_group_accessors ('simple', 'cag_xs'); + } + __PACKAGE__->mk_accessors('caf'); + + { + require Class::Accessor::Fast::XS; + local @ISA = 'Class::Accessor::Fast::XS'; + __PACKAGE__->mk_accessors ('caf_xs'); + } + + sub handmade { + @_ > 1 ? $_[0]->{handmade} = $_[1] : $_[0]->{handmade}; + } + +} +my $bench_objs = { + base => bless ({}, 'Bench::Accessor') +}; + +sub _add_moose_task { + my ($tasks, $name, $class) = @_; + my $meth = lc($name); + + my $gen_class = "Bench::Accessor::$class"; + eval <<"EOC"; +package $gen_class; +use $class; +has $meth => (is => 'rw'); +__PACKAGE__->meta->make_immutable; +EOC + + $bench_objs->{$name} = $gen_class->new; + _add_task ($tasks, $name, $meth, $name); +} + +sub _add_task { + my ($tasks, $name, $meth, $slot) = @_; + + $tasks->{$name} = eval "sub { + for (my \$i = 0; \$i < 100; \$i++) { + \$bench_objs->{$slot}->$meth(1); + \$bench_objs->{$slot}->$meth(\$bench_objs->{$slot}->$meth + 1); + } + }"; +} + +my $tasks = { +# 'direct' => sub { +# $bench_objs->{base}{direct} = 1; +# $bench_objs->{base}{direct} = $bench_objs->{base}{direct} + 1; +# } +}; + +for (qw/CAG CAG_XS CAF CAF_XS XSA HANDMADE/) { + _add_task ($tasks, $_, lc($_), 'base'); +} + +my $moose_based = { + moOse => 'Moose', + ($ENV{MOUSE_PUREPERL} ? 'moUse' : 'moUse_XS') => 'Mouse', +}; +for (keys %$moose_based) { + _add_moose_task ($tasks, $_, $moose_based->{$_}) +} + + +for (1, 2) { + print "Perl $], take $_:\n"; + cmpthese ( -1, $tasks ); + print "\n"; +} diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm index 514c9f7..cf15365 100644 --- a/lib/Class/Accessor/Grouped.pm +++ b/lib/Class/Accessor/Grouped.pm @@ -9,25 +9,41 @@ use Sub::Name (); our $VERSION = '0.09005'; $VERSION = eval $VERSION; -# Class::XSAccessor is segfaulting on win32, so be careful -# Win32 users can set $hasXS to try to use it anyway +# when changing minimum version don't forget to adjust L as well +our $__minimum_xsa_version = '1.06'; -our $hasXS; +our $USE_XS; +# the unless defined is here so that we can override the value +# before require/use, *regardless* of the state of $ENV{CAG_USE_XS} +$USE_XS = $ENV{CAG_USE_XS} + unless defined $USE_XS; -sub _hasXS { - if (not defined $hasXS) { - $hasXS = 0; +my $xsa_loaded; +my $load_xsa = sub { + return if $xsa_loaded++; + require Class::XSAccessor; + Class::XSAccessor->VERSION($__minimum_xsa_version); +}; + +my $use_xs = sub { + if (defined $USE_XS) { + $load_xsa->() if ($USE_XS && ! $xsa_loaded); + return $USE_XS; + } + + $USE_XS = 0; + + # Class::XSAccessor is segfaulting on win32, in some + # esoteric heavily-threaded scenarios + # Win32 users can set $USE_XS/CAG_USE_XS to try to use it anyway if ($^O ne 'MSWin32') { - eval { - require Class::XSAccessor; - $hasXS = 1; - }; + local $@; + eval { $load_xsa->(); $USE_XS = 1 }; } - } - return $hasXS; -} + return $USE_XS; +}; =head1 NAME @@ -86,41 +102,30 @@ sub mk_group_accessors { # So we don't have to do lots of lookups inside the loop. $maker = $self->can($maker) unless ref $maker; - my $hasXS = _hasXS(); - - foreach my $field (@fields) { - if( $field eq 'DESTROY' ) { + foreach (@fields) { + if( $_ eq 'DESTROY' ) { Carp::carp("Having a data accessor named DESTROY in ". "'$class' is unwise."); } - my $name = $field; - - ($name, $field) = @$field if ref $field; + my ($name, $field) = (ref $_) + ? (@$_) + : ($_, $_) + ; my $alias = "_${name}_accessor"; - my $full_name = join('::', $class, $name); - my $full_alias = join('::', $class, $alias); - if ( $hasXS && $group eq 'simple' ) { - require Class::XSAccessor; - Class::XSAccessor->import({ - replace => 1, - class => $class, - accessors => { - $name => $field, - $alias => $field, - }, - }); - } - else { - my $accessor = $self->$maker($group, $field); - my $alias_accessor = $self->$maker($group, $field); - *$full_name = Sub::Name::subname($full_name, $accessor); - #unless defined &{$class."\:\:$field"} + for my $meth ($name, $alias) { + + # the maker may elect to not return anything, meaning it already + # installed the coderef for us + my $cref = $self->$maker($group, $field, $meth) + or next; + + my $fq_meth = join('::', $class, $meth); - *$full_alias = Sub::Name::subname($full_alias, $alias_accessor); - #unless defined &{$class."\:\:$alias"} + *$fq_meth = Sub::Name::subname($fq_meth, $cref); + #unless defined &{$class."\:\:$field"} } } } @@ -174,19 +179,31 @@ sub mk_group_wo_accessors { =over 4 -=item Arguments: $group, $field +=item Arguments: $group, $field, $method -Returns: $sub (\CODE) +Returns: \&accessor_coderef ? =back -Returns a single accessor in a given group; called by mk_group_accessors -for each entry in @fieldspec. +Called by mk_group_accessors for each entry in @fieldspec. Either returns +a coderef which will be installed at C<&__PACKAGE__::$method>, or returns +C if it elects to install the coderef on its own. =cut sub make_group_accessor { - my ($class, $group, $field) = @_; + my ($class, $group, $field, $name) = @_; + + if ( $group eq 'simple' && $use_xs->() ) { + Class::XSAccessor->import({ + replace => 1, + class => $class, + accessors => { + $name => $field, + }, + }); + return; + } my $set = "set_$group"; my $get = "get_$group"; @@ -211,19 +228,31 @@ sub make_group_accessor { =over 4 -=item Arguments: $group, $field +=item Arguments: $group, $field, $method -Returns: $sub (\CODE) +Returns: \&accessor_coderef ? =back -Returns a single read-only accessor in a given group; called by -mk_group_ro_accessors for each entry in @fieldspec. +Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns +a coderef which will be installed at C<&__PACKAGE__::$method>, or returns +C if it elects to install the coderef on its own. =cut sub make_group_ro_accessor { - my($class, $group, $field) = @_; + my($class, $group, $field, $name) = @_; + + if ( $group eq 'simple' && $use_xs->() ) { + Class::XSAccessor->import({ + replace => 1, + class => $class, + getters => { + $name => $field, + }, + }); + return; + } my $get = "get_$group"; @@ -248,19 +277,31 @@ sub make_group_ro_accessor { =over 4 -=item Arguments: $group, $field +=item Arguments: $group, $field, $method -Returns: $sub (\CODE) +Returns: \&accessor_coderef ? =back -Returns a single write-only accessor in a given group; called by -mk_group_wo_accessors for each entry in @fieldspec. +Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns +a coderef which will be installed at C<&__PACKAGE__::$method>, or returns +C if it elects to install the coderef on its own. =cut sub make_group_wo_accessor { - my($class, $group, $field) = @_; + my($class, $group, $field, $name) = @_; + + if ( $group eq 'simple' && $use_xs->() ) { + Class::XSAccessor->import({ + replace => 1, + class => $class, + setters => { + $name => $field, + }, + }); + return; + } my $set = "set_$group"; @@ -480,7 +521,45 @@ sub get_super_paths { =head1 PERFORMANCE -You can speed up accessors of type 'simple' by installing L. +To provide total flexibility L calls methods +internally while performing get/set actions, which makes it noticeably +slower than similar modules. To compensate, this module will automatically +use the insanely fast L to generate the C-group +accessors, if L<< Class::XSAccessor >= 1.06|Class::XSAccessor >> is +available on your system. + +=head2 Benchmark + +This is the result of a set/get/set loop benchmark on perl 5.12.1 with +thread support, showcasing most popular accessor builders: L, L, +L, L +and L: + + Rate CAG moOse CAF HANDMADE CAF_XS moUse_XS CAG_XS XSA + CAG 1777/s -- -27% -29% -36% -62% -67% -72% -73% + moOse 2421/s 36% -- -4% -13% -48% -55% -61% -63% + CAF 2511/s 41% 4% -- -10% -47% -53% -60% -61% + HANDMADE 2791/s 57% 15% 11% -- -41% -48% -56% -57% + CAF_XS 4699/s 164% 94% 87% 68% -- -13% -25% -28% + moUse_XS 5375/s 203% 122% 114% 93% 14% -- -14% -18% + CAG_XS 6279/s 253% 159% 150% 125% 34% 17% -- -4% + XSA 6515/s 267% 169% 159% 133% 39% 21% 4% -- + +Benchmark program is available in the root of the +L: + +=head2 Notes on Class::XSAccessor + +While L works surprisingly well for the amount of black +magic it tries to pull off, it's still black magic. At present (Sep 2010) +the module is known to have problems on Windows under heavy thread-stress +(e.g. Win32+Apache+mod_perl). Thus for the time being L +will not be used automatically if you are running under C. + +You can force the use of L before creating a particular +C accessor by either manipulating the global variable +C<$Class::Accessor::Grouped::USE_XS>, or you can do so before runtime via the +C environment variable. =head1 AUTHORS diff --git a/t/accessors.t b/t/accessors.t index edd11ca..49c6bea 100644 --- a/t/accessors.t +++ b/t/accessors.t @@ -2,14 +2,19 @@ use Test::More tests => 62; use strict; use warnings; use lib 't/lib'; -use Sub::Identify qw/sub_name sub_fullname/;; +use Sub::Identify qw/sub_name sub_fullname/; +# we test the pure-perl versions only, but allow overrides +# from the accessor_xs test-umbrella +# Also make sure a rogue envvar will not interfere with +# things BEGIN { - # Disable XSAccessor to test pure-Perl accessors - $Class::Accessor::Grouped::hasXS = 0; - - require AccessorGroups; -} + $Class::Accessor::Grouped::USE_XS = 0 + unless defined $Class::Accessor::Grouped::USE_XS; + $ENV{CAG_USE_XS} = 1; +}; + +use AccessorGroups; my $class = AccessorGroups->new; @@ -98,4 +103,5 @@ foreach (qw/lr1 lr2/) { is($class->$name, 'd'); }; +# important 1; diff --git a/t/accessors_ro.t b/t/accessors_ro.t index 6b543ed..4268b25 100644 --- a/t/accessors_ro.t +++ b/t/accessors_ro.t @@ -1,7 +1,21 @@ use Test::More tests => 48; +use Test::Exception; use strict; use warnings; use lib 't/lib'; + +# we test the pure-perl versions only, but allow overrides +# from the accessor_xs test-umbrella +# Also make sure a rogue envvar will not interfere with +# things +my $use_xs; +BEGIN { + $Class::Accessor::Grouped::USE_XS = 0 + unless defined $Class::Accessor::Grouped::USE_XS; + $ENV{CAG_USE_XS} = 1; + $use_xs = $Class::Accessor::Grouped::USE_XS; +}; + use AccessorGroupsRO; my $class = AccessorGroupsRO->new; @@ -24,68 +38,60 @@ my $class = AccessorGroupsRO->new; *AccessorGroupsRO::DESTROY = sub {}; }; -foreach (qw/singlefield multiple1 multiple2/) { - my $name = $_; +my $test_accessors = { + singlefield => { + is_xs => $use_xs, + }, + multiple1 => { + }, + multiple2 => { + }, + lr1name => { + custom_field => 'lr1;field', + }, + lr2name => { + custom_field => "lr2'field", + }, +}; + +for my $name (sort keys %$test_accessors) { + my $alias = "_${name}_accessor"; + my $field = $test_accessors->{$name}{custom_field} || $name; can_ok($class, $name, $alias); + ok(!$class->can($field)) + if $field ne $name; + is($class->$name, undef); is($class->$alias, undef); # get via name - $class->{$name} = 'a'; + $class->{$field} = 'a'; is($class->$name, 'a'); # alias gets same as name is($class->$alias, 'a'); + my $ro_regex = $test_accessors->{$name}{is_xs} + ? qr/Usage\:.+$name.*\(self\)/ + : qr/cannot alter the value of '\Q$field\E'/ + ; + # die on set via name/alias - eval { + throws_ok { $class->$name('b'); - }; - ok($@ =~ /cannot alter/); + } $ro_regex; - eval { + throws_ok { $class->$alias('b'); - }; - ok($@ =~ /cannot alter/); + } $ro_regex; # value should be unchanged is($class->$name, 'a'); is($class->$alias, 'a'); }; -foreach (qw/lr1 lr2/) { - my $name = "$_".'name'; - my $alias = "_${name}_accessor"; - my $field = { lr1 => 'lr1;field', lr2 => q{lr2'field} }->{$_}; - - can_ok($class, $name, $alias); - ok(!$class->can($field)); - - is($class->$name, undef); - is($class->$alias, undef); - - # get via name - $class->{$field} = 'c'; - is($class->$name, 'c'); - - # alias gets same as name - is($class->$alias, 'c'); - - # die on set via name/alias - eval { - $class->$name('d'); - }; - ok($@ =~ /cannot alter/); - - eval { - $class->$alias('d'); - }; - ok($@ =~ /cannot alter/); - - # value should be unchanged - is($class->$name, 'c'); - is($class->$alias, 'c'); -}; +#important +1; diff --git a/t/accessors_wo.t b/t/accessors_wo.t index bc5307c..1cda04a 100644 --- a/t/accessors_wo.t +++ b/t/accessors_wo.t @@ -1,7 +1,21 @@ use Test::More tests => 38; +use Test::Exception; use strict; use warnings; use lib 't/lib'; + +# we test the pure-perl versions only, but allow overrides +# from the accessor_xs test-umbrella +# Also make sure a rogue envvar will not interfere with +# things +my $use_xs; +BEGIN { + $Class::Accessor::Grouped::USE_XS = 0 + unless defined $Class::Accessor::Grouped::USE_XS; + $ENV{CAG_USE_XS} = 1; + $use_xs = $Class::Accessor::Grouped::USE_XS; +}; + use AccessorGroupsWO; my $class = AccessorGroupsWO->new; @@ -24,57 +38,54 @@ my $class = AccessorGroupsWO->new; *AccessorGroupsWO::DESTROY = sub {}; }; -foreach (qw/singlefield multiple1 multiple2/) { - my $name = $_; +my $test_accessors = { + singlefield => { + is_xs => $use_xs, + }, + multiple1 => { + }, + multiple2 => { + }, + lr1name => { + custom_field => 'lr1;field', + }, + lr2name => { + custom_field => "lr2'field", + }, +}; + +for my $name (sort keys %$test_accessors) { + my $alias = "_${name}_accessor"; + my $field = $test_accessors->{$name}{custom_field} || $name; can_ok($class, $name, $alias); + ok(!$class->can($field)) + if $field ne $name; + # set via name is($class->$name('a'), 'a'); - is($class->{$name}, 'a'); + is($class->{$field}, 'a'); # alias sets same as name is($class->$alias('b'), 'b'); - is($class->{$name}, 'b'); - - # die on get via name/alias - eval { - $class->$name; - }; - ok($@ =~ /cannot access/); - - eval { - $class->$alias; - }; - ok($@ =~ /cannot access/); -}; - -foreach (qw/lr1 lr2/) { - my $name = "$_".'name'; - my $alias = "_${name}_accessor"; + is($class->{$field}, 'b'); - my $field = { lr1 => 'lr1;field', lr2 => q{lr2'field} }->{$_}; - - can_ok($class, $name, $alias); - ok(!$class->can($field)); - - # set via name - is($class->$name('c'), 'c'); - is($class->{$field}, 'c'); - - # alias sets same as name - is($class->$alias('d'), 'd'); - is($class->{$field}, 'd'); + my $wo_regex = $test_accessors->{$name}{is_xs} + ? qr/Usage\:.+$name.*\(self, newvalue\)/ + : qr/cannot access the value of '\Q$field\E'/ + ; # die on get via name/alias - eval { + throws_ok { $class->$name; - }; - ok($@ =~ /cannot access/); + } $wo_regex; - eval { + throws_ok { $class->$alias; - }; - ok($@ =~ /cannot access/); + } $wo_regex; }; + +# important +1; \ No newline at end of file diff --git a/t/accessors_xs.t b/t/accessors_xs.t index 672dafd..393f916 100644 --- a/t/accessors_xs.t +++ b/t/accessors_xs.t @@ -5,9 +5,21 @@ use File::Spec::Functions; use Test::More; use lib 't/lib'; -use AccessorGroups (); - -plan skip_all => 'Class::XSAccessor not available' - unless Class::Accessor::Grouped::_hasXS(); +BEGIN { + require Class::Accessor::Grouped; + my $xsa_ver = $Class::Accessor::Grouped::__minimum_xsa_version; + eval { + require Class::XSAccessor; + Class::XSAccessor->VERSION ($xsa_ver); + }; + plan skip_all => "Class::XSAccessor >= $xsa_ver not available" + if $@; +} -require( catfile($Bin, 'accessors.t') ); +# rerun all 3 tests under XSAccessor +$Class::Accessor::Grouped::USE_XS = 1; +for (qw/accessors.t accessors_ro.t accessors_wo.t/) { + subtest "$_ with USE_XS" => sub { require( catfile($Bin, $_) ) } +} + +done_testing; diff --git a/t/lib/AccessorGroupsRO.pm b/t/lib/AccessorGroupsRO.pm index 3cb8a1c..25857a4 100644 --- a/t/lib/AccessorGroupsRO.pm +++ b/t/lib/AccessorGroupsRO.pm @@ -3,7 +3,7 @@ use strict; use warnings; use base 'Class::Accessor::Grouped'; -__PACKAGE__->mk_group_ro_accessors('single', 'singlefield'); +__PACKAGE__->mk_group_ro_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_ro_accessors('multiple', qw/multiple1 multiple2/); __PACKAGE__->mk_group_ro_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]); @@ -11,7 +11,7 @@ sub new { return bless {}, shift; }; -foreach (qw/single multiple listref/) { +foreach (qw/multiple listref/) { no strict 'refs'; *{"get_$_"} = \&Class::Accessor::Grouped::get_simple; diff --git a/t/lib/AccessorGroupsWO.pm b/t/lib/AccessorGroupsWO.pm index a0a2617..2f46e75 100644 --- a/t/lib/AccessorGroupsWO.pm +++ b/t/lib/AccessorGroupsWO.pm @@ -3,7 +3,7 @@ use strict; use warnings; use base 'Class::Accessor::Grouped'; -__PACKAGE__->mk_group_wo_accessors('single', 'singlefield'); +__PACKAGE__->mk_group_wo_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_wo_accessors('multiple', qw/multiple1 multiple2/); __PACKAGE__->mk_group_wo_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]); @@ -11,7 +11,7 @@ sub new { return bless {}, shift; }; -foreach (qw/single multiple listref/) { +foreach (qw/multiple listref/) { no strict 'refs'; *{"set_$_"} = \&Class::Accessor::Grouped::set_simple; diff --git a/t/pod_spelling.t b/t/pod_spelling.t index 4cedcfe..a01c909 100644 --- a/t/pod_spelling.t +++ b/t/pod_spelling.t @@ -39,4 +39,8 @@ ribasushi Rabbitson groditi Caelum -Kitover \ No newline at end of file +Kitover +CAF +Sep +XSA +runtime