X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FTypes%2FStructured.pm;h=94dde0d9719b3c9e5584d8f0b2805aed6bdb3d0a;hb=220f2fbb9e5b5a0bf23bd9839d8fc91ca8ac1b37;hp=c95ada85e38947918cae5c096c67532a3ca9561f;hpb=21d0e759ab986615952773d9dce93ec2b28f7b2a;p=gitmo%2FMooseX-Types-Structured.git diff --git a/lib/MooseX/Types/Structured.pm b/lib/MooseX/Types/Structured.pm index c95ada8..94dde0d 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; @@ -718,6 +719,25 @@ my $Optional = MooseX::Meta::TypeConstraint::Structured::Optional->new( } ); +my $IsType = sub { + my ($obj, $type) = @_; + + return $obj->can('equals') + ? $obj->equals($type) + : undef; +}; + +my $CompiledTC = sub { + my ($obj) = @_; + + my $method = '_compiled_type_constraint'; + return( + $obj->$IsType('Any') ? undef + : $obj->can($method) ? $obj->$method + : sub { $obj->check(shift) }, + ); +}; + Moose::Util::TypeConstraints::register_type_constraint($Optional); Moose::Util::TypeConstraints::add_parameterizable_type($Optional); @@ -727,7 +747,8 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( parent => find_type_constraint('ArrayRef'), constraint_generator=> sub { ## Get the constraints and values to check - my ($type_constraints, $values) = @_; + my ($self, $type_constraints) = @_; + $type_constraints ||= $self->type_constraints; my @type_constraints = defined $type_constraints ? @$type_constraints : (); @@ -737,49 +758,74 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( $overflow_handler = pop @type_constraints; } - my @values = defined $values ? @$values: (); - ## Perform the checking - while(@type_constraints) { - my $type_constraint = shift @type_constraints; - 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]; + my $length = $#type_constraints; + foreach my $idx (0..$length) { + unless(blessed $type_constraints[$idx]) { + ($type_constraints[$idx] = find_type_constraint($type_constraints[$idx])) + || die "$type_constraints[$idx] is not a registered type"; + } + } + + my (@checks, @optional, $o_check, $is_compiled); + return sub { + my ($values, $err) = @_; + my @values = defined $values ? @$values : (); + + ## initialise on first time run + unless ($is_compiled) { + @checks = map { $_->$CompiledTC } @type_constraints; + @optional = map { $_->is_subtype_of($Optional) } @type_constraints; + $o_check = $overflow_handler->$CompiledTC + if $overflow_handler; + $is_compiled++; + } + + ## Perform the checking + VALUE: + for my $type_index (0 .. $#checks) { + + my $type_constraint = $checks[ $type_index ]; + + if(@values) { + my $value = shift @values; + + next VALUE + unless $type_constraint; + + unless($type_constraint->($value)) { + if($err) { + my $message = $type_constraints[ $type_index ]->validate($value,$err); + $err->add_message({message=>$message,level=>$err->level}); + } + return; + } + } else { + ## Test if the TC supports null values + unless ($optional[ $type_index ]) { + if($err) { + my $message = $type_constraints[ $type_index ]->get_message('NULL',$err); + $err->add_message({message=>$message,level=>$err->level}); + } return; - } else { -#warn "Don't know what to do with $message"; -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]; + } + + ## Make sure there are no leftovers. + if(@values) { + if($overflow_handler) { + return $o_check->([@values], $err); + } else { + if($err) { + my $message = "More values than Type Constraints!"; + $err->add_message({message=>$message,level=>$err->level}); + } return; } - } - } - ## Make sure there are no leftovers. - if(@values) { - if($overflow_handler) { - return $overflow_handler->check([@values], $_[2]); } else { - $_[2]->{message} = "More values than Type Constraints!" - if ref $_[2]; - return; + return 1; } - } elsif(@type_constraints) { - $_[2]->{message} = - "Not enough values for all defined type constraints. Remaining: ". join(', ',@type_constraints) - if ref $_[2]; - return; - } else { - return 1; - } + }; } ) ); @@ -790,7 +836,8 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( parent => find_type_constraint('HashRef'), constraint_generator => sub { ## Get the constraints and values to check - my ($type_constraints, $values) = @_; + my ($self, $type_constraints) = @_; + $type_constraints = $self->type_constraints; my @type_constraints = defined $type_constraints ? @$type_constraints : (); @@ -799,51 +846,72 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( && $type_constraints[-1]->isa('MooseX::Types::Structured::OverflowHandler')) { $overflow_handler = pop @type_constraints; } - my (%type_constraints) = @type_constraints; - my %values = defined $values ? %$values: (); - ## Perform the checking - while(%type_constraints) { - my($key, $type_constraint) = each %type_constraints; - delete $type_constraints{$key}; - if(exists $values{$key}) { - 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]; + my %type_constraints = @type_constraints; + foreach my $key (keys %type_constraints) { + unless(blessed $type_constraints{$key}) { + ($type_constraints{$key} = find_type_constraint($type_constraints{$key})) + || die "$type_constraints{$key} is not a registered type"; + } + } + + my (%check, %optional, $o_check, $is_compiled); + return sub { + my ($values, $err) = @_; + my %values = defined $values ? %$values: (); + + unless ($is_compiled) { + %check = map { ($_ => $type_constraints{ $_ }->$CompiledTC) } keys %type_constraints; + %optional = map { ($_ => $type_constraints{ $_ }->is_subtype_of($Optional)) } keys %type_constraints; + $o_check = $overflow_handler->$CompiledTC + if $overflow_handler; + $is_compiled++; + } + + ## Perform the checking + KEY: + for my $key (keys %check) { + my $type_constraint = $check{ $key }; + + if(exists $values{$key}) { + my $value = $values{$key}; + delete $values{$key}; + + next KEY + unless $type_constraint; + + unless($type_constraint->($value)) { + if($err) { + my $message = $type_constraints{ $key }->validate($value,$err); + $err->add_message({message=>$message,level=>$err->level}); + } + return; + } + } else { + ## Test to see if the TC supports null values + unless ($optional{ $key }) { + if($err) { + my $message = $type_constraints{ $key }->get_message('NULL',$err); + $err->add_message({message=>$message,level=>$err->level}); + } return; - } else { -#warn "Don't know what to do with $message"; -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]; + } + + ## Make sure there are no leftovers. + if(%values) { + if($overflow_handler) { + return $o_check->(+{%values}); + } else { + if($err) { + my $message = "More values than Type Constraints!"; + $err->add_message({message=>$message,level=>$err->level}); + } return; } - } - } - ## Make sure there are no leftovers. - if(%values) { - if($overflow_handler) { - return $overflow_handler->check(+{%values}); } else { - $_[2]->{message} = "More values than Type Constraints!" - if ref $_[2]; - return; + return 1; } - } elsif(%type_constraints) { - $_[2]->{message} = - "Not enough values for all defined type constraints. Remaining: ". join(', ',values %values) - if ref $_[2]; - return; - } else { - return 1; } }, ) @@ -855,7 +923,8 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( parent => find_type_constraint('HashRef'), constraint_generator=> sub { ## Get the constraints and values to check - my ($type_constraints, $values) = @_; + my ($self, $type_constraints) = @_; + $type_constraints = $self->type_constraints; my @constraints = defined $type_constraints ? @$type_constraints : (); Carp::confess( "too many args for Map type" ) if @constraints > 2; @@ -864,27 +933,44 @@ Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( : @constraints == 1 ? (undef, @constraints) : (); - my %values = defined $values ? %$values: (); - ## Perform the checking - if ($value_type) { - for my $value (values %$values) { - unless ($value_type->check($value)) { - $_[2]->{message} = $value_type->get_message($value) if ref $_[2]; - return; + my ($key_check, $value_check, $is_compiled); + return sub { + my ($values, $err) = @_; + my %values = defined $values ? %$values: (); + + unless ($is_compiled) { + ($key_check, $value_check) + = map { $_ ? $_->$CompiledTC : undef } + $key_type, $value_type; + $is_compiled++; } - } - } - if ($key_type) { - for my $key (keys %$values) { - unless ($key_type->check($key)) { - $_[2]->{message} = $key_type->get_message($key) if ref $_[2]; - return; + ## Perform the checking + if ($value_check) { + for my $value (values %$values) { + unless ($value_check->($value)) { + if($err) { + my $message = $value_type->validate($value,$err); + $err->add_message({message=>$message,level=>$err->level}); + } + return; + } + } + } + if ($key_check) { + for my $key (keys %$values) { + unless ($key_check->($key)) { + if($err) { + my $message = $key_type->validate($key,$err); + $err->add_message({message=>$message,level=>$err->level}); + } + return; + } + } } - } - } - return 1; + return 1; + }; }, ) ); @@ -903,15 +989,6 @@ The following modules or resources may be of interest. L, L, L, L -=head1 TODO - -Here's a list of stuff I would be happy to get volunteers helping with: - - * All POD examples need test cases in t/documentation/*.t - * Want to break out the examples section to a separate cookbook style POD. - * Want more examples and best practice / usage guidance for authors - * Need to clarify deep coercions, - =cut 1;