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     return;
 141 }
 142
 143 sub validate {
 144     my ($self, $value) = @_;
 145     my $message;
 146     foreach my $type (@{$self->type_constraints}) {
 147         my $err = $type->validate($value);
 148         return unless defined $err;
 149         $message .= ($message ? ' and ' : '') . $err
 150             if defined $err;
 151     }
 152     return ($message . ' in (' . $self->name . ')') ;
 153 }
 154
 155 sub find_type_for {
 156     my ($self, $value) = @_;
 157
 158     return first { $_->check($value) } @{ $self->type_constraints };
 159 }
 160
 161 sub is_a_type_of {
 162     my ($self, $type_name) = @_;
 163
 164     return all { $_->is_a_type_of($type_name) } @{ $self->type_constraints };
 165 }
 166
 167 sub is_subtype_of {
 168     my ($self, $type_name) = @_;
 169
 170     return all { $_->is_subtype_of($type_name) } @{ $self->type_constraints };
 171 }
 172
 173 sub create_child_type {
 174     my ( $self, %opts ) = @_;
 175
 176     my $constraint
 177         = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
 178
 179     # if we have a type constraint union, and no
 180     # type check, this means we are just aliasing
 181     # the union constraint, which means we need to
 182     # handle this differently.
 183     # - SL
 184     if ( not( defined $opts{constraint} )
 185         && $self->has_coercion ) {
 186         $constraint->coercion(
 187             Moose::Meta::TypeCoercion::Union->new(
 188                 type_constraint => $self,
 189             )
 190         );
 191     }
 192
 193     return $constraint;
 194 }
 195
 196 1;
 197
 198 # ABSTRACT: A union of Moose type constraints
 199
 200 __END__
 201
 202 =pod
 203
 204 =head1 DESCRIPTION
 205
 206 This metaclass represents a union of type constraints. A union takes
 207 multiple type constraints, and is true if any one of its member
 208 constraints is true.
 209
 210 =head1 INHERITANCE
 211
 212 C<Moose::Meta::TypeConstraint::Union> is a subclass of
 213 L<Moose::Meta::TypeConstraint>.
 214
 215 =over 4
 216
 217 =item B<< Moose::Meta::TypeConstraint::Union->new(%options) >>
 218
 219 This creates a new class type constraint based on the given
 220 C<%options>.
 221
 222 It takes the same options as its parent. It also requires an
 223 additional option, C<type_constraints>. This is an array reference
 224 containing the L<Moose::Meta::TypeConstraint> objects that are the
 225 members of the union type. The C<name> option defaults to the names
 226 all of these member types sorted and then joined by a pipe (|).
 227
 228 The constructor sets the implementation of the constraint so that is
 229 simply calls C<check> on the newly created object.
 230
 231 Finally, the constructor also makes sure that the object's C<coercion>
 232 attribute is a L<Moose::Meta::TypeCoercion::Union> object.
 233
 234 =item B<< $constraint->type_constraints >>
 235
 236 This returns the array reference of C<type_constraints> provided to
 237 the constructor.
 238
 239 =item B<< $constraint->parent >>
 240
 241 This returns the nearest common ancestor of all the components of the union.
 242
 243 =item B<< $constraint->check($value) >>
 244
 245 =item B<< $constraint->validate($value) >>
 246
 247 These two methods simply call the relevant method on each of the
 248 member type constraints in the union. If any type accepts the value,
 249 the value is valid.
 250
 251 With C<validate> the error message returned includes all of the error
 252 messages returned by the member type constraints.
 253
 254 =item B<< $constraint->equals($type_name_or_object) >>
 255
 256 A type is considered equal if it is also a union type, and the two
 257 unions have the same member types.
 258
 259 =item B<< $constraint->find_type_for($value) >>
 260
 261 This returns the first member type constraint for which C<check($value)> is
 262 true, allowing you to determine which of the Union's member type constraints
 263 a given value matches.
 264
 265 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
 266
 267 This returns true if all of the member type constraints return true
 268 for the C<is_a_type_of> method.
 269
 270 =item B<< $constraint->is_subtype_of >>
 271
 272 This returns true if all of the member type constraints return true
 273 for the C<is_a_subtype_of> method.
 274
 275 =item B<< $constraint->create_child_type(%options) >>
 276
 277 This returns a new L<Moose::Meta::TypeConstraint> object with the type
 278 as its parent.
 279
 280 =back
 281
 282 =head1 BUGS
 283
 284 See L<Moose/BUGS> for details on reporting bugs.
 285
 286 =cut