[Bast-commits] r9746 - in Class-Accessor-Grouped/trunk: .
lib/Class/Accessor t t/lib
ribasushi at dev.catalyst.perl.org
ribasushi at dev.catalyst.perl.org
Fri Oct 8 15:50:27 GMT 2010
Author: ribasushi
Date: 2010-10-08 16:50:27 +0100 (Fri, 08 Oct 2010)
New Revision: 9746
Modified:
Class-Accessor-Grouped/trunk/Changes
Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm
Class-Accessor-Grouped/trunk/t/accessors.t
Class-Accessor-Grouped/trunk/t/lib/AccessorGroups.pm
Log:
Fix another XSA corner case - how can something so simple get so complex...
Modified: Class-Accessor-Grouped/trunk/Changes
===================================================================
--- Class-Accessor-Grouped/trunk/Changes 2010-10-08 12:20:42 UTC (rev 9745)
+++ Class-Accessor-Grouped/trunk/Changes 2010-10-08 15:50:27 UTC (rev 9746)
@@ -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
Modified: Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm
===================================================================
--- Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm 2010-10-08 12:20:42 UTC (rev 9745)
+++ Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm 2010-10-08 15:50:27 UTC (rev 9746)
@@ -46,12 +46,81 @@
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 @@
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 @@
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 @@
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";
Modified: Class-Accessor-Grouped/trunk/t/accessors.t
===================================================================
--- Class-Accessor-Grouped/trunk/t/accessors.t 2010-10-08 12:20:42 UTC (rev 9745)
+++ Class-Accessor-Grouped/trunk/t/accessors.t 2010-10-08 15:50:27 UTC (rev 9746)
@@ -53,6 +53,7 @@
my $test_accessors = {
singlefield => {
is_xs => $use_xs,
+ has_extra => 1,
},
multiple1 => {
},
@@ -70,6 +71,7 @@
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 @@
# 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 @@
# 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');
Modified: Class-Accessor-Grouped/trunk/t/lib/AccessorGroups.pm
===================================================================
--- Class-Accessor-Grouped/trunk/t/lib/AccessorGroups.pm 2010-10-08 12:20:42 UTC (rev 9745)
+++ Class-Accessor-Grouped/trunk/t/lib/AccessorGroups.pm 2010-10-08 15:50:27 UTC (rev 9746)
@@ -7,6 +7,19 @@
__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;
};
More information about the Bast-commits
mailing list