[Bast-commits] r7003 - in trunk/Class-Accessor-Grouped: . lib/Class/Accessor t t/lib

claco at dev.catalyst.perl.org claco at dev.catalyst.perl.org
Wed Jul 8 02:24:07 GMT 2009


Author: claco
Date: 2009-07-08 02:24:06 +0000 (Wed, 08 Jul 2009)
New Revision: 7003

Added:
   trunk/Class-Accessor-Grouped/t/accessors_xs.t
Modified:
   trunk/Class-Accessor-Grouped/Changes
   trunk/Class-Accessor-Grouped/Makefile.PL
   trunk/Class-Accessor-Grouped/README
   trunk/Class-Accessor-Grouped/lib/Class/Accessor/Grouped.pm
   trunk/Class-Accessor-Grouped/t/accessors.t
   trunk/Class-Accessor-Grouped/t/lib/AccessorGroups.pm
   trunk/Class-Accessor-Grouped/t/pod_spelling.t
Log:
Use Class::XSAccessor if available RT#45577, AGRUNDMA

Modified: trunk/Class-Accessor-Grouped/Changes
===================================================================
--- trunk/Class-Accessor-Grouped/Changes	2009-07-07 18:47:20 UTC (rev 7002)
+++ trunk/Class-Accessor-Grouped/Changes	2009-07-08 02:24:06 UTC (rev 7003)
@@ -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

Modified: trunk/Class-Accessor-Grouped/Makefile.PL
===================================================================
--- trunk/Class-Accessor-Grouped/Makefile.PL	2009-07-07 18:47:20 UTC (rev 7002)
+++ trunk/Class-Accessor-Grouped/Makefile.PL	2009-07-08 02:24:06 UTC (rev 7003)
@@ -14,6 +14,11 @@
 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";

Modified: trunk/Class-Accessor-Grouped/README
===================================================================
--- trunk/Class-Accessor-Grouped/README	2009-07-07 18:47:20 UTC (rev 7002)
+++ trunk/Class-Accessor-Grouped/README	2009-07-08 02:24:06 UTC (rev 7003)
@@ -132,6 +132,10 @@
     Matt S. Trout <mst at shadowcatsystems.co.uk> Christopher H. Laco
     <claco at chrislaco.com>
 
+    With contributions from:
+
+    Guillermo Roditi <groditi at cpan.org>
+
 LICENSE
     You may distribute this code under the same terms as Perl itself.
 

Modified: trunk/Class-Accessor-Grouped/lib/Class/Accessor/Grouped.pm
===================================================================
--- trunk/Class-Accessor-Grouped/lib/Class/Accessor/Grouped.pm	2009-07-07 18:47:20 UTC (rev 7002)
+++ trunk/Class-Accessor-Grouped/lib/Class/Accessor/Grouped.pm	2009-07-08 02:24:06 UTC (rev 7003)
@@ -7,8 +7,24 @@
 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
 
 Class::Accessor::Grouped - Lets you build groups of accessors
@@ -65,6 +81,8 @@
 
         # 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 @@
             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"}
+            }
         }
     }
 }

Modified: trunk/Class-Accessor-Grouped/t/accessors.t
===================================================================
--- trunk/Class-Accessor-Grouped/t/accessors.t	2009-07-07 18:47:20 UTC (rev 7002)
+++ trunk/Class-Accessor-Grouped/t/accessors.t	2009-07-08 02:24:06 UTC (rev 7003)
@@ -2,9 +2,15 @@
 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 @@
     # alias gets same as name
     is($class->$name, 'd');
 };
+
+1;
+

Added: trunk/Class-Accessor-Grouped/t/accessors_xs.t
===================================================================
--- trunk/Class-Accessor-Grouped/t/accessors_xs.t	                        (rev 0)
+++ trunk/Class-Accessor-Grouped/t/accessors_xs.t	2009-07-08 02:24:06 UTC (rev 7003)
@@ -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

Modified: trunk/Class-Accessor-Grouped/t/lib/AccessorGroups.pm
===================================================================
--- trunk/Class-Accessor-Grouped/t/lib/AccessorGroups.pm	2009-07-07 18:47:20 UTC (rev 7002)
+++ trunk/Class-Accessor-Grouped/t/lib/AccessorGroups.pm	2009-07-08 02:24:06 UTC (rev 7003)
@@ -3,20 +3,13 @@
 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;

Modified: trunk/Class-Accessor-Grouped/t/pod_spelling.t
===================================================================
--- trunk/Class-Accessor-Grouped/t/pod_spelling.t	2009-07-07 18:47:20 UTC (rev 7002)
+++ trunk/Class-Accessor-Grouped/t/pod_spelling.t	2009-07-08 02:24:06 UTC (rev 7003)
@@ -22,6 +22,7 @@
 __DATA__
 Bowden
 Raygun
+Roditi
 isa
 mst
 behaviour




More information about the Bast-commits mailing list