From: John Napiorkowski Date: Sun, 29 Mar 2009 17:04:23 +0000 (+0000) Subject: Got the basic requirement in place! X-Git-Tag: 0.01~49 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Dependent.git;a=commitdiff_plain;h=3a5dab7415b3af75abb2e002d98eedf1ba441d28 Got the basic requirement in place! --- diff --git a/lib/MooseX/Meta/TypeConstraint/Dependent.pm b/lib/MooseX/Meta/TypeConstraint/Dependent.pm index 01853fe..50e2a9c 100644 --- a/lib/MooseX/Meta/TypeConstraint/Dependent.pm +++ b/lib/MooseX/Meta/TypeConstraint/Dependent.pm @@ -29,7 +29,12 @@ L has 'dependent_type_constraint' => ( is=>'ro', + isa=>'Object', predicate=>'has_dependent_type_constraint', + required=>1, + handles=>{ + check_dependent=>'check', + }, ); =head2 constraining_type_constraint @@ -41,10 +46,15 @@ constraining value of the depending type. has 'constraining_type_constraint' => ( is=>'ro', + isa=>'Object', predicate=>'has_constraining_type_constraint', + required=>1, + 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 validates as well as the check value. @@ -57,10 +67,11 @@ not as a sneaky way to mess with the constraining value. =cut -has 'comparision_callback' => ( +has 'comparison_callback' => ( is=>'ro', isa=>'CodeRef', - predicate=>'has_comparision_callback', + predicate=>'has_comparison_callback', + required=>1, ); =head2 constraint_generator @@ -74,6 +85,7 @@ has 'constraint_generator' => ( is=>'ro', isa=>'CodeRef', predicate=>'has_constraint_generator', + required=>1, ); =head1 METHODS @@ -89,12 +101,32 @@ 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; }; +=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 @@ -103,33 +135,37 @@ 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, $constraining) = @_; + return sub { + my ($check_value, $constraining_value) = @_; my $constraint_generator = $self->constraint_generator; - return $constraint_generator->($dependent, $callback, $constraining, @args); + return $constraint_generator->( + $callback, + $check_value, + $constraining_value, + ); }; } -=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 $class = ref $self; - my $name = $self->_generate_subtype_name($dependent, $constraining); + my $name = $self->_generate_subtype_name($dependent, $callback, $constraining); my $constraint_generator = $self->__infer_constraint_generator; return $class->new( name => $name, parent => $self, dependent_type_constraint=>$dependent, - comparision_callback=>$callback, + comparison_callback=>$callback, constraint_generator => $constraint_generator, + constraining_type_constraint => $constraining, ); } @@ -140,10 +176,10 @@ Returns a name for the dependent type that should be unique =cut sub _generate_subtype_name { - my ($self, $dependent, $constraining) = @_; + my ($self, $dependent, $callback, $constraining) = @_; return sprintf( - "%s_depends_on_%s", - $dependent, $constraining + "%s_depends_on_%s_via_%s", + $dependent, $constraining, $callback ); } @@ -166,8 +202,7 @@ sub __infer_constraint_generator { my $tc = shift @_; my $merged_tc = [ @$tc, - $self->dependent_type_constraint, - $self->comparision_callback, + $self->comparison_callback, $self->constraining_type_constraint, ]; @@ -183,23 +218,24 @@ 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->constraining_type_constraint, + ); + $self->_set_constraint($generated_constraint); } - return $self->$compile_type_constraint(@args); + return $self->$compile_type_constraint; }; =head2 create_child_type 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( @@ -293,4 +329,4 @@ it under the same terms as Perl itself. =cut -__PACKAGE__->meta->make_immutable; \ No newline at end of file +__PACKAGE__->meta->make_immutable; diff --git a/t/00-load.t b/t/00-load.t index 062b92b..d685168 100644 --- a/t/00-load.t +++ b/t/00-load.t @@ -1,11 +1,11 @@ -use Test::More tests=>3; { +use Test::More tests=>2; { use strict; use warnings; ## List all the modules we want to make sure can at least compile - use_ok 'MooseX::Types::Dependent'; + ##use_ok 'MooseX::Types::Dependent'; use_ok 'MooseX::Meta::TypeConstraint::Dependent'; use_ok 'MooseX::Meta::TypeCoercion::Dependent'; } diff --git a/t/01-basic.t b/t/01-basic.t index 136928b..611cb06 100644 --- a/t/01-basic.t +++ b/t/01-basic.t @@ -1,5 +1,5 @@ -use Test::More tests=>8; { +use Test::More tests=>9; { use strict; use warnings; @@ -7,32 +7,33 @@ use Test::More tests=>8; { use_ok 'MooseX::Meta::TypeConstraint::Dependent'; use_ok 'Moose::Util::TypeConstraints'; - ## A sample dependent type constraint the requires two ints and see which - ## is the greater. + ## A sample dependent type constraint the requires two ints and sees if + ## the dependent value (the first) is greater than the constraining value + ## (the second). ok my $int = find_type_constraint('Int') => 'Got Int'; my $dep_tc = MooseX::Meta::TypeConstraint::Dependent->new( name => "MooseX::Types::Dependent::Depending" , - parent => find_type_constraint('ArrayRef'), + parent => find_type_constraint('Int'), dependent_type_constraint=>$int, - comparision_callback=>sub { + comparison_callback=>sub { my ($constraining_value, $check_value) = @_; - return $constraining_value > $check_value ? 0:1; + return $check_value > $constraining_value ? 0:1; }, - constraint_generator =>$int, - constraint_generator=> sub { + constraining_type_constraint =>$int, + constraint_generator=> sub { + ## Because "shift->(shift,shift)" is not very clear, is it :) my ($callback, $constraining_value, $check_value) = @_; - return $callback->($constraining_value, $check_value) ? 1:0; + return $callback->($constraining_value, $check_value); }, ); - - ## Does this work at all? isa_ok $dep_tc, 'MooseX::Meta::TypeConstraint::Dependent'; - - ok !$dep_tc->check([5,10]), "Fails, 5 is less than 10"; - ok !$dep_tc->check(['a',10]), "Fails, 'a' is not an Int."; - ok !$dep_tc->check([5,'b']), "Fails, 'b' is not an Int either."; - ok $dep_tc->check([10,5]), "Success, 10 is greater than 5."; + + ok !$dep_tc->check('a',10), "Fails, 'a' is not an Int."; + ok !$dep_tc->check(5,'b'), "Fails, 'b' is not an Int either."; + ok !$dep_tc->check([4,1]), "Fails, since this isn't an arrayref"; + ok !$dep_tc->check(5,10), "Fails, 5 is less than 10"; + ok $dep_tc->check(11,6), "Success, 11 is greater than 6."; }