use compiled constraints instead of objects

[gitmo/MooseX-Types-Structured.git] / lib / MooseX / Meta / TypeConstraint / Structured.pm

diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm
index 9a76e4c..0db946f 100644 (file)
--- a/lib/MooseX/Meta/TypeConstraint/Structured.pm
+++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm
@@ -65,18 +65,35 @@ Messing with validate so that we can support niced error messages.
 
 =cut
 
+sub _clean_message {
+    my $message = shift @_;
+    $message =~s/MooseX::Types::Structured:://g;
+    return $message;
+}
+
 override 'validate' => sub {
-    my ($self, @args) = @_;
-    my $message = bless {message=>undef}, 'MooseX::Types::Structured::Message';
+    my ($self, $value, $message_stack) = @_;
+    unless ($message_stack) {
+        $message_stack = MooseX::Types::Structured::MessageStack->new();
+    }
 
-    if ($self->_compiled_type_constraint->(@args, $message)) {
+    $message_stack->inc_level;
+
+    if ($self->_compiled_type_constraint->($value, $message_stack)) {
         ## Everything is good, no error message to return
         return undef;
     } else {
         ## Whoops, need to figure out the right error message
-        my $args = Devel::PartialDump::dump(@args);
-        if(my $message = $message->{message}) {
-            return $self->get_message("$args, Internal Validation Error is: $message");
+        my $args = Devel::PartialDump::dump($value);
+        $message_stack->dec_level;
+        if($message_stack->has_messages) {
+            if($message_stack->level) {
+                ## we are inside a deeply structured constraint
+                return $self->get_message($args);
+            } else {
+                my $message_str = $message_stack->as_string;
+                return _clean_message($self->get_message("$args, Internal Validation Error is: $message_str"));
+            }
         } else {
             return $self->get_message($args);
         }
@@ -92,12 +109,7 @@ of values (to be passed at check time)
 
 sub generate_constraint_for {
     my ($self, $type_constraints) = @_;
-    return sub {
-        my $arg =  shift @_;
-        my $constraint_generator = $self->constraint_generator;
-        my $result = $constraint_generator->($type_constraints, $arg, $_[0]);
-        return $result;
-    };
+    return $self->constraint_generator->($self, $type_constraints);
 }
 
 =method parameterize (@type_constraints)