X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FAccessor%2FGrouped.pm;h=afe019bd62a15bb2f04c13edac472098cd61b093;hb=00e42e876950facc93918342bf6a4bfc1bc0a985;hp=f7bc475676e4861b7f47d7861431e213421516f4;hpb=da609a465417b66a52918e7e2be3c38309bdc21f;p=p5sagit%2FClass-Accessor-Grouped.git

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index f7bc475..afe019b 100644
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -15,12 +15,12 @@ BEGIN {
   }
 }
 
-our $VERSION = '0.10006';
+our $VERSION = '0.10007';
 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
 
 # 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 );
@@ -77,10 +90,11 @@ sub _mk_group_accessors {
 
     my ($name, $field) = (ref $_) ? (@$_) : ($_, $_);
 
-    for (qw/DESTROY AUTOLOAD CLONE/) {
-      Carp::carp("Having a data accessor named '$name' in '$class' is unwise.")
-        if $name eq $_;
-    }
+    Carp::croak("Illegal accessor name '$name'")
+      unless $name =~ /\A[A-Z_a-z][0-9A-Z_a-z]*\z/;
+
+    Carp::carp("Having a data accessor named '$name' in '$class' is unwise.")
+      if $name =~ /\A(?: DESTROY | AUTOLOAD | CLONE )\z/x;
 
     my $alias = "_${name}_accessor";
 
@@ -99,7 +113,7 @@ sub _mk_group_accessors {
   }
 };
 
-# coderef is setup at the end for clarity
+# $gen_accessor coderef is setup at the end for clarity
 my $gen_accessor;
 
 =head1 NAME
@@ -585,8 +599,8 @@ else {
 
 my $maker_templates = {
   rw => {
-    xs_call => 'accessors',
-    pp_code => sub {
+    cxsa_call => 'accessors',
+    pp_generator => sub {
       # my ($group, $fieldname) = @_;
       my $quoted_fieldname = $perlstring->($_[1]);
       sprintf <<'EOS', ($_[0], $quoted_fieldname) x 2;
@@ -599,8 +613,8 @@ EOS
     },
   },
   ro => {
-    xs_call => 'getters',
-    pp_code => sub {
+    cxsa_call => 'getters',
+    pp_generator => sub {
       # my ($group, $fieldname) = @_;
       my $quoted_fieldname = $perlstring->($_[1]);
       sprintf  <<'EOS', $_[0], $quoted_fieldname;
@@ -619,8 +633,8 @@ EOS
     },
   },
   wo => {
-    xs_call => 'setters',
-    pp_code => sub {
+    cxsa_call => 'setters',
+    pp_generator => sub {
       # my ($group, $fieldname) = @_;
       my $quoted_fieldname = $perlstring->($_[1]);
       sprintf  <<'EOS', $_[0], $quoted_fieldname;
@@ -640,6 +654,29 @@ EOS
   },
 };
 
+my $cag_eval = sub {
+  #my ($src, $no_warnings, $err_msg) = @_;
+
+  my $src = sprintf "{ %s warnings; use strict; no strict 'refs'; %s }",
+    $_[1] ? 'no' : 'use',
+    $_[0],
+  ;
+
+  my (@rv, $err);
+  {
+    local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT;
+    wantarray
+      ? @rv = eval $src
+      : $rv[0] = eval $src
+    ;
+    $err = $@ if $@ ne '';
+  }
+
+  Carp::croak(join ': ', ($_[2] || 'String-eval failed'), "$err\n$src\n" )
+    if defined $err;
+
+  wantarray ? @rv : $rv[0];
+};
 
 my ($accessor_maker_cache, $no_xsa_warned_classes);
 
@@ -692,7 +729,7 @@ $gen_accessor = sub {
           Class::XSAccessor->import(
             replace => 1,
             class => '__CAG__XSA__BREEDER__',
-            $maker_templates->{$type}{xs_call} => {
+            $maker_templates->{$type}{cxsa_call} => {
               $methname => $field,
             },
           );
@@ -743,7 +780,7 @@ $gen_accessor = sub {
             "Deferred version of method $cframe[3] invoked more than once (originally "
           . "invoked at $already_seen). This is a strong indication your code has "
           . 'cached the original ->can derived method coderef, and is using it instead '
-          . 'of the proper method re-lookup, causing performance regressions'
+          . 'of the proper method re-lookup, causing minor performance regressions'
           );
         }
         else {
@@ -781,11 +818,11 @@ $gen_accessor = sub {
   # no Sub::Name - just install the coderefs directly (compiling every time)
   elsif (__CAG_ENV__::NO_SUBNAME) {
     my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
-      $maker_templates->{$type}{pp_code}->($group, $field);
+      $maker_templates->{$type}{pp_generator}->($group, $field);
 
-    no warnings 'redefine';
-    local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT;
-    eval "sub ${class}::${methname} { $src }";
+    $cag_eval->(
+      "no warnings 'redefine'; sub ${class}::${methname} { $src }; 1",
+    );
 
     undef;  # so that no further attempt will be made to install anything
   }
@@ -794,10 +831,9 @@ $gen_accessor = sub {
   else {
     ($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do {
       my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
-        $maker_templates->{$type}{pp_code}->($group, $field);
+        $maker_templates->{$type}{pp_generator}->($group, $field);
 
-      local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT;
-      eval "sub { my \$dummy; sub { \$dummy if 0; $src } }" or die $@;
+      $cag_eval->( "sub { my \$dummy; sub { \$dummy if 0; $src } }" );
     })->()
   }
 };