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