X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FTypeConstraint%2FUnion.pm;h=ad9b414129266ed96d0a1bbac6a6f1e87951d212;hb=0c3879e855fa83153b432144307fb0e8b7e8d595;hp=aea91e0467be3fd2f9bd322d930338ec303c7932;hpb=84a9c64c562ec926d73ecec464b5a0463d6aacef;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/TypeConstraint/Union.pm b/lib/Moose/Meta/TypeConstraint/Union.pm index aea91e0..ad9b414 100644 --- a/lib/Moose/Meta/TypeConstraint/Union.pm +++ b/lib/Moose/Meta/TypeConstraint/Union.pm @@ -7,7 +7,9 @@ use metaclass; use Moose::Meta::TypeCoercion::Union; -our $VERSION = '0.57'; +use List::Util qw(first); + +our $VERSION = '1.25'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -18,29 +20,61 @@ __PACKAGE__->meta->add_attribute('type_constraints' => ( default => sub { [] } )); -sub new { +sub new { my ($class, %options) = @_; + + my $name = join '|' => sort { $a cmp $b } + map { $_->name } @{ $options{type_constraints} }; + my $self = $class->SUPER::new( - name => (join '|' => sort map { $_->name } @{$options{type_constraints}}), - parent => undef, - message => undef, - hand_optimized_type_constraint => undef, - compiled_type_constraint => sub { - my $value = shift; - foreach my $type (@{$options{type_constraints}}) { - return 1 if $type->check($value); - } - return undef; - }, - %options + name => $name, + %options, ); + $self->_set_constraint(sub { $self->check($_[0]) }); - $self->coercion(Moose::Meta::TypeCoercion::Union->new( - type_constraint => $self - )); + return $self; } +# XXX - this is a rather gross implementation of laziness for the benefit of +# MX::Types. If we try to call ->has_coercion on the objects during object +# construction, this does not work when defining a recursive constraint with +# MX::Types. +sub coercion { + my $self = shift; + + return $self->{coercion} if exists $self->{coercion}; + + # Using any instead of grep here causes a weird error with some corner + # cases when MX::Types is in use. See RT #61001. + if ( grep { $_->has_coercion } @{ $self->type_constraints } ) { + return $self->{coercion} = Moose::Meta::TypeCoercion::Union->new( + type_constraint => $self ); + } + else { + return $self->{coercion} = undef; + } +} + +sub has_coercion { + return defined $_[0]->coercion; +} + +sub _actually_compile_type_constraint { + my $self = shift; + + my @constraints = @{ $self->type_constraints }; + + return sub { + my $value = shift; + foreach my $type (@constraints) { + return 1 if $type->check($value); + } + return undef; + }; +} + + sub equals { my ( $self, $type_or_name ) = @_; @@ -80,7 +114,13 @@ sub validate { $message .= ($message ? ' and ' : '') . $err if defined $err; } - return ($message . ' in (' . $self->name . ')') ; + return ($message . ' in (' . $self->name . ')') ; +} + +sub find_type_for { + my ($self, $value) = @_; + + return first { $_->check($value) } @{ $self->type_constraints }; } sub is_a_type_of { @@ -88,7 +128,7 @@ sub is_a_type_of { foreach my $type (@{$self->type_constraints}) { return 1 if $type->is_a_type_of($type_name); } - return 0; + return 0; } sub is_subtype_of { @@ -99,6 +139,29 @@ sub is_subtype_of { return 0; } +sub create_child_type { + my ( $self, %opts ) = @_; + + my $constraint + = Moose::Meta::TypeConstraint->new( %opts, parent => $self ); + + # if we have a type constraint union, and no + # type check, this means we are just aliasing + # the union constraint, which means we need to + # handle this differently. + # - SL + if ( not( defined $opts{constraint} ) + && $self->has_coercion ) { + $constraint->coercion( + Moose::Meta::TypeCoercion::Union->new( + type_constraint => $self, + ) + ); + } + + return $constraint; +} + 1; __END__ @@ -111,83 +174,85 @@ Moose::Meta::TypeConstraint::Union - A union of Moose type constraints =head1 DESCRIPTION -This metaclass represents a union of Moose type constraints. More -details to be explained later (possibly in a Cookbook recipe). - -This actually used to be part of Moose::Meta::TypeConstraint, but it -is now better off in it's own file. +This metaclass represents a union of type constraints. A union takes +multiple type constraints, and is true if any one of its member +constraints is true. -=head1 METHODS +=head1 INHERITANCE -This class is not a subclass of Moose::Meta::TypeConstraint, -but it does provide the same API +C is a subclass of +L. =over 4 -=item B - -=item B - -=item B - -=item B +=item B<< Moose::Meta::TypeConstraint::Union->new(%options) >> -=item B +This creates a new class type constraint based on the given +C<%options>. -=item B +It takes the same options as its parent. It also requires an +additional option, C. This is an array reference +containing the L objects that are the +members of the union type. The C option defaults to the names +all of these member types sorted and then joined by a pipe (|). -=item B +The constructor sets the implementation of the constraint so that is +simply calls C on the newly created object. -=item B +Finally, the constructor also makes sure that the object's C +attribute is a L object. -=back +=item B<< $constraint->type_constraints >> -=head2 Overriden methods +This returns the array reference of C provided to +the constructor. -=over 4 +=item B<< $constraint->parents >> -=item B +This returns the same constraint as the C method. -=item B +=item B<< $constraint->check($value) >> -=item B +=item B<< $constraint->validate($value) >> -=item B +These two methods simply call the relevant method on each of the +member type constraints in the union. If any type accepts the value, +the value is valid. -=item B +With C the error message returned includes all of the error +messages returned by the member type constraints. -=back +=item B<< $constraint->equals($type_name_or_object) >> -=head2 Empty or Stub methods +A type is considered equal if it is also a union type, and the two +unions have the same member types. -These methods tend to not be very relevant in -the context of a union. Either that or they are -just difficult to specify and not very useful -anyway. They are here for completeness. - -=over 4 +=item B<< $constraint->find_type_for($value) >> -=item B +This returns the first member type constraint for which C is +true, allowing you to determine which of the Union's member type constraints +a given value matches. -=item B +=item B<< $constraint->is_a_type_of($type_name_or_object) >> -=item B +This returns true if any of the member type constraints return true +for the C method. -=item B +=item B<< $constraint->is_subtype_of >> -=item B +This returns true if any of the member type constraints return true +for the C method. -=item B +=item B<< $constraint->create_child_type(%options) >> -=item B +This returns a new L object with the type +as its parent. =back =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 @@ -195,7 +260,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