From: John Napiorkowski <johnn@ool-18e46e12.dyn.optonline.net>
Date: Thu, 1 Jul 2010 00:49:28 +0000 (-0400)
Subject: toward better error messages
X-Git-Tag: 0.23~8
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Types-Structured.git;a=commitdiff_plain;h=21d0e759ab986615952773d9dce93ec2b28f7b2a

toward better error messages
---

diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm
index 9a76e4c..33ed2c8 100644
--- a/lib/MooseX/Meta/TypeConstraint/Structured.pm
+++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm
@@ -66,18 +66,31 @@ Messing with validate so that we can support niced error messages.
 =cut
 
 override 'validate' => sub {
-    my ($self, @args) = @_;
-    my $message = bless {message=>undef}, 'MooseX::Types::Structured::Message';
+    my ($self, $value, $message) = @_;
+    $message = bless {message=>undef, level=>0}, 'MooseX::Types::Structured::Message'
+      unless $message;
 
-    if ($self->_compiled_type_constraint->(@args, $message)) {
+    $message->{level}++;
+
+    if ($self->_compiled_type_constraint->($value, $message)) {
         ## 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);
+        if(my $messages = $message->{message}) {
+            my $level = $message->{level};
+            my $message_str = ref $messages ? join("\n".(" "x$level)."[+] ",reverse @$messages) : $messages;        
+            $message->{level}--;
+
+            if($message->{level}) {
+                return $self->get_message($args);
+            } else {
+                return $self->get_message("$args, Internal Validation Error is: $message_str");
+            }
         } else {
+            $message->{level}--;
+
             return $self->get_message($args);
         }
     }
diff --git a/lib/MooseX/Types/Structured.pm b/lib/MooseX/Types/Structured.pm
index 214dcd9..c95ada8 100644
--- a/lib/MooseX/Types/Structured.pm
+++ b/lib/MooseX/Types/Structured.pm
@@ -744,9 +744,15 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
                 if(@values) {
                     my $value = shift @values;
                     unless($type_constraint->check($value)) {
-                        $_[2]->{message} = $type_constraint->get_message($value)
-                         if ref $_[2];
-                        return;
+                        my $message = $type_constraint->validate($value,$_[2]);
+                        if(ref $_[2]) {
+                            push @{$_[2]->{message}}, $message
+                             if ref $_[2];
+                            return;
+                        } else {
+#warn "Don't know what to do with $message";
+return;
+                        }
                     }
                 } else {
                     ## Test if the TC supports null values
@@ -782,7 +788,7 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
     MooseX::Meta::TypeConstraint::Structured->new(
         name => "MooseX::Types::Structured::Dict",
         parent => find_type_constraint('HashRef'),
-        constraint_generator=> sub {
+        constraint_generator => sub {
             ## Get the constraints and values to check
             my ($type_constraints, $values) = @_;
             my @type_constraints = defined $type_constraints ?
@@ -803,9 +809,15 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
                     my $value = $values{$key};
                     delete $values{$key};
                     unless($type_constraint->check($value)) {
-                        $_[2]->{message} = $type_constraint->get_message($value)
-                         if ref $_[2];
-                        return;
+                        my $message = $type_constraint->validate($value,$_[2]);
+                        if(ref $_[2]) {
+                            push @{$_[2]->{message}}, $message
+                             if ref $_[2];
+                            return;
+                        } else {
+#warn "Don't know what to do with $message";
+return;
+                        }
                     }
                 } else {
                     ## Test to see if the TC supports null values
diff --git a/t/12-error.t b/t/12-error.t
index e253c78..7df84f0 100644
--- a/t/12-error.t
+++ b/t/12-error.t
@@ -1,7 +1,7 @@
 BEGIN {
     use strict;
     use warnings;
-    use Test::More tests=>25;
+    use Test::More tests=>27;
 }
 
 use Moose::Util::TypeConstraints;
@@ -116,10 +116,51 @@ my $deep_tuple = subtype 'deep_tuple',
 ok $deep_tuple->check([1,{a=>2},{name=>'Vincent',age=>15}]),
   'Good Constraint';
 
-like $deep_tuple->validate([1,{a=>2},{name=>'Vincent',age=>'Hello'}]),
-  qr/Error is: Validation failed for 'MooseX::Types::Structured::Dict\[name,Str,age,Int\]'/,
-  'Example deeper error';
+{
+    my $message = $deep_tuple->validate([1,{a=>2},{name=>'Vincent',age=>'Hello'}]);
+    like $message,
+      qr/Validation failed for 'MooseX::Types::Structured::Dict\[name,Str,age,Int\]'/,
+      'Example deeper error';
+}
+
+like $simple_tuple->validate(["aaa","bbb"]),
+  qr/'Int' with value aaa/,
+  'correct deeper error';
+
+like $deep_tuple->validate([1,{a=>2},{name=>'Vincent1',age=>'Hello1'}]),
+  qr/'Int' with value Hello1/,
+  'correct deeper error';
+
+my $deeper_tc = subtype
+  as Dict[
+    a => Tuple[
+        Dict[
+            a1a => Tuple[Int],
+            a1b => Tuple[Int],
+        ],
+        Dict[
+            a2a => Tuple[Int],
+            a2b => Tuple[Int],
+        ],
+    ],
+    b => Tuple[
+        Dict[
+            b1a => Tuple[Int],
+            b1b => Tuple[Int],
+        ],
+        Dict[
+            b2a => Tuple[Int],
+            b2b => Tuple[Int],
+        ],
+    ],
+  ];
+
+{
+    my $message = $deeper_tc->validate({a=>[{a1a=>[1],a1b=>[2]},{a2a=>[3],a2b=>[4]}],b=>[{b1a=>[5],b1b=>['AA']},{b2a=>[7],b2b=>[8]}]});
+    warn $message;
+}
 
 ## Success Tests...
 
 ok !$deep_tuple->validate([1,{a=>2},{name=>'John',age=>40}]), 'Validates ok';
+