more pod and clarified license

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

diff --git a/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm b/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm
index 79ca107..359685d 100644 (file)
--- a/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm
+++ b/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm
@@ -3,6 +3,7 @@ package ## Hide from PAUSE
 
 use Moose;
 use Moose::Util::TypeConstraints ();
+use MooseX::Dependent::Meta::TypeCoercion::Dependent;
 use Scalar::Util qw(blessed);
 use Data::Dump;
 use Digest::MD5;
@@ -19,6 +20,11 @@ see L<MooseX::Dependent> for examples and details of how to use dependent
 types.  This class is a subclass of L<Moose::Meta::TypeConstraint> which
 provides the gut functionality to enable dependent type constraints.
 
+This class is not intended for public consumption.  Please don't subclass it
+or rely on it.  Chances are high stuff here is going to change a lot.  For
+example, I will probably refactor this into several classes to get rid of all
+the ugly conditionals.
+
 =head1 ATTRIBUTES
 
 This class defines the following attributes.
@@ -70,6 +76,23 @@ has 'constraining_value' => (
 
 This class defines the following methods.
 
+=head2 BUILD
+
+Do some post build stuff
+
+=cut
+
+## Right now I add in the dependent type coercion until I can merge some Moose
+## changes upstream
+
+around 'new' => sub {
+    my ($new, $class, @args) = @_;
+    my $self = $class->$new(@args);
+    my $coercion = MooseX::Dependent::Meta::TypeCoercion::Dependent->new(type_constraint => $self);
+    $self->coercion($coercion);    
+    return $self;
+};
+
 =head2 parameterize (@args)
 
 Given a ref of type constraints, create a structured type.
@@ -173,7 +196,9 @@ sub parameterize {
                     parent_type_constraint=>$self->parent_type_constraint,
                     constraining_value_type_constraint => $self->constraining_value_type_constraint,
                 );
-                Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
+                
+                ## TODO This is probably going to have to go away (too many things added to the registry)
+                ##Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
                 return $type_constraint;
             }
         }
@@ -239,6 +264,13 @@ around 'equals' => sub {
     }
 };
 
+=head2 is_subtype_of
+
+Method modifier to make sure we match on subtype for both the dependent type
+as well as the type being made dependent
+
+=cut
+
 around 'is_subtype_of' => sub {
     my ( $is_subtype_of, $self, $type_or_name ) = @_;
 
@@ -254,11 +286,11 @@ around 'is_subtype_of' => sub {
 
 };
 
-sub is_a_type_of {
-    my ($self, @args) = @_;
-    return ($self->equals(@args) ||
-      $self->is_subtype_of(@args));
-}
+=head2 check
+
+As with 'is_subtype_of', we need to dual dispatch the method request
+
+=cut
 
 around 'check' => sub {
     my ($check, $self, @args) = @_;
@@ -268,6 +300,12 @@ around 'check' => sub {
     );
 };
 
+=head2 validate
+
+As with 'is_subtype_of', we need to dual dispatch the method request
+
+=cut
+
 around 'validate' => sub {
     my ($validate, $self, @args) = @_;
     return (
@@ -276,6 +314,14 @@ around 'validate' => sub {
     );
 };
 
+=head2 _compiled_type_constraint
+
+modify this method so that we pass along the constraining value to the constraint
+coderef and also throw the correct error message if the constraining value does
+not match it's requirement.
+
+=cut
+
 around '_compiled_type_constraint' => sub {
     my ($method, $self, @args) = @_;
     my $coderef = $self->$method(@args);
@@ -293,14 +339,35 @@ around '_compiled_type_constraint' => sub {
     };
 };
 
+=head2 coerce
+
+More method modification to support dispatch coerce to a parent.
+
+=cut
+
 around 'coerce' => sub {
     my ($coerce, $self, @args) = @_;
-    if($self->coercion) {
-        if(my $value = $self->$coerce(@args)) {
-            return $value;
+    
+    if($self->has_constraining_value) {
+        push @args, $self->constraining_value;
+        if(@{$self->coercion->type_coercion_map}) {
+            my $coercion = $self->coercion;
+            my $coerced = $self->$coerce(@args);
+            if(defined $coerced) {
+                return $coerced;
+            } else {
+                my $parent = $self->parent;
+                return $parent->coerce(@args); 
+            }
+        } else {
+            my $parent = $self->parent;
+            return $parent->coerce(@args); 
         } 
     }
-    return $self->parent->coerce(@args);
+    else {
+        return $self->$coerce(@args);
+    }
+    return;
 };
 
 =head2 get_message
@@ -329,5 +396,6 @@ it under the same terms as Perl itself.
 
 =cut
 
-__PACKAGE__->meta->make_immutable(inline_constructor => 0);
+1;
+##__PACKAGE__->meta->make_immutable(inline_constructor => 0);