lib/Moose/Meta/TypeConstraint/Union.pm

   1
   2 package Moose::Meta::TypeConstraint::Union;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use Moose::Meta::TypeCoercion::Union;
   9
  10 use List::Util qw(first);
  11
  12 our $VERSION   = '1.16';
  13 $VERSION = eval $VERSION;
  14 our $AUTHORITY = 'cpan:STEVAN';
  15
  16 use base 'Moose::Meta::TypeConstraint';
  17
  18 __PACKAGE__->meta->add_attribute('type_constraints' => (
  19     accessor  => 'type_constraints',
  20     default   => sub { [] }
  21 ));
  22
  23 sub new {
  24     my ($class, %options) = @_;
  25
  26     my $name = join '|' => sort { $a cmp $b }
  27         map { $_->name } @{ $options{type_constraints} };
  28
  29     my $self = $class->SUPER::new(
  30         name => $name,
  31         %options,
  32     );
  33
  34     $self->_set_constraint(sub { $self->check($_[0]) });
  35
  36     return $self;
  37 }
  38
  39 # XXX - this is a rather gross implementation of laziness for the benefit of
  40 # MX::Types. If we try to call ->has_coercion on the objects during object
  41 # construction, this does not work when defining a recursive constraint with
  42 # MX::Types.
  43 sub coercion {
  44     my $self = shift;
  45
  46     return $self->{coercion} if exists $self->{coercion};
  47
  48     # Using any instead of grep here causes a weird error with some corner
  49     # cases when MX::Types is in use. See RT #61001.
  50     if ( grep { $_->has_coercion } @{ $self->type_constraints } ) {
  51         return $self->{coercion} = Moose::Meta::TypeCoercion::Union->new(
  52             type_constraint => $self );
  53     }
  54     else {
  55         return $self->{coercion} = undef;
  56     }
  57 }
  58
  59 sub has_coercion {
  60     return defined $_[0]->coercion;
  61 }
  62
  63 sub _actually_compile_type_constraint {
  64     my $self = shift;
  65
  66     my @constraints = @{ $self->type_constraints };
  67
  68     return sub {
  69         my $value = shift;
  70         foreach my $type (@constraints) {
  71             return 1 if $type->check($value);
  72         }
  73         return undef;
  74     };
  75 }
  76
  77
  78 sub equals {
  79     my ( $self, $type_or_name ) = @_;
  80
  81     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  82
  83     return unless $other->isa(__PACKAGE__);
  84
  85     my @self_constraints  = @{ $self->type_constraints };
  86     my @other_constraints = @{ $other->type_constraints };
  87
  88     return unless @self_constraints == @other_constraints;
  89
  90     # FIXME presort type constraints for efficiency?
  91     constraint: foreach my $constraint ( @self_constraints ) {
  92         for ( my $i = 0; $i < @other_constraints; $i++ ) {
  93             if ( $constraint->equals($other_constraints[$i]) ) {
  94                 splice @other_constraints, $i, 1;
  95                 next constraint;
  96             }
  97         }
  98     }
  99
 100     return @other_constraints == 0;
 101 }
 102
 103 sub parents {
 104     my $self = shift;
 105     $self->type_constraints;
 106 }
 107
 108 sub validate {
 109     my ($self, $value) = @_;
 110     my $message;
 111     foreach my $type (@{$self->type_constraints}) {
 112         my $err = $type->validate($value);
 113         return unless defined $err;
 114         $message .= ($message ? ' and ' : '') . $err
 115             if defined $err;
 116     }
 117     return ($message . ' in (' . $self->name . ')') ;
 118 }
 119
 120 sub find_type_for {
 121     my ($self, $value) = @_;
 122
 123     return first { $_->check($value) } @{ $self->type_constraints };
 124 }
 125
 126 sub is_a_type_of {
 127     my ($self, $type_name) = @_;
 128     foreach my $type (@{$self->type_constraints}) {
 129         return 1 if $type->is_a_type_of($type_name);
 130     }
 131     return 0;
 132 }
 133
 134 sub is_subtype_of {
 135     my ($self, $type_name) = @_;
 136     foreach my $type (@{$self->type_constraints}) {
 137         return 1 if $type->is_subtype_of($type_name);
 138     }
 139     return 0;
 140 }
 141
 142 sub create_child_type {
 143     my ( $self, %opts ) = @_;
 144
 145     my $constraint
 146         = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
 147
 148     # if we have a type constraint union, and no
 149     # type check, this means we are just aliasing
 150     # the union constraint, which means we need to
 151     # handle this differently.
 152     # - SL
 153     if ( not( defined $opts{constraint} )
 154         && $self->has_coercion ) {
 155         $constraint->coercion(
 156             Moose::Meta::TypeCoercion::Union->new(
 157                 type_constraint => $self,
 158             )
 159         );
 160     }
 161
 162     return $constraint;
 163 }
 164
 165 1;
 166
 167 __END__
 168
 169 =pod
 170
 171 =head1 NAME
 172
 173 Moose::Meta::TypeConstraint::Union - A union of Moose type constraints
 174
 175 =head1 DESCRIPTION
 176
 177 This metaclass represents a union of type constraints. A union takes
 178 multiple type constraints, and is true if any one of its member
 179 constraints is true.
 180
 181 =head1 INHERITANCE
 182
 183 C<Moose::Meta::TypeConstraint::Union> is a subclass of
 184 L<Moose::Meta::TypeConstraint>.
 185
 186 =over 4
 187
 188 =item B<< Moose::Meta::TypeConstraint::Union->new(%options) >>
 189
 190 This creates a new class type constraint based on the given
 191 C<%options>.
 192
 193 It takes the same options as its parent. It also requires an
 194 additional option, C<type_constraints>. This is an array reference
 195 containing the L<Moose::Meta::TypeConstraint> objects that are the
 196 members of the union type. The C<name> option defaults to the names
 197 all of these member types sorted and then joined by a pipe (|).
 198
 199 The constructor sets the implementation of the constraint so that is
 200 simply calls C<check> on the newly created object.
 201
 202 Finally, the constructor also makes sure that the object's C<coercion>
 203 attribute is a L<Moose::Meta::TypeCoercion::Union> object.
 204
 205 =item B<< $constraint->type_constraints >>
 206
 207 This returns the array reference of C<type_constraints> provided to
 208 the constructor.
 209
 210 =item B<< $constraint->parents >>
 211
 212 This returns the same constraint as the C<type_constraints> method.
 213
 214 =item B<< $constraint->check($value) >>
 215
 216 =item B<< $constraint->validate($value) >>
 217
 218 These two methods simply call the relevant method on each of the
 219 member type constraints in the union. If any type accepts the value,
 220 the value is valid.
 221
 222 With C<validate> the error message returned includes all of the error
 223 messages returned by the member type constraints.
 224
 225 =item B<< $constraint->equals($type_name_or_object) >>
 226
 227 A type is considered equal if it is also a union type, and the two
 228 unions have the same member types.
 229
 230 =item B<< $constraint->find_type_for($value) >>
 231
 232 This returns the first member type constraint for which C<check($value)> is
 233 true, allowing you to determine which of the Union's member type constraints
 234 a given value matches.
 235
 236 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
 237
 238 This returns true if any of the member type constraints return true
 239 for the C<is_a_type_of> method.
 240
 241 =item B<< $constraint->is_subtype_of >>
 242
 243 This returns true if any of the member type constraints return true
 244 for the C<is_a_subtype_of> method.
 245
 246 =item B<< $constraint->create_child_type(%options) >>
 247
 248 This returns a new L<Moose::Meta::TypeConstraint> object with the type
 249 as its parent.
 250
 251 =back
 252
 253 =head1 BUGS
 254
 255 See L<Moose/BUGS> for details on reporting bugs.
 256
 257 =head1 AUTHOR
 258
 259 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 260
 261 =head1 COPYRIGHT AND LICENSE
 262
 263 Copyright 2006-2010 by Infinity Interactive, Inc.
 264
 265 L<http://www.iinteractive.com>
 266
 267 This library is free software; you can redistribute it and/or modify
 268 it under the same terms as Perl itself.
 269
 270 =cut