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 parent {
 132     my $self = shift;
 133
 134     my @tcs = @{ $self->type_constraints };
 135
 136     my $deepest
 137         = ( sort { $a->_ancestor_count <=> $b->_ancestor_count } @tcs )[-1];
 138
 139     for my $parent ( $deepest->_collect_all_parents ) {
 140         return $parent if all { $_->is_a_type_of($parent) } @tcs;
 141     }
 142 }
 143
 144 sub validate {
 145     my ($self, $value) = @_;
 146     my $message;
 147     foreach my $type (@{$self->type_constraints}) {
 148         my $err = $type->validate($value);
 149         return unless defined $err;
 150         $message .= ($message ? ' and ' : '') . $err
 151             if defined $err;
 152     }
 153     return ($message . ' in (' . $self->name . ')') ;
 154 }
 155
 156 sub find_type_for {
 157     my ($self, $value) = @_;
 158
 159     return first { $_->check($value) } @{ $self->type_constraints };
 160 }
 161
 162 sub is_a_type_of {
 163     my ($self, $type_name) = @_;
 164
 165     return all { $_->is_a_type_of($type_name) } @{ $self->type_constraints };
 166 }
 167
 168 sub is_subtype_of {
 169     my ($self, $type_name) = @_;
 170
 171     return all { $_->is_subtype_of($type_name) } @{ $self->type_constraints };
 172 }
 173
 174 sub create_child_type {
 175     my ( $self, %opts ) = @_;
 176
 177     my $constraint
 178         = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
 179
 180     # if we have a type constraint union, and no
 181     # type check, this means we are just aliasing
 182     # the union constraint, which means we need to
 183     # handle this differently.
 184     # - SL
 185     if ( not( defined $opts{constraint} )
 186         && $self->has_coercion ) {
 187         $constraint->coercion(
 188             Moose::Meta::TypeCoercion::Union->new(
 189                 type_constraint => $self,
 190             )
 191         );
 192     }
 193
 194     return $constraint;
 195 }
 196
 197 1;
 198
 199 # ABSTRACT: A union of Moose type constraints
 200
 201 __END__
 202
 203 =pod
 204
 205 =head1 DESCRIPTION
 206
 207 This metaclass represents a union of type constraints. A union takes
 208 multiple type constraints, and is true if any one of its member
 209 constraints is true.
 210
 211 =head1 INHERITANCE
 212
 213 C<Moose::Meta::TypeConstraint::Union> is a subclass of
 214 L<Moose::Meta::TypeConstraint>.
 215
 216 =over 4
 217
 218 =item B<< Moose::Meta::TypeConstraint::Union->new(%options) >>
 219
 220 This creates a new class type constraint based on the given
 221 C<%options>.
 222
 223 It takes the same options as its parent. It also requires an
 224 additional option, C<type_constraints>. This is an array reference
 225 containing the L<Moose::Meta::TypeConstraint> objects that are the
 226 members of the union type. The C<name> option defaults to the names
 227 all of these member types sorted and then joined by a pipe (|).
 228
 229 The constructor sets the implementation of the constraint so that is
 230 simply calls C<check> on the newly created object.
 231
 232 Finally, the constructor also makes sure that the object's C<coercion>
 233 attribute is a L<Moose::Meta::TypeCoercion::Union> object.
 234
 235 =item B<< $constraint->type_constraints >>
 236
 237 This returns the array reference of C<type_constraints> provided to
 238 the constructor.
 239
 240 =item B<< $constraint->parent >>
 241
 242 This returns the nearest common ancestor of all the components of the union.
 243
 244 =item B<< $constraint->check($value) >>
 245
 246 =item B<< $constraint->validate($value) >>
 247
 248 These two methods simply call the relevant method on each of the
 249 member type constraints in the union. If any type accepts the value,
 250 the value is valid.
 251
 252 With C<validate> the error message returned includes all of the error
 253 messages returned by the member type constraints.
 254
 255 =item B<< $constraint->equals($type_name_or_object) >>
 256
 257 A type is considered equal if it is also a union type, and the two
 258 unions have the same member types.
 259
 260 =item B<< $constraint->find_type_for($value) >>
 261
 262 This returns the first member type constraint for which C<check($value)> is
 263 true, allowing you to determine which of the Union's member type constraints
 264 a given value matches.
 265
 266 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
 267
 268 This returns true if all of the member type constraints return true
 269 for the C<is_a_type_of> method.
 270
 271 =item B<< $constraint->is_subtype_of >>
 272
 273 This returns true if all of the member type constraints return true
 274 for the C<is_a_subtype_of> method.
 275
 276 =item B<< $constraint->create_child_type(%options) >>
 277
 278 This returns a new L<Moose::Meta::TypeConstraint> object with the type
 279 as its parent.
 280
 281 =back
 282
 283 =head1 BUGS
 284
 285 See L<Moose/BUGS> for details on reporting bugs.
 286
 287 =cut