From: Dave Rolsky <autarch@urth.org>
Date: Thu, 21 Apr 2011 20:40:08 +0000 (-0500)
Subject: Whenever we inline a type constraint, we need to include its inline environment.
X-Git-Tag: 2.0100~47
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e750d47f97f7c7bc0c805d582455e994b64fe724;p=gitmo%2FMoose.git

Whenever we inline a type constraint, we need to include its inline environment.

Test every builtin TC as a simple attr's constraint, and as a native Array trait's member TC.

This thoroughly tests that we are propogating the TC's inline environment properly.
---

diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm
index 07d10f0..2bb2708 100644
--- a/lib/Moose/Meta/Method/Accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor.pm
@@ -44,8 +44,13 @@ sub _eval_environment {
         '$type_constraint_obj' => \$type_constraint_obj,
         '$type_constraint'     => \(
               $type_constraint_obj
-                  ? $type_constraint_obj->_compiled_type_constraint
-                  : undef
+            ? $type_constraint_obj->_compiled_type_constraint
+            : undef
+        ),
+        (
+            $type_constraint_obj
+            ? %{ $type_constraint_obj->inline_environment }
+            : ()
         ),
     };
 }
diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index 695b826..3acc738 100644
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -80,6 +80,7 @@ sub _eval_environment {
         '$defaults' => \$defaults,
         '@type_constraints' => \@type_constraints,
         '@type_constraint_bodies' => \@type_constraint_bodies,
+        ( map { %{ $_->inline_environment } } @type_constraints ),
     };
 }
 
diff --git a/lib/Moose/Meta/TypeConstraint/Parameterized.pm b/lib/Moose/Meta/TypeConstraint/Parameterized.pm
index 09c2473..c8c887a 100644
--- a/lib/Moose/Meta/TypeConstraint/Parameterized.pm
+++ b/lib/Moose/Meta/TypeConstraint/Parameterized.pm
@@ -72,6 +72,15 @@ sub can_be_inlined {
         && $self->type_parameter->can_be_inlined;
 }
 
+sub inline_environment {
+    my $self = shift;
+
+    return {
+        %{ $self->parameterized_from->inline_environment },
+        %{ $self->type_parameter->inline_environment },
+    };
+}
+
 sub _inline_check {
     my $self = shift;
 
diff --git a/t/type_constraints/util_std_type_constraints.t b/t/type_constraints/util_std_type_constraints.t
index 51b667c..181d647 100644
--- a/t/type_constraints/util_std_type_constraints.t
+++ b/t/type_constraints/util_std_type_constraints.t
@@ -1028,10 +1028,10 @@ sub test_constraint {
             isa => $type,
         )
     );
+
     $class->add_attribute(
         collection => (
             traits  => ['Array'],
-            is      => 'ro',
             isa     => 'ArrayRef[' . $type->name . ']',
             default => sub { [] },
             handles => { add_to_collection => 'push' },
@@ -1062,7 +1062,7 @@ sub test_constraint {
                 $anon_class->new( simple => $accept );
             },
             undef,
-            "no exception passing $described to constructor"
+            "no exception passing $described to constructor with $name"
         );
 
         is(
@@ -1070,7 +1070,7 @@ sub test_constraint {
                 $anon_class->new()->add_to_collection($accept);
             },
             undef,
-            "no exception passing $described to constructor"
+            "no exception passing $described to native trait push method with $name"
         );
     }
 
@@ -1095,14 +1095,14 @@ sub test_constraint {
             exception {
                 $anon_class->new( simple => $reject );
             },
-            "got exception passing $described to constructor"
+            "got exception passing $described to constructor with $name"
         );
 
         ok(
             exception {
                 $anon_class->new()->add_to_collection($reject);
             },
-            "got exception passing $described to constructor"
+            "got exception passing $described to native trait push method with $name"
         );
     }
 }