Require bugfixed CXSA and warn on old (unusable) versions
Peter Rabbitson [Sun, 4 Nov 2012 18:11:42 +0000 (19:11 +0100)]
Changes
Makefile.PL
lib/Class/Accessor/Grouped.pm
t/accessors_ro.t
t/accessors_wo.t
t/lib/AccessorGroupsRO.pm
t/lib/AccessorGroupsWO.pm

diff --git a/Changes b/Changes
index b2f858d..3518da7 100644 (file)
--- a/Changes
+++ b/Changes
@@ -7,6 +7,7 @@ Revision history for Class::Accessor::Grouped.
       dependency on Class::Inspector
     - Simplify superclass traversal done by the 'inherited' group type
     - Fix incorrect quoting of unusual hash keys (fieldnames)
+    - Depend on newer bugfixed Class::XSAccessor 1.15
     - Improve text of ro/wo violation exceptions
     - Sanity-check accessor names for well-formedness
       (qr/[A-Z_a-z][0-9A-Z_a-z]*/)
index 3842e22..a8379e2 100644 (file)
@@ -16,7 +16,7 @@ if (can_xs or $Module::Install::AUTHOR) {
   requires 'Sub::Name' => '0.05';
 
   # when changing don't forget to adjust lib/Class/Accessor/Grouped.pm as well
-  requires 'Class::XSAccessor' => '1.13'
+  requires 'Class::XSAccessor' => '1.15'
     if $] > '5.008'; # CXSA does not work on 5.6
 }
 
index 4cfca4d..d51d3e8 100644 (file)
@@ -20,7 +20,7 @@ $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev relea
 
 # when changing minimum version don't forget to adjust Makefile.PL as well
 our $__minimum_xsa_version;
-BEGIN { $__minimum_xsa_version = '1.13' }
+BEGIN { $__minimum_xsa_version = '1.15' }
 
 our $USE_XS;
 # the unless defined is here so that we can override the value
@@ -44,10 +44,23 @@ BEGIN {
     Module::Runtime::require_module('Sub::Name')
   } ? 0 : "$@" );
 
+  my $found_cxsa;
   constant->import( NO_CXSA => ( !NO_SUBNAME() and eval {
-    Module::Runtime::use_module('Class::XSAccessor' => $__minimum_xsa_version)
+    Module::Runtime::require_module('Class::XSAccessor');
+    $found_cxsa = Class::XSAccessor->VERSION;
+    Class::XSAccessor->VERSION($__minimum_xsa_version);
   } ) ? 0 : "$@" );
 
+  if (NO_CXSA() and $found_cxsa and !$ENV{CAG_OLD_XS_NOWARN}) {
+    warn(
+      'The installed version of Class::XSAccessor is too old '
+    . "(v$found_cxsa < v$__minimum_xsa_version). Please upgrade "
+    . "to instantly quadruple the performance of 'simple' accessors. "
+    . 'Set $ENV{CAG_OLD_XS_NOWARN} if you wish to disable this '
+    . "warning.\n"
+    );
+  }
+
   constant->import( BROKEN_GOTO => ($] < '5.008009') ? 1 : 0 );
 
   constant->import( UNSTABLE_DOLLARAT => ($] < '5.013002') ? 1 : 0 );
index ca372a6..f9427b1 100644 (file)
@@ -53,7 +53,7 @@ my $test_accessors = {
     custom_field => "lr2'field",
   },
   fieldname_torture => {
-    custom_field => join ('', map { chr($_) } (1..255) ), # FIXME after RT#80569 is fixed 0..255 should work
+    custom_field => join ('', map { chr($_) } (0..255) ),
     is_xs => $use_xs,
   },
 };
index 5f996e5..ee16358 100644 (file)
@@ -52,7 +52,7 @@ my $test_accessors = {
     custom_field => "lr2'field",
   },
   fieldname_torture => {
-    custom_field => join ('', map { chr($_) } (1..255) ), # FIXME after RT#80569 is fixed 0..255 should work
+    custom_field => join ('', map { chr($_) } (0..255) ),
     is_xs => $use_xs,
   },
 };
index d023275..6ff30e1 100644 (file)
@@ -6,7 +6,7 @@ use base 'Class::Accessor::Grouped';
 __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/]);
-__PACKAGE__->mk_group_ro_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (1..255) ) ]);
+__PACKAGE__->mk_group_ro_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]);
 
 sub new {
   return bless {}, shift;
index b8b8c56..527f39b 100644 (file)
@@ -6,7 +6,7 @@ use base 'Class::Accessor::Grouped';
 __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/]);
-__PACKAGE__->mk_group_wo_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (1..255) ) ]);
+__PACKAGE__->mk_group_wo_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]);
 
 sub new {
   return bless {}, shift;