starting on the error messaging problem;

[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 50e2a9c..caed2ae 100644 (file)
--- a/lib/MooseX/Meta/TypeConstraint/Dependent.pm
+++ b/lib/MooseX/Meta/TypeConstraint/Dependent.pm
@@ -31,9 +31,9 @@ has 'dependent_type_constraint' => (
     is=>'ro',
     isa=>'Object',
     predicate=>'has_dependent_type_constraint',
-    required=>1,
     handles=>{
-        check_dependent=>'check',  
+        check_dependent=>'check',
+        get_message_dependent=>'get_message',
     },
 );
 
@@ -48,7 +48,6 @@ has 'constraining_type_constraint' => (
     is=>'ro',
     isa=>'Object',
     predicate=>'has_constraining_type_constraint',
-    required=>1,
     handles=>{
         check_constraining=>'check',  
     },
@@ -65,13 +64,15 @@ 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' => (
     is=>'ro',
     isa=>'CodeRef',
     predicate=>'has_comparison_callback',
-    required=>1,
 );
 
 =head2 constraint_generator
@@ -107,24 +108,33 @@ around 'new' => sub {
     return $self;
 };
 
-=head2 check($check_value, $constraining_value)
+=head2 validate
+
+We intercept validate in order to custom process the message
 
-Make sure when properly dispatch all the right values to the right spots
 
 =cut
 
 around 'check' => sub {
-    my ($check, $self, $check_value, $constraining_value) = @_;
-    
-    unless($self->check_dependent($check_value)) {
-        return;
-    }
+    my ($check, $self, @args) = @_;
+    my ($result, $message) = $self->_compiled_type_constraint->(@args);
+    warn $result;
+    return $result;
+};
 
-    unless($self->check_constraining($constraining_value)) {
-        return;
+around 'validate' => sub {
+    my ($validate, $self, @args) = @_;
+    my ($result, $message) = $self->_compiled_type_constraint->(@args);
+    
+    if($result) {
+        return $result;
+    } else {
+        if(defined $message) {
+            return "Inner: $message";
+        } else { warn '......................';
+            return $self->get_message(@args);
+        }
     }
-
-    return $self->$check($check_value, $constraining_value);
 };
 
 =head2 generate_constraint_for ($type_constraints)
@@ -135,14 +145,25 @@ of values (to be passed at check time)
 =cut
 
 sub generate_constraint_for {
-    my ($self, $callback, $constraining) = @_;
+    my ($self, $callback) = @_;
     return sub {   
-        my ($check_value, $constraining_value) = @_;
+        my $dependent_pair = shift @_;
+        my ($dependent, $constraining) = @$dependent_pair;
+        
+        ## First need to test the bits
+        unless($self->check_dependent($dependent)) {
+            return (undef, 'bbbbbb');
+        }
+    
+        unless($self->check_constraining($constraining)) {
+            return;
+        }
+    
         my $constraint_generator = $self->constraint_generator;
         return $constraint_generator->(
+            $dependent,
             $callback,
-            $check_value,
-            $constraining_value,
+            $constraining,
         );
     };
 }
@@ -154,18 +175,18 @@ Given a ref of type constraints, create a structured type.
 =cut
 
 sub parameterize {
-    my ($self, $dependent, $callback, $constraining) = @_;
+    my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
     my $class = ref $self;
-    my $name = $self->_generate_subtype_name($dependent,  $callback, $constraining);
+    my $name = $self->_generate_subtype_name($dependent_tc,  $callback, $constraining_tc);
     my $constraint_generator = $self->__infer_constraint_generator;
 
     return $class->new(
         name => $name,
         parent => $self,
-        dependent_type_constraint=>$dependent,
+        dependent_type_constraint=>$dependent_tc,
         comparison_callback=>$callback,
         constraint_generator => $constraint_generator,
-        constraining_type_constraint => $constraining,
+        constraining_type_constraint => $constraining_tc,
     );
 }
 
@@ -176,10 +197,10 @@ Returns a name for the dependent type that should be unique
 =cut
 
 sub _generate_subtype_name {
-    my ($self, $dependent, $callback, $constraining) = @_;
+    my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
     return sprintf(
         "%s_depends_on_%s_via_%s",
-        $dependent, $constraining, $callback
+        $dependent_tc, $constraining_tc, $callback,
     );
 }
 
@@ -197,6 +218,7 @@ sub __infer_constraint_generator {
     if($self->has_constraint_generator) {
         return $self->constraint_generator;
     } else {
+        warn "I'm doing the questioning infer generator thing";
         return sub {
             ## I'm not sure about this stuff but everything seems to work
             my $tc = shift @_;
@@ -224,7 +246,6 @@ around 'compile_type_constraint' => sub {
         $self->has_constraining_type_constraint) {
         my $generated_constraint = $self->generate_constraint_for(
             $self->comparison_callback,
-             $self->constraining_type_constraint,
         );
         $self->_set_constraint($generated_constraint);       
     }
@@ -236,6 +257,8 @@ around 'compile_type_constraint' => sub {
 
 modifier to make sure we get the constraint_generator
 
+=cut
+
 around 'create_child_type' => sub {
     my ($create_child_type, $self, %opts) = @_;
     return $self->$create_child_type(