Add support for Type in native traits

[gitmo/Moose.git] / lib / Moose / Meta / Method / Accessor / Native / Collection.pm

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Collection.pm b/lib/Moose/Meta/Method/Accessor/Native/Collection.pm
index d06ae03..cd58f4b 100644 (file)
--- 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 . ';',
     );
 }
@@ -50,6 +50,7 @@ sub _writer_value_needs_copy {
 
 sub _inline_tc_code {
     my $self = shift;
+    my ($value, $tc, $coercion, $message, $is_lazy) = @_;
 
     return unless $self->_constraint_must_be_checked;
 
@@ -60,8 +61,8 @@ sub _inline_tc_code {
     }
     else {
         return (
-            $self->_inline_check_coercion(@_),
-            $self->_inline_check_constraint(@_),
+            $self->_inline_check_coercion($value, $tc, $coercion, $is_lazy),
+            $self->_inline_check_constraint($value, $tc, $message, $is_lazy),
         );
     }
 }
@@ -86,7 +87,8 @@ sub _check_new_members_only {
     # constraint, so we need to check the whole value, not just the members.
     return 1
         if $self->_is_root_type( $tc->parent )
-            && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
+            && ( $tc->isa('Moose::Meta::TypeConstraint::Parameterized')
+                 || $tc->isa('Type::Constraint::Parameterized') );
 
     return 0;
 }
@@ -107,8 +109,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',
                 ) . ';',
             '}',
@@ -140,9 +142,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();