From: Stevan Little <stevan.little@iinteractive.com>
Date: Wed, 19 Sep 2007 02:23:09 +0000 (+0000)
Subject: adding fix for dexter
X-Git-Tag: 0_26~8
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3ccdc84a9133a12b740f930560088203253bb577;p=gitmo%2FMoose.git

adding fix for dexter
---

diff --git a/Changes b/Changes
index eb46bfe..d6e71cc 100644
--- a/Changes
+++ b/Changes
@@ -27,6 +27,10 @@ Revision history for Perl extension Moose
         on non-blessed items. (RT #29269)
         - added tests for this
     
+    * Moose::Meta::Method::Accessor
+      - fixed issue with generated accessor code making 
+        assumptions about hash based classes (thanks to dexter)
+    
     * Moose::Coookbook::Snacks
       - these are bits of documentation, not quite as big as 
         Recipes but which have no clear place in the module docs. 
diff --git a/PLANS b/PLANS
index eef625b..35c6aa1 100644
--- a/PLANS
+++ b/PLANS
@@ -1,12 +1,6 @@
 -----------------------------------------------------------
 -- Type Constraints refactor
------------------------------------------------------------
-
-- allow a switch of some kind to optionally turn TC checking off at runtime 
-
-The type checks can get expensive and some people have suggested that allowing 
-the checks to be turned off would be helpful for deploying into performance 
-intensive systems. Perhaps this can actually be done as an option to make_immutable? 
+----------------------------------------------------------- 
 
 - add support for locally scoped TC
 
@@ -22,6 +16,12 @@ would allow custom metaclasses to provide roles to extend the sugar syntax with.
 
 (NOTE: Talk to phaylon a bit more on this)
 
+- allow a switch of some kind to optionally turn TC checking off at runtime 
+
+The type checks can get expensive and some people have suggested that allowing 
+the checks to be turned off would be helpful for deploying into performance 
+intensive systems. Perhaps this can actually be done as an option to make_immutable?
+
 - misc. minor bits
 
 * make the errors for TCs use ->message
diff --git a/lib/Moose.pm b/lib/Moose.pm
index f363c93..4ed6614 100644
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -872,6 +872,8 @@ Yuval (nothingmuch) Kogman
 
 Chris (perigrin) Prather
 
+Piotr (dexter) Roszatycki
+
 Sam (mugwump) Vilain 
 
 ... and many other #moose folks
diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm
index b429cd4..7e05ba5 100644
--- a/lib/Moose/Meta/Method/Accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor.pm
@@ -15,14 +15,13 @@ use base 'Moose::Meta::Method',
 ## Inline method generators
 
 sub generate_accessor_method_inline {
-    my $self      = $_[0];
-    my $attr      = $self->associated_attribute; 
-    my $attr_name = $attr->name;
+    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 $value_name  = $attr->should_coerce ? '$val' : '$_[1]';
 
-    my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
-	my $mi = $attr->associated_class->get_meta_instance;
-	my $slot_name = sprintf "'%s'", $attr->slots;
-	my $inv = '$_[0]';
     my $code = 'sub { '
     . $self->_inline_pre_body(@_)
     . 'if (scalar(@_) == 2) {'
@@ -49,12 +48,13 @@ sub generate_accessor_method_inline {
 }
 
 sub generate_writer_method_inline {
-    my $self      = $_[0];
-    my $attr      = $self->associated_attribute; 
-    my $attr_name = $attr->name;
-    
-    my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
-	my $inv = '$_[0]';
+    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 $value_name  = $attr->should_coerce ? '$val' : '$_[1]';
+
     my $code = 'sub { '
     . $self->_inline_pre_body(@_)
     . $self->_inline_check_required
@@ -77,16 +77,18 @@ sub generate_writer_method_inline {
 }
 
 sub generate_reader_method_inline {
-    my $self      = $_[0];
-    my $attr      = $self->associated_attribute; 
-    my $attr_name = $attr->name;
+    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 $code = 'sub {'
     . $self->_inline_pre_body(@_)
     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
     . $self->_inline_check_lazy
     . $self->_inline_post_body(@_)
-    . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
+    . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
     . '}';
     
     # NOTE:
@@ -104,7 +106,7 @@ sub generate_reader_method_inline {
 *generate_writer_method   = \&generate_writer_method_inline;
 *generate_accessor_method = \&generate_accessor_method_inline;
 
-sub _inline_pre_body { '' }
+sub _inline_pre_body  { '' }
 sub _inline_post_body { '' }
 
 sub _inline_check_constraint {
@@ -114,6 +116,9 @@ sub _inline_check_constraint {
 	
 	return '' unless $attr->has_type_constraint;
 	
+	# FIXME
+	# This sprintf is insanely annoying, we should
+	# fix it someday - SL
 	return sprintf <<'EOF', $value, $value, $value, $value, $value, $value, $value
 defined($type_constraint->(%s))
 	|| confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
@@ -138,17 +143,21 @@ sub _inline_check_required {
 }
 
 sub _inline_check_lazy {
-	my $attr = (shift)->associated_attribute; 
+    my $self = $_[0];
+    my $attr = $self->associated_attribute; 
 	
 	return '' unless $attr->is_lazy;
 	
+    my $inv         = '$_[0]';
+    my $slot_access = $self->_inline_get($inv, $attr->name);	
+	
 	if ($attr->has_type_constraint) {
 	    # NOTE:
 	    # this could probably be cleaned 
 	    # up and streamlined a little more
-	    return 'unless (exists $_[0]->{$attr_name}) {' .
+	    return 'unless (exists ' . $slot_access . ') {' .
 	           '    if ($attr->has_default) {' .
-	           '        my $default = $attr->default($_[0]);' .
+	           '        my $default = $attr->default(' . $inv . ');' .
 	           ($attr->should_coerce
 	               ? '$default = $attr->type_constraint->coerce($default);'
 	               : '') .
@@ -156,15 +165,15 @@ sub _inline_check_lazy {
                '        	|| confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
                '               . $attr->type_constraint->name . ") with " . (defined($default) ? (Scalar::Util::blessed($default) && overload::Overloaded($default) ? overload::StrVal($default) : $default) : "undef")' .               
                '          if defined($default);' .	                
-	           '        $_[0]->{$attr_name} = $default; ' .
+	           '        ' . $slot_access . ' = $default; ' .
 	           '    }' .
 	           '    else {' .
-               '        $_[0]->{$attr_name} = undef;' .
+               '        ' . $slot_access . ' = undef;' .
 	           '    }' .
 	           '}';	    
 	}
-    return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
-         . 'unless exists $_[0]->{$attr_name};';
+    return $slot_access . ' = ($attr->has_default ? $attr->default(' . $inv . ') : undef)'
+         . 'unless exists ' . $slot_access . ';';
 }