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