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