From: Peter Rabbitson <ribasushi@cpan.org>
Date: Fri, 2 Nov 2012 16:20:24 +0000 (+0100)
Subject: Fix incorrect handling of exotic fieldnames
X-Git-Tag: v0.10007~7
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4d70ba11c00e532cd69f2f044f8e27abae0ccd0b;p=p5sagit%2FClass-Accessor-Grouped.git

Fix incorrect handling of exotic fieldnames
---

diff --git a/Changes b/Changes
index 6a39c87..45b9eb1 100644
--- a/Changes
+++ b/Changes
@@ -6,6 +6,7 @@ Revision history for Class::Accessor::Grouped.
     - Switch all module loading to Module::Runtime and lose
       dependency on Class::Inspector
     - Simplify superclass traversal done by the 'inherited' group type
+    - Fix incorrect quoting of unusual hash keys (fieldnames)
 
 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 35d21de..c60ef7f 100644
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -571,58 +571,73 @@ if (! defined $USE_XS) {
   $xsa_autodetected++;
 }
 
+my $perlstring;
+if ($] < '5.008') {
+  require Data::Dumper;
+  my $d = Data::Dumper->new([])->Indent(0)->Purity(0)->Pad('')->Useqq(1)->Terse(1)->Freezer('')->Toaster('');
+  $perlstring = sub { $d->Values([shift])->Dump };
+}
+else {
+  require B;
+  $perlstring = \&B::perlstring;
+}
+
+
 my $maker_templates = {
   rw => {
     xs_call => 'accessors',
     pp_code => sub {
-      my $set = "set_$_[0]";
-      my $get = "get_$_[0]";
-      my $field = $_[1];
-      $field =~ s/'/\\'/g;
-
-      "
-        \@_ != 1
-          ? shift->$set('$field', \@_)
-          : shift->$get('$field')
-      "
+      # my ($group, $fieldname) = @_;
+      my $quoted_fieldname = $perlstring->($_[1]);
+      sprintf <<'EOS', ($_[0], $quoted_fieldname) x 2;
+
+@_ > 1
+  ? shift->set_%s(%s, @_)
+  : shift->get_%s(%s)
+EOS
+
     },
   },
   ro => {
     xs_call => 'getters',
     pp_code => sub {
-      my $get = "get_$_[0]";
-      my $field = $_[1];
-      $field =~ s/'/\\'/g;
-
-      "
-        \@_ == 1
-          ? shift->$get('$field')
-          : do {
-            my \$caller = caller;
-            my \$class = length( ref(\$_[0]) ) ? ref(\$_[0]) : \$_[0];
-            Carp::croak(\"'\$caller' cannot alter the value of '$field' \".
-                        \"(read-only attributes of class '\$class')\");
-          }
-      "
+      # my ($group, $fieldname) = @_;
+      my $quoted_fieldname = $perlstring->($_[1]);
+      sprintf  <<'EOS', $quoted_fieldname, $_[0], $quoted_fieldname;
+
+@_ > 1
+  ? do {
+    my $caller = caller;
+    my $class = length( ref($_[0]) ) ? ref($_[0]) : $_[0];
+    Carp::croak(sprintf
+      "'%%s' cannot alter the value of '%%s' (read-only attribute of class '%%s')",
+      $caller, %s, $class
+    );
+  }
+  : shift->get_%s(%s)
+EOS
+
     },
   },
   wo => {
     xs_call => 'setters',
     pp_code => sub {
-      my $set = "set_$_[0]";
-      my $field = $_[1];
-      $field =~ s/'/\\'/g;
-
-      "
-        \@_ != 1
-          ? shift->$set('$field', \@_)
-          : do {
-            my \$caller = caller;
-            my \$class = length ( ref(\$_[0]) ) ? ref(\$_[0]) : \$_[0];
-            Carp::croak(\"'\$caller' cannot access the value of '$field' \".
-                        \"(write-only attributes of class '\$class')\");
-          }
-      "
+      # my ($group, $fieldname) = @_;
+      my $quoted_fieldname = $perlstring->($_[1]);
+      sprintf  <<'EOS', $_[0], ($quoted_fieldname) x 2;
+
+@_ > 1
+  ? shift->set_%s(%s, @_)
+  : do {
+    my $caller = caller;
+    my $class = length( ref($_[0]) ) ? ref($_[0]) : $_[0];
+    Carp::croak(sprintf
+      "'%%s' cannot access the value of '%%s' (write-only attribute of class '%%s')",
+      $caller, %s, $class
+    );
+  }
+EOS
+
     },
   },
 };
diff --git a/t/accessors.t b/t/accessors.t
index a7f7b00..a525715 100644
--- a/t/accessors.t
+++ b/t/accessors.t
@@ -1,4 +1,4 @@
-use Test::More tests => 117;
+use Test::More tests => 137;
 use strict;
 use warnings;
 use lib 't/lib';
@@ -61,6 +61,10 @@ my $test_accessors = {
   lr2name => {
     custom_field => "lr2'field",
   },
+  fieldname_torture => {
+    custom_field => join ('', map { chr($_) } (0..255) ),
+    is_xs => $use_xs,
+  },
 };
 
 for my $name (sort keys %$test_accessors) {
diff --git a/t/accessors_ro.t b/t/accessors_ro.t
index 6834fb9..7b385a2 100644
--- a/t/accessors_ro.t
+++ b/t/accessors_ro.t
@@ -1,4 +1,4 @@
-use Test::More tests => 48;
+use Test::More tests => 58;
 use Test::Exception;
 use strict;
 use warnings;
@@ -52,6 +52,10 @@ my $test_accessors = {
   lr2name => {
     custom_field => "lr2'field",
   },
+  fieldname_torture => {
+    custom_field => join ('', map { chr($_) } (1..255) ), # FIXME after RT#80569 is fixed 0..255 should work
+    is_xs => $use_xs,
+  },
 };
 
 for my $name (sort keys %$test_accessors) {
diff --git a/t/accessors_wo.t b/t/accessors_wo.t
index 68c3eea..39c5d7a 100644
--- a/t/accessors_wo.t
+++ b/t/accessors_wo.t
@@ -1,4 +1,4 @@
-use Test::More tests => 38;
+use Test::More tests => 46;
 use Test::Exception;
 use strict;
 use warnings;
@@ -51,6 +51,10 @@ my $test_accessors = {
   lr2name => {
     custom_field => "lr2'field",
   },
+  fieldname_torture => {
+    custom_field => join ('', map { chr($_) } (1..255) ), # FIXME after RT#80569 is fixed 0..255 should work
+    is_xs => $use_xs,
+  },
 };
 
 for my $name (sort keys %$test_accessors) {
diff --git a/t/lib/AccessorGroups.pm b/t/lib/AccessorGroups.pm
index a8e3b97..10801c8 100644
--- a/t/lib/AccessorGroups.pm
+++ b/t/lib/AccessorGroups.pm
@@ -18,6 +18,7 @@ __PACKAGE__->mk_group_accessors('simple', 'singlefield');
 __PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/);
 __PACKAGE__->mk_group_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]);
 __PACKAGE__->mk_group_accessors('simple', 'runtime_around');
+__PACKAGE__->mk_group_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]);
 
 sub get_simple {
   my $v = shift->SUPER::get_simple (@_);
diff --git a/t/lib/AccessorGroupsRO.pm b/t/lib/AccessorGroupsRO.pm
index 1f88a47..d023275 100644
--- a/t/lib/AccessorGroupsRO.pm
+++ b/t/lib/AccessorGroupsRO.pm
@@ -6,6 +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) ) ]);
 
 sub new {
   return bless {}, shift;
diff --git a/t/lib/AccessorGroupsWO.pm b/t/lib/AccessorGroupsWO.pm
index 2ea6887..b8b8c56 100644
--- a/t/lib/AccessorGroupsWO.pm
+++ b/t/lib/AccessorGroupsWO.pm
@@ -6,6 +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) ) ]);
 
 sub new {
   return bless {}, shift;