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