Bug fixes for handling attr names like "@foo"

Squashed commit of the following:

commit 7607ae11345e64bbb5e1b2aa6ac50b2a4fde2154
Author: Dave Rolsky <autarch@urth.org>
Date:   Sun Jan 17 11:18:38 2010 -0600

    Add changes for bug fix

commit bc41986f83d549a00b9b1eb2b50590a41546d3dc
Author: Dave Rolsky <autarch@urth.org>
Date:   Sun Jan 17 11:07:09 2010 -0600

    Quotemeta one last name

commit 4a5cc686e344c2dedbf15d9c91536edb1f0e40b5
Author: Dave Rolsky <autarch@urth.org>
Date:   Sun Jan 17 11:06:00 2010 -0600

    start fixing use of non-alpha names and remove more unused vars

commit 8beb437913f2f1c194e78597da4af48cf22dba23
Author: Dave Rolsky <autarch@urth.org>
Date:   Sun Jan 17 11:04:43 2010 -0600

    More type fixes for values

commit ff707cbf2bdb2adfc2c9100fc0cc6e4a24b6c1b6
Author: Dave Rolsky <autarch@urth.org>
Date:   Sun Jan 17 11:03:57 2010 -0600

    Fix value for has spaces

commit b2dc594248b2f7c88afce07c9561b5059806ccd0
Author: Dave Rolsky <autarch@urth.org>
Date:   Sun Jan 17 11:03:30 2010 -0600

    Add reader for !req

commit 85fe6c1e51c2e53483312a41090430df3c26916c
Author: Dave Rolsky <autarch@urth.org>
Date:   Sun Jan 17 10:59:52 2010 -0600

    Improve non-alpha attr tests. Need to include constraints and required attrs to smoke out bugs.

    Also use with_immutable for tests

commit 3c3def7dc1347edf8b0316467c3c2439fa7fc6f6
Author: Dave Rolsky <autarch@urth.org>
Date:   Sun Jan 17 10:58:04 2010 -0600

    Remove unused variables from the environment for accessors when evaling code

commit 4510a53ce87a440ed9bb9a2a028053e6c93ad0f3
Author: Dave Rolsky <autarch@urth.org>
Date:   Sun Jan 17 10:56:21 2010 -0600

    Remove more unused variables

commit 6c40837349c828f159ea8dd752d847991e43ddf1
Author: Dave Rolsky <autarch@urth.org>
Date:   Sun Jan 17 10:51:30 2010 -0600

    Remove unused variable

diff --git a/Changes b/Changes
index c209b8d..b1eb911 100644 (file)
--- a/Changes
+++ b/Changes
@@ -17,6 +17,12 @@ next
 
   Requested by Shawn Moore. Addresses RT #51143 (and then some). (Dave Rolsky)
 
+[BUG FIXES]
+
+* Fix handling of non-alphanumeric attributes names like '@foo'. This should
+  work as long as the accessor method names are explicitly set to valid Perl
+  method names. Reported by Doug Treder. RT #53731. (Dave Rolsky)
+
 
 0.93_03 Tue, Jan 5, 2009
 

diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm
index e7c26a5..136f6ea 100644 (file)
--- a/lib/Moose/Meta/Method/Accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor.pm
@@ -25,10 +25,8 @@ sub _eval_code {
     my $type_constraint_obj = $attr->type_constraint;
     my $environment = {
         '$attr' => \$attr,
-        '$attr_name' => \$attr->name,
         '$meta' => \$self,
         '$type_constraint_obj' => \$type_constraint_obj,
-        '$type_constraint_name' => \($type_constraint_obj && $type_constraint_obj->name),
         '$type_constraint' => \($type_constraint_obj
                                    ? $type_constraint_obj->_compiled_type_constraint
                                    : undef),
@@ -48,7 +46,6 @@ sub _eval_code {
 sub _generate_accessor_method_inline {
     my $self        = $_[0];
     my $attr        = $self->associated_attribute;
-    my $attr_name   = $attr->name;
     my $inv         = '$_[0]';
     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
 
@@ -72,9 +69,8 @@ sub _generate_accessor_method_inline {
 sub _generate_writer_method_inline {
     my $self        = $_[0];
     my $attr        = $self->associated_attribute;
-    my $attr_name   = $attr->name;
     my $inv         = '$_[0]';
-    my $slot_access = $self->_inline_get($inv, $attr_name);
+    my $slot_access = $self->_inline_get($inv);
     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
 
     $self->_eval_code('sub { '
@@ -93,9 +89,8 @@ sub _generate_writer_method_inline {
 sub _generate_reader_method_inline {
     my $self        = $_[0];
     my $attr        = $self->associated_attribute;
-    my $attr_name   = $attr->name;
     my $inv         = '$_[0]';
-    my $slot_access = $self->_inline_get($inv, $attr_name);
+    my $slot_access = $self->_inline_get($inv);
 
     $self->_eval_code('sub {'
     . $self->_inline_pre_body(@_)
@@ -129,11 +124,10 @@ sub _inline_check_constraint {
     my ($self, $value) = @_;
 
     my $attr = $self->associated_attribute;
-    my $attr_name = $attr->name;
 
     return '' unless $attr->has_type_constraint;
 
-    my $type_constraint_name = $attr->type_constraint->name;
+    my $attr_name = quotemeta( $attr->name );
 
     qq{\$type_constraint->($value) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) does not pass the type constraint because: " . \$type_constraint_obj->get_message($value)}, "data => $value") . ";";
 }
@@ -151,9 +145,10 @@ sub _inline_check_required {
     my $self = shift;
     my $attr = $self->associated_attribute;
 
-    my $attr_name = $attr->name;
-
     return '' unless $attr->is_required;
+
+    my $attr_name = quotemeta( $attr->name );
+
     return qq{(\@_ >= 2) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) is required, so cannot be set to undef"}) . ';' # defined $_[1] is not good enough
 }
 
@@ -164,7 +159,7 @@ sub _inline_check_lazy {
 
     return '' unless $attr->is_lazy;
 
-    my $slot_exists = $self->_inline_has($instance, $attr->name);
+    my $slot_exists = $self->_inline_has($instance);
 
     my $code = 'unless (' . $slot_exists . ') {' . "\n";
     if ($attr->has_type_constraint) {
@@ -293,7 +288,9 @@ sub _inline_auto_deref {
         $sigil = '%';
     }
     else {
-        $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", type_constraint => $type_constraint );
+        $self->throw_error( "Can not auto de-reference the type constraint '"
+                . quotemeta( $type_constraint->name )
+                . "'", type_constraint => $type_constraint );
     }
 
     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";

diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index bce06e8..90849a9 100644 (file)
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -199,7 +199,7 @@ sub _generate_slot_initializer {
 
     if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
         push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
-                        '|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
+                        '|| ' . $self->_inline_throw_error('"Attribute (' . quotemeta($attr->name) . ') is required"') .';');
     }
 
     if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
@@ -326,7 +326,7 @@ sub _generate_type_constraint_check {
     my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
     return (
         $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
-        . $attr->name
+        . quotemeta( $attr->name )
         . ') does not pass the type constraint because: " . '
         . $type_constraint_obj . '->get_message(' . $value_name . ')')
         . "\n\t unless " .  $type_constraint_cv . '->(' . $value_name . ');'

diff --git a/t/020_attributes/030_non_alpha_attr_names.t b/t/020_attributes/030_non_alpha_attr_names.t
index c2b1fb6..f710c88 100644 (file)
--- a/t/020_attributes/030_non_alpha_attr_names.t
+++ b/t/020_attributes/030_non_alpha_attr_names.t
@@ -2,6 +2,7 @@ use strict;
 use warnings;
 
 use Test::More;
+use Test::Moose;
 
 {
     package Foo;
@@ -12,32 +13,54 @@ use Test::More;
         default  => 1,
     );
 
+    # Assigning types to these non-alpha attrs exposed a bug in Moose.
     has '@type' => (
+        isa      => 'Str',
         required => 0,
         reader   => 'get_at_type',
-        default  => 2,
+        writer   => 'set_at_type',
+        default  => 'at type',
     );
 
     has 'has spaces' => (
+        isa      => 'Int',
         required => 0,
         reader   => 'get_hs',
         default  => 42,
     );
 
+    has '!req' => (
+        required => 1,
+        reader   => 'req'
+    );
+
     no Moose;
 }
 
-{
-    my $foo = Foo->new;
-
+with_immutable {
     ok( Foo->meta->has_attribute($_), "Foo has '$_' attribute" )
         for 'type', '@type', 'has spaces';
 
-    is( $foo->get_type,    1,  q{'type' attribute default is 1} );
-    is( $foo->get_at_type, 2,  q{'@type' attribute default is 1} );
-    is( $foo->get_hs,      42, q{'has spaces' attribute default is 42} );
+    my $foo = Foo->new( '!req' => 42 );
+
+    is( $foo->get_type,    1,         q{'type' attribute default is 1} );
+    is( $foo->get_at_type, 'at type', q{'@type' attribute default is 1} );
+    is( $foo->get_hs, 42, q{'has spaces' attribute default is 42} );
+
+    $foo = Foo->new(
+        type         => 'foo',
+        '@type'      => 'bar',
+        'has spaces' => 200,
+        '!req'       => 84,
+    );
+
+    isa_ok( $foo, 'Foo' );
+    is( $foo->get_at_type, 'bar', q{reader for '@type'} );
+    is( $foo->get_hs,      200, q{reader for 'has spaces'} );
 
-    Foo->meta->make_immutable, redo if Foo->meta->is_mutable;
+    $foo->set_at_type(99);
+    is( $foo->get_at_type, 99, q{writer for '@type' worked} );
 }
+'Foo';
 
 done_testing;