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