Extra sanity check of accessor names

diff --git a/Changes b/Changes
index fee1fd9..b2f858d 100644 (file)
--- a/Changes
+++ b/Changes
@@ -8,6 +8,8 @@ Revision history for Class::Accessor::Grouped.
     - Simplify superclass traversal done by the 'inherited' group type
     - Fix incorrect quoting of unusual hash keys (fieldnames)
     - Improve text of ro/wo violation exceptions
+    - Sanity-check accessor names for well-formedness
+      (qr/[A-Z_a-z][0-9A-Z_a-z]*/)
 
 0.10006 2011-12-30 03:52 (UTC)
     - Silence warnings resulting from incomplete can() overrides

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index f7bc475..ad0e870 100644 (file)
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -77,10 +77,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";
 

diff --git a/t/accessors.t b/t/accessors.t
index a525715..8290c02 100644 (file)
--- a/t/accessors.t
+++ b/t/accessors.t
@@ -1,4 +1,5 @@
-use Test::More tests => 137;
+use Test::More tests => 138;
+use Test::Exception;
 use strict;
 use warnings;
 use lib 't/lib';
@@ -18,7 +19,10 @@ BEGIN {
 
 use AccessorGroupsSubclass;
 
-{
+SKIP: {
+  skip( 'Perl 5.6 does not like localizing globs', 1 )
+    if $] < '5.008';
+
   my $obj = AccessorGroupsSubclass->new;
   my $class = ref $obj;
   my $name = 'multiple1';
@@ -26,18 +30,24 @@ use AccessorGroupsSubclass;
 
   my $warned = 0;
   local $SIG{__WARN__} = sub {
-    if  (shift =~ /DESTROY/i) {
-      $warned++;
-    };
+    $_[0] =~ /unwise/ ? $warned++ : warn(@_)
   };
 
-  no warnings qw/once/;
-  local *AccessorGroupsSubclass::DESTROY = sub {};
+  for (qw/DESTROY AUTOLOAD CLONE/) {
+    no warnings qw/once/;
+    no strict 'refs';
+
+    local *{"AccessorGroupsSubclass::$_"} = sub {};
 
-  $class->mk_group_accessors('warnings', 'DESTROY');
-  ok($warned);
+    $class->mk_group_accessors(warnings => $_);
+  }
+
+  is($warned, 3, 'Correct amount of warnings');
 };
 
+throws_ok { AccessorGroupsSubclass->mk_group_accessors(simple => '2wrvwrv;') }
+  qr/Illegal accessor name/;
+
 my $obj = AccessorGroupsSubclass->new;
 
 my $test_accessors = {