X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FTypeConstraint%2FParameterizable.pm;h=31b5c06823a8f4320abaef19cd6b8e4fca138306;hb=refs%2Ftags%2F1.12;hp=93d0cc968cd8171bac70b98b38cd7f5b49570bb4;hpb=af6941770334c72d83b12fcb0f45a55b09dfaaea;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm index 93d0cc9..31b5c06 100644 --- a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm +++ b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm @@ -4,12 +4,13 @@ use strict; use warnings; use metaclass; -our $VERSION = '0.57'; +our $VERSION = '1.12'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::TypeConstraint'; use Moose::Meta::TypeConstraint::Parameterized; +use Moose::Util::TypeConstraints (); __PACKAGE__->meta->add_attribute('constraint_generator' => ( accessor => 'constraint_generator', @@ -18,16 +19,16 @@ __PACKAGE__->meta->add_attribute('constraint_generator' => ( sub generate_constraint_for { my ($self, $type) = @_; - + return unless $self->has_constraint_generator; - + return $self->constraint_generator->($type->type_parameter) if $type->is_subtype_of($self->name); - + return $self->_can_coerce_constraint_from($type) if $self->has_coercion && $self->coercion->has_coercion_for_type($type->parent->name); - + return; } @@ -41,32 +42,40 @@ sub _can_coerce_constraint_from { }; } -sub parse_parameter_str { - my ($self, $type_str) = @_; - return find_or_create_isa_type_constraint($type_str); +sub _parse_type_parameter { + my ($self, $type_parameter) = @_; + return Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($type_parameter); } sub parameterize { - my ($self, @args) = @_; - - ## ugly hacking to deal with tc naming normalization issue - my ($tc_name, $contained_tc); - if (ref $args[0]) { - $contained_tc = shift @args; - $tc_name = $self->name .'['. $contained_tc->name .']'; - } else { - ($tc_name, $contained_tc) = @args; + my ($self, $type_parameter) = @_; + + my $contained_tc = $self->_parse_type_parameter($type_parameter); + + ## The type parameter should be a subtype of the parent's type parameter + ## if there is one. + + if(my $parent = $self->parent) { + if($parent->can('type_parameter')) { + unless ( $contained_tc->is_a_type_of($parent->type_parameter) ) { + require Moose; + Moose->throw_error("$type_parameter is not a subtype of ".$parent->type_parameter); + } + } + } + + if ( $contained_tc->isa('Moose::Meta::TypeConstraint') ) { + my $tc_name = $self->name . '[' . $contained_tc->name . ']'; + return Moose::Meta::TypeConstraint::Parameterized->new( + name => $tc_name, + parent => $self, + type_parameter => $contained_tc, + ); + } + else { + require Moose; + Moose->throw_error("The type parameter must be a Moose meta type"); } - - unless($contained_tc->isa('Moose::Meta::TypeConstraint')) { - Moose->throw_error("The type parameter must be a Moose meta type"); - } - - return Moose::Meta::TypeConstraint::Parameterized->new( - name => $tc_name, - parent => $self, - type_parameter => $contained_tc, - ); } @@ -79,35 +88,33 @@ __END__ =head1 NAME -Moose::Meta::TypeConstraint::Parameterizable - Higher Order type constraints for Moose - -=head1 METHODS - -=over 4 - -=item B +Moose::Meta::TypeConstraint::Parameterizable - Type constraints which can take a parameter (ArrayRef) -=item B +=head1 DESCRIPTION -=item B +This class represents a parameterizable type constraint. This is a +type constraint like C or C, that can be +parameterized and made more specific by specifying a contained +type. For example, instead of just an C of anything, you can +specify that is an C. -=item B +A parameterizable constraint should not be used as an attribute type +constraint. Instead, when parameterized it creates a +L which should be used. -Given a string, convert it to a Perl structure. +=head1 INHERITANCE -=item B +C is a subclass of +L. -Given an array of type constraints, parameterize the current type constraint. - -=item B +=head1 METHODS -=back +This class is intentionally not documented because the API is +confusing and needs some work. =head1 BUGS -All complex software has bugs lurking in it, and this module is no -exception. If you find a bug please either email me, or add the bug -to cpan-RT. +See L for details on reporting bugs. =head1 AUTHOR @@ -115,7 +122,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2008 by Infinity Interactive, Inc. +Copyright 2006-2010 by Infinity Interactive, Inc. L