From: Peter Rabbitson Date: Fri, 8 Oct 2010 15:50:27 +0000 (+0000) Subject: Fix another XSA corner case - how can something so simple get so complex... X-Git-Tag: v0.09007~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fee7c68b86e9fde5f67765fe221c384ac649b5e8;p=p5sagit%2FClass-Accessor-Grouped.git Fix another XSA corner case - how can something so simple get so complex... --- diff --git a/Changes b/Changes index 8005a2b..405b30e 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ Revision history for Class::Accessor::Grouped. + - Fix corner case when get/set_simple overrides are circumvented + iff Class::XSAccessor is present + 0.09006 Wed Sep 10 23:55:00 2010 - Fix bugs in ro/wo accessor generation when XSAccessor is being used diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm index aeeb430..9c6b398 100644 --- a/lib/Class/Accessor/Grouped.pm +++ b/lib/Class/Accessor/Grouped.pm @@ -46,12 +46,81 @@ my $use_xs = sub { return $USE_XS; }; +my $maker_type_map = { + rw => { + xsa => 'accessors', + cag => 'make_group_accessor', + }, + ro => { + xsa => 'getters', + cag => 'make_group_ro_accessor', + }, + wo => { + xsa => 'setters', + cag => 'make_group_wo_accessor', + }, +}; + +# When installing an XSA simple accessor, we need to make sure we are not +# short-circuiting a (compile or runtime) get_simple/set_simple override. +# What we do here is install a lazy first-access check, which will decide +# the ultimate coderef being placed in the accessor slot + +my $no_xsa_classes_warned; my $add_xs_accessor = sub { + my ($class, $group, $field, $name, $type) = @_; + Class::XSAccessor->import({ replace => 1, - %{shift()} + class => $class, + $maker_type_map->{$type}{xsa} => { + $name => $field, + }, }); - return undef; + + my $xs_cref = $class->can($name); + + my $pp_cref = do { + my $cag_method = $maker_type_map->{$type}{cag}; + local $USE_XS = 0; + $class->$cag_method ($group, $field, $name, $type); + }; + + # can't use pkg_gen to track this stuff, as it doesn't + # detect superclass mucking + my $original_getter = __PACKAGE__->can ("get_$group"); + my $original_setter = __PACKAGE__->can ("set_$group"); + + return sub { + my $self = $_[0]; + my $current_class = (ref $self) || $self; + + my $final_cref; + if ( + $current_class->can("get_$group") == $original_getter + && + $current_class->can("set_$group") == $original_setter + ) { + # nothing has changed, might as well use the XS crefs + # (if one changes methods that far into runtime - look pieces!) + $final_cref = $xs_cref; + } + else { + $final_cref = $pp_cref; + if ($USE_XS and ! $xsa_autodetected and ! $no_xsa_classes_warned->{$current_class}++) { + warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class' + . " '$current_class' due to an overriden get_$group and/or set_$group\n"; + } + } + + my $fq_meth = "${current_class}::${name}"; + + no strict qw/refs/; + no warnings qw/redefine/; + *$fq_meth = Sub::Name::subname($fq_meth, $final_cref); + + goto $final_cref; + }; }; =head1 NAME @@ -204,12 +273,7 @@ sub make_group_accessor { my ($class, $group, $field, $name) = @_; if ( $group eq 'simple' && $use_xs->() ) { - return $add_xs_accessor->({ - class => $class, - accessors => { - $name => $field, - }, - }); + return $add_xs_accessor->(@_, 'rw'); } my $set = "set_$group"; @@ -251,12 +315,7 @@ sub make_group_ro_accessor { my($class, $group, $field, $name) = @_; if ( $group eq 'simple' && $use_xs->() ) { - return $add_xs_accessor->({ - class => $class, - getters => { - $name => $field, - }, - }); + return $add_xs_accessor->(@_, 'ro'); } my $get = "get_$group"; @@ -298,12 +357,7 @@ sub make_group_wo_accessor { my($class, $group, $field, $name) = @_; if ( $group eq 'simple' && $use_xs->() ) { - return $add_xs_accessor->({ - class => $class, - setters => { - $name => $field, - }, - }); + return $add_xs_accessor->(@_, 'wo') } my $set = "set_$group"; diff --git a/t/accessors.t b/t/accessors.t index 3fc1145..e10f102 100644 --- a/t/accessors.t +++ b/t/accessors.t @@ -53,6 +53,7 @@ my $class = AccessorGroups->new; my $test_accessors = { singlefield => { is_xs => $use_xs, + has_extra => 1, }, multiple1 => { }, @@ -70,6 +71,7 @@ my $test_accessors = { for my $name (sort keys %$test_accessors) { my $alias = "_${name}_accessor"; my $field = $test_accessors->{$name}{custom_field} || $name; + my $extra = $test_accessors->{$name}{has_extra}; can_ok($class, $name, $alias); ok(!$class->can($field)) @@ -81,7 +83,7 @@ for my $name (sort keys %$test_accessors) { # get/set via name is($class->$name('a'), 'a'); is($class->$name, 'a'); - is($class->{$field}, 'a'); + is($class->{$field}, $extra ? 'a Extra tackled on' : 'a'); # alias gets same as name is($class->$alias, 'a'); @@ -89,7 +91,7 @@ for my $name (sort keys %$test_accessors) { # get/set via alias is($class->$alias('b'), 'b'); is($class->$alias, 'b'); - is($class->{$field}, 'b'); + is($class->{$field}, $extra ? 'b Extra tackled on' : 'b'); # alias gets same as name is($class->$name, 'b'); diff --git a/t/lib/AccessorGroups.pm b/t/lib/AccessorGroups.pm index d728251..240b76d 100644 --- a/t/lib/AccessorGroups.pm +++ b/t/lib/AccessorGroups.pm @@ -7,6 +7,19 @@ __PACKAGE__->mk_group_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/); __PACKAGE__->mk_group_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]); +sub get_simple { + my $v = shift->SUPER::get_simple (@_); + $v =~ s/ Extra tackled on$// if $v; + $v; +} + +sub set_simple { + my ($self, $f, $v) = @_; + $v .= ' Extra tackled on' if $f eq 'singlefield'; + $self->SUPER::set_simple ($f, $v); + $_[2]; +} + sub new { return bless {}, shift; };