changed around to override since we are actually overriding this validation method

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

diff --git a/lib/MooseX/Meta/TypeConstraint/Dependent.pm b/lib/MooseX/Meta/TypeConstraint/Dependent.pm
index 4080494..6360c75 100644 (file)
--- a/lib/MooseX/Meta/TypeConstraint/Dependent.pm
+++ b/lib/MooseX/Meta/TypeConstraint/Dependent.pm
@@ -4,6 +4,7 @@ package ## Hide from PAUSE
 use Moose;
 use Moose::Util::TypeConstraints ();
 use MooseX::Meta::TypeCoercion::Dependent;
+use Devel::PartialDump;
 extends 'Moose::Meta::TypeConstraint';
 
 =head1 NAME
@@ -32,7 +33,8 @@ has 'dependent_type_constraint' => (
     isa=>'Object',
     predicate=>'has_dependent_type_constraint',
     handles=>{
-        check_dependent=>'check',  
+        check_dependent=>'check',
+        get_message_dependent=>'get_message',
     },
 );
 
@@ -48,7 +50,8 @@ has 'constraining_type_constraint' => (
     isa=>'Object',
     predicate=>'has_constraining_type_constraint',
     handles=>{
-        check_constraining=>'check',  
+        check_constraining=>'check',
+        get_message_constraining=>'get_message',
     },
 );
 
@@ -63,6 +66,9 @@ However, the 'where' clause only get's the check value.
 Exercise some sanity, this should be limited to actual comparision operations,
 not as a sneaky way to mess with the constraining value.
 
+This should return a Bool, suitable for ->check (That is true for valid, false
+for fail).
+
 =cut
 
 has 'comparison_callback' => (
@@ -104,6 +110,30 @@ around 'new' => sub {
     return $self;
 };
 
+=head2 validate
+
+We intercept validate in order to custom process the message.
+
+=cut
+
+override 'validate' => sub {
+    my ($self, @args) = @_;
+    my $compiled_type_constraint = $self->_compiled_type_constraint;
+    my $message = bless {message=>undef}, 'MooseX::Types::Dependent::Message';
+    my $result = $compiled_type_constraint->(@args, $message);
+
+    if($result) {
+        return $result;
+    } else {
+        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
@@ -114,15 +144,19 @@ of values (to be passed at check time)
 sub generate_constraint_for {
     my ($self, $callback) = @_;
     return sub {   
-        my ($dependent_pair) = @_;
+        my $dependent_pair = shift @_;
         my ($dependent, $constraining) = @$dependent_pair;
         
         ## First need to test the bits
         unless($self->check_dependent($dependent)) {
+            $_[0]->{message} = $self->get_message_dependent($dependent)
+             if $_[0];
             return;
         }
     
         unless($self->check_constraining($constraining)) {
+            $_[0]->{message} = $self->get_message_constraining($constraining)
+             if $_[0];
             return;
         }
     
@@ -176,7 +210,10 @@ sub _generate_subtype_name {
 This returns a CODEREF which generates a suitable constraint generator.  Not
 user servicable, you'll never call this directly.
 
-    TBD, this is definitely going to need some work.
+    TBD, this is definitely going to need some work.  Cargo culted from some
+    code I saw in Moose::Meta::TypeConstraint::Parameterized or similar.  I
+    Don't think I need this, since Dependent types require parameters, so
+    will always have a constrain generator.
 
 =cut
 
@@ -185,7 +222,7 @@ sub __infer_constraint_generator {
     if($self->has_constraint_generator) {
         return $self->constraint_generator;
     } else {
-        warn "I'm doing the questioning infer generator thing";
+        warn "I'm doing the questionable infer generator thing";
         return sub {
             ## I'm not sure about this stuff but everything seems to work
             my $tc = shift @_;
@@ -214,7 +251,7 @@ around 'compile_type_constraint' => sub {
         my $generated_constraint = $self->generate_constraint_for(
             $self->comparison_callback,
         );
-        $self->_set_constraint($generated_constraint);       
+        $self->_set_constraint($generated_constraint);
     }
 
     return $self->$compile_type_constraint;
@@ -289,17 +326,13 @@ sub type_constraints_equals {
 
 =head2 get_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
+Give you a better peek into what's causing the error.
 
-    TBD
+=cut
 
 around 'get_message' => sub {
     my ($get_message, $self, $value) = @_;
-    my $new_value = Devel::PartialDump::dump($value);
-    return $self->$get_message($new_value);
+    return $self->$get_message($value);
 };
 
 =head1 SEE ALSO