[Bast-commits] r9716 - in Class-Accessor-Grouped/trunk: .
lib/Class/Accessor t t/lib
ribasushi at dev.catalyst.perl.org
ribasushi at dev.catalyst.perl.org
Fri Sep 10 17:46:29 GMT 2010
Author: ribasushi
Date: 2010-09-10 18:46:29 +0100 (Fri, 10 Sep 2010)
New Revision: 9716
Added:
Class-Accessor-Grouped/trunk/benchmark.pl
Modified:
Class-Accessor-Grouped/trunk/Changes
Class-Accessor-Grouped/trunk/MANIFEST.SKIP
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/accessors_ro.t
Class-Accessor-Grouped/trunk/t/accessors_wo.t
Class-Accessor-Grouped/trunk/t/accessors_xs.t
Class-Accessor-Grouped/trunk/t/lib/AccessorGroupsRO.pm
Class-Accessor-Grouped/trunk/t/lib/AccessorGroupsWO.pm
Class-Accessor-Grouped/trunk/t/pod_spelling.t
Log:
Fix braindead ro/wo accessor breakage when CXSA is available
Better control on whether to use CXSA or not (global var and envvar)
Rewrite tests so that PP and XS codepaths are fully tested
Bump Test::More for subtests functionality
Add benchmark and XS discussion to POD
Modified: Class-Accessor-Grouped/trunk/Changes
===================================================================
--- Class-Accessor-Grouped/trunk/Changes 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/Changes 2010-09-10 17:46:29 UTC (rev 9716)
@@ -1,5 +1,10 @@
Revision history for Class::Accessor::Grouped.
+ - Fix bugs in ro/wo accessor generation when XSAccessor is
+ being used
+ - Better Class::XSAccessor usage control - introducing
+ $ENV{CAG_USE_XS} and $Class::Accessor::Grouped::USE_XS
+
0.09005 Wed Sep 1 04:00:00 2010
- Again, remove Class::XSAccessor for Win32 sine it still breaks
Modified: Class-Accessor-Grouped/trunk/MANIFEST.SKIP
===================================================================
--- Class-Accessor-Grouped/trunk/MANIFEST.SKIP 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/MANIFEST.SKIP 2010-09-10 17:46:29 UTC (rev 9716)
@@ -38,3 +38,5 @@
# Avoid author test files.
\bpod_spelling.t$
+
+benchmark.pl
Modified: Class-Accessor-Grouped/trunk/Makefile.PL
===================================================================
--- Class-Accessor-Grouped/trunk/Makefile.PL 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/Makefile.PL 2010-09-10 17:46:29 UTC (rev 9716)
@@ -15,6 +15,7 @@
requires 'Sub::Name' => '0.04';
test_requires 'Sub::Identify';
+test_requires 'Test::More' => '0.94';
test_requires 'Test::Exception';
clean_files "Class-Accessor-Grouped-* t/var";
Added: Class-Accessor-Grouped/trunk/benchmark.pl
===================================================================
--- Class-Accessor-Grouped/trunk/benchmark.pl (rev 0)
+++ Class-Accessor-Grouped/trunk/benchmark.pl 2010-09-10 17:46:29 UTC (rev 9716)
@@ -0,0 +1,111 @@
+use strictures 1;
+
+BEGIN {
+ my @missing;
+ for (qw/
+ Class::Accessor::Grouped
+ Class::XSAccessor
+ Class::Accessor::Fast
+ Class::Accessor::Fast::XS
+ Moose
+ Mouse
+ /) {
+ eval "require $_" or push @missing, $_;
+ }
+
+ if (@missing) {
+ die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
+ join ("\n", @missing);
+ }
+}
+
+
+use Benchmark qw/:hireswallclock cmpthese/;
+
+{
+ package Bench::Accessor;
+
+ use strictures 1;
+
+ our @ISA;
+
+ use base qw/Class::Accessor::Grouped Class::Accessor::Fast/;
+ use Class::XSAccessor { accessors => [ 'xsa' ] };
+
+ {
+ local $Class::Accessor::Grouped::USE_XS = 0;
+ __PACKAGE__->mk_group_accessors ('simple', 'cag');
+ }
+ {
+ local $Class::Accessor::Grouped::USE_XS = 1;
+ __PACKAGE__->mk_group_accessors ('simple', 'cag_xs');
+ }
+ __PACKAGE__->mk_accessors('caf');
+
+ {
+ require Class::Accessor::Fast::XS;
+ local @ISA = 'Class::Accessor::Fast::XS';
+ __PACKAGE__->mk_accessors ('caf_xs');
+ }
+
+ sub handmade {
+ @_ > 1 ? $_[0]->{handmade} = $_[1] : $_[0]->{handmade};
+ }
+
+}
+my $bench_objs = {
+ base => bless ({}, 'Bench::Accessor')
+};
+
+sub _add_moose_task {
+ my ($tasks, $name, $class) = @_;
+ my $meth = lc($name);
+
+ my $gen_class = "Bench::Accessor::$class";
+ eval <<"EOC";
+package $gen_class;
+use $class;
+has $meth => (is => 'rw');
+__PACKAGE__->meta->make_immutable;
+EOC
+
+ $bench_objs->{$name} = $gen_class->new;
+ _add_task ($tasks, $name, $meth, $name);
+}
+
+sub _add_task {
+ my ($tasks, $name, $meth, $slot) = @_;
+
+ $tasks->{$name} = eval "sub {
+ for (my \$i = 0; \$i < 100; \$i++) {
+ \$bench_objs->{$slot}->$meth(1);
+ \$bench_objs->{$slot}->$meth(\$bench_objs->{$slot}->$meth + 1);
+ }
+ }";
+}
+
+my $tasks = {
+# 'direct' => sub {
+# $bench_objs->{base}{direct} = 1;
+# $bench_objs->{base}{direct} = $bench_objs->{base}{direct} + 1;
+# }
+};
+
+for (qw/CAG CAG_XS CAF CAF_XS XSA HANDMADE/) {
+ _add_task ($tasks, $_, lc($_), 'base');
+}
+
+my $moose_based = {
+ moOse => 'Moose',
+ ($ENV{MOUSE_PUREPERL} ? 'moUse' : 'moUse_XS') => 'Mouse',
+};
+for (keys %$moose_based) {
+ _add_moose_task ($tasks, $_, $moose_based->{$_})
+}
+
+
+for (1, 2) {
+ print "Perl $], take $_:\n";
+ cmpthese ( -1, $tasks );
+ print "\n";
+}
Modified: Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm
===================================================================
--- Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm 2010-09-10 17:46:29 UTC (rev 9716)
@@ -9,25 +9,41 @@
our $VERSION = '0.09005';
$VERSION = eval $VERSION;
-# Class::XSAccessor is segfaulting on win32, so be careful
-# Win32 users can set $hasXS to try to use it anyway
+# when changing minimum version don't forget to adjust L</PERFROMANCE> as well
+our $__minimum_xsa_version = '1.06';
-our $hasXS;
+our $USE_XS;
+# the unless defined is here so that we can override the value
+# before require/use, *regardless* of the state of $ENV{CAG_USE_XS}
+$USE_XS = $ENV{CAG_USE_XS}
+ unless defined $USE_XS;
-sub _hasXS {
- if (not defined $hasXS) {
- $hasXS = 0;
+my $xsa_loaded;
+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;
+ }
+
+ $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') {
- eval {
- require Class::XSAccessor;
- $hasXS = 1;
- };
+ local $@;
+ eval { $load_xsa->(); $USE_XS = 1 };
}
- }
- return $hasXS;
-}
+ return $USE_XS;
+};
=head1 NAME
@@ -86,41 +102,30 @@
# 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' ) {
+ foreach (@fields) {
+ if( $_ eq 'DESTROY' ) {
Carp::carp("Having a data accessor named DESTROY in ".
"'$class' is unwise.");
}
- my $name = $field;
+ my ($name, $field) = (ref $_)
+ ? (@$_)
+ : ($_, $_)
+ ;
- ($name, $field) = @$field if ref $field;
-
my $alias = "_${name}_accessor";
- my $full_name = join('::', $class, $name);
- my $full_alias = join('::', $class, $alias);
- if ( $hasXS && $group eq 'simple' ) {
- require Class::XSAccessor;
- Class::XSAccessor->import({
- replace => 1,
- class => $class,
- accessors => {
- $name => $field,
- $alias => $field,
- },
- });
- }
- 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"}
+ for my $meth ($name, $alias) {
- *$full_alias = Sub::Name::subname($full_alias, $alias_accessor);
- #unless defined &{$class."\:\:$alias"}
+ # the maker may elect to not return anything, meaning it already
+ # installed the coderef for us
+ my $cref = $self->$maker($group, $field, $meth)
+ or next;
+
+ my $fq_meth = join('::', $class, $meth);
+
+ *$fq_meth = Sub::Name::subname($fq_meth, $cref);
+ #unless defined &{$class."\:\:$field"}
}
}
}
@@ -174,20 +179,32 @@
=over 4
-=item Arguments: $group, $field
+=item Arguments: $group, $field, $method
-Returns: $sub (\CODE)
+Returns: \&accessor_coderef ?
=back
-Returns a single accessor in a given group; called by mk_group_accessors
-for each entry in @fieldspec.
+Called by mk_group_accessors for each entry in @fieldspec. Either returns
+a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
+C<undef> if it elects to install the coderef on its own.
=cut
sub make_group_accessor {
- my ($class, $group, $field) = @_;
+ my ($class, $group, $field, $name) = @_;
+ if ( $group eq 'simple' && $use_xs->() ) {
+ Class::XSAccessor->import({
+ replace => 1,
+ class => $class,
+ accessors => {
+ $name => $field,
+ },
+ });
+ return;
+ }
+
my $set = "set_$group";
my $get = "get_$group";
@@ -211,20 +228,32 @@
=over 4
-=item Arguments: $group, $field
+=item Arguments: $group, $field, $method
-Returns: $sub (\CODE)
+Returns: \&accessor_coderef ?
=back
-Returns a single read-only accessor in a given group; called by
-mk_group_ro_accessors for each entry in @fieldspec.
+Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
+a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
+C<undef> if it elects to install the coderef on its own.
=cut
sub make_group_ro_accessor {
- my($class, $group, $field) = @_;
+ my($class, $group, $field, $name) = @_;
+ if ( $group eq 'simple' && $use_xs->() ) {
+ Class::XSAccessor->import({
+ replace => 1,
+ class => $class,
+ getters => {
+ $name => $field,
+ },
+ });
+ return;
+ }
+
my $get = "get_$group";
$field =~ s/'/\\'/g;
@@ -248,20 +277,32 @@
=over 4
-=item Arguments: $group, $field
+=item Arguments: $group, $field, $method
-Returns: $sub (\CODE)
+Returns: \&accessor_coderef ?
=back
-Returns a single write-only accessor in a given group; called by
-mk_group_wo_accessors for each entry in @fieldspec.
+Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
+a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
+C<undef> if it elects to install the coderef on its own.
=cut
sub make_group_wo_accessor {
- my($class, $group, $field) = @_;
+ my($class, $group, $field, $name) = @_;
+ if ( $group eq 'simple' && $use_xs->() ) {
+ Class::XSAccessor->import({
+ replace => 1,
+ class => $class,
+ setters => {
+ $name => $field,
+ },
+ });
+ return;
+ }
+
my $set = "set_$group";
$field =~ s/'/\\'/g;
@@ -480,8 +521,46 @@
=head1 PERFORMANCE
-You can speed up accessors of type 'simple' by installing L<Class::XSAccessor>.
+To provide total flexibility L<Class::Accessor::Grouped> calls methods
+internally while performing get/set actions, which makes it noticeably
+slower than similar modules. To compensate, this module will automatically
+use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
+accessors, if L<< Class::XSAccessor >= 1.06|Class::XSAccessor >> is
+available on your system.
+=head2 Benchmark
+
+This is the result of a set/get/set loop benchmark on perl 5.12.1 with
+thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,
+L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>
+and L<XSA|Class::XSAccessor>:
+
+ Rate CAG moOse CAF HANDMADE CAF_XS moUse_XS CAG_XS XSA
+ CAG 1777/s -- -27% -29% -36% -62% -67% -72% -73%
+ moOse 2421/s 36% -- -4% -13% -48% -55% -61% -63%
+ CAF 2511/s 41% 4% -- -10% -47% -53% -60% -61%
+ HANDMADE 2791/s 57% 15% 11% -- -41% -48% -56% -57%
+ CAF_XS 4699/s 164% 94% 87% 68% -- -13% -25% -28%
+ moUse_XS 5375/s 203% 122% 114% 93% 14% -- -14% -18%
+ CAG_XS 6279/s 253% 159% 150% 125% 34% 17% -- -4%
+ XSA 6515/s 267% 169% 159% 133% 39% 21% 4% --
+
+Benchmark program is available in the root of the
+L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
+
+=head2 Notes on Class::XSAccessor
+
+While L<Class::XSAccessor> works surprisingly well for the amount of black
+magic it tries to pull off, it's still black magic. At present (Sep 2010)
+the module is known to have problems on Windows under heavy thread-stress
+(e.g. Win32+Apache+mod_perl). Thus for the time being L<Class::XSAccessor>
+will not be used automatically if you are running under C<MSWin32>.
+
+You can force the use of L<Class::XSAccessor> before creating a particular
+C<simple> accessor by either manipulating the global variable
+C<$Class::Accessor::Grouped::USE_XS>, or you can do so before runtime via the
+C<CAG_USE_XS> environment variable.
+
=head1 AUTHORS
Matt S. Trout <mst at shadowcatsystems.co.uk>
Modified: Class-Accessor-Grouped/trunk/t/accessors.t
===================================================================
--- Class-Accessor-Grouped/trunk/t/accessors.t 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/t/accessors.t 2010-09-10 17:46:29 UTC (rev 9716)
@@ -2,15 +2,20 @@
use strict;
use warnings;
use lib 't/lib';
-use Sub::Identify qw/sub_name sub_fullname/;;
+use Sub::Identify qw/sub_name sub_fullname/;
+# we test the pure-perl versions only, but allow overrides
+# from the accessor_xs test-umbrella
+# Also make sure a rogue envvar will not interfere with
+# things
BEGIN {
- # Disable XSAccessor to test pure-Perl accessors
- $Class::Accessor::Grouped::hasXS = 0;
-
- require AccessorGroups;
-}
+ $Class::Accessor::Grouped::USE_XS = 0
+ unless defined $Class::Accessor::Grouped::USE_XS;
+ $ENV{CAG_USE_XS} = 1;
+};
+use AccessorGroups;
+
my $class = AccessorGroups->new;
{
@@ -98,4 +103,5 @@
is($class->$name, 'd');
};
+# important
1;
Modified: Class-Accessor-Grouped/trunk/t/accessors_ro.t
===================================================================
--- Class-Accessor-Grouped/trunk/t/accessors_ro.t 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/t/accessors_ro.t 2010-09-10 17:46:29 UTC (rev 9716)
@@ -1,7 +1,21 @@
use Test::More tests => 48;
+use Test::Exception;
use strict;
use warnings;
use lib 't/lib';
+
+# we test the pure-perl versions only, but allow overrides
+# from the accessor_xs test-umbrella
+# Also make sure a rogue envvar will not interfere with
+# things
+my $use_xs;
+BEGIN {
+ $Class::Accessor::Grouped::USE_XS = 0
+ unless defined $Class::Accessor::Grouped::USE_XS;
+ $ENV{CAG_USE_XS} = 1;
+ $use_xs = $Class::Accessor::Grouped::USE_XS;
+};
+
use AccessorGroupsRO;
my $class = AccessorGroupsRO->new;
@@ -24,68 +38,60 @@
*AccessorGroupsRO::DESTROY = sub {};
};
-foreach (qw/singlefield multiple1 multiple2/) {
- my $name = $_;
+my $test_accessors = {
+ singlefield => {
+ is_xs => $use_xs,
+ },
+ multiple1 => {
+ },
+ multiple2 => {
+ },
+ lr1name => {
+ custom_field => 'lr1;field',
+ },
+ lr2name => {
+ custom_field => "lr2'field",
+ },
+};
+
+for my $name (sort keys %$test_accessors) {
+
my $alias = "_${name}_accessor";
+ my $field = $test_accessors->{$name}{custom_field} || $name;
can_ok($class, $name, $alias);
+ ok(!$class->can($field))
+ if $field ne $name;
+
is($class->$name, undef);
is($class->$alias, undef);
# get via name
- $class->{$name} = 'a';
+ $class->{$field} = 'a';
is($class->$name, 'a');
# alias gets same as name
is($class->$alias, 'a');
+ my $ro_regex = $test_accessors->{$name}{is_xs}
+ ? qr/Usage\:.+$name.*\(self\)/
+ : qr/cannot alter the value of '\Q$field\E'/
+ ;
+
# die on set via name/alias
- eval {
+ throws_ok {
$class->$name('b');
- };
- ok($@ =~ /cannot alter/);
+ } $ro_regex;
- eval {
+ throws_ok {
$class->$alias('b');
- };
- ok($@ =~ /cannot alter/);
+ } $ro_regex;
# value should be unchanged
is($class->$name, 'a');
is($class->$alias, 'a');
};
-foreach (qw/lr1 lr2/) {
- my $name = "$_".'name';
- my $alias = "_${name}_accessor";
- my $field = { lr1 => 'lr1;field', lr2 => q{lr2'field} }->{$_};
-
- can_ok($class, $name, $alias);
- ok(!$class->can($field));
-
- is($class->$name, undef);
- is($class->$alias, undef);
-
- # get via name
- $class->{$field} = 'c';
- is($class->$name, 'c');
-
- # alias gets same as name
- is($class->$alias, 'c');
-
- # die on set via name/alias
- eval {
- $class->$name('d');
- };
- ok($@ =~ /cannot alter/);
-
- eval {
- $class->$alias('d');
- };
- ok($@ =~ /cannot alter/);
-
- # value should be unchanged
- is($class->$name, 'c');
- is($class->$alias, 'c');
-};
+#important
+1;
Modified: Class-Accessor-Grouped/trunk/t/accessors_wo.t
===================================================================
--- Class-Accessor-Grouped/trunk/t/accessors_wo.t 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/t/accessors_wo.t 2010-09-10 17:46:29 UTC (rev 9716)
@@ -1,7 +1,21 @@
use Test::More tests => 38;
+use Test::Exception;
use strict;
use warnings;
use lib 't/lib';
+
+# we test the pure-perl versions only, but allow overrides
+# from the accessor_xs test-umbrella
+# Also make sure a rogue envvar will not interfere with
+# things
+my $use_xs;
+BEGIN {
+ $Class::Accessor::Grouped::USE_XS = 0
+ unless defined $Class::Accessor::Grouped::USE_XS;
+ $ENV{CAG_USE_XS} = 1;
+ $use_xs = $Class::Accessor::Grouped::USE_XS;
+};
+
use AccessorGroupsWO;
my $class = AccessorGroupsWO->new;
@@ -24,57 +38,54 @@
*AccessorGroupsWO::DESTROY = sub {};
};
-foreach (qw/singlefield multiple1 multiple2/) {
- my $name = $_;
+my $test_accessors = {
+ singlefield => {
+ is_xs => $use_xs,
+ },
+ multiple1 => {
+ },
+ multiple2 => {
+ },
+ lr1name => {
+ custom_field => 'lr1;field',
+ },
+ lr2name => {
+ custom_field => "lr2'field",
+ },
+};
+
+for my $name (sort keys %$test_accessors) {
+
my $alias = "_${name}_accessor";
+ my $field = $test_accessors->{$name}{custom_field} || $name;
can_ok($class, $name, $alias);
+ ok(!$class->can($field))
+ if $field ne $name;
+
# set via name
is($class->$name('a'), 'a');
- is($class->{$name}, 'a');
+ is($class->{$field}, 'a');
# alias sets same as name
is($class->$alias('b'), 'b');
- is($class->{$name}, 'b');
+ is($class->{$field}, 'b');
+ my $wo_regex = $test_accessors->{$name}{is_xs}
+ ? qr/Usage\:.+$name.*\(self, newvalue\)/
+ : qr/cannot access the value of '\Q$field\E'/
+ ;
+
# die on get via name/alias
- eval {
+ throws_ok {
$class->$name;
- };
- ok($@ =~ /cannot access/);
+ } $wo_regex;
- eval {
+ throws_ok {
$class->$alias;
- };
- ok($@ =~ /cannot access/);
+ } $wo_regex;
};
-foreach (qw/lr1 lr2/) {
- my $name = "$_".'name';
- my $alias = "_${name}_accessor";
-
- my $field = { lr1 => 'lr1;field', lr2 => q{lr2'field} }->{$_};
-
- can_ok($class, $name, $alias);
- ok(!$class->can($field));
-
- # set via name
- is($class->$name('c'), 'c');
- is($class->{$field}, 'c');
-
- # alias sets same as name
- is($class->$alias('d'), 'd');
- is($class->{$field}, 'd');
-
- # die on get via name/alias
- eval {
- $class->$name;
- };
- ok($@ =~ /cannot access/);
-
- eval {
- $class->$alias;
- };
- ok($@ =~ /cannot access/);
-};
+# important
+1;
\ No newline at end of file
Modified: Class-Accessor-Grouped/trunk/t/accessors_xs.t
===================================================================
--- Class-Accessor-Grouped/trunk/t/accessors_xs.t 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/t/accessors_xs.t 2010-09-10 17:46:29 UTC (rev 9716)
@@ -5,9 +5,21 @@
use Test::More;
use lib 't/lib';
-use AccessorGroups ();
-
-plan skip_all => 'Class::XSAccessor not available'
- unless Class::Accessor::Grouped::_hasXS();
+BEGIN {
+ require Class::Accessor::Grouped;
+ my $xsa_ver = $Class::Accessor::Grouped::__minimum_xsa_version;
+ eval {
+ require Class::XSAccessor;
+ Class::XSAccessor->VERSION ($xsa_ver);
+ };
+ plan skip_all => "Class::XSAccessor >= $xsa_ver not available"
+ if $@;
+}
-require( catfile($Bin, 'accessors.t') );
+# rerun all 3 tests under XSAccessor
+$Class::Accessor::Grouped::USE_XS = 1;
+for (qw/accessors.t accessors_ro.t accessors_wo.t/) {
+ subtest "$_ with USE_XS" => sub { require( catfile($Bin, $_) ) }
+}
+
+done_testing;
Modified: Class-Accessor-Grouped/trunk/t/lib/AccessorGroupsRO.pm
===================================================================
--- Class-Accessor-Grouped/trunk/t/lib/AccessorGroupsRO.pm 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/t/lib/AccessorGroupsRO.pm 2010-09-10 17:46:29 UTC (rev 9716)
@@ -3,7 +3,7 @@
use warnings;
use base 'Class::Accessor::Grouped';
-__PACKAGE__->mk_group_ro_accessors('single', 'singlefield');
+__PACKAGE__->mk_group_ro_accessors('simple', 'singlefield');
__PACKAGE__->mk_group_ro_accessors('multiple', qw/multiple1 multiple2/);
__PACKAGE__->mk_group_ro_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]);
@@ -11,7 +11,7 @@
return bless {}, shift;
};
-foreach (qw/single multiple listref/) {
+foreach (qw/multiple listref/) {
no strict 'refs';
*{"get_$_"} = \&Class::Accessor::Grouped::get_simple;
Modified: Class-Accessor-Grouped/trunk/t/lib/AccessorGroupsWO.pm
===================================================================
--- Class-Accessor-Grouped/trunk/t/lib/AccessorGroupsWO.pm 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/t/lib/AccessorGroupsWO.pm 2010-09-10 17:46:29 UTC (rev 9716)
@@ -3,7 +3,7 @@
use warnings;
use base 'Class::Accessor::Grouped';
-__PACKAGE__->mk_group_wo_accessors('single', 'singlefield');
+__PACKAGE__->mk_group_wo_accessors('simple', 'singlefield');
__PACKAGE__->mk_group_wo_accessors('multiple', qw/multiple1 multiple2/);
__PACKAGE__->mk_group_wo_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]);
@@ -11,7 +11,7 @@
return bless {}, shift;
};
-foreach (qw/single multiple listref/) {
+foreach (qw/multiple listref/) {
no strict 'refs';
*{"set_$_"} = \&Class::Accessor::Grouped::set_simple;
Modified: Class-Accessor-Grouped/trunk/t/pod_spelling.t
===================================================================
--- Class-Accessor-Grouped/trunk/t/pod_spelling.t 2010-09-10 11:41:21 UTC (rev 9715)
+++ Class-Accessor-Grouped/trunk/t/pod_spelling.t 2010-09-10 17:46:29 UTC (rev 9716)
@@ -39,4 +39,8 @@
Rabbitson
groditi
Caelum
-Kitover
\ No newline at end of file
+Kitover
+CAF
+Sep
+XSA
+runtime
More information about the Bast-commits
mailing list