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