X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FMeta%2FTypeConstraint%2FStructured.pm;h=166794772a135c590616709040463bdfdc79631a;hb=8b810e835ea88682b4858363749fa201e9b45126;hp=dc4549398196f925371a84f2a59300a48682142c;hpb=59deb8586dff2cca93f750ff381ae190e628193d;p=gitmo%2FMooseX-Types-Structured.git diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm index dc45493..1667947 100644 --- a/lib/MooseX/Meta/TypeConstraint/Structured.pm +++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm @@ -1,32 +1,27 @@ package ## Hide from PAUSE MooseX::Meta::TypeConstraint::Structured; +# ABSTRACT: Structured type constraints. use Moose; +use Devel::PartialDump; use Moose::Util::TypeConstraints (); use MooseX::Meta::TypeCoercion::Structured; extends 'Moose::Meta::TypeConstraint'; -=head1 NAME - -MooseX::Meta::TypeConstraint::Structured - Structured type constraints. =head1 DESCRIPTION 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: +idea here is that a Type Constraint could be something like, "An C followed by +an C and then a C" 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. +So a structure is a list of type constraints (the C in the above +example) which are intended to function together. -=head2 type_constraints +=attr type_constraints A list of L objects. @@ -38,35 +33,76 @@ has 'type_constraints' => ( predicate=>'has_type_constraints', ); -=head2 constraint_generator +=attr constraint_generator + +=for stopwords subref A subref or closure that contains the way we validate incoming values against a set of type constraints. =cut -has 'constraint_generator' => (is=>'ro', isa=>'CodeRef'); +has 'constraint_generator' => ( + is=>'ro', + isa=>'CodeRef', + predicate=>'has_constraint_generator', +); -=head1 METHODS +has coercion => ( + is => 'ro', + isa => 'Object', + builder => '_build_coercion', +); -This class defines the following methods. +sub _build_coercion { + my ($self) = @_; + return MooseX::Meta::TypeCoercion::Structured->new( + type_constraint => $self, + ); +} -=head2 new +=method validate -Initialization stuff. +Messing with validate so that we can support nicer error messages. =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; +sub _clean_message { + my $message = shift @_; + $message =~s/MooseX::Types::Structured:://g; + return $message; +} + +override 'validate' => sub { + my ($self, $value, $message_stack) = @_; + unless ($message_stack) { + $message_stack = MooseX::Types::Structured::MessageStack->new(); + } + + $message_stack->inc_level; + + if ($self->_compiled_type_constraint->($value, $message_stack)) { + ## Everything is good, no error message to return + return undef; + } else { + ## Whoops, need to figure out the right error message + my $args = Devel::PartialDump::dump($value); + $message_stack->dec_level; + if($message_stack->has_messages) { + if($message_stack->level) { + ## we are inside a deeply structured constraint + return $self->get_message($args); + } else { + my $message_str = $message_stack->as_string; + return _clean_message($self->get_message("$args, Internal Validation Error is: $message_str")); + } + } else { + return $self->get_message($args); + } + } }; -=head2 generate_constraint_for ($type_constraints) +=method 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) @@ -75,13 +111,12 @@ of values (to be passed at check time) sub generate_constraint_for { my ($self, $type_constraints) = @_; - return sub { - my $constraint_generator = $self->constraint_generator; - return $constraint_generator->($type_constraints, @_); - }; + return $self->constraint_generator->($self, $type_constraints); } -=head2 parameterize (@type_constraints) +=for stopwords parameterize + +=method parameterize (@type_constraints) Given a ref of type constraints, create a structured type. @@ -91,20 +126,40 @@ 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 => $self->constraint_generator || sub { + constraint_generator => $constraint_generator, + ); +} + +=method __infer_constraint_generator + +=for stopwords servicable + +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 +=method compile_type_constraint hook into compile_type_constraint so we can set the correct validation rules. @@ -112,17 +167,17 @@ hook into compile_type_constraint so we can set the correct validation rules. 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); + $self->_set_constraint($constraint); } return $self->$compile_type_constraint(@args); }; -=head2 create_child_type +=method create_child_type modifier to make sure we get the constraint_generator @@ -132,15 +187,15 @@ around 'create_child_type' => sub { my ($create_child_type, $self, %opts) = @_; return $self->$create_child_type( %opts, - constraint_generator => $self->constraint_generator, + constraint_generator => $self->__infer_constraint_generator, ); }; -=head2 is_a_type_of +=method is_a_type_of -=head2 is_subtype_of +=method is_subtype_of -=head2 equals +=method equals Override the base class behavior. @@ -148,66 +203,153 @@ Override the base class behavior. sub equals { my ( $self, $type_or_name ) = @_; - my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) + or return; return unless $other->isa(__PACKAGE__); - + return ( - $self->type_constraints_equals($other) + $self->parent->equals($other->parent) and - $self->parent->equals( $other->parent ) + $self->type_constraints_equals($other) ); } -=head2 type_constraints_equals +sub is_a_type_of { + my ( $self, $type_or_name ) = @_; + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) + or return; + + if ( $other->isa(__PACKAGE__) and @{ $other->type_constraints || [] }) { + if ( $self->parent->is_a_type_of($other->parent) ) { + return $self->_type_constraints_op_all($other, "is_a_type_of"); + } elsif ( $self->parent->is_a_type_of($other) ) { + return 1; + # FIXME compare? + } else { + return 0; + } + } else { + return $self->SUPER::is_a_type_of($other); + } +} -Checks to see if the internal type contraints are equal. +sub is_subtype_of { + my ( $self, $type_or_name ) = @_; + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) + or return; + if ( $other->isa(__PACKAGE__) ) { + if ( $other->type_constraints and $self->type_constraints ) { + if ( $self->parent->is_a_type_of($other->parent) ) { + return ( + $self->_type_constraints_op_all($other, "is_a_type_of") + and + $self->_type_constraints_op_any($other, "is_subtype_of") + ); + } elsif ( $self->parent->is_a_type_of($other) ) { + return 1; + # FIXME compare? + } else { + return 0; + } + } else { + if ( $self->type_constraints ) { + if ( $self->SUPER::is_subtype_of($other) ) { + return 1; + } else { + return; + } + } else { + return $self->parent->is_subtype_of($other->parent); + } + } + } else { + return $self->SUPER::is_subtype_of($other); + } +} + +=method type_constraints_equals + +Checks to see if the internal type constraints are equal. =cut sub type_constraints_equals { - my ($self, $other) = @_; + my ( $self, $other ) = @_; + $self->_type_constraints_op_all($other, "equals"); +} + +sub _type_constraints_op_all { + my ($self, $other, $op) = @_; + + return unless $other->isa(__PACKAGE__); + my @self_type_constraints = @{$self->type_constraints||[]}; my @other_type_constraints = @{$other->type_constraints||[]}; - + + return unless @self_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 - } + my $other_type_constraint = shift @other_type_constraints; + $_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_) + for $self_type_constraint, $other_type_constraint; + + my $result = $self_type_constraint->$op($other_type_constraint); + return unless $result; } - + return 1; ##If we get this far, everything is good. } -=head2 get_message +sub _type_constraints_op_any { + my ($self, $other, $op) = @_; -May want to override this to set a more useful error message + return unless $other->isa(__PACKAGE__); -=head1 SEE ALSO + my @self_type_constraints = @{$self->type_constraints||[]}; + my @other_type_constraints = @{$other->type_constraints||[]}; -The following modules or resources may be of interest. + return unless @self_type_constraints == @other_type_constraints; -L, L + ## 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; + + $_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_) + for $self_type_constraint, $other_type_constraint; -=head1 AUTHOR + return 1 if $self_type_constraint->$op($other_type_constraint); + } + + return 0; +} -John Napiorkowski, C<< >> +=method get_message -=head1 COPYRIGHT & LICENSE +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 -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +=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 =cut -1; \ No newline at end of file +__PACKAGE__->meta->make_immutable(inline_constructor => 0);