From: Christopher H. Laco Date: Wed, 8 Jul 2009 02:24:06 +0000 (+0000) Subject: Use Class::XSAccessor if available RT#45577, AGRUNDMA X-Git-Tag: v0.09004~21 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9540f4e48444e779e875f193db7cf234c3cd8b40;p=p5sagit%2FClass-Accessor-Grouped.git Use Class::XSAccessor if available RT#45577, AGRUNDMA --- diff --git a/Changes b/Changes index 58a5736..5a7af73 100644 --- a/Changes +++ b/Changes @@ -1,7 +1,8 @@ Revision history for Class::Accessor::Grouped. -0.08004 +0.08999_01 Tue July 7 22:06:21 2009 - Make _mk_group_accessors name the closures installed for Moose compat + - Use Class::XSAccessor if available RT#45577, AGRUNDMA 0.08003 Sat Mar 21 9:27:24 2009 - Fixed set_inherited under C3::Componentised: RT#43702, RIBASUSHI diff --git a/Makefile.PL b/Makefile.PL index 8b78312..102b106 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -14,6 +14,11 @@ requires 'MRO::Compat'; requires 'Class::Inspector'; requires 'Sub::Name' => '0.04'; +feature 'XS Accessor Support', + -default => 0, + 'Class::XSAccessor' => 0; + + test_requires 'Sub::Identify'; clean_files "Class-Accessor-Grouped-* t/var"; diff --git a/README b/README index 2f08e17..2c22a31 100644 --- a/README +++ b/README @@ -132,6 +132,10 @@ AUTHORS Matt S. Trout Christopher H. Laco + With contributions from: + + Guillermo Roditi + LICENSE You may distribute this code under the same terms as Perl itself. diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm index 9bd5372..a14e57c 100644 --- a/lib/Class/Accessor/Grouped.pm +++ b/lib/Class/Accessor/Grouped.pm @@ -7,7 +7,23 @@ use Scalar::Util (); use MRO::Compat; use Sub::Name (); -our $VERSION = '0.08004'; +our $VERSION = '0.08999_01'; + +BEGIN { + our $hasXS; + + sub _hasXS { + return $hasXS if defined $hasXS; + + $hasXS = 0; + eval { + require Class::XSAccessor; + $hasXS = 1; + }; + + return $hasXS; + } +} =head1 NAME @@ -65,6 +81,8 @@ sub mk_group_accessors { # So we don't have to do lots of lookups inside the loop. $maker = $self->can($maker) unless ref $maker; + + my $hasXS = _hasXS(); foreach my $field (@fields) { if( $field eq 'DESTROY' ) { @@ -75,18 +93,27 @@ sub mk_group_accessors { my $name = $field; ($name, $field) = @$field if ref $field; - - my $accessor = $self->$maker($group, $field); - my $alias_accessor = $self->$maker($group, $field); - + my $alias = "_${name}_accessor"; my $full_name = join('::', $class, $name); my $full_alias = join('::', $class, $alias); - - *$full_name = Sub::Name::subname($full_name, $accessor); - #unless defined &{$class."\:\:$field"} - *$full_alias = Sub::Name::subname($full_alias, $alias_accessor); - #unless defined &{$class."\:\:$alias"} + + if ( $hasXS && $group eq 'simple' ) { + Class::XSAccessor::newxs_accessor("${class}::${name}", $field, 0); + Class::XSAccessor::newxs_accessor("${class}::${alias}", $field, 0); + + # XXX: is the alias accessor really necessary? + } + else { + my $accessor = $self->$maker($group, $field); + my $alias_accessor = $self->$maker($group, $field); + + *$full_name = Sub::Name::subname($full_name, $accessor); + #unless defined &{$class."\:\:$field"} + + *$full_alias = Sub::Name::subname($full_alias, $alias_accessor); + #unless defined &{$class."\:\:$alias"} + } } } } diff --git a/t/accessors.t b/t/accessors.t index 1703e12..ddd5aa4 100644 --- a/t/accessors.t +++ b/t/accessors.t @@ -2,9 +2,15 @@ use Test::More tests => 62; use strict; use warnings; use lib 't/lib'; -use AccessorGroups; use Sub::Identify qw/sub_name sub_fullname/;; +BEGIN { + # Disable XSAccessor to test pure-Perl accessors + $Class::Accessor::Grouped::hasXS = 0; + + require AccessorGroups; +} + my $class = AccessorGroups->new; { @@ -90,3 +96,6 @@ foreach (qw/lr1 lr2/) { # alias gets same as name is($class->$name, 'd'); }; + +1; + diff --git a/t/accessors_xs.t b/t/accessors_xs.t new file mode 100644 index 0000000..68091a2 --- /dev/null +++ b/t/accessors_xs.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use FindBin qw($Bin); +use File::Spec::Functions; +use Test::More; +use lib 't/lib'; + +BEGIN { + # Enable XSAccessor check + $Class::Accessor::Grouped::hasXS = undef; + + require AccessorGroups; +} + +plan skip_all => 'Class::XSAccessor not available' + unless Class::Accessor::Grouped::_hasXS(); + +require( catfile($Bin, 'accessors.t') ); \ No newline at end of file diff --git a/t/lib/AccessorGroups.pm b/t/lib/AccessorGroups.pm index 3a31fdd..52dabe4 100644 --- a/t/lib/AccessorGroups.pm +++ b/t/lib/AccessorGroups.pm @@ -3,20 +3,13 @@ use strict; use warnings; use base 'Class::Accessor::Grouped'; -__PACKAGE__->mk_group_accessors('single', 'singlefield'); -__PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/); -__PACKAGE__->mk_group_accessors('listref', [qw/lr1name lr1field/], [qw/lr2name lr2field/]); +__PACKAGE__->mk_group_accessors('simple', 'singlefield'); +__PACKAGE__->mk_group_accessors('simple', qw/multiple1 multiple2/); +__PACKAGE__->mk_group_accessors('simple', [qw/lr1name lr1field/], [qw/lr2name lr2field/]); __PACKAGE__->mk_group_accessors('component_class', 'result_class'); sub new { return bless {}, shift; }; -foreach (qw/single multiple listref/) { - no strict 'refs'; - - *{"get_$_"} = \&Class::Accessor::Grouped::get_simple; - *{"set_$_"} = \&Class::Accessor::Grouped::set_simple; -}; - 1; diff --git a/t/pod_spelling.t b/t/pod_spelling.t index e987230..ecae4e4 100644 --- a/t/pod_spelling.t +++ b/t/pod_spelling.t @@ -22,6 +22,7 @@ all_pod_files_spelling_ok(); __DATA__ Bowden Raygun +Roditi isa mst behaviour