From: Peter Rabbitson Date: Fri, 26 Nov 2010 01:29:33 +0000 (+0000) Subject: Even more corner case fixes - install the resolved final cref into the callER, not... X-Git-Tag: v0.09009~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FClass-Accessor-Grouped.git;a=commitdiff_plain;h=f7cf686751b8f117429990e7aac90a74a63b087a Even more corner case fixes - install the resolved final cref into the callER, not the original method source --- diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm index 375a4eb..5a441ff 100644 --- a/lib/Class/Accessor/Grouped.pm +++ b/lib/Class/Accessor/Grouped.pm @@ -537,8 +537,7 @@ BEGIN { ? sub () { 1 } : sub () { 0 } ; - -}; +} # Autodetect unless flag supplied # Class::XSAccessor is segfaulting on win32, in some @@ -621,65 +620,67 @@ $gen_accessor = sub { $class = $c; } - # 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 + # + # Also note that the *original* class will always retain this shim, as + # different branches inheriting from it may have different overrides. + # Thus the final method (properly labeled and all) is installed in the + # calling-package's namespace if ($USE_XS and $group eq 'simple') { - my $fq_name = "${class}::${methname}"; - ($accessor_maker_cache->{xs}{$field}{$type}{$fq_name} ||= do { - die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_NO_CXSA ) - if __CAG_NO_CXSA; - - - sub { sub { - my $current_class = Scalar::Util::blessed( $_[0] ) || $_[0]; - - if ( - $current_class->can('get_simple') == $original_simple_getter - && - $current_class->can('set_simple') == $original_simple_setter - ) { - # nothing has changed, might as well use the XS crefs - # - # note that by the time this code executes, we already have - # *objects* (since XSA works on 'simple' only by definition). - # If someone is mucking with the symbol table *after* there - # are some objects already - look! many, shiny pieces! :) - Class::XSAccessor->import( - replace => 1, - class => $class, - $maker_templates->{$type}{xs_call} => { - $methname => $field, - }, - ); + die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_NO_CXSA ) + if __CAG_NO_CXSA; + + return sub { + my $current_class = Scalar::Util::blessed( $_[0] ) || $_[0]; + + if ( + $current_class->can('get_simple') == $original_simple_getter + && + $current_class->can('set_simple') == $original_simple_setter + ) { + # nothing has changed, might as well use the XS crefs + # + # note that by the time this code executes, we already have + # *objects* (since XSA works on 'simple' only by definition). + # If someone is mucking with the symbol table *after* there + # are some objects already - look! many, shiny pieces! :) + Class::XSAccessor->import( + replace => 1, + class => $current_class, + $maker_templates->{$type}{xs_call} => { + $methname => $field, + }, + ); + } + else { + if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) { + # not using Carp since the line where this happens doesn't mean much + warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class ' + . "'$current_class' inheriting from '$class' due to an overriden get_simple and/or " + . "set_simple\n"; } - else { - if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) { - # not using Carp since the line where this happens doesn't mean much - warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class ' - . "'$current_class' due to an overriden get_simple and/or set_simple\n"; - } - no strict qw/refs/; + no strict qw/refs/; - *$fq_name = Sub::Name::subname($fq_name, do { - # that's faster than local - $USE_XS = 0; - my $c = $gen_accessor->($type, $class, 'simple', $field, $methname); - $USE_XS = 1; - $c; - }); - } + my $fq_name = "${current_class}::${methname}"; + *$fq_name = Sub::Name::subname($fq_name, do { + # that's faster than local + $USE_XS = 0; + my $c = $gen_accessor->($type, $class, 'simple', $field, $methname); + $USE_XS = 1; + $c; + }); + } - # older perls segfault if the cref behind the goto throws - # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878 - return $current_class->can($methname)->(@_) if __CAG_BROKEN_GOTO; + # older perls segfault if the cref behind the goto throws + # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878 + return $current_class->can($methname)->(@_) if __CAG_BROKEN_GOTO; - goto $current_class->can($methname); - }} - })->(); + goto $current_class->can($methname); + }; } # no Sub::Name - just install the coderefs directly (compiling every time) diff --git a/t/accessors.t b/t/accessors.t index 7432c0c..c04ece2 100644 --- a/t/accessors.t +++ b/t/accessors.t @@ -94,7 +94,12 @@ for my $name (sort keys %$test_accessors) { for my $meth ($name, $alias) { my $cv = svref_2object( $obj->can($meth) ); is($cv->GV->NAME, $meth, "$meth accessor is named after operations"); - is($cv->GV->STASH->NAME, 'AccessorGroups', "$meth class correct after operations"); + is( + $cv->GV->STASH->NAME, + # XS lazyinstalls install into each caller, not into the original parent + $test_accessors->{$name}{is_xs} ? 'AccessorGroupsSubclass' :'AccessorGroups', + "$meth class correct after operations", + ); } }; diff --git a/t/accessors_xs.t b/t/accessors_xs.t index fdd251e..4694f84 100644 --- a/t/accessors_xs.t +++ b/t/accessors_xs.t @@ -24,10 +24,16 @@ for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) { subtest "$tname with USE_XS (pass $_)" => sub { my $tfn = catfile($Bin, $tname); - delete $INC{$_} for ( + for ( qw/AccessorGroups.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsWO.pm/, File::Spec::Unix->catfile ($tfn), - ); + ) { + delete $INC{$_}; + no strict 'refs'; + if (my ($mod) = $_ =~ /(.+)\.pm$/ ) { + %{"${mod}::"} = (); + } + } local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /subroutine .+ redefined/i };