From: john napiorkowski Date: Fri, 22 May 2009 19:49:46 +0000 (-0400) Subject: updated makefile requirements and got the basics of coercions in place X-Git-Tag: 0.01~13 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9c319add216c3b774b1740bf98b1a1f8492dc1c0;p=gitmo%2FMooseX-Dependent.git updated makefile requirements and got the basics of coercions in place --- diff --git a/Makefile.PL b/Makefile.PL index c25ab1b..e8a38dc 100644 --- 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 --- 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 --- 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 --- 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). +related exception catching system (see L). 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 --- 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