properly supporting a where clause in the suger example and proof you can customize...

[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..ae6ca56 100644 (file)
--- a/lib/MooseX/Meta/TypeConstraint/Dependent.pm
+++ b/lib/MooseX/Meta/TypeConstraint/Dependent.pm
@@ -31,7 +31,6 @@ has 'dependent_type_constraint' => (
     is=>'ro',
     isa=>'Object',
     predicate=>'has_dependent_type_constraint',
-    required=>1,
     handles=>{
         check_dependent=>'check',  
     },
@@ -48,7 +47,6 @@ has 'constraining_type_constraint' => (
     is=>'ro',
     isa=>'Object',
     predicate=>'has_constraining_type_constraint',
-    required=>1,
     handles=>{
         check_constraining=>'check',  
     },
@@ -65,13 +63,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,26 +107,6 @@ around 'new' => sub {
     return $self;
 };
 
-=head2 check($check_value, $constraining_value)
-
-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;
-    }
-
-    unless($self->check_constraining($constraining_value)) {
-        return;
-    }
-
-    return $self->$check($check_value, $constraining_value);
-};
-
 =head2 generate_constraint_for ($type_constraints)
 
 Given some type constraints, use them to generate validation rules for an ref
@@ -135,14 +115,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) = @_;
+        my ($dependent, $constraining) = @$dependent_pair;
+        
+        ## First need to test the bits
+        unless($self->check_dependent($dependent)) {
+            return;
+        }
+    
+        unless($self->check_constraining($constraining)) {
+            return;
+        }
+    
         my $constraint_generator = $self->constraint_generator;
         return $constraint_generator->(
+            $dependent,
             $callback,
-            $check_value,
-            $constraining_value,
+            $constraining,
         );
     };
 }
@@ -154,18 +145,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 +167,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 +188,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 +216,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 +227,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(
@@ -244,6 +237,20 @@ around 'create_child_type' => sub {
     );
 };
 
+=head2 constraint
+
+We modify constraint so that the value pass is automatically dereferenced
+
+=cut
+
+around 'constraint' => sub {
+    my ($constraint, $self) = @_;
+    return sub {
+        my ($arg) = @_;
+        $self->$constraint->($arg);
+    };
+};
+
 =head2 is_a_type_of
 
 =head2 is_subtype_of