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 has_inlined_type_constraint {
  75     my $self = shift;
  76
  77     return all { $_->has_inlined_type_constraint }
  78         @{ $self->type_constraints };
  79 }
  80
  81 sub _inline_check {
  82     my $self = shift;
  83     my $val  = shift;
  84
  85     return
  86         join ' || ', map { '(' . $_->_inline_check($val) . ')' }
  87         @{ $self->type_constraints };
  88 };
  89
  90 sub equals {
  91     my ( $self, $type_or_name ) = @_;
  92
  93     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  94
  95     return unless $other->isa(__PACKAGE__);
  96
  97     my @self_constraints  = @{ $self->type_constraints };
  98     my @other_constraints = @{ $other->type_constraints };
  99
 100     return unless @self_constraints == @other_constraints;
 101
 102     # FIXME presort type constraints for efficiency?
 103     constraint: foreach my $constraint ( @self_constraints ) {
 104         for ( my $i = 0; $i < @other_constraints; $i++ ) {
 105             if ( $constraint->equals($other_constraints[$i]) ) {
 106                 splice @other_constraints, $i, 1;
 107                 next constraint;
 108             }
 109         }
 110     }
 111
 112     return @other_constraints == 0;
 113 }
 114
 115 sub parents {
 116     my $self = shift;
 117     $self->type_constraints;
 118 }
 119
 120 sub validate {
 121     my ($self, $value) = @_;
 122     my $message;
 123     foreach my $type (@{$self->type_constraints}) {
 124         my $err = $type->validate($value);
 125         return unless defined $err;
 126         $message .= ($message ? ' and ' : '') . $err
 127             if defined $err;
 128     }
 129     return ($message . ' in (' . $self->name . ')') ;
 130 }
 131
 132 sub find_type_for {
 133     my ($self, $value) = @_;
 134
 135     return first { $_->check($value) } @{ $self->type_constraints };
 136 }
 137
 138 sub is_a_type_of {
 139     my ($self, $type_name) = @_;
 140     foreach my $type (@{$self->type_constraints}) {
 141         return 1 if $type->is_a_type_of($type_name);
 142     }
 143     return 0;
 144 }
 145
 146 sub is_subtype_of {
 147     my ($self, $type_name) = @_;
 148     foreach my $type (@{$self->type_constraints}) {
 149         return 1 if $type->is_subtype_of($type_name);
 150     }
 151     return 0;
 152 }
 153
 154 sub create_child_type {
 155     my ( $self, %opts ) = @_;
 156
 157     my $constraint
 158         = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
 159
 160     # if we have a type constraint union, and no
 161     # type check, this means we are just aliasing
 162     # the union constraint, which means we need to
 163     # handle this differently.
 164     # - SL
 165     if ( not( defined $opts{constraint} )
 166         && $self->has_coercion ) {
 167         $constraint->coercion(
 168             Moose::Meta::TypeCoercion::Union->new(
 169                 type_constraint => $self,
 170             )
 171         );
 172     }
 173
 174     return $constraint;
 175 }
 176
 177 1;
 178
 179 # ABSTRACT: A union of Moose type constraints
 180
 181 __END__
 182
 183 =pod
 184
 185 =head1 DESCRIPTION
 186
 187 This metaclass represents a union of type constraints. A union takes
 188 multiple type constraints, and is true if any one of its member
 189 constraints is true.
 190
 191 =head1 INHERITANCE
 192
 193 C<Moose::Meta::TypeConstraint::Union> is a subclass of
 194 L<Moose::Meta::TypeConstraint>.
 195
 196 =over 4
 197
 198 =item B<< Moose::Meta::TypeConstraint::Union->new(%options) >>
 199
 200 This creates a new class type constraint based on the given
 201 C<%options>.
 202
 203 It takes the same options as its parent. It also requires an
 204 additional option, C<type_constraints>. This is an array reference
 205 containing the L<Moose::Meta::TypeConstraint> objects that are the
 206 members of the union type. The C<name> option defaults to the names
 207 all of these member types sorted and then joined by a pipe (|).
 208
 209 The constructor sets the implementation of the constraint so that is
 210 simply calls C<check> on the newly created object.
 211
 212 Finally, the constructor also makes sure that the object's C<coercion>
 213 attribute is a L<Moose::Meta::TypeCoercion::Union> object.
 214
 215 =item B<< $constraint->type_constraints >>
 216
 217 This returns the array reference of C<type_constraints> provided to
 218 the constructor.
 219
 220 =item B<< $constraint->parents >>
 221
 222 This returns the same constraint as the C<type_constraints> method.
 223
 224 =item B<< $constraint->check($value) >>
 225
 226 =item B<< $constraint->validate($value) >>
 227
 228 These two methods simply call the relevant method on each of the
 229 member type constraints in the union. If any type accepts the value,
 230 the value is valid.
 231
 232 With C<validate> the error message returned includes all of the error
 233 messages returned by the member type constraints.
 234
 235 =item B<< $constraint->equals($type_name_or_object) >>
 236
 237 A type is considered equal if it is also a union type, and the two
 238 unions have the same member types.
 239
 240 =item B<< $constraint->find_type_for($value) >>
 241
 242 This returns the first member type constraint for which C<check($value)> is
 243 true, allowing you to determine which of the Union's member type constraints
 244 a given value matches.
 245
 246 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
 247
 248 This returns true if any of the member type constraints return true
 249 for the C<is_a_type_of> method.
 250
 251 =item B<< $constraint->is_subtype_of >>
 252
 253 This returns true if any of the member type constraints return true
 254 for the C<is_a_subtype_of> method.
 255
 256 =item B<< $constraint->create_child_type(%options) >>
 257
 258 This returns a new L<Moose::Meta::TypeConstraint> object with the type
 259 as its parent.
 260
 261 =back
 262
 263 =head1 BUGS
 264
 265 See L<Moose/BUGS> for details on reporting bugs.
 266
 267 =cut