updated makefile requirements and got the basics of coercions in place

diff --git a/Makefile.PL b/Makefile.PL
index c25ab1b..e8a38dc 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -13,6 +13,8 @@ requires 'Moose' => '0.79';
 requires 'MooseX::Types' => '0.10';
 requires 'Scalar::Util' => '1.19';
 requires 'Devel::PartialDump' => '0.07';
+requires 'Data::Dump' => '';
+requires 'Digest::MD5' => '';
 
 build_requires 'Test::More' => '0.86';
 build_requires 'Test::Exception' => '0.27';

diff --git a/lib/MooseX/Dependent.pm b/lib/MooseX/Dependent.pm
index 9ab310e..18f6e52 100644 (file)
--- a/lib/MooseX/Dependent.pm
+++ b/lib/MooseX/Dependent.pm
@@ -87,6 +87,8 @@ and set the dependency target to the value of another attribute or method:
     
     has people => (is=>'ro', isa=>Set, required=>1);
     has id => (is=>'ro', dependent_isa=>UniqueID, required=>1);
+    
+    TODO notes, coerce=>1 should coerce both check value and constraining value
 
 Please see the test cases for more examples.
 

diff --git a/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm b/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm
index b05a3e2..79ca107 100644 (file)
--- a/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm
+++ b/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm
@@ -4,7 +4,9 @@ package ## Hide from PAUSE
 use Moose;
 use Moose::Util::TypeConstraints ();
 use Scalar::Util qw(blessed);
-
+use Data::Dump;
+use Digest::MD5;
+            
 extends 'Moose::Meta::TypeConstraint';
 
 =head1 NAME
@@ -99,24 +101,38 @@ sub parameterize {
              
             Moose->throw_error('Too Many Args!  Two are allowed.') if @_;
             
-            return $class->new(
-                name => $self->_generate_subtype_name($arg1, $arg2),
-                parent => $self,
-                constraint => $self->constraint,
-                parent_type_constraint=>$arg1,
-                constraining_value_type_constraint => $arg2,
-            );
+            my $name = $self->_generate_subtype_name($arg1, $arg2);
+            if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
+                return $exists;
+            } else {
+                my $type_constraint = $class->new(
+                    name => $name,
+                    parent => $self,
+                    constraint => $self->constraint,
+                    parent_type_constraint=>$arg1,
+                    constraining_value_type_constraint => $arg2,
+                );
+                Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
+                return $type_constraint;
+            }
         } else {
             Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name)
              unless $arg1->is_a_type_of($self->constraining_value_type_constraint);
              
-            return $class->new(
-                name => $self->_generate_subtype_name($self->parent_type_constraint, $arg1),
-                parent => $self,
-                constraint => $self->constraint,
-                parent_type_constraint=>$self->parent_type_constraint,
-                constraining_value_type_constraint => $arg1,
-            );
+            my $name = $self->_generate_subtype_name($self->parent_type_constraint, $arg1);
+            if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
+                return $exists;
+            } else {
+                my $type_constraint = $class->new(
+                    name => $name,
+                    parent => $self,
+                    constraint => $self->constraint,
+                    parent_type_constraint=>$self->parent_type_constraint,
+                    constraining_value_type_constraint => $arg1,
+                );
+                Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint);
+                return $type_constraint;
+            }
         }
     } else {
         my $args;
@@ -140,15 +156,26 @@ sub parameterize {
         if(my $err = $self->constraining_value_type_constraint->validate($args)) {
             Moose->throw_error($err);
         } else {
-            ## TODO memorize or do a registry lookup on the name as an optimization
-            return $class->new(
-                name => $self->name."[$args]",
-                parent => $self,
-                constraint => $self->constraint,
-                constraining_value => $args,
-                parent_type_constraint=>$self->parent_type_constraint,
-                constraining_value_type_constraint => $self->constraining_value_type_constraint,
-            );            
+
+            my $sig = $args;
+            if(ref $sig) {
+                $sig = Digest::MD5::md5_hex(Data::Dump::dump($args));               
+            }
+            my $name = $self->name."[$sig]";
+            if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) {
+                return $exists;
+            } else {
+                my $type_constraint = $class->new(
+                    name => $name,
+                    parent => $self,
+                    constraint => $self->constraint,
+                    constraining_value => $args,
+                    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);
+                return $type_constraint;
+            }
         }
     } 
 }
@@ -266,6 +293,16 @@ around '_compiled_type_constraint' => sub {
     };
 };
 
+around 'coerce' => sub {
+    my ($coerce, $self, @args) = @_;
+    if($self->coercion) {
+        if(my $value = $self->$coerce(@args)) {
+            return $value;
+        } 
+    }
+    return $self->parent->coerce(@args);
+};
+
 =head2 get_message
 
 Give you a better peek into what's causing the error.

diff --git a/lib/MooseX/Dependent/Types.pm b/lib/MooseX/Dependent/Types.pm
index cec413e..57000a2 100644 (file)
--- a/lib/MooseX/Dependent/Types.pm
+++ b/lib/MooseX/Dependent/Types.pm
@@ -51,7 +51,7 @@ for a integer, such as in:
        RangedInt([{min=>50, max=>75}])->check(99); ## Not OK, 99 exceeds max
        
 This throws a hard Moose exception.  You'll need to capture it in an eval or
-related exception catching system (see L<Try::Catch>).
+related exception catching system (see L<TryCatch>).
 
        RangedInt([{min=>99, max=>10}])->check(10); ## Not OK, not a valid Range!
 

diff --git a/t/03-coercions.t b/t/03-coercions.t
index 3743b80..db900d3 100644 (file)
--- a/t/03-coercions.t
+++ b/t/03-coercions.t
@@ -1,5 +1,5 @@
 
-use Test::More tests=>9; {
+use Test::More tests=>14; {
        
        use strict;
        use warnings;
@@ -33,7 +33,27 @@ use Test::More tests=>9; {
        ok !OlderThanAge([older_than=>1])->check('aaa'), '"aaa" not an int';
        ok !OlderThanAge([older_than=>10])->check(9), '9 is not older than 10';
        
+       my $a = OlderThanAge([older_than=>1]);
+       
+       coerce $a,
+               from ArrayRef,
+               via {
+                       my ($arrayref, $constraining_value) = @_;
+                       my $age;
+                       $age += $_ for @$arrayref;
+                       return $age;
+               };
+       
+       is $a->coerce([1,2,3]), 6, 'Got expected Value';
+       
        coerce OlderThanAge,
+               from HashRef,
+               via {
+                       my ($hashref, $constraining_value) = @_;
+                       return keys %$hashref;
+               };
+
+       coerce OlderThanAge([older_than=>5]),
                from ArrayRef,
                via {
                        my ($arrayref, $constraining_value) = @_;
@@ -41,6 +61,15 @@ use Test::More tests=>9; {
                        $age += $_ for @$arrayref;
                        return $age;
                };
-               
-       #warn OlderThanAge([older_than=>1])->coerce([1,2,3,4]);
+
+       is OlderThanAge->name, 'main::OlderThanAge',
+         'Got corect name for OlderThanAge';
+       is OlderThanAge([older_than=>5])->coerce([1..10]), 55,
+         'Coerce works';
+       like OlderThanAge([older_than=>2])->name, qr/main::OlderThanAge\[/,
+         'Got correct name for OlderThanAge([older_than=>2])';
+       is OlderThanAge([older_than=>2])->coerce({a=>1,b=>2,c=>3,d=>4}), 4,
+         'inherited Coerce works';
+       
+       
 }
\ No newline at end of file