=cut
override 'validate' => sub {
- my ($self, @args) = @_;
- my $message = bless {message=>undef}, 'MooseX::Types::Structured::Message';
+ my ($self, $value, $message) = @_;
+ $message = bless {message=>undef, level=>0}, 'MooseX::Types::Structured::Message'
+ unless $message;
- if ($self->_compiled_type_constraint->(@args, $message)) {
+ $message->{level}++;
+
+ if ($self->_compiled_type_constraint->($value, $message)) {
## 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(@args);
- if(my $message = $message->{message}) {
- return $self->get_message("$args, Internal Validation Error is: $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}) {
+ return $self->get_message($args);
+ } else {
+ return $self->get_message("$args, Internal Validation Error is: $message_str");
+ }
} else {
+ $message->{level}--;
+
return $self->get_message($args);
}
}
if(@values) {
my $value = shift @values;
unless($type_constraint->check($value)) {
- $_[2]->{message} = $type_constraint->get_message($value)
- if ref $_[2];
- return;
+ 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;
+ }
}
} else {
## Test if the TC supports null values
MooseX::Meta::TypeConstraint::Structured->new(
name => "MooseX::Types::Structured::Dict",
parent => find_type_constraint('HashRef'),
- constraint_generator=> sub {
+ constraint_generator => sub {
## Get the constraints and values to check
my ($type_constraints, $values) = @_;
my @type_constraints = defined $type_constraints ?
my $value = $values{$key};
delete $values{$key};
unless($type_constraint->check($value)) {
- $_[2]->{message} = $type_constraint->get_message($value)
- if ref $_[2];
- return;
+ 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;
+ }
}
} else {
## Test to see if the TC supports null values
BEGIN {
use strict;
use warnings;
- use Test::More tests=>25;
+ use Test::More tests=>27;
}
use Moose::Util::TypeConstraints;
ok $deep_tuple->check([1,{a=>2},{name=>'Vincent',age=>15}]),
'Good Constraint';
-like $deep_tuple->validate([1,{a=>2},{name=>'Vincent',age=>'Hello'}]),
- qr/Error is: Validation failed for 'MooseX::Types::Structured::Dict\[name,Str,age,Int\]'/,
- 'Example deeper error';
+{
+ my $message = $deep_tuple->validate([1,{a=>2},{name=>'Vincent',age=>'Hello'}]);
+ like $message,
+ qr/Validation failed for 'MooseX::Types::Structured::Dict\[name,Str,age,Int\]'/,
+ 'Example deeper error';
+}
+
+like $simple_tuple->validate(["aaa","bbb"]),
+ qr/'Int' with value aaa/,
+ 'correct deeper error';
+
+like $deep_tuple->validate([1,{a=>2},{name=>'Vincent1',age=>'Hello1'}]),
+ qr/'Int' with value Hello1/,
+ 'correct deeper error';
+
+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;
+}
## Success Tests...
ok !$deep_tuple->validate([1,{a=>2},{name=>'John',age=>40}]), 'Validates ok';
+