[Bast-commits] r9794 - in Class-Accessor-Grouped/trunk: .
lib/Class/Accessor t t/lib
ribasushi at dev.catalyst.perl.org
ribasushi at dev.catalyst.perl.org
Thu Nov 25 14:22:45 GMT 2010
Author: ribasushi
Date: 2010-11-25 14:22:45 +0000 (Thu, 25 Nov 2010)
New Revision: 9794
Added:
Class-Accessor-Grouped/trunk/t/accessors_pp.t
Modified:
Class-Accessor-Grouped/trunk/Makefile.PL
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:
Major revamp of CAG internals - now works on pure-perl
Modified: Class-Accessor-Grouped/trunk/Makefile.PL
===================================================================
--- Class-Accessor-Grouped/trunk/Makefile.PL 2010-11-14 19:04:46 UTC (rev 9793)
+++ Class-Accessor-Grouped/trunk/Makefile.PL 2010-11-25 14:22:45 UTC (rev 9794)
@@ -5,17 +5,23 @@
name 'Class-Accessor-Grouped';
license 'perl';
-perl_version '5.006001';
+perl_version '5.006002';
all_from 'lib/Class/Accessor/Grouped.pm';
requires 'Carp';
requires 'Scalar::Util';
requires 'MRO::Compat';
requires 'Class::Inspector';
-requires 'Sub::Name' => '0.04';
+if (can_cc or $Module::Install::AUTHOR) {
+ requires 'Sub::Name' => '0.05';
+
+ requires 'Class::XSAccessor' => '1.06'
+ if ($^O ne 'MSWin32' and $] > '5.008');
+}
+
test_requires 'Test::More' => '0.94';
-test_requires 'Test::Exception';
+test_requires 'Test::Exception' => '0.31';
clean_files "Class-Accessor-Grouped-* t/var";
@@ -30,3 +36,13 @@
'http://dev.catalyst.perl.org/repos/bast/Class-Accessor-Grouped/trunk';
WriteAll;
+use Data::Dumper;
+if ($Module::Install::AUTHOR) {
+ @{Meta->{values}{requires}} = grep
+ { $_->[0] !~ /^ (?: Class\:\:XSAccessor | Sub\:\:Name ) $/x }
+ @{Meta->{values}{requires}}
+ ;
+ print "Regenerating META with XS requires excluded\n";
+ Meta->write;
+}
+
Modified: Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm
===================================================================
--- Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm 2010-11-14 19:04:46 UTC (rev 9793)
+++ Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm 2010-11-25 14:22:45 UTC (rev 9794)
@@ -4,13 +4,16 @@
use Carp ();
use Scalar::Util ();
use MRO::Compat;
-use Sub::Name ();
our $VERSION = '0.09008';
$VERSION = eval $VERSION;
-# when changing minimum version don't forget to adjust L</PERFROMANCE> as well
-our $__minimum_xsa_version = '1.06';
+# when changing minimum version don't forget to adjust L</PERFORMANCE> and
+# the Makefile.PL as well
+our $__minimum_xsa_version;
+BEGIN {
+ $__minimum_xsa_version = '1.06';
+}
our $USE_XS;
# the unless defined is here so that we can override the value
@@ -18,127 +21,8 @@
$USE_XS = $ENV{CAG_USE_XS}
unless defined $USE_XS;
-my ($xsa_loaded, $xsa_autodetected);
-
-my $load_xsa = sub {
- return if $xsa_loaded++;
- require Class::XSAccessor;
- Class::XSAccessor->VERSION($__minimum_xsa_version);
-};
-
-my $use_xs = sub {
- if (defined $USE_XS) {
- $load_xsa->() if ($USE_XS && ! $xsa_loaded);
- return $USE_XS;
- }
-
- $xsa_autodetected = 1;
- $USE_XS = 0;
-
- # Class::XSAccessor is segfaulting on win32, in some
- # esoteric heavily-threaded scenarios
- # Win32 users can set $USE_XS/CAG_USE_XS to try to use it anyway
- if ($^O ne 'MSWin32') {
- local $@;
- eval { $load_xsa->(); $USE_XS = 1 };
- }
-
- 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,
- class => $class,
- $maker_type_map->{$type}{xsa} => {
- $name => $field,
- },
- });
-
- 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 = Scalar::Util::blessed( $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
- #
- # 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! :)
- $final_cref = $xs_cref;
- }
- else {
- $final_cref = $pp_cref;
- if ($USE_XS and ! $xsa_autodetected and ! $no_xsa_classes_warned->{$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_$group and/or set_$group\n";
- }
- }
-
- # installing an XSA cref that was originally created on a class
- # different than $current_class is perfectly safe as per
- # C::XSA's author
- my $fq_meth = "${current_class}::${name}";
-
- no strict qw/refs/;
- no warnings qw/redefine/;
-
- *$fq_meth = Sub::Name::subname($fq_meth, $final_cref);
-
- # older perls segfault if the cref behind the goto throws
- # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
- return $final_cref->(@_) if ($] < 5.008009);
-
- goto $final_cref;
- };
-};
-
# Yes this method is undocumented
-# Yes it should be a private coderef like the one above it
+# Yes it should be a private coderef like all the rest at the end of this file
# No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
# %$*@!?&!&#*$!!!
sub _mk_group_accessors {
@@ -149,7 +33,7 @@
no warnings 'redefine';
# So we don't have to do lots of lookups inside the loop.
- $maker = $self->can($maker) unless ref $maker eq 'CODE';
+ $maker = $self->can($maker) unless ref $maker;
foreach (@fields) {
if( $_ eq 'DESTROY' ) {
@@ -167,11 +51,11 @@
for my $meth ($name, $alias) {
# the maker may elect to not return anything, meaning it already
- # installed the coderef for us
+ # installed the coderef for us (e.g. lack of Sub::Name)
my $cref = $self->$maker($group, $field, $meth)
or next;
- my $fq_meth = join('::', $class, $meth);
+ my $fq_meth = "${class}::${meth}";
*$fq_meth = Sub::Name::subname($fq_meth, $cref);
#unless defined &{$class."\:\:$field"}
@@ -179,6 +63,8 @@
}
};
+# coderef is setup at the end for clarity
+my $gen_accessor;
=head1 NAME
@@ -219,10 +105,10 @@
=cut
sub mk_group_accessors {
- my ($self, $group, @fields) = @_;
+ my ($self, $group, @fields) = @_;
- $self->_mk_group_accessors('make_group_accessor', $group, @fields);
- return;
+ $self->_mk_group_accessors('make_group_accessor', $group, @fields);
+ return;
}
=head2 mk_group_ro_accessors
@@ -285,32 +171,8 @@
=cut
-sub make_group_accessor {
- my ($class, $group, $field, $name) = @_;
+sub make_group_accessor { $gen_accessor->('rw', @_) }
- if ( $group eq 'simple' && $use_xs->() ) {
- return $add_xs_accessor->(@_, 'rw');
- }
-
- my $set = "set_$group";
- my $get = "get_$group";
-
- $field =~ s/'/\\'/g;
-
- # eval for faster fastiness
- my $code = eval "sub {
- if(\@_ > 1) {
- return shift->$set('$field', \@_);
- }
- else {
- return shift->$get('$field');
- }
- };";
- Carp::croak $@ if $@;
-
- return $code;
-}
-
=head2 make_group_ro_accessor
=over 4
@@ -327,32 +189,8 @@
=cut
-sub make_group_ro_accessor {
- my($class, $group, $field, $name) = @_;
+sub make_group_ro_accessor { $gen_accessor->('ro', @_) }
- if ( $group eq 'simple' && $use_xs->() ) {
- return $add_xs_accessor->(@_, 'ro');
- }
-
- my $get = "get_$group";
-
- $field =~ s/'/\\'/g;
-
- my $code = eval "sub {
- if(\@_ > 1) {
- my \$caller = caller;
- Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
- \"objects of class '$class'\");
- }
- else {
- return shift->$get('$field');
- }
- };";
- Carp::croak $@ if $@;
-
- return $code;
-}
-
=head2 make_group_wo_accessor
=over 4
@@ -369,32 +207,8 @@
=cut
-sub make_group_wo_accessor {
- my($class, $group, $field, $name) = @_;
+sub make_group_wo_accessor { $gen_accessor->('wo', @_) }
- if ( $group eq 'simple' && $use_xs->() ) {
- return $add_xs_accessor->(@_, 'wo')
- }
-
- my $set = "set_$group";
-
- $field =~ s/'/\\'/g;
-
- my $code = eval "sub {
- unless (\@_ > 1) {
- my \$caller = caller;
- Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
- \"objects of class '$class'\");
- }
- else {
- return shift->$set('$field', \@_);
- }
- };";
- Carp::croak $@ if $@;
-
- return $code;
-}
-
=head2 get_simple
=over 4
@@ -411,7 +225,7 @@
=cut
sub get_simple {
- return $_[0]->{$_[1]};
+ return $_[0]->{$_[1]};
}
=head2 set_simple
@@ -430,7 +244,7 @@
=cut
sub set_simple {
- return $_[0]->{$_[1]} = $_[2];
+ return $_[0]->{$_[1]} = $_[2];
}
@@ -571,7 +385,7 @@
local $^W = 0;
require Class::Inspector;
if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
- eval "use $_[2]";
+ eval "require $_[2]";
Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
};
@@ -590,8 +404,6 @@
return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
};
-1;
-
=head1 PERFORMANCE
To provide total flexibility L<Class::Accessor::Grouped> calls methods
@@ -669,3 +481,211 @@
it under the same terms as perl itself.
=cut
+
+########################################################################
+########################################################################
+########################################################################
+#
+# Here be many angry dragons
+# (all code is in private coderefs since everything inherits CAG)
+#
+########################################################################
+########################################################################
+
+BEGIN {
+
+ die "Huh?! No minimum C::XSA version?!\n"
+ unless $__minimum_xsa_version;
+
+ local $@;
+ my $err;
+
+ $err = eval { require Sub::Name; 1; } ? undef : do {
+ delete $INC{'Sub/Name.pm'}; # because older perls suck
+ $@;
+ };
+ *__CAG_NO_SUBNAME = $err
+ ? sub () { $err }
+ : sub () { 0 }
+ ;
+
+
+ $err = eval {
+ require Class::XSAccessor;
+ Class::XSAccessor->VERSION($__minimum_xsa_version);
+ require Sub::Name;
+ 1;
+ } ? undef : do {
+ delete $INC{'Sub/Name.pm'}; # because older perls suck
+ delete $INC{'Class/XSAccessor.pm'};
+ $@;
+ };
+ *__CAG_NO_CXSA = $err
+ ? sub () { $err }
+ : sub () { 0 }
+ ;
+
+
+ *__CAG_BROKEN_GOTO = ($] < '5.008009')
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+
+};
+
+# Autodetect unless flag supplied
+# Class::XSAccessor is segfaulting on win32, in some
+# esoteric heavily-threaded scenarios
+# Win32 users can set $USE_XS/CAG_USE_XS to try to use it anyway
+my $xsa_autodetected;
+if (! defined $USE_XS) {
+ $USE_XS = (!__CAG_NO_CXSA and $^O ne 'MSWin32') ? 1 : 0;
+ $xsa_autodetected++;
+}
+
+my $maker_templates = {
+ rw => {
+ xs_call => 'accessors',
+ pp_code => sub {
+ my $set = "set_$_[1]";
+ my $get = "get_$_[1]";
+ my $field = $_[2];
+ $field =~ s/'/\\'/g;
+
+ "
+ \@_ > 1
+ ? shift->$set('$field', \@_)
+ : shift->$get('$field')
+ "
+ },
+ },
+ ro => {
+ xs_call => 'getters',
+ pp_code => sub {
+ my $get = "get_$_[1]";
+ my $field = $_[2];
+ $field =~ s/'/\\'/g;
+
+ "
+ \@_ == 1
+ ? shift->$get('$field')
+ : do {
+ my \$caller = caller;
+ Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
+ \"objects of class '$_[0]'\");
+ }
+ "
+ },
+ },
+ wo => {
+ xs_call => 'setters',
+ pp_code => sub {
+ my $set = "set_$_[1]";
+ my $field = $_[2];
+ $field =~ s/'/\\'/g;
+
+ "
+ \@_ > 1
+ ? shift->$set('$field', \@_)
+ : do {
+ my \$caller = caller;
+ Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
+ \"objects of class '$_[0]'\");
+ }
+ "
+ },
+ },
+};
+
+
+my ($accessor_maker_cache, $no_xsa_warned_classes);
+
+# can't use pkg_gen to track this stuff, as it doesn't
+# detect superclass mucking
+my $original_simple_getter = __PACKAGE__->can ('get_simple');
+my $original_simple_setter = __PACKAGE__->can ('set_simple');
+
+# Note!!! Unusual signature
+$gen_accessor = sub {
+ my ($type, $class, $group, $field, $methname) = @_;
+ if (my $c = ref $class) {
+ $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
+ 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,
+ },
+ );
+ }
+ 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;
+ });
+ }
+
+ # 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}->($class, $group, $field);
+ eval "sub ${class}::${methname} { $pp_code }; 1" or die $@;
+ undef; # so that no attempt will be made to install anything
+ }
+
+ # a coderef generator with a variable pad (returns a fresh cref on every invocation)
+ # also since it is much simpler than the xs one it needs less cache-keys
+ else {
+ ($accessor_maker_cache->{pp}{$field}{$type} ||= do {
+ my $pp_code = $maker_templates->{$type}{pp_code}->($class, $group, $field);
+ eval "sub { my \$dummy; sub { \$dummy if 0; $pp_code } }" or die $@;
+ })->()
+ }
+};
+
+1;
Modified: Class-Accessor-Grouped/trunk/t/accessors.t
===================================================================
--- Class-Accessor-Grouped/trunk/t/accessors.t 2010-11-14 19:04:46 UTC (rev 9793)
+++ Class-Accessor-Grouped/trunk/t/accessors.t 2010-11-25 14:22:45 UTC (rev 9794)
@@ -1,4 +1,4 @@
-use Test::More tests => 62;
+use Test::More tests => 98;
use strict;
use warnings;
use lib 't/lib';
@@ -24,12 +24,6 @@
my $name = 'multiple1';
my $alias = "_${name}_accessor";
- for my $meth ($name, $alias) {
- my $cv = svref_2object( $obj->can($meth) );
- is($cv->GV->NAME, $meth, "$meth accessor is named");
- is($cv->GV->STASH->NAME, 'AccessorGroups', "$meth class correct");
- }
-
my $warned = 0;
local $SIG{__WARN__} = sub {
if (shift =~ /DESTROY/i) {
@@ -44,7 +38,6 @@
ok($warned);
};
-
my $obj = AccessorGroupsSubclass->new;
my $test_accessors = {
@@ -64,7 +57,6 @@
},
};
-
for my $name (sort keys %$test_accessors) {
my $alias = "_${name}_accessor";
my $field = $test_accessors->{$name}{custom_field} || $name;
@@ -74,6 +66,12 @@
ok(!$obj->can($field))
if $field ne $name;
+ for my $meth ($name, $alias) {
+ my $cv = svref_2object( $obj->can($meth) );
+ is($cv->GV->NAME, $meth, "$meth accessor is named");
+ is($cv->GV->STASH->NAME, 'AccessorGroups', "$meth class correct");
+ }
+
is($obj->$name, undef);
is($obj->$alias, undef);
@@ -92,6 +90,12 @@
# alias gets same as name
is($obj->$name, 'b');
+
+ 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");
+ }
};
# important
Added: Class-Accessor-Grouped/trunk/t/accessors_pp.t
===================================================================
--- Class-Accessor-Grouped/trunk/t/accessors_pp.t (rev 0)
+++ Class-Accessor-Grouped/trunk/t/accessors_pp.t 2010-11-25 14:22:45 UTC (rev 9794)
@@ -0,0 +1,40 @@
+use strict;
+use warnings;
+use FindBin qw($Bin);
+use File::Spec::Functions;
+use File::Spec::Unix (); # need this for %INC munging
+use Test::More;
+use lib 't/lib';
+
+BEGIN {
+ eval { require Devel::Hide };
+ if ($@) {
+ eval { require Sub::Name };
+ plan skip_all => "Devel::Hide required for this test in presence of Sub::Name"
+ if ! $@;
+ }
+ else {
+ Devel::Hide->import('Sub/Name.pm');
+ }
+ require Class::Accessor::Grouped;
+}
+
+# rerun the regular 3 tests under the assumption of no Sub::Name
+for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) {
+
+ subtest "$tname without Sub::Name (pass $_)" => sub {
+ my $tfn = catfile($Bin, $tname);
+
+ delete $INC{$_} for (
+ qw/AccessorGroups.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsWO.pm/,
+ File::Spec::Unix->catfile ($tfn),
+ );
+
+ local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /subroutine .+ redefined/i };
+
+ do($tfn);
+
+ } for (1 .. 2);
+}
+
+done_testing;
Modified: Class-Accessor-Grouped/trunk/t/lib/AccessorGroups.pm
===================================================================
--- Class-Accessor-Grouped/trunk/t/lib/AccessorGroups.pm 2010-11-14 19:04:46 UTC (rev 9793)
+++ Class-Accessor-Grouped/trunk/t/lib/AccessorGroups.pm 2010-11-25 14:22:45 UTC (rev 9794)
@@ -1,3 +1,15 @@
+{
+ package AccessorGroups::BeenThereDoneThat;
+
+ use strict;
+ use warnings;
+ use base 'Class::Accessor::Grouped';
+
+ __PACKAGE__->mk_group_accessors('simple', 'singlefield');
+ __PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/);
+}
+
+
package AccessorGroups;
use strict;
use warnings;
@@ -2,3 +14,2 @@
use base 'Class::Accessor::Grouped';
-
__PACKAGE__->mk_group_accessors('simple', 'singlefield');
More information about the Bast-commits
mailing list