From: john napiorkowski Date: Mon, 18 May 2009 21:40:06 +0000 (-0400) Subject: more refactoring and first go at getting the tests to work again X-Git-Tag: 0.01~20 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a588ee005c92b0c750a082b442a3ea9edcb54f3c;p=gitmo%2FMooseX-Dependent.git more refactoring and first go at getting the tests to work again --- diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index b055a14..f4c504e 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -4,6 +4,7 @@ \bCVS\b ,v$ \B\.svn\b +\B\.git\b # Avoid Makemaker generated and utility files. \bMakefile$ diff --git a/Makefile.PL b/Makefile.PL index de65056..c25ab1b 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -15,6 +15,7 @@ requires 'Scalar::Util' => '1.19'; requires 'Devel::PartialDump' => '0.07'; build_requires 'Test::More' => '0.86'; +build_requires 'Test::Exception' => '0.27'; auto_install; tests_recursive; diff --git a/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm b/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm index be3c2b8..ab439b6 100644 --- a/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm +++ b/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm @@ -1,19 +1,17 @@ package ## Hide from PAUSE - MooseX::Meta::TypeConstraint::Dependent; + MooseX::Dependent::Meta::TypeConstraint::Dependent; use Moose; use Moose::Util::TypeConstraints (); -use MooseX::Meta::TypeCoercion::Dependent; -use Devel::PartialDump; extends 'Moose::Meta::TypeConstraint'; =head1 NAME -MooseX::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints. +MooseX::Dependent::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints. =head1 DESCRIPTION -see L for examples and details of how to use dependent +see L for examples and details of how to use dependent types. This class is a subclass of L which provides the gut functionality to enable dependent type constraints. @@ -21,60 +19,49 @@ provides the gut functionality to enable dependent type constraints. This class defines the following attributes. -=head2 dependent_type_constraint +=head2 parent_type_constraint -The type constraint whose validity is being made dependent on a value that is a -L +The type constraint whose validity is being made dependent. =cut -has 'dependent_type_constraint' => ( +has 'parent_type_constraint' => ( is=>'ro', isa=>'Object', - predicate=>'has_dependent_type_constraint', - handles=>{ - check_dependent=>'check', - get_message_dependent=>'get_message', + predicate=>'has_parent_type_constraint', + default=> sub { + Moose::Util::TypeConstraints::find_type_constraint("Any"); }, + required=>1, ); -=head2 constraining_type_constraint +=head2 constraining_value_type_constraint This is a type constraint which defines what kind of value is allowed to be the -constraining value of the depending type. +constraining value of the dependent type. =cut -has 'constraining_type_constraint' => ( +has 'constraining_value_type_constraint' => ( is=>'ro', isa=>'Object', - predicate=>'has_constraining_type_constraint', - handles=>{ - check_constraining=>'check', - get_message_constraining=>'get_message', + predicate=>'has_constraining_value_type_constraint', + default=> sub { + Moose::Util::TypeConstraints::find_type_constraint("Any"); }, + required=>1, ); -=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. - -This callback is executed in addition to anything you put into a 'where' clause. -However, the 'where' clause only get's the check value. +=head2 constrainting_value -Exercise some sanity, this should be limited to actual comparision operations, -not as a sneaky way to mess with the constraining value. - -This should return a Bool, suitable for ->check (That is true for valid, false -for fail). +This is the actual value that constraints the L =cut -has 'comparison_callback' => ( - is=>'ro', - isa=>'CodeRef', - predicate=>'has_comparison_callback', +has 'constraining_value' => ( + reader=>'constraining_value', + writer=>'_set_constraining_value', + predicate=>'has_constraining_value', ); =head2 constraint_generator @@ -82,7 +69,6 @@ has 'comparison_callback' => ( A subref or closure that contains the way we validate incoming values against a set of type constraints. -=cut has 'constraint_generator' => ( is=>'ro', @@ -95,27 +81,10 @@ has 'constraint_generator' => ( This class defines the following methods. -=head2 new - -Initialization stuff. - -=cut - -around 'new' => sub { - my ($new, $class, @args) = @_; - my $self = $class->$new(@args); - $self->coercion(MooseX::Meta::TypeCoercion::Dependent->new( - type_constraint => $self, - )); - return $self; -}; - =head2 validate We intercept validate in order to custom process the message. -=cut - override 'validate' => sub { my ($self, @args) = @_; my $compiled_type_constraint = $self->_compiled_type_constraint; @@ -139,7 +108,6 @@ override 'validate' => sub { Given some type constraints, use them to generate validation rules for an ref of values (to be passed at check time) -=cut sub generate_constraint_for { my ($self, $callback) = @_; @@ -177,6 +145,9 @@ Given a ref of type constraints, create a structured type. sub parameterize { my ($self, $dependent_tc, $callback, $constraining_tc) = @_; + + die 'something'; + my $class = ref $self; my $name = $self->_generate_subtype_name($dependent_tc, $callback, $constraining_tc); my $constraint_generator = $self->__infer_constraint_generator; @@ -198,10 +169,10 @@ Returns a name for the dependent type that should be unique =cut sub _generate_subtype_name { - my ($self, $dependent_tc, $callback, $constraining_tc) = @_; + my ($self, $parent_tc, $constraining_tc) = @_; return sprintf( - "%s_depends_on_%s_via_%s", - $dependent_tc, $constraining_tc, $callback, + "%s_depends_on_%s", + $parent_tc, $constraining_tc, ); } @@ -228,8 +199,6 @@ sub __infer_constraint_generator { my $tc = shift @_; my $merged_tc = [ @$tc, - $self->comparison_callback, - $self->constraining_type_constraint, ]; $self->constraint->($merged_tc, @_); @@ -267,7 +236,7 @@ around 'create_child_type' => sub { my ($create_child_type, $self, %opts) = @_; return $self->$create_child_type( %opts, - constraint_generator => $self->__infer_constraint_generator, + #constraint_generator => $self->__infer_constraint_generator, ); }; @@ -275,8 +244,6 @@ around 'create_child_type' => sub { Override the base class behavior. -=cut - sub equals { my ( $self, $type_or_name ) = @_; my $other = Moose::Util::TypeConstraints::find_type_constraint("$type_or_name"); @@ -296,13 +263,23 @@ sub equals { Give you a better peek into what's causing the error. -=cut - around 'get_message' => sub { my ($get_message, $self, $value) = @_; 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 8ad9ad4..a3dd92f 100644 --- a/lib/MooseX/Dependent/Types.pm +++ b/lib/MooseX/Dependent/Types.pm @@ -1,14 +1,9 @@ package MooseX::Dependent::Types; -use 5.008; - use Moose::Util::TypeConstraints; -use MooseX::Dependent::Meta::TypeConstraint::Parameterizable; +use MooseX::Dependent::Meta::TypeConstraint::Dependent; use MooseX::Types -declare => [qw(Dependent)]; -our $VERSION = '0.01'; -our $AUTHORITY = 'cpan:JJNAPIORK'; - =head1 NAME MooseX::Dependent::Types - L constraints that depend on values. @@ -200,13 +195,9 @@ will cause an exception. =cut Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( - MooseX::Dependent::Meta::TypeConstraint::Parameterizable->new( + MooseX::Dependent::Meta::TypeConstraint::Dependent->new( name => 'MooseX::Dependent::Types::Dependent', - parent => find_type_constraint('ArrayRef'), - constraint_generator=> sub { - my ($dependent_val, $callback, $constraining_val) = @_; - return $callback->($dependent_val, $constraining_val); - }, + parent => find_type_constraint('Any'), ) ); @@ -222,3 +213,40 @@ it under the same terms as Perl itself. =cut 1; + +__END__ + +oose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( + Moose::Meta::TypeConstraint::Parameterizable->new( + name => 'MooseX::Dependent::Types::Dependent', + parent => find_type_constraint('Any'), + constraint => sub { 0 }, + constraint_generator=> sub { + my ($dependent_val, $callback, $constraining_val) = @_; + return $callback->($dependent_val, $constraining_val); + }, + ) +); + + + +$REGISTRY->add_type_constraint( + Moose::Meta::TypeConstraint::Parameterizable->new( + name => 'HashRef', + package_defined_in => __PACKAGE__, + parent => find_type_constraint('Ref'), + constraint => sub { ref($_) eq 'HASH' }, + optimized => + \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef, + constraint_generator => sub { + my $type_parameter = shift; + my $check = $type_parameter->_compiled_type_constraint; + return sub { + foreach my $x ( values %$_ ) { + ( $check->($x) ) || return; + } + 1; + } + } + ) +); \ No newline at end of file diff --git a/t/01-basic.t b/t/01-basic.t deleted file mode 100644 index 86b12e0..0000000 --- a/t/01-basic.t +++ /dev/null @@ -1,38 +0,0 @@ - -use Test::More tests=>9; { - - use strict; - use warnings; - - use_ok 'MooseX::Meta::TypeConstraint::Dependent'; - use_ok 'Moose::Util::TypeConstraints'; - - ## 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'), - dependent_type_constraint=>$int, - comparison_callback=>sub { - my ($dependent_val, $constraining_val) = @_; - return ($dependent_val > $constraining_val) ? 1:undef; - }, - constraining_type_constraint =>$int, - constraint_generator=> sub { - my ($dependent_val, $callback, $constraining_val) = @_; - return $callback->($dependent_val, $constraining_val); - }, - ); - - isa_ok $dep_tc, 'MooseX::Meta::TypeConstraint::Dependent'; - - 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."; -} diff --git a/t/01-dependent.t b/t/01-dependent.t new file mode 100644 index 0000000..78fbb38 --- /dev/null +++ b/t/01-dependent.t @@ -0,0 +1,15 @@ + +use Test::More tests=>2; { + + use strict; + use warnings; + + use MooseX::Dependent::Types qw(Dependent); + use MooseX::Types -declare=>[qw(SubDependent)]; + use Moose::Util::TypeConstraints; + + ## Raw tests on dependent. + ok subtype( SubDependent, as Dependent ), 'Create a useless subtype'; + ok ((Dependent->check(1)), 'Dependent is basically an Any'); + +}