X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FMeta%2FTypeConstraint%2FStructured.pm;h=0db946f9a5319d265867b26ff51c480ab8710575;hb=a4ae4800dff610e55214ff02068618705963b15c;hp=e674f8b2f6f9600f37946518ae68a42b6b0a1ab3;hpb=820efec95e5d777aeaeb04a0fcf14d086a76c995;p=gitmo%2FMooseX-Types-Structured.git diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm index e674f8b..0db946f 100644 --- a/lib/MooseX/Meta/TypeConstraint/Structured.pm +++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm @@ -1,5 +1,6 @@ package ## Hide from PAUSE MooseX::Meta::TypeConstraint::Structured; +# ABSTRACT: MooseX::Meta::TypeConstraint::Structured - Structured type constraints. use Moose; use Devel::PartialDump; @@ -7,9 +8,6 @@ use Moose::Util::TypeConstraints (); use MooseX::Meta::TypeCoercion::Structured; extends 'Moose::Meta::TypeConstraint'; -=head1 NAME - -MooseX::Meta::TypeConstraint::Structured - Structured type constraints. =head1 DESCRIPTION @@ -19,15 +17,11 @@ 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 type_constraints +=attr type_constraints A list of L objects. @@ -39,7 +33,7 @@ has 'type_constraints' => ( predicate=>'has_type_constraints', ); -=head2 constraint_generator +=attr constraint_generator A subref or closure that contains the way we validate incoming values against a set of type constraints. @@ -52,49 +46,61 @@ has 'constraint_generator' => ( predicate=>'has_constraint_generator', ); -=head1 METHODS - -This class defines the following methods. - -=head2 new - -Initialization stuff. - -=cut +has coercion => ( + is => 'ro', + isa => 'Object', + builder => '_build_coercion', +); -around 'new' => sub { - my ($new, $class, @args) = @_; - my $self = $class->$new(@args); - $self->coercion(MooseX::Meta::TypeCoercion::Structured->new( +sub _build_coercion { + my ($self) = @_; + return MooseX::Meta::TypeCoercion::Structured->new( type_constraint => $self, - )); - return $self; -}; + ); +} -=head2 validate +=method validate Messing with validate so that we can support niced error messages. + =cut +sub _clean_message { + my $message = shift @_; + $message =~s/MooseX::Types::Structured:://g; + return $message; +} + override 'validate' => sub { - my ($self, @args) = @_; - my $message = bless {message=>undef}, 'MooseX::Types::Structured::Message'; + my ($self, $value, $message_stack) = @_; + unless ($message_stack) { + $message_stack = MooseX::Types::Structured::MessageStack->new(); + } + + $message_stack->inc_level; - if ($self->_compiled_type_constraint->(@args, $message)) { + 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(@args); - if(my $message = $message->{message}) { - return $self->get_message("$args, Internal Validation Error is: $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) @@ -103,22 +109,16 @@ of values (to be passed at check time) sub generate_constraint_for { my ($self, $type_constraints) = @_; - return sub { - my $arg = shift @_; - my $constraint_generator = $self->constraint_generator; - my $result = $constraint_generator->($type_constraints, $arg, $_[0]); - return $result; - }; + return $self->constraint_generator->($self, $type_constraints); } -=head2 parameterize (@type_constraints) +=method 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) .']'; @@ -132,7 +132,7 @@ sub parameterize { ); } -=head2 __infer_constraint_generator +=method __infer_constraint_generator This returns a CODEREF which generates a suitable constraint generator. Not user servicable, you'll never call this directly. @@ -148,12 +148,12 @@ sub __infer_constraint_generator { ## 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, @_); + $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. @@ -161,17 +161,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 @@ -185,11 +185,11 @@ around 'create_child_type' => sub { ); }; -=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. @@ -200,7 +200,7 @@ sub equals { my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); return unless $other->isa(__PACKAGE__); - + return ( $self->parent->equals($other->parent) and @@ -228,9 +228,7 @@ sub is_a_type_of { sub is_subtype_of { my ( $self, $type_or_name ) = @_; - my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); - if ( $other->isa(__PACKAGE__) ) { if ( $other->type_constraints and $self->type_constraints ) { if ( $self->parent->is_a_type_of($other->parent) ) { @@ -261,9 +259,9 @@ sub is_subtype_of { } } -=head2 type_constraints_equals +=method type_constraints_equals -Checks to see if the internal type contraints are equal. +Checks to see if the internal type constraints are equal. =cut @@ -286,13 +284,14 @@ sub _type_constraints_op_all { 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; - $self_type_constraint->$op($other_type_constraint) or return; + my $result = $self_type_constraint->$op($other_type_constraint); + return unless $result; } - + return 1; ##If we get this far, everything is good. } @@ -310,17 +309,17 @@ sub _type_constraints_op_any { 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; - + return 1 if $self_type_constraint->$op($other_type_constraint); } return 0; } -=head2 get_message +=method 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 @@ -342,15 +341,6 @@ The following modules or resources may be of interest. L, L -=head1 AUTHOR - -John Napiorkowski, C<< >> - -=head1 COPYRIGHT & LICENSE - -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - =cut -__PACKAGE__->meta->make_immutable; +__PACKAGE__->meta->make_immutable(inline_constructor => 0);