X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FMeta%2FTypeConstraint%2FStructured.pm;h=10bb30a136ad70d98455d5deffd0b640f0bf56b9;hb=67a8bc0491edda720c7450433ccdf3cb07edb6ff;hp=51c4d78dad7c426f353fb6af1d674b92004fc566;hpb=8b276dd42ea4fbc163ce67ef2f7e12a4123beda3;p=gitmo%2FMooseX-Types-Structured.git diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm index 51c4d78..10bb30a 100644 --- a/lib/MooseX/Meta/TypeConstraint/Structured.pm +++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm @@ -1,171 +1,124 @@ package MooseX::Meta::TypeConstraint::Structured; -use 5.8.8; ## Minimum tested Perl Version use Moose; -use Moose::Util::TypeConstraints; - +use Moose::Util::TypeConstraints (); extends 'Moose::Meta::TypeConstraint'; -our $AUTHORITY = 'cpan:JJNAPIORK'; - =head1 NAME -MooseX::Meta::TypeConstraint::Structured - Structured Type Constraints - -=head1 VERSION - -0.01 - -=cut - -our $VERSION = '0.01'; +MooseX::Meta::TypeConstraint::Structured - Structured type constraints. =head1 DESCRIPTION -Structured type constraints let you assign an internal pattern of type -constraints to a 'container' constraint. The goal is to make it easier to -declare constraints like "ArrayRef[Int, Int, Str]" where the constraint is an -ArrayRef of three elements and the internal constraint on the three is Int, Int -and Str. - -=head1 SUBTYPES - -The following subtypes and coercions are defined in this class. - -=head2 MooseX::Meta::TypeConstraint::Structured::Signature +A structure is a set of L that are 'aggregated' in +such a way as that they are all applied to an incoming list of arguments. The +idea here is that a Type Constraint could be something like, "An Int followed by +an Int and then a Str" and that this could be done so with a declaration like: -This is a type constraint to normalize the incoming L. - -=cut - -subtype 'MooseX::Meta::TypeConstraint::Structured::Signature', - as 'HashRef[Object]', - where { - my %signature = %$_; - foreach my $key (keys %signature) { - $signature{$key}->isa('Moose::Meta::TypeConstraint'); - } 1; - }; - -coerce 'MooseX::Meta::TypeConstraint::Structured::Signature', - from 'ArrayRef[Object]', - via { - my @signature = @$_; - my %hashed_signature = map { $_ => $signature[$_] } 0..$#signature; - \%hashed_signature; - }; + Tuple[Int,Int,Str]; ## Example syntax + +So a structure is a list of Type constraints (the "Int,Int,Str" in the above +example) which are intended to function together. =head1 ATTRIBUTES This class defines the following attributes. -=head2 signature +=head2 type_constraints -This is a signature of internal contraints for the contents of the outer -contraint container. +A list of L objects. =cut -has 'signature' => ( +has 'type_constraints' => ( is=>'ro', - isa=>'MooseX::Meta::TypeConstraint::Structured::Signature', - coerce=>1, - required=>1, + isa=>'Ref', + predicate=>'has_type_constraints', ); -=head1 METHODS +=head2 constraint_generator -This class defines the following methods. +A subref or closure that contains the way we validate incoming values against +a set of type constraints. -=head2 _normalize_args +=cut -Get arguments into a known state or die trying. Ideally we try to make this -into a HashRef so we can match it up with the L HashRef. +has 'constraint_generator' => (is=>'ro', isa=>'CodeRef'); -=cut +=head1 METHODS -sub _normalize_args { - my ($self, $args) = @_; - if(defined $args) { - if(ref $args eq 'ARRAY') { - return map { $_ => $args->[$_] } (0..$#$args); - } elsif (ref $args eq 'HASH') { - return %$args; - } else { - confess 'Signature must be a reference'; - } - } else { - confess 'Signature cannot be empty'; - } -} - -=head2 constraint +This class defines the following methods. + +=head2 generate_constraint_for ($type_constraints) -The constraint is basically validating the L against the incoming +Given some type constraints, use them to generate validation rules for an ref +of values (to be passed at check time) =cut -sub constraint { - my $self = shift; +sub generate_constraint_for { + my ($self, $type_constraints) = @_; return sub { - my %args = $self->_normalize_args(shift); - foreach my $idx (keys %{$self->signature}) { - my $type_constraint = $self->signature->{$idx}; - if(my $error = $type_constraint->validate($args{$idx})) { - confess $error; - } - } 1; + my $constraint_generator = $self->constraint_generator; + return $constraint_generator->($type_constraints, @_); }; } -=head2 equals +=head2 parameterize (@type_constraints) -modifier to make sure equals descends into the L +Given a ref of type constraints, create a structured type. =cut -around 'equals' => sub { - my ($equals, $self, $compared_type_constraint) = @_; - - ## Make sure we are comparing typeconstraints of the same base class - return unless $compared_type_constraint->isa(__PACKAGE__); - - ## Make sure the base equals is also good - return unless $self->$equals($compared_type_constraint); - - ## Make sure the signatures match - return unless $self->signature_equals($compared_type_constraint); - - ## If we get this far, the two are equal - return 1; -}; +sub parameterize { + my ($self, @type_constraints) = @_; + my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']'; + + return __PACKAGE__->new( + name => $name, + parent => $self, + type_constraints => \@type_constraints, + constraint_generator => $self->constraint_generator || sub { + my $tc = shift @_; + my $merged_tc = [@$tc, @{$self->parent->type_constraints}]; + $self->constraint->($merged_tc, @_); + }, + ); +} -=head2 signature_equals +=head2 compile_type_constraint -Check that the signature equals another signature. +hook into compile_type_constraint so we can set the correct validation rules. =cut -sub signature_equals { - my ($self, $compared_type_constraint) = @_; +around 'compile_type_constraint' => sub { + my ($compile_type_constraint, $self, @args) = @_; - foreach my $idx (keys %{$self->signature}) { - my $this = $self->signature->{$idx}; - my $that = $compared_type_constraint->signature->{$idx}; - return unless $this->equals($that); + if($self->has_type_constraints) { + my $type_constraints = $self->type_constraints; + my $constraint = $self->generate_constraint_for($type_constraints); + $self->_set_constraint($constraint); } - - return 1; -} + + return $self->$compile_type_constraint(@args); +}; + +=head1 SEE ALSO + +The following modules or resources may be of interest. + +L, L =head1 AUTHOR -John James Napiorkowski +John Napiorkowski, C<< >> -=head1 LICENSE +=head1 COPYRIGHT & LICENSE -You may distribute this code under the same terms as Perl itself. +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. =cut -no Moose; 1; +1; \ No newline at end of file