Fix another XSA corner case - how can something so simple get so complex...

diff --git a/Changes b/Changes
index 8005a2b..405b30e 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;
 };