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 01853fe..ae6ca56 100644 (file)
--- a/lib/MooseX/Meta/TypeConstraint/Dependent.pm
+++ b/lib/MooseX/Meta/TypeConstraint/Dependent.pm
@@ -29,7 +29,11 @@ L</constraining_type_constraint>
 
 has 'dependent_type_constraint' => (
     is=>'ro',
+    isa=>'Object',
     predicate=>'has_dependent_type_constraint',
+    handles=>{
+        check_dependent=>'check',  
+    },
 );
 
 =head2 constraining_type_constraint
@@ -41,10 +45,14 @@ constraining value of the depending type.
 
 has 'constraining_type_constraint' => (
     is=>'ro',
+    isa=>'Object',
     predicate=>'has_constraining_type_constraint',
+    handles=>{
+        check_constraining=>'check',  
+    },
 );
 
-=head2 comparision_callback
+=head2 comparison_callback
 
 This is a callback which returns a boolean value.  It get's passed the value
 L</constraining_type_constraint> validates as well as the check value.
@@ -55,12 +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 'comparision_callback' => (
+has 'comparison_callback' => (
     is=>'ro',
     isa=>'CodeRef',
-    predicate=>'has_comparision_callback',
+    predicate=>'has_comparison_callback',
 );
 
 =head2 constraint_generator
@@ -74,6 +85,7 @@ has 'constraint_generator' => (
     is=>'ro',
     isa=>'CodeRef',
     predicate=>'has_constraint_generator',
+    required=>1,
 );
 
 =head1 METHODS
@@ -89,7 +101,7 @@ Initialization stuff.
 around 'new' => sub {
     my ($new, $class, @args)  = @_;
     my $self = $class->$new(@args);
-    $self->coercion(MooseX::Meta::TypeCoercion::Structured->new(
+    $self->coercion(MooseX::Meta::TypeCoercion::Dependent->new(
         type_constraint => $self,
     ));
     return $self;
@@ -103,33 +115,48 @@ of values (to be passed at check time)
 =cut
 
 sub generate_constraint_for {
-    my ($self, $dependent, $callback, $constraining) = @_;
-    return sub {
-        my (@args) = @_;
+    my ($self, $callback) = @_;
+    return sub {   
+        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, $constraining, @args);
+        return $constraint_generator->(
+            $dependent,
+            $callback,
+            $constraining,
+        );
     };
 }
 
-=head2 parameterize (@type_constraints)
+=head2 parameterize ($dependent, $callback, $constraining)
 
 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, $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,
-        comparision_callback=>$callback,
+        dependent_type_constraint=>$dependent_tc,
+        comparison_callback=>$callback,
         constraint_generator => $constraint_generator,
+        constraining_type_constraint => $constraining_tc,
     );
 }
 
@@ -140,10 +167,10 @@ Returns a name for the dependent type that should be unique
 =cut
 
 sub _generate_subtype_name {
-    my ($self, $dependent, $constraining) = @_;
+    my ($self, $dependent_tc, $callback, $constraining_tc) = @_;
     return sprintf(
-        "%s_depends_on_%s",
-        $dependent, $constraining
+        "%s_depends_on_%s_via_%s",
+        $dependent_tc, $constraining_tc, $callback,
     );
 }
 
@@ -161,13 +188,13 @@ 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 @_;
             my $merged_tc = [
                 @$tc,
-                $self->dependent_type_constraint,
-                $self->comparision_callback,
+                $self->comparison_callback,
                 $self->constraining_type_constraint,
             ];
             
@@ -183,15 +210,17 @@ hook into compile_type_constraint so we can set the correct validation rules.
 =cut
 
 around 'compile_type_constraint' => sub {
-    my ($compile_type_constraint, $self, @args) = @_;
+    my ($compile_type_constraint, $self) = @_;
     
-    if($self->has_type_constraints) {
-        my $type_constraints = $self->type_constraints;
-        my $constraint = $self->generate_constraint_for($type_constraints);
-        $self->_set_constraint($constraint);        
+    if($self->has_comparison_callback &&
+        $self->has_constraining_type_constraint) {
+        my $generated_constraint = $self->generate_constraint_for(
+            $self->comparison_callback,
+        );
+        $self->_set_constraint($generated_constraint);       
     }
 
-    return $self->$compile_type_constraint(@args);
+    return $self->$compile_type_constraint;
 };
 
 =head2 create_child_type
@@ -208,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
@@ -293,4 +336,4 @@ it under the same terms as Perl itself.
 
 =cut
 
-__PACKAGE__->meta->make_immutable;
\ No newline at end of file
+__PACKAGE__->meta->make_immutable;