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