From: Jesse Luehrs <doy@tozt.net>
Date: Tue, 26 Apr 2011 01:15:32 +0000 (-0500)
Subject: also don't close over member tc objects in native delegations
X-Git-Tag: 2.0100~22
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ec02b571ce7161c0374d3b1da223fbdcdc5fd847;p=gitmo%2FMoose.git

also don't close over member tc objects in native delegations
---

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm
index 08d4723..3025947 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm
@@ -44,7 +44,7 @@ sub _inline_coerce_new_values {
 
     return unless $self->_tc_member_type_can_coerce;
 
-    return '@_ = ($_[0], $member_tc_obj->coerce($_[1]));';
+    return '@_ = ($_[0], $member_coercion->($_[1]));';
 };
 
 sub _new_members { '$_[1]' }
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm
index 6534fe0..33a8054 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm
@@ -51,7 +51,7 @@ sub _inline_coerce_new_values {
 
     return unless $self->_tc_member_type_can_coerce;
 
-    return '@_ = ($_[0], $member_tc_obj->coerce($_[1]));';
+    return '@_ = ($_[0], $member_coercion->($_[1]));';
 };
 
 sub _new_members { '$_[1]' }
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
index 4754768..ffed041 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
@@ -15,7 +15,7 @@ sub _inline_coerce_new_values {
     return unless $self->_tc_member_type_can_coerce;
 
     return (
-        '(' . $self->_new_members . ') = map { $member_tc_obj->coerce($_) }',
+        '(' . $self->_new_members . ') = map { $member_coercion->($_) }',
                                              $self->_new_members . ';',
     );
 }
@@ -108,8 +108,8 @@ sub _inline_check_member_constraint {
             "if ($check) {",
                 $self->_inline_throw_error(
                     '"A new member value for ' . $attr_name
-                  . ' does not pass its type constraint because: "'
-                  . ' . $member_tc_obj->get_message($new_val)',
+                  . ' does not pass its type constraint because: "' . ' . '
+                  . 'do { local $_ = $new_val; $member_message->($new_val) }',
                     'data => $new_val',
                 ) . ';',
             '}',
@@ -141,9 +141,15 @@ around _eval_environment => sub {
 
     return $env unless $member_tc;
 
-    $env->{'$member_tc_obj'} = \($member_tc);
-
     $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );
+    $env->{'$member_coercion'} = \(
+        $member_tc->coercion->_compiled_type_coercion
+    ) if $member_tc->has_coercion;
+    $env->{'$member_message'} = \(
+        $member_tc->has_message
+            ? $member_tc->message
+            : $member_tc->_default_message
+    );
 
     my $tc_env = $member_tc->inline_environment();
 
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm
index b60719d..9bcbaba 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm
@@ -79,7 +79,7 @@ sub _inline_coerce_new_values {
         'my $iter = List::MoreUtils::natatime(2, @_);',
         '@_ = ();',
         'while (my ($key, $val) = $iter->()) {',
-            'push @_, $key, $member_tc_obj->coerce($val);',
+            'push @_, $key, $member_coercion->($val);',
         '}',
     );
 };