Use Class::XSAccessor if available RT#45577, AGRUNDMA

diff --git a/Changes b/Changes
index 58a5736..5a7af73 100644 (file)
--- 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 (file)
--- 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 (file)
--- a/README
+++ b/README
@@ -132,6 +132,10 @@ AUTHORS
     Matt S. Trout <mst@shadowcatsystems.co.uk> Christopher H. Laco
     <claco@chrislaco.com>
 
+    With contributions from:
+
+    Guillermo Roditi <groditi@cpan.org>
+
 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 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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 (file)
--- 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