X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FMeta%2FTypeConstraint%2FStructured.pm;h=d7b655b91718139837e5d014b9da28db7619e109;hb=d716430a1f595e7bd54039e440a0286102fc87f1;hp=0bfde1b3b0a79fcfeaf052fff227315c5020f526;hpb=65748864062f4fca6f1e4c538b3079eb55c8ddff;p=gitmo%2FMooseX-Types-Structured.git diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm index 0bfde1b..d7b655b 100644 --- a/lib/MooseX/Meta/TypeConstraint/Structured.pm +++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm @@ -1,99 +1,274 @@ -package MooseX::Meta::TypeConstraint::Structured; +package ## Hide from PAUSE + MooseX::Meta::TypeConstraint::Structured; -use 5.8.8; ## Minimum tested Perl Version use Moose; -use Moose::Util::TypeConstraints; - +use Devel::PartialDump; +use Moose::Util::TypeConstraints (); +use MooseX::Meta::TypeCoercion::Structured; 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. +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: + + 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 parent +=head2 type_constraints + +A list of L objects. -additional details on the inherited parent attribute +=cut + +has 'type_constraints' => ( + is=>'ro', + isa=>'Ref', + predicate=>'has_type_constraints', +); -=head2 signature +=head2 constraint_generator -This is a signature of internal contraints for the contents of the outer -contraint container. +A subref or closure that contains the way we validate incoming values against +a set of type constraints. =cut -has 'signature' => ( +has 'constraint_generator' => ( is=>'ro', - isa=>'Ref', - required=>1, + isa=>'CodeRef', + predicate=>'has_constraint_generator', ); =head1 METHODS This class defines the following methods. -=head2 _normalize_args +=head2 new + +Initialization stuff. + +=cut + +around 'new' => sub { + my ($new, $class, @args) = @_; + my $self = $class->$new(@args); + $self->coercion(MooseX::Meta::TypeCoercion::Structured->new( + type_constraint => $self, + )); + return $self; +}; -Get arguments into a known state or die trying +=head2 validate +Messing with validate so that we can support niced error messages. =cut -sub _normalize_args { - my ($self, $args) = @_; - if(defined $args && ref $args eq 'ARRAY') { - return @{$args}; +override 'validate' => sub { + my ($self, @args) = @_; + my $message = bless {message=>undef}, 'MooseX::Types::Structured::Message'; + + if ($self->_compiled_type_constraint->(@args, $message)) { + ## Everything is good, no error message to return + return undef; } else { - confess 'Arguments not ArrayRef as expected.'; + ## 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"); + } else { + return $self->get_message($args); + } } -} - -=head2 constraint +}; -The constraint is basically validating the L against the incoming +=head2 generate_constraint_for ($type_constraints) + +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 (0..$#args) { - if(my $error = $self->signature->[$idx]->validate($args[$idx])) { - confess $error; - } - } 1; + my $arg = shift @_; + my $constraint_generator = $self->constraint_generator; + my $result = $constraint_generator->($type_constraints, $arg, $_[0]); + return $result; }; } +=head2 parameterize (@type_constraints) + +Given a ref of type constraints, create a structured type. + +=cut + +sub parameterize { + + my ($self, @type_constraints) = @_; + my $class = ref $self; + my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']'; + my $constraint_generator = $self->__infer_constraint_generator; + + return $class->new( + name => $name, + parent => $self, + type_constraints => \@type_constraints, + constraint_generator => $constraint_generator, + ); +} + +=head2 __infer_constraint_generator + +This returns a CODEREF which generates a suitable constraint generator. Not +user servicable, you'll never call this directly. + +=cut + +sub __infer_constraint_generator { + my ($self) = @_; + if($self->has_constraint_generator) { + return $self->constraint_generator; + } else { + return sub { + ## I'm not sure about this stuff but everything seems to work + my $tc = shift @_; + my $merged_tc = [@$tc, @{$self->parent->type_constraints}]; + $self->constraint->($merged_tc, @_); + }; + } +} + +=head2 compile_type_constraint + +hook into compile_type_constraint so we can set the correct validation rules. + +=cut + +around 'compile_type_constraint' => sub { + my ($compile_type_constraint, $self, @args) = @_; + + if($self->has_type_constraints) { + my $type_constraints = $self->type_constraints; + my $constraint = $self->generate_constraint_for($type_constraints); + $self->_set_constraint($constraint); + } + + return $self->$compile_type_constraint(@args); +}; + +=head2 create_child_type + +modifier to make sure we get the constraint_generator + +=cut + +around 'create_child_type' => sub { + my ($create_child_type, $self, %opts) = @_; + return $self->$create_child_type( + %opts, + constraint_generator => $self->__infer_constraint_generator, + ); +}; + +=head2 is_a_type_of + +=head2 is_subtype_of + +=head2 equals + +Override the base class behavior. + +=cut + +sub equals { + my ( $self, $type_or_name ) = @_; + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + return ( + $self->type_constraints_equals($other) + and + $self->parent->equals( $other->parent ) + ); +} + +=head2 type_constraints_equals + +Checks to see if the internal type contraints are equal. + +=cut + +sub type_constraints_equals { + my ($self, $other) = @_; + my @self_type_constraints = @{$self->type_constraints||[]}; + my @other_type_constraints = @{$other->type_constraints||[]}; + + ## Incoming ay be either arrayref or hashref, need top compare both + while(@self_type_constraints) { + my $self_type_constraint = shift @self_type_constraints; + my $other_type_constraint = shift @other_type_constraints + || return; ## $other needs the same number of children. + + if( ref $self_type_constraint) { + $self_type_constraint->equals($other_type_constraint) + || return; ## type constraints obviously need top be equal + } else { + $self_type_constraint eq $other_type_constraint + || return; ## strings should be equal + } + + } + + return 1; ##If we get this far, everything is good. +} + +=head2 get_message + +Give you a better peek into what's causing the error. For now we stringify the +incoming deep value with L and pass that on to either your +custom error message or the default one. In the future we'll try to provide a +more complete stack trace of the actual offending elements + +=cut + +around 'get_message' => sub { + my ($get_message, $self, $value) = @_; + $value = Devel::PartialDump::dump($value) + if ref $value; + return $self->$get_message($value); +}; + +=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; +__PACKAGE__->meta->make_immutable; \ No newline at end of file