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=d534f447792fab19a7a042d8eb19c791f9c65852;hpb=91416e91698e60b3349427b4d8b0b4bc2795f59c;p=gitmo%2FMooseX-Types-Structured.git diff --git a/lib/MooseX/Types/Structured.pm b/lib/MooseX/Types/Structured.pm index d534f44..94dde0d 100644 --- a/lib/MooseX/Types/Structured.pm +++ b/lib/MooseX/Types/Structured.pm @@ -1,22 +1,18 @@ package MooseX::Types::Structured; +# ABSTRACT: MooseX::Types::Structured - Structured Type Constraints for Moose use 5.008; -use Moose::Util::TypeConstraints; +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 -declare => [qw(Dict Tuple Optional)]; -use Sub::Exporter -setup => { exports => [ qw(Dict Tuple Optional slurpy) ] }; -use Devel::PartialDump; +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; use Scalar::Util qw(blessed); -our $VERSION = '0.19'; -our $AUTHORITY = 'cpan:JJNAPIORK'; - -=head1 NAME - -MooseX::Types::Structured - Structured Type Constraints for Moose - =head1 SYNOPSIS The following is example usage for this module. @@ -44,7 +40,7 @@ The following is example usage for this module. ], ); - ## Remainder of your class attributes and methods + ## Remainder of your class attributes and methods Then you can instantiate this class with something like: @@ -127,7 +123,7 @@ if you are not familiar with it. =head2 Comparing Parameterized types to Structured types Parameterized constraints are built into core Moose and you are probably already -familar with the type constraints 'HashRef' and 'ArrayRef'. Structured types +familiar with the type constraints 'HashRef' and 'ArrayRef'. Structured types have similar functionality, so their syntax is likewise similar. For example, you could define a parameterized constraint like: @@ -149,7 +145,7 @@ example: use MooseX::Types -declare [qw(StringIntOptionalHashRef)]; use MooseX::Types::Moose qw(Str Int); - use MooseX::Types::Structured qw(Tuple Optional); + use MooseX::Types::Structured qw(Tuple Optional); subtype StringIntOptionalHashRef, as Tuple[ @@ -174,7 +170,7 @@ Please note the subtle difference between undefined and null. If you wish to allow both null and undefined, you should use the core Moose 'Maybe' type constraint instead: - package MyApp::Types; + package MyApp::Types; use MooseX::Types -declare [qw(StringIntMaybeHashRef)]; use MooseX::Types::Moose qw(Str Int Maybe); @@ -227,24 +223,24 @@ combine various structured, parameterized and simple constraints all together: Which would match: - [1, {name=>'John', age=>25},[10,11,12]]; + [1, {name=>'John', age=>25},[10,11,12]]; Please notice how the type parameters can be visually arranged to your liking and to improve the clarity of your meaning. You don't need to run then altogether onto a single line. Additionally, since the 'Dict' type constraint defines a hash constraint, the key order is not meaningful. For example: - subtype AnyKeyOrder, - as Dict[ - key1=>Int, - key2=>Str, - key3=>Int, - ]; + subtype AnyKeyOrder, + as Dict[ + key1=>Int, + key2=>Str, + key3=>Int, + ]; Would validate both: - {key1 => 1, key2 => "Hi!", key3 => 2}; - {key2 => "Hi!", key1 => 100, key3 => 300}; + {key1 => 1, key2 => "Hi!", key3 => 2}; + {key2 => "Hi!", key1 => 100, key3 => 300}; As you would expect, since underneath its just a plain old Perl hash at work. @@ -419,53 +415,53 @@ Newer versions of L support recursive type constraints. That is you can include a type constraint as a contained type constraint of itself. For example: - subtype Person, - as Dict[ - name=>Str, - friends=>Optional[ - ArrayRef[Person] - ], - ]; + subtype Person, + as Dict[ + name=>Str, + friends=>Optional[ + ArrayRef[Person] + ], + ]; This would declare a Person subtype that contains a name and an optional ArrayRef of Persons who are friends as in: - { - name => 'Mike', - friends => [ - { name => 'John' }, - { name => 'Vincent' }, - { - name => 'Tracey', - friends => [ - { name => 'Stephenie' }, - { name => 'Ilya' }, - ], - }, - ], - }; + { + name => 'Mike', + friends => [ + { name => 'John' }, + { name => 'Vincent' }, + { + name => 'Tracey', + friends => [ + { name => 'Stephenie' }, + { name => 'Ilya' }, + ], + }, + ], + }; Please take care to make sure the recursion node is either Optional, or declare a Union with an non recursive option such as: - subtype Value - as Tuple[ - Str, - Str|Tuple, - ]; + subtype Value + as Tuple[ + Str, + Str|Tuple, + ]; Which validates: - [ - 'Hello', [ - 'World', [ - 'Is', [ - 'Getting', - 'Old', - ], - ], - ], - ]; + [ + 'Hello', [ + 'World', [ + 'Is', [ + 'Getting', + 'Old', + ], + ], + ], + ]; Otherwise you will define a subtype thatis impossible to validate since it is infinitely recursive. For more information about defining recursive types, @@ -500,6 +496,17 @@ hashref. For example: The keys in %constraints follow the same rules as @constraints in the above section. +=head2 Map[ $key_constraint, $value_constraint ] + +This defines a HashRef based constraint in which both the keys and values are +required to meet certain constraints. For example, to map hostnames to IP +addresses, you might say: + + Map[ HostName, IPAddress ] + +The type constraint would only be met if every key was a valid HostName and +every value was a valid IPAddress. + =head2 Optional[$constraint] This is primarily a helper constraint for Dict and Tuple type constraints. What @@ -623,25 +630,25 @@ other MooseX::Types libraries. subtype Person, as Dict[ - name=>Str, - age=>Int, + name=>Str, + age=>Int, ]; coerce Person, from Dict[ - first=>Str, - last=>Str, - years=>Int, + first=>Str, + last=>Str, + years=>Int, ], via { +{ name => "$_->{first} $_->{last}", age => $_->{years}, }}, from Dict[ - fullname=>Dict[ - last=>Str, - first=>Str, - ], - dob=>DateTime, + fullname=>Dict[ + last=>Str, + first=>Str, + ], + dob=>DateTime, ], ## DateTime needs to be inside of single quotes here to disambiguate the ## class package from the DataTime type constraint imported via the @@ -689,14 +696,60 @@ clean and declarative way. =cut +my $Optional = MooseX::Meta::TypeConstraint::Structured::Optional->new( + name => 'MooseX::Types::Structured::Optional', + package_defined_in => __PACKAGE__, + parent => find_type_constraint('Item'), + constraint => sub { 1 }, + constraint_generator => sub { + my ($type_parameter, @args) = @_; + my $check = $type_parameter->_compiled_type_constraint(); + return sub { + my (@args) = @_; + ## Does the arg exist? Something exists if it's a 'real' value + ## or if it is set to undef. + if(exists($args[0])) { + ## If it exists, we need to validate it + $check->($args[0]); + } else { + ## But it's is okay if the value doesn't exists + return 1; + } + } + } +); + +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); + Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( - MooseX::Meta::TypeConstraint::Structured->new( - name => "MooseX::Types::Structured::Tuple" , - parent => find_type_constraint('ArrayRef'), - constraint_generator=> sub { - ## Get the constraints and values to check - my ($type_constraints, $values) = @_; - my @type_constraints = defined $type_constraints ? + MooseX::Meta::TypeConstraint::Structured->new( + name => "MooseX::Types::Structured::Tuple" , + parent => find_type_constraint('ArrayRef'), + constraint_generator=> sub { + ## Get the constraints and values to check + my ($self, $type_constraints) = @_; + $type_constraints ||= $self->type_constraints; + my @type_constraints = defined $type_constraints ? @$type_constraints : (); my $overflow_handler; @@ -705,55 +758,87 @@ 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)) { - $_[2]->{message} = $type_constraint->get_message($value) - if ref $_[2]; - return; - } - } else { - ## Test if the TC supports null values - unless($type_constraint->check()) { - $_[2]->{message} = $type_constraint->get_message('NULL') - if ref $_[2]; - return; - } - } - } - ## Make sure there are no leftovers. - if(@values) { - if($overflow_handler) { - return $overflow_handler->check([@values], $_[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; + } + } + } + + ## 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; + } } 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; - } - } - ) + }; + } + ) ); Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( - MooseX::Meta::TypeConstraint::Structured->new( - name => "MooseX::Types::Structured::Dict", - parent => find_type_constraint('HashRef'), - constraint_generator=> sub { - ## Get the constraints and values to check - my ($type_constraints, $values) = @_; - my @type_constraints = defined $type_constraints ? + MooseX::Meta::TypeConstraint::Structured->new( + name => "MooseX::Types::Structured::Dict", + parent => find_type_constraint('HashRef'), + constraint_generator => sub { + ## Get the constraints and values to check + my ($self, $type_constraints) = @_; + $type_constraints = $self->type_constraints; + my @type_constraints = defined $type_constraints ? @$type_constraints : (); my $overflow_handler; @@ -761,81 +846,138 @@ 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)) { - $_[2]->{message} = $type_constraint->get_message($value) - if ref $_[2]; - return; - } - } else { - ## Test to see if the TC supports null values - unless($type_constraint->check()) { - $_[2]->{message} = $type_constraint->get_message('NULL') - if ref $_[2]; - 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; + 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"; } - } elsif(%type_constraints) { - $_[2]->{message} = - "Not enough values for all defined type constraints. Remaining: ". join(', ',values %values) - if ref $_[2]; - return; - } else { - return 1; - } - }, - ) -); + } -OPTIONAL: { - my $Optional = Moose::Meta::TypeConstraint::Parameterizable->new( - name => 'MooseX::Types::Structured::Optional', - package_defined_in => __PACKAGE__, - parent => find_type_constraint('Item'), - constraint => sub { 1 }, - constraint_generator => sub { - my ($type_parameter, @args) = @_; - my $check = $type_parameter->_compiled_type_constraint(); + my (%check, %optional, $o_check, $is_compiled); return sub { - my (@args) = @_; - ## Does the arg exist? Something exists if it's a 'real' value - ## or if it is set to undef. - if(exists($args[0])) { - ## If it exists, we need to validate it - $check->($args[0]); + 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; + } + } + } + + ## 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; + } } else { - ## But it's is okay if the value doesn't exists return 1; } } - } - ); + }, + ) +); - Moose::Util::TypeConstraints::register_type_constraint($Optional); - Moose::Util::TypeConstraints::add_parameterizable_type($Optional); -} +Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint( + MooseX::Meta::TypeConstraint::Structured->new( + name => "MooseX::Types::Structured::Map", + parent => find_type_constraint('HashRef'), + constraint_generator=> sub { + ## Get the constraints and values to check + 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; + + my ($key_type, $value_type) = @constraints == 2 ? @constraints + : @constraints == 1 ? (undef, @constraints) + : (); + + 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++; + } + + ## 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; + }; + }, + ) +); sub slurpy ($) { - my ($tc) = @_; - return MooseX::Types::Structured::OverflowHandler->new( + my ($tc) = @_; + return MooseX::Types::Structured::OverflowHandler->new( type_constraint => $tc, ); } @@ -847,35 +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, - -=head1 AUTHOR - -John Napiorkowski - -=head1 CONTRIBUTORS - -The following people have contributed to this module and agree with the listed -Copyright & license information included below: - - Florian Ragwitz, - Yuval Kogman, - Tomas Doran, - -=head1 COPYRIGHT & LICENSE - -Copyright 2008-2009, John Napiorkowski - -This program is free software; you can redistribute it and/or modify it under -the same terms as Perl itself. - =cut 1;