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 Map Tuple Optional)];
-use Sub::Exporter -setup => [ qw(Dict Map 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.20';
-our $AUTHORITY = 'cpan:JJNAPIORK';
-
-=head1 NAME
-
-MooseX::Types::Structured - Structured Type Constraints for Moose
-
=head1 SYNOPSIS
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:
=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:
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[
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);
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.
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,
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
}
);
+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;
$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->is_subtype_of($Optional)) {
- $_[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;
&& $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->is_subtype_of($Optional)) {
- $_[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});
+ 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;
+ }
+ }
+ }
+
+ ## 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 {
- $_[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;
- }
- },
- )
+ }
+ },
+ )
);
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;
: @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;
+ };
},
)
);
sub slurpy ($) {
- my ($tc) = @_;
- return MooseX::Types::Structured::OverflowHandler->new(
+ my ($tc) = @_;
+ return MooseX::Types::Structured::OverflowHandler->new(
type_constraint => $tc,
);
}
L<Moose>, L<MooseX::Types>, L<Moose::Meta::TypeConstraint>,
L<MooseX::Meta::TypeConstraint::Structured>
-=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 <jjnapiork@cpan.org>
-
-=head1 CONTRIBUTORS
-
-The following people have contributed to this module and agree with the listed
-Copyright & license information included below:
-
- Florian Ragwitz, <rafl@debian.org>
- Yuval Kogman, <nothingmuch@woobling.org>
- Tomas Doran, <bobtfish@bobtfish.net>
-
-=head1 COPYRIGHT & LICENSE
-
-Copyright 2008-2009, John Napiorkowski <jjnapiork@cpan.org>
-
-This program is free software; you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
=cut
1;
projects / gitmo/MooseX-Types-Structured.git / blobdiff