X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FAccessor%2FGrouped.pm;h=69be59ab962e8537cc33b29aae6aacdbded3e13b;hb=bd9750940ac55f86ffa87313bda265f51990fa4d;hp=f6afab8eb6285633466440bf9695effda512a8cd;hpb=98694bf03648a122590d2c92f8cdde12ea878725;p=p5sagit%2FClass-Accessor-Grouped.git

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index f6afab8..69be59a 100644
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -5,7 +5,7 @@ use Carp ();
 use Scalar::Util ();
 use MRO::Compat;
 
-our $VERSION = '0.09008';
+our $VERSION = '0.09009';
 $VERSION = eval $VERSION;
 
 # when changing minimum version don't forget to adjust L</PERFORMANCE> and
@@ -500,6 +500,7 @@ BEGIN {
   local $@;
   my $err;
 
+
   $err = eval { require Sub::Name; 1; } ? undef : do {
     delete $INC{'Sub/Name.pm'};   # because older perls suck
     $@;
@@ -531,7 +532,21 @@ BEGIN {
     : sub () { 0 }
   ;
 
-};
+
+  *__CAG_UNSTABLE_DOLLARAT = ($] < '5.013002')
+    ? sub () { 1 }
+    : sub () { 0 }
+  ;
+
+
+  *__CAG_TRACK_UNDEFER_FAIL = (
+    $INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'}
+      and
+    $0 =~ m|^ x?t / .+ \.t $|x
+  ) ? sub () { 1 }
+    : sub () { 0 }
+  ;
+}
 
 # Autodetect unless flag supplied
 # Class::XSAccessor is segfaulting on win32, in some
@@ -618,73 +633,104 @@ $gen_accessor = sub {
   # 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;
+
+    my %deferred_calls_seen;
+
+    return sub {
+      my $current_class = Scalar::Util::blessed( $_[0] ) || $_[0];
+
+      if (__CAG_TRACK_UNDEFER_FAIL) {
+        my @cframe = caller(0);
+        if ($deferred_calls_seen{$cframe[3]}) {
+          Carp::carp (
+            "Deferred version of method $cframe[3] invoked more than once (originally "
+          . "invoked at $deferred_calls_seen{$cframe[3]}). This is a strong "
+          . 'indication your code has cached the original ->can derived method coderef, '
+          . 'and is using it instead of the proper method re-lookup, causing performance '
+          . 'regressions'
           );
         }
         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/;
-
-          *$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;
-          });
+          $deferred_calls_seen{$cframe[3]} = "$cframe[1] line $cframe[2]";
+        }
+      }
+
+      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";
         }
 
-        # 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);
-      }}
-    })->();
+        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;
+        });
+      }
+
+      # 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);
+    };
   }
 
   # no Sub::Name - just install the coderefs directly (compiling every time)
   elsif (__CAG_NO_SUBNAME) {
-    my $pp_code = $maker_templates->{$type}{pp_code}->($group, $field);
-    eval "sub ${class}::${methname} { $pp_code }; 1" or die $@;
-    undef;  # so that no attempt will be made to install anything
+    my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
+      $maker_templates->{$type}{pp_code}->($group, $field);
+
+    no warnings 'redefine';
+    local $@ if __CAG_UNSTABLE_DOLLARAT;
+    eval "sub ${class}::${methname} { $src }";
+
+    undef;  # so that no further attempt will be made to install anything
   }
 
   # a coderef generator with a variable pad (returns a fresh cref on every invocation)
   else {
-    ($accessor_maker_cache->{pp}{$group}{$field}{$type} ||= do {
-      my $pp_code = $maker_templates->{$type}{pp_code}->($group, $field);
-      eval "sub { my \$dummy; sub { \$dummy if 0; $pp_code } }" or die $@;
+    ($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do {
+      my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
+        $maker_templates->{$type}{pp_code}->($group, $field);
+
+      local $@ if __CAG_UNSTABLE_DOLLARAT;
+      eval "sub { my \$dummy; sub { \$dummy if 0; $src } }" or die $@;
     })->()
   }
 };