X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FTypeConstraint%2FUnion.pm;h=0ee81659dcc94141c869b168598c41db0f1aa33d;hb=c05704596921f27fba4b1148dfed3ddd0d15795e;hp=d1d2c181031c7dfe28eb74bcd20bfdcddf4fa4d5;hpb=7a10df4daf77f0efcf873693e0868b845387430d;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/TypeConstraint/Union.pm b/lib/Moose/Meta/TypeConstraint/Union.pm index d1d2c18..0ee8165 100644 --- a/lib/Moose/Meta/TypeConstraint/Union.pm +++ b/lib/Moose/Meta/TypeConstraint/Union.pm @@ -7,15 +7,15 @@ use metaclass; use Moose::Meta::TypeCoercion::Union; -our $VERSION = '0.93_03'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; +use List::MoreUtils qw(all); +use List::Util qw(first); use base 'Moose::Meta::TypeConstraint'; __PACKAGE__->meta->add_attribute('type_constraints' => ( accessor => 'type_constraints', - default => sub { [] } + default => sub { [] }, + Class::MOP::_definition_context(), )); sub new { @@ -29,13 +29,35 @@ sub new { %options, ); - $self->_set_constraint(sub { $self->check($_[0]) }); - $self->coercion(Moose::Meta::TypeCoercion::Union->new( - type_constraint => $self - )); + $self->_set_constraint( $self->_compiled_type_constraint ); + 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; @@ -50,6 +72,36 @@ sub _actually_compile_type_constraint { }; } +sub can_be_inlined { + my $self = shift; + + # This was originally done with all() from List::MoreUtils, but that + # caused some sort of bizarro parsing failure under 5.10. + for my $tc ( @{ $self->type_constraints } ) { + return 0 unless $tc->can_be_inlined; + } + + return 1; +} + +sub _inline_check { + my $self = shift; + my $val = shift; + + return '(' + . ( + join ' || ', map { '(' . $_->_inline_check($val) . ')' } + @{ $self->type_constraints } + ) + . ')'; +} + +sub inline_environment { + my $self = shift; + + return { map { %{ $_->inline_environment } } + @{ $self->type_constraints } }; +} sub equals { my ( $self, $type_or_name ) = @_; @@ -76,9 +128,16 @@ sub equals { return @other_constraints == 0; } -sub parents { +sub parent { my $self = shift; - $self->type_constraints; + + my ($first, @rest) = @{ $self->type_constraints }; + + for my $parent ( $first->_collect_all_parents ) { + return $parent if all { $_->is_a_type_of($parent) } @rest; + } + + return; } sub validate { @@ -93,20 +152,22 @@ sub validate { return ($message . ' in (' . $self->name . ')') ; } +sub find_type_for { + my ($self, $value) = @_; + + return first { $_->check($value) } @{ $self->type_constraints }; +} + sub is_a_type_of { my ($self, $type_name) = @_; - foreach my $type (@{$self->type_constraints}) { - return 1 if $type->is_a_type_of($type_name); - } - return 0; + + return all { $_->is_a_type_of($type_name) } @{ $self->type_constraints }; } sub is_subtype_of { my ($self, $type_name) = @_; - foreach my $type (@{$self->type_constraints}) { - return 1 if $type->is_subtype_of($type_name); - } - return 0; + + return all { $_->is_subtype_of($type_name) } @{ $self->type_constraints }; } sub create_child_type { @@ -134,14 +195,12 @@ sub create_child_type { 1; +# ABSTRACT: A union of Moose type constraints + __END__ =pod -=head1 NAME - -Moose::Meta::TypeConstraint::Union - A union of Moose type constraints - =head1 DESCRIPTION This metaclass represents a union of type constraints. A union takes @@ -177,9 +236,9 @@ attribute is a L object. This returns the array reference of C provided to the constructor. -=item B<< $constraint->parents >> +=item B<< $constraint->parent >> -This returns the same constraint as the C method. +This returns the nearest common ancestor of all the components of the union. =item B<< $constraint->check($value) >> @@ -197,14 +256,20 @@ messages returned by the member type constraints. A type is considered equal if it is also a union type, and the two unions have the same member types. +=item B<< $constraint->find_type_for($value) >> + +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<< $constraint->is_a_type_of($type_name_or_object) >> -This returns true if any of the member type constraints return true +This returns true if all of the member type constraints return true for the C method. =item B<< $constraint->is_subtype_of >> -This returns true if any of the member type constraints return true +This returns true if all of the member type constraints return true for the C method. =item B<< $constraint->create_child_type(%options) >> @@ -218,17 +283,4 @@ as its parent. See L for details on reporting bugs. -=head1 AUTHOR - -Stevan Little Estevan@iinteractive.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006-2010 by Infinity Interactive, Inc. - -L - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - =cut