Fix deferred XS accessors and 'around' interaction

diff --git a/Changes b/Changes
index 11f75f6..1f9b72c 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
 Revision history for Class::Accessor::Grouped.
 
+    - Fix grave bug of XS-enabled simple accessors clobbering an
+      existing 'around' overlay installed in the same method slot
+
 0.10001 Sun Dec 12 03:17:05 2010
     - Fix an ActiveState Win32 incompatibility
     - Fix spurious method re-invocation warnings after Class::Unload

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index 3317c16..8bbce64 100644 (file)
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -646,9 +646,72 @@ $gen_accessor = sub {
     die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_NO_CXSA )
       if __CAG_NO_CXSA;
 
-    return sub {
+    my ($expected_cref, $cached_implementation);
+    my $ret = $expected_cref = sub {
       my $current_class = Scalar::Util::blessed( $_[0] ) || $_[0];
 
+      # $cached_implementation will be set only if the shim got
+      # 'around'ed, in which case it is handy to avoid re-running
+      # this block over and over again
+      my $resolved_implementation = $cached_implementation->{$current_class} || do {
+        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! :)
+          #
+          # The weird breeder thingy is because XSA does not have an
+          # interface returning *just* a coderef, without installing it
+          # anywhere :(
+          Class::XSAccessor->import(
+            replace => 1,
+            class => '__CAG__XSA__BREEDER__',
+            $maker_templates->{$type}{xs_call} => {
+              $methname => $field,
+            },
+          );
+          __CAG__XSA__BREEDER__->can($methname);
+        }
+        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";
+          }
+
+          do {
+            # that's faster than local
+            $USE_XS = 0;
+            my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);
+            $USE_XS = 1;
+            $c;
+          };
+        }
+      };
+
+      # if after this shim was created someone wrapped it with an 'around',
+      # we can not blindly reinstall the method slot - we will destroy the
+      # wrapper. Silently chain execution further...
+      if ($expected_cref != $current_class->can($methname)) {
+
+        # there is no point in re-determining it on every subsequent call,
+        # just store for future reference
+        $cached_implementation->{$current_class} ||= $resolved_implementation;
+
+        # older perls segfault if the cref behind the goto throws
+        # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
+        return $resolved_implementation->(@_) if __CAG_BROKEN_GOTO;
+
+        goto $resolved_implementation;
+      }
+
       if (__CAG_TRACK_UNDEFER_FAIL) {
         my $deferred_calls_seen = do {
           no strict 'refs';
@@ -668,52 +731,31 @@ $gen_accessor = sub {
         }
       }
 
-      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";
-        }
-
+      # install the resolved implementation into the code slot so we do not
+      # come here anymore (hopefully)
+      # since XSAccessor was available - so is Sub::Name
+      {
         no strict 'refs';
         no warnings 'redefine';
 
         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;
-        });
+        *$fq_name = Sub::Name::subname($fq_name, $resolved_implementation);
+
+        # need to update what the shim expects too *in case* its
+        # ->can was cached for some moronic reason
+        $expected_cref = $resolved_implementation;
+        Scalar::Util::weaken($expected_cref);
       }
 
       # 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;
+      return $resolved_implementation->(@_) if __CAG_BROKEN_GOTO;
 
-      goto $current_class->can($methname);
+      goto $resolved_implementation;
     };
+
+    Scalar::Util::weaken($expected_cref); # to break the self-reference
+    $ret;
   }
 
   # no Sub::Name - just install the coderefs directly (compiling every time)

diff --git a/t/accessors.t b/t/accessors.t
index c04ece2..cf219b0 100644 (file)
--- a/t/accessors.t
+++ b/t/accessors.t
@@ -1,4 +1,4 @@
-use Test::More tests => 98;
+use Test::More tests => 117;
 use strict;
 use warnings;
 use lib 't/lib';
@@ -45,6 +45,12 @@ my $test_accessors = {
         is_xs => $use_xs,
         has_extra => 1,
     },
+    runtime_around => {
+        # even though this accessor is simple it will *not* be XSified
+        # due to the runtime 'around'
+        is_xs => 0,
+        has_extra => 1,
+    },
     multiple1 => {
     },
     multiple2 => {

diff --git a/t/lib/AccessorGroups.pm b/t/lib/AccessorGroups.pm
index b7188e9..3d0685b 100644 (file)
--- a/t/lib/AccessorGroups.pm
+++ b/t/lib/AccessorGroups.pm
@@ -17,6 +17,7 @@ use base 'Class::Accessor::Grouped';
 __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/]);
+__PACKAGE__->mk_group_accessors('simple', 'runtime_around');
 
 sub get_simple {
   my $v = shift->SUPER::get_simple (@_);
@@ -31,6 +32,30 @@ sub set_simple {
   $_[2];
 }
 
+# a runtime Class::Method::Modifiers style around
+# the eval/our combo is so that we do not need to rely on Sub::Name being available
+my $orig_ra_cref = __PACKAGE__->can('runtime_around');
+our $around_cref = sub {
+  my $self = shift;
+  if (@_) {
+    my $val = shift;
+    $self->$orig_ra_cref($val . ' Extra tackled on');
+    $val;
+  }
+  else {
+    my $val = $self->$orig_ra_cref;
+    $val =~ s/ Extra tackled on$// if defined $val;
+    $val;
+  }
+};
+{
+  no warnings qw/redefine/;
+  eval <<'EOE';
+    sub AccessorGroups::runtime_around { goto $AccessorGroups::around_cref };
+    sub AccessorGroups::_runtime_around_accessor { goto $AccessorGroups::around_cref };
+EOE
+}
+
 sub new {
     return bless {}, shift;
 };