fixed incorrect alway finding an error with TC->validate

[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 b58c92e..d7b655b 100644 (file)
--- a/lib/MooseX/Meta/TypeConstraint/Structured.pm
+++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm
@@ -2,6 +2,7 @@ package ## Hide from PAUSE
  MooseX::Meta::TypeConstraint::Structured;
 
 use Moose;
+use Devel::PartialDump;
 use Moose::Util::TypeConstraints ();
 use MooseX::Meta::TypeCoercion::Structured;
 extends 'Moose::Meta::TypeConstraint';
@@ -70,6 +71,29 @@ around 'new' => sub {
     return $self;
 };
 
+=head2 validate
+
+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';
+
+    if ($self->_compiled_type_constraint->(@args, $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");
+        } else {
+            return $self->get_message($args);
+        }
+    }
+};
+
 =head2 generate_constraint_for ($type_constraints)
 
 Given some type constraints, use them to generate validation rules for an ref
@@ -80,9 +104,10 @@ of values (to be passed at check time)
 sub generate_constraint_for {
     my ($self, $type_constraints) = @_;
     return sub {
-        my (@args) = @_;
+        my $arg =  shift @_;
         my $constraint_generator = $self->constraint_generator;
-        return $constraint_generator->($type_constraints, @args);
+        my $result = $constraint_generator->($type_constraints, $arg, $_[0]);
+        return $result;
     };
 }
 
@@ -215,7 +240,19 @@ sub type_constraints_equals {
 
 =head2 get_message
 
-May want to override this to set a more useful error message
+Give you a better peek into what's causing the error.  For now we stringify the
+incoming deep value with L<Devel::PartialDump> and pass that on to either your
+custom error message or the default one.  In the future we'll try to provide a
+more complete stack trace of the actual offending elements
+
+=cut
+
+around 'get_message' => sub {
+    my ($get_message, $self, $value) = @_;
+    $value = Devel::PartialDump::dump($value)
+     if ref $value;
+    return $self->$get_message($value);
+};
 
 =head1 SEE ALSO
 
@@ -234,4 +271,4 @@ it under the same terms as Perl itself.
 
 =cut
 
-1;
\ No newline at end of file
+__PACKAGE__->meta->make_immutable;
\ No newline at end of file