From: Dave Rolsky Date: Mon, 18 Jan 2010 04:20:18 +0000 (-0600) Subject: Bug fixes for handling attr names like "@foo" X-Git-Tag: 0.94~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=95d922a2fd10553fdca2e2b7f17e0cb7ab73b7b9;p=gitmo%2FMoose.git Bug fixes for handling attr names like "@foo" Squashed commit of the following: commit 7607ae11345e64bbb5e1b2aa6ac50b2a4fde2154 Author: Dave Rolsky Date: Sun Jan 17 11:18:38 2010 -0600 Add changes for bug fix commit bc41986f83d549a00b9b1eb2b50590a41546d3dc Author: Dave Rolsky Date: Sun Jan 17 11:07:09 2010 -0600 Quotemeta one last name commit 4a5cc686e344c2dedbf15d9c91536edb1f0e40b5 Author: Dave Rolsky 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 Date: Sun Jan 17 11:04:43 2010 -0600 More type fixes for values commit ff707cbf2bdb2adfc2c9100fc0cc6e4a24b6c1b6 Author: Dave Rolsky Date: Sun Jan 17 11:03:57 2010 -0600 Fix value for has spaces commit b2dc594248b2f7c88afce07c9561b5059806ccd0 Author: Dave Rolsky Date: Sun Jan 17 11:03:30 2010 -0600 Add reader for !req commit 85fe6c1e51c2e53483312a41090430df3c26916c Author: Dave Rolsky 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 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 Date: Sun Jan 17 10:56:21 2010 -0600 Remove more unused variables commit 6c40837349c828f159ea8dd752d847991e43ddf1 Author: Dave Rolsky Date: Sun Jan 17 10:51:30 2010 -0600 Remove unused variable --- diff --git a/Changes b/Changes index c209b8d..b1eb911 100644 --- 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 --- 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 --- 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 --- 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;