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