From: john napiorkowski Date: Thu, 21 May 2009 14:47:03 +0000 (-0400) Subject: the basic, basics in place X-Git-Tag: 0.01~18 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0a9f5b94966259cd648910629225ea950fbba082;p=gitmo%2FMooseX-Dependent.git the basic, basics in place --- diff --git a/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm b/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm index 43851c6..b829ffe 100644 --- a/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm +++ b/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm @@ -3,6 +3,8 @@ package ## Hide from PAUSE use Moose; use Moose::Util::TypeConstraints (); +use Scalar::Util qw(blessed); + extends 'Moose::Meta::TypeConstraint'; =head1 NAME @@ -28,7 +30,6 @@ The type constraint whose validity is being made dependent. has 'parent_type_constraint' => ( is=>'ro', isa=>'Object', - predicate=>'has_parent_type_constraint', default=> sub { Moose::Util::TypeConstraints::find_type_constraint("Any"); }, @@ -45,22 +46,20 @@ constraining value of the dependent type. has 'constraining_value_type_constraint' => ( is=>'ro', isa=>'Object', - predicate=>'has_constraining_value_type_constraint', default=> sub { Moose::Util::TypeConstraints::find_type_constraint("Any"); }, required=>1, ); -=head2 constrainting_value +=head2 constraining_value This is the actual value that constraints the L =cut has 'constraining_value' => ( - reader=>'constraining_value', - writer=>'_set_constraining_value', + is=>'ro', predicate=>'has_constraining_value', ); @@ -137,29 +136,69 @@ sub generate_constraint_for { }; } -=head2 parameterize ($dependent, $callback, $constraining) +=head2 parameterize (@args) Given a ref of type constraints, create a structured type. - + =cut sub parameterize { - my ($self, $dependent_tc, $callback, $constraining_tc) = @_; - - die 'something'; - + my $self = shift @_; my $class = ref $self; - 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_tc, - comparison_callback=>$callback, - constraint_generator => $constraint_generator, - constraining_type_constraint => $constraining_tc, - ); + + if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) { + my $arg1 = shift @_; + my $arg2 = shift @_ || $self->constraining_value_type_constraint; + + Moose->throw_error("$arg2 is not a type constraint") + unless $arg2->isa('Moose::Meta::TypeConstraint'); + + 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, + ); + + } else { + Moose->throw_error("$self already has a constraining value.") if + $self->has_constraining_value; + + my $args; + ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}] + if(@_) { + if($#_) { + if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) { + $args = {@_}; + } else { + $args = [@_]; + } + } else { + $args = $_[0]; + } + + } else { + ## TODO: Is there a use case for parameterizing null or undef? + Moose->throw_error('Cannot Parameterize null values.'); + } + + 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, + ); + } + } } =head2 _generate_subtype_name @@ -171,93 +210,89 @@ Returns a name for the dependent type that should be unique sub _generate_subtype_name { my ($self, $parent_tc, $constraining_tc) = @_; return sprintf( - "%s_depends_on_%s", + $self."[%s, %s]", $parent_tc, $constraining_tc, ); } -=head2 __infer_constraint_generator - -This returns a CODEREF which generates a suitable constraint generator. Not -user servicable, you'll never call this directly. +=head2 create_child_type - TBD, this is definitely going to need some work. Cargo culted from some - code I saw in Moose::Meta::TypeConstraint::Parameterized or similar. I - Don't think I need this, since Dependent types require parameters, so - will always have a constrain generator. +modifier to make sure we get the constraint_generator =cut -sub __infer_constraint_generator { - my ($self) = @_; - if($self->has_constraint_generator) { - return $self->constraint_generator; - } else { - warn "I'm doing the questionable 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->constraint->($merged_tc, @_); - }; - } -} - -=head2 compile_type_constraint +around 'create_child_type' => sub { + my ($create_child_type, $self, %opts) = @_; + return $self->$create_child_type( + %opts, + parent=> $self, + parent_type_constraint=>$self->parent_type_constraint, + constraining_value_type_constraint => $self->constraining_value_type_constraint, + ); +}; -hook into compile_type_constraint so we can set the correct validation rules. +=head2 equals ($type_constraint) +Override the base class behavior so that a dependent type equal both the parent +type and the overall dependent container. This behavior may change if we can +figure out what a dependent type is (multiply inheritance or a role...) +=cut -around 'compile_type_constraint' => sub { - my ($compile_type_constraint, $self) = @_; +around 'equals' => sub { + my ( $equals, $self, $type_or_name ) = @_; - 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); + my $other = defined $type_or_name ? + Moose::Util::TypeConstraints::find_type_constraint($type_or_name) : + Moose->throw_error("Can't call $self ->equals without a parameter"); + + Moose->throw_error("$type_or_name is not a registered Type") + unless $other; + + if(my $parent = $other->parent) { + return $self->$equals($other) + || $self->parent->equals($parent); + } else { + return $self->$equals($other); } - - return $self->$compile_type_constraint; }; -=head2 create_child_type - -modifier to make sure we get the constraint_generator +around 'is_subtype_of' => sub { + my ( $is_subtype_of, $self, $type_or_name ) = @_; -=cut + my $other = defined $type_or_name ? + Moose::Util::TypeConstraints::find_type_constraint($type_or_name) : + Moose->throw_error("Can't call $self ->equals without a parameter"); + + Moose->throw_error("$type_or_name is not a registered Type") + unless $other; + + return $self->$is_subtype_of($other) + || $self->parent_type_constraint->is_subtype_of($other); -around 'create_child_type' => sub { - my ($create_child_type, $self, %opts) = @_; - return $self->$create_child_type( - %opts, - #constraint_generator => $self->__infer_constraint_generator, - ); }; -=head2 equals - -Override the base class behavior. +sub is_a_type_of { + my ($self, @args) = @_; + return ($self->equals(@args) || + $self->is_subtype_of(@args)); +} -sub equals { - my ( $self, $type_or_name ) = @_; - my $other = Moose::Util::TypeConstraints::find_type_constraint("$type_or_name"); +around 'check' => sub { + my ($check, $self, @args) = @_; + if($self->has_constraining_value) { + push @args, $self->constraining_value; + } + return $self->parent_type_constraint->check(@args) && $self->$check(@args) +}; - return ( - $other->isa(__PACKAGE__) - and - $self->dependent_type_constraint->equals($other) - and - $self->constraining_type_constraint->equals($other) - and - $self->parent->equals($other->parent) - ); -} +around 'validate' => sub { + my ($validate, $self, @args) = @_; + if($self->has_constraining_value) { + push @args, $self->constraining_value; + } + return $self->parent_type_constraint->validate(@args) || $self->$validate(@args); +}; =head2 get_message @@ -268,18 +303,6 @@ around 'get_message' => sub { return $self->$get_message($value); }; -=head2 _throw_error ($error) - -Given a string, delegate to the Moose exception object - -=cut - -sub _throw_error { - my $self = shift @_; - my $err = defined $_[0] ? $_[0] : 'Exception Thrown without Message'; - require Moose; Moose->throw_error($err); -} - =head1 SEE ALSO The following modules or resources may be of interest. diff --git a/lib/MooseX/Dependent/Types.pm b/lib/MooseX/Dependent/Types.pm index a3dd92f..b013b5c 100644 --- a/lib/MooseX/Dependent/Types.pm +++ b/lib/MooseX/Dependent/Types.pm @@ -198,6 +198,7 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( MooseX::Dependent::Meta::TypeConstraint::Dependent->new( name => 'MooseX::Dependent::Types::Dependent', parent => find_type_constraint('Any'), + constraint => sub {1}, ) ); diff --git a/t/01-dependent.t b/t/01-dependent.t index a202843..e525c55 100644 --- a/t/01-dependent.t +++ b/t/01-dependent.t @@ -1,34 +1,185 @@ -use Test::More tests=>5; { +use Test::More tests=>53; { use strict; use warnings; use MooseX::Dependent::Types qw(Dependent); - use MooseX::Types -declare=>[qw(SubDependent)]; + use MooseX::Types::Moose qw(Int Any); + use MooseX::Types -declare=>[qw(SubDependent IntLessThan EvenInt)]; use Moose::Util::TypeConstraints; - - ok subtype( SubDependent, as Dependent ), - 'Create a useless subtype'; + ok Dependent->check(1), - 'Dependent is basically an Any'; - ok SubDependent->check(1), - 'SubDependent is basically an Any'; + 'Dependent is basically an "Any"'; + + ok !Dependent->validate(1), + 'No Error Message'; + is Dependent->parent, 'Any', 'Dependent is an Any'; + + is Dependent->name, 'MooseX::Dependent::Types::Dependent', + 'Dependent has expected name'; + + is Dependent->get_message, + "Validation failed for 'MooseX::Dependent::Types::Dependent' failed with value undef", + 'Got Expected Message'; + + ok Dependent->equals(Dependent), + 'Dependent equal Dependent'; + + ok Dependent->is_a_type_of(Dependent), + 'Dependent is_a_type_of Dependent'; + + ok Dependent->is_a_type_of('Any'), + 'Dependent is_a_type_of Any'; + + ok Dependent->is_subtype_of('Any'), + 'Dependent is_subtype_of Dependent'; + + is Dependent->parent_type_constraint, 'Any', + 'Correct parent type'; + + is subtype( SubDependent, as Dependent ), + 'main::SubDependent', + 'Create a useless subtype'; + + ok SubDependent->check(1), + 'SubDependent is basically an "Any"'; + + ok !SubDependent->validate(1), + 'validate returned no error message'; + is SubDependent->parent, 'MooseX::Dependent::Types::Dependent', 'SubDependent is a Dependent'; - is Dependent->get_message, "Validation failed for 'MooseX::Dependent::Types::Dependent' failed with value undef", - 'Got Expected Message' - warn SubDependent->get_message; -} + + is SubDependent->name, 'main::SubDependent', + 'Dependent has expected name'; + + is SubDependent->get_message, + "Validation failed for 'main::SubDependent' failed with value undef", + 'Got Expected Message'; + + ok SubDependent->equals(SubDependent), + 'SubDependent equal SubDependent'; + + ok !SubDependent->equals(Dependent), + 'SubDependent does not equal Dependent'; + + ok SubDependent->is_a_type_of(Dependent), + 'SubDependent is_a_type_of Dependent'; + + ok SubDependent->is_a_type_of(Any), + 'SubDependent is_a_type_of Any'; + + ok SubDependent->is_subtype_of('Any'), + 'SubDependent is_subtype_of Dependent'; + + ok !SubDependent->is_subtype_of(SubDependent), + 'SubDependent is not is_subtype_of SubDependent'; + + ok subtype( EvenInt, + as Int, + where { + my $val = shift @_; + return $val % 2 ? 0:1; + }), + 'Created a subtype of Int'; -__END__ + ok !EvenInt->check('aaa'), '"aaa" not an Int'; + ok !EvenInt->check(1), '1 is not even'; + ok EvenInt->check(2), 'but 2 is!'; + + ok subtype( IntLessThan, + as Dependent[EvenInt, Int], + where { + my $value = shift @_; + my $constraining = shift @_ || 200; + return ($value < $constraining && $value > 5); + }), + 'Created IntLessThan subtype'; + + ok !IntLessThan->check('aaa'), + '"aaa" is not an integer'; + + is IntLessThan->validate('aaa'), + "Validation failed for 'main::EvenInt' failed with value aaa", + 'Got expected error messge for "aaa"'; + + ok !IntLessThan->check(1), + '1 smaller than 5'; -check -validate -get_message -name -equals -is_a_type_of -is_subtype_of \ No newline at end of file + ok !IntLessThan->check(2), + '2 smaller than 5'; + + ok !IntLessThan->check(15), + '15 greater than 5 (but odd)'; + + ok !IntLessThan->check(301), + '301 is too big'; + + ok !IntLessThan->check(400), + '400 is too big'; + + ok IntLessThan->check(10), + '10 greater than 5 (and even)'; + + is IntLessThan->validate(1), + "Validation failed for 'main::EvenInt' failed with value 1", + 'error message is correct'; + + is IntLessThan->name, 'main::IntLessThan', + 'Got correct name for IntLessThan'; + + is IntLessThan->parent, 'MooseX::Dependent::Types::Dependent[main::EvenInt, Int]', + 'IntLessThan is a Dependent'; + + is IntLessThan->parent_type_constraint, EvenInt, + 'Parent is an Int'; + + is IntLessThan->constraining_value_type_constraint, Int, + 'constraining is an Int'; + + ok IntLessThan->equals(IntLessThan), + 'IntLessThan equals IntLessThan'; + + ok IntLessThan->is_subtype_of(Dependent), + 'IntLessThan is_subtype_of Dependent'; + + ok IntLessThan->is_subtype_of(Int), + 'IntLessThan is_subtype_of Int'; + + ok IntLessThan->is_a_type_of(Dependent), + 'IntLessThan is_a_type_of Dependent'; + + ok IntLessThan->is_a_type_of(Int), + 'IntLessThan is_a_type_of Int'; + + ok IntLessThan->is_a_type_of(IntLessThan), + 'IntLessThan is_a_type_of IntLessThan'; + + ok( (my $lessThan100GreatThen5andEvenInt = IntLessThan[100]), + 'Parameterized!'); + + ok !$lessThan100GreatThen5andEvenInt->check(150), + '150 Not less than 100'; + + ok !$lessThan100GreatThen5andEvenInt->check(151), + '151 Not less than 100'; + + ok !$lessThan100GreatThen5andEvenInt->check(2), + 'Not greater than 5'; + + ok !$lessThan100GreatThen5andEvenInt->check(51), + 'Not even'; + + ok !$lessThan100GreatThen5andEvenInt->check('aaa'), + 'Not Int'; + + ok $lessThan100GreatThen5andEvenInt->check(42), + 'is Int, is even, greater than 5, less than 100'; + + #die IntLessThan->validate(100); + #use Data::Dump qw/dump/; + #warn dump IntLessThan; +}