From: John Napiorkowski Date: Wed, 1 Apr 2009 16:14:03 +0000 (+0000) Subject: placeholder for api test, much improved support for error message (now give you more... X-Git-Tag: 0.01~33 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ae1d065233974a8e76f9b8da9f696a9380a32d4e;p=gitmo%2FMooseX-Dependent.git placeholder for api test, much improved support for error message (now give you more details about what type of failure you have (should backport to MX:T:Structured...) updates to docs and updates to the makefile --- diff --git a/Makefile.PL b/Makefile.PL index 8838cff..f35b4c5 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -11,6 +11,7 @@ license 'perl'; requires 'Moose' => '0.73'; requires 'MooseX::Types' => '0.10'; requires 'Scalar::Util' => '1.19'; +requires 'Devel::PartialDump' => '0.07'; ## Testing dependencies build_requires 'Test::More' => '0.70'; diff --git a/lib/MooseX/Meta/TypeConstraint/Dependent.pm b/lib/MooseX/Meta/TypeConstraint/Dependent.pm index caed2ae..7de4db2 100644 --- a/lib/MooseX/Meta/TypeConstraint/Dependent.pm +++ b/lib/MooseX/Meta/TypeConstraint/Dependent.pm @@ -4,6 +4,7 @@ package ## Hide from PAUSE use Moose; use Moose::Util::TypeConstraints (); use MooseX::Meta::TypeCoercion::Dependent; +use Devel::PartialDump; extends 'Moose::Meta::TypeConstraint'; =head1 NAME @@ -49,7 +50,8 @@ has 'constraining_type_constraint' => ( isa=>'Object', predicate=>'has_constraining_type_constraint', handles=>{ - check_constraining=>'check', + check_constraining=>'check', + get_message_constraining=>'get_message', }, ); @@ -112,27 +114,22 @@ around 'new' => sub { We intercept validate in order to custom process the message - =cut -around 'check' => sub { - my ($check, $self, @args) = @_; - my ($result, $message) = $self->_compiled_type_constraint->(@args); - warn $result; - return $result; -}; - around 'validate' => sub { my ($validate, $self, @args) = @_; - my ($result, $message) = $self->_compiled_type_constraint->(@args); - + my $compiled_type_constraint = $self->_compiled_type_constraint; + my $message = bless {message=>undef}, 'MooseX::Types::Dependent::Message'; + my $result = $compiled_type_constraint->(@args, $message); + if($result) { return $result; } else { - if(defined $message) { - return "Inner: $message"; - } else { warn '......................'; - return $self->get_message(@args); + my $args = Devel::PartialDump::dump(@args); + if(my $message = $message->{message}) { + return $self->get_message("$args, Internal Validation Error is: $message"); + } else { + return $self->get_message($args); } } }; @@ -152,10 +149,14 @@ sub generate_constraint_for { ## First need to test the bits unless($self->check_dependent($dependent)) { - return (undef, 'bbbbbb'); + $_[0]->{message} = $self->get_message_dependent($dependent) + if $_[0]; + return; } unless($self->check_constraining($constraining)) { + $_[0]->{message} = $self->get_message_constraining($constraining) + if $_[0]; return; } @@ -209,7 +210,10 @@ sub _generate_subtype_name { This returns a CODEREF which generates a suitable constraint generator. Not user servicable, you'll never call this directly. - TBD, this is definitely going to need some work. + 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. =cut @@ -218,7 +222,7 @@ sub __infer_constraint_generator { if($self->has_constraint_generator) { return $self->constraint_generator; } else { - warn "I'm doing the questioning infer generator thing"; + 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 @_; @@ -247,7 +251,7 @@ around 'compile_type_constraint' => sub { my $generated_constraint = $self->generate_constraint_for( $self->comparison_callback, ); - $self->_set_constraint($generated_constraint); + $self->_set_constraint($generated_constraint); } return $self->$compile_type_constraint; @@ -322,17 +326,13 @@ sub type_constraints_equals { =head2 get_message -Give you a better peek into what's causing the error. For now we stringify the -incoming deep value with L and pass that on to either your -custom error message or the default one. In the future we'll try to provide a -more complete stack trace of the actual offending elements +Give you a better peek into what's causing the error. - TBD +=cut around 'get_message' => sub { my ($get_message, $self, $value) = @_; - my $new_value = Devel::PartialDump::dump($value); - return $self->$get_message($new_value); + return $self->$get_message($value); }; =head1 SEE ALSO diff --git a/t/02-depending.t b/t/02-depending.t index dbffb72..9831139 100644 --- a/t/02-depending.t +++ b/t/02-depending.t @@ -1,9 +1,8 @@ -use Test::More tests=>24; { +use Test::More tests=>29; { use strict; use warnings; - - use Test::Exception; + use MooseX::Types::Dependent qw(Depending); use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef Maybe); use MooseX::Types -declare => [qw( @@ -57,7 +56,8 @@ use Test::More tests=>24; { my ($dependent_val, $constraining_value) = @$_; return $dependent_val > 2 ? 1:undef; }; - + #message {"Custom Error: $_"}; + isa_ok UniqueInt, 'MooseX::Meta::TypeConstraint::Dependent'; ok !UniqueInt->check(['a',[1,2,3]]), '"a" not an Int'; ok !UniqueInt->check([1,['b','c']]), '"b","c" not an arrayref'; @@ -88,6 +88,18 @@ use Test::More tests=>24; { ok UniqueInt2->check([4,[100..110]]), 'PASS unique in set'; ## Basic error messages. TODO should be it's own test + like UniqueInt->validate(['a',[1,2,3]]), qr/failed for 'Int' failed with value a/, + "a is not an Int"; + + like UniqueInt->validate([1,['b','c']]), qr/failed for 'ArrayRef\[Int\]'/, + "ArrayRef doesn't contain Ints"; + + like UniqueInt->validate([1,[1,2,3]]), qr/failed with value \[ 1, \[ 1, 2, 3 \] \]/, + "Is not unique in the constraint"; + + like UniqueInt->validate([10,[1,10,15]]), qr/failed with value \[ 10, \[ 1, 10, 15 \] \]/, + "Expected Error message for [10,[1,10,15]]"; - warn UniqueInt2->validate(['a',[1,2,3]]); + like UniqueInt->validate([2,[3..6]]), qr/failed with value \[ 2, \[ 3, 4, 5, 6 \] \]/, + "Expected Error message for [2,[3..6]]"; } diff --git a/t/03-api.t b/t/03-api.t new file mode 100644 index 0000000..ea84022 --- /dev/null +++ b/t/03-api.t @@ -0,0 +1,32 @@ +use Test::More tests=>1; { + + use strict; + use warnings; + + use Test::Exception; + use MooseX::Types::Dependent qw(Depending); + use MooseX::Types::Moose qw(Int ArrayRef ); + use MooseX::Types -declare => [qw( + UniqueInt + )]; + + ## sugar for alternative syntax: depending {} TC,TC + sub depending(&@) { + my ($coderef, $dependent_tc, $constraining_tc, @args) = @_; + if(@args) { + return (Depending[$dependent_tc,$coderef,$constraining_tc],@args); + } else { + return Depending[$dependent_tc,$coderef,$constraining_tc]; + } + } + + ok subtype UniqueInt, + as depending { + my ($dependent_int, $constraining_arrayref) = @_; + (grep { $_ == $dependent_int} @$constraining_arrayref) ? undef:1 + } Int, ArrayRef[Int], + where { + my ($dependent_val, $constraining_value) = @$_; + return $dependent_val > 2 ? 1:undef; + }; +}