[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