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