From: John Napiorkowski Date: Thu, 1 Jul 2010 14:14:10 +0000 (-0400) Subject: all tests passing again after move to message stack X-Git-Tag: 0.23~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Types-Structured.git;a=commitdiff_plain;h=9448ea2c4ec450d2c5bbf8f10692457cb583facb all tests passing again after move to message stack --- diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm index 33ed2c8..25b8c87 100644 --- a/lib/MooseX/Meta/TypeConstraint/Structured.pm +++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm @@ -66,31 +66,29 @@ Messing with validate so that we can support niced error messages. =cut override 'validate' => sub { - my ($self, $value, $message) = @_; - $message = bless {message=>undef, level=>0}, 'MooseX::Types::Structured::Message' - unless $message; + my ($self, $value, $message_stack) = @_; + unless ($message_stack) { + $message_stack = MooseX::Types::Structured::MessageStack->new(); + } - $message->{level}++; + $message_stack->inc_level; - if ($self->_compiled_type_constraint->($value, $message)) { + if ($self->_compiled_type_constraint->($value, $message_stack)) { ## Everything is good, no error message to return return undef; } else { ## Whoops, need to figure out the right error message my $args = Devel::PartialDump::dump($value); - if(my $messages = $message->{message}) { - my $level = $message->{level}; - my $message_str = ref $messages ? join("\n".(" "x$level)."[+] ",reverse @$messages) : $messages; - $message->{level}--; - - if($message->{level}) { + $message_stack->dec_level; + if($message_stack->has_messages) { + if($message_stack->level) { + ## we are inside a deeply structured constraint return $self->get_message($args); } else { + my $message_str = $message_stack->as_string; return $self->get_message("$args, Internal Validation Error is: $message_str"); } } else { - $message->{level}--; - return $self->get_message($args); } } diff --git a/lib/MooseX/Types/Structured.pm b/lib/MooseX/Types/Structured.pm index c95ada8..228b51c 100644 --- a/lib/MooseX/Types/Structured.pm +++ b/lib/MooseX/Types/Structured.pm @@ -7,6 +7,7 @@ use Moose::Util::TypeConstraints 1.06; use MooseX::Meta::TypeConstraint::Structured; use MooseX::Meta::TypeConstraint::Structured::Optional; use MooseX::Types::Structured::OverflowHandler; +use MooseX::Types::Structured::MessageStack; use MooseX::Types 0.22 -declare => [qw(Dict Map Tuple Optional)]; use Sub::Exporter 0.982 -setup => [ qw(Dict Map Tuple Optional slurpy) ]; use Devel::PartialDump 0.10; @@ -744,21 +745,19 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( if(@values) { my $value = shift @values; unless($type_constraint->check($value)) { - my $message = $type_constraint->validate($value,$_[2]); - if(ref $_[2]) { - push @{$_[2]->{message}}, $message - if ref $_[2]; - return; - } else { -#warn "Don't know what to do with $message"; -return; + if($_[2]) { + my $message = $type_constraint->validate($value,$_[2]); + $_[2]->add_message({message=>$message,level=>$_[2]->level}); } + return; } } else { ## Test if the TC supports null values unless ($type_constraint->is_subtype_of($Optional)) { - $_[2]->{message} = $type_constraint->get_message('NULL') - if ref $_[2]; + if($_[2]) { + my $message = $type_constraint->get_message('NULL',$_[2]); + $_[2]->add_message({message=>$message,level=>$_[2]->level}); + } return; } } @@ -768,14 +767,17 @@ return; if($overflow_handler) { return $overflow_handler->check([@values], $_[2]); } else { - $_[2]->{message} = "More values than Type Constraints!" - if ref $_[2]; + if($_[2]) { + my $message = "More values than Type Constraints!"; + $_[2]->add_message({message=>$message,level=>$_[2]->level}); + } return; } } elsif(@type_constraints) { - $_[2]->{message} = - "Not enough values for all defined type constraints. Remaining: ". join(', ',@type_constraints) - if ref $_[2]; + if($_[2]) { + my $message = "Not enough values for all defined type constraints. Remaining: ". join(', ',@type_constraints); + $_[2]->add_message({message=>$message,level=>$_[2]->level}); + } return; } else { return 1; @@ -809,21 +811,19 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( my $value = $values{$key}; delete $values{$key}; unless($type_constraint->check($value)) { - my $message = $type_constraint->validate($value,$_[2]); - if(ref $_[2]) { - push @{$_[2]->{message}}, $message - if ref $_[2]; - return; - } else { -#warn "Don't know what to do with $message"; -return; + if($_[2]) { + my $message = $type_constraint->validate($value,$_[2]); + $_[2]->add_message({message=>$message,level=>$_[2]->level}); } + return; } } else { ## Test to see if the TC supports null values unless ($type_constraint->is_subtype_of($Optional)) { - $_[2]->{message} = $type_constraint->get_message('NULL') - if ref $_[2]; + if($_[2]) { + my $message = $type_constraint->get_message('NULL',$_[2]); + $_[2]->add_message({message=>$message,level=>$_[2]->level}); + } return; } } @@ -833,14 +833,17 @@ return; if($overflow_handler) { return $overflow_handler->check(+{%values}); } else { - $_[2]->{message} = "More values than Type Constraints!" - if ref $_[2]; + if($_[2]) { + my $message = "More values than Type Constraints!"; + $_[2]->add_message({message=>$message,level=>$_[2]->level}); + } return; } } elsif(%type_constraints) { - $_[2]->{message} = - "Not enough values for all defined type constraints. Remaining: ". join(', ',values %values) - if ref $_[2]; + if($_[2]) { + my $message = "Not enough values for all defined type constraints. Remaining: ". join(', ',@type_constraints); + $_[2]->add_message({message=>$message,level=>$_[2]->level}); + } return; } else { return 1; @@ -869,7 +872,10 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( if ($value_type) { for my $value (values %$values) { unless ($value_type->check($value)) { - $_[2]->{message} = $value_type->get_message($value) if ref $_[2]; + if($_[2]) { + my $message = $value_type->validate($value,$_[2]); + $_[2]->add_message({message=>$message,level=>$_[2]->level}); + } return; } } @@ -878,7 +884,10 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( if ($key_type) { for my $key (keys %$values) { unless ($key_type->check($key)) { - $_[2]->{message} = $key_type->get_message($key) if ref $_[2]; + if($_[2]) { + my $message = $key_type->validate($key,$_[2]); + $_[2]->add_message({message=>$message,level=>$_[2]->level}); + } return; } } diff --git a/t/12-error.t b/t/12-error.t index 404716d..acf8cd3 100644 --- a/t/12-error.t +++ b/t/12-error.t @@ -1,8 +1,6 @@ -BEGIN { - use strict; - use warnings; - use Test::More tests=>27; -} +use strict; +use warnings; +use Test::More; use Moose::Util::TypeConstraints; use MooseX::Types::Structured qw(Dict Tuple Optional); @@ -135,35 +133,4 @@ like $deep_tuple->validate([1,{a=>2},{name=>'Vincent1',age=>'Hello1'}]), ok !$deep_tuple->validate([1,{a=>2},{name=>'John',age=>40}]), 'Validates ok'; -## Deeper Tests... - -my $deeper_tc = subtype - as Dict[ - a => Tuple[ - Dict[ - a1a => Tuple[Int], - a1b => Tuple[Int], - ], - Dict[ - a2a => Tuple[Int], - a2b => Tuple[Int], - ], - ], - b => Tuple[ - Dict[ - b1a => Tuple[Int], - b1b => Tuple[Int], - ], - Dict[ - b2a => Tuple[Int], - b2b => Tuple[Int], - ], - ], - ]; - -{ - my $message = $deeper_tc->validate({a=>[{a1a=>[1],a1b=>[2]},{a2a=>[3],a2b=>[4]}],b=>[{b1a=>[5],b1b=>['AA']},{b2a=>[7],b2b=>[8]}]}); - warn $message; -} - - +done_testing();