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(any);
  11 use List::Util qw(first);
  12
  13 our $VERSION   = '1.10';
  14 $VERSION = eval $VERSION;
  15 our $AUTHORITY = 'cpan:STEVAN';
  16
  17 use base 'Moose::Meta::TypeConstraint';
  18
  19 __PACKAGE__->meta->add_attribute('type_constraints' => (
  20     accessor  => 'type_constraints',
  21     default   => sub { [] }
  22 ));
  23
  24 sub new {
  25     my ($class, %options) = @_;
  26
  27     my $name = join '|' => sort { $a cmp $b }
  28         map { $_->name } @{ $options{type_constraints} };
  29
  30     my $self = $class->SUPER::new(
  31         name => $name,
  32         %options,
  33     );
  34
  35     $self->_set_constraint(sub { $self->check($_[0]) });
  36
  37     return $self;
  38 }
  39
  40 # XXX - this is a rather gross implementation of laziness for the benefit of
  41 # MX::Types. If we try to call ->has_coercion on the objects during object
  42 # construction, this does not work when defining a recursive constraint with
  43 # MX::Types.
  44 sub coercion {
  45     my $self = shift;
  46
  47     return $self->{coercion} if exists $self->{coercion};
  48
  49     if ( any { $_->has_coercion } @{ $self->type_constraints } ) {
  50         return $self->{coercion} = Moose::Meta::TypeCoercion::Union->new(
  51             type_constraint => $self );
  52     }
  53     else {
  54         return $self->{coercion} = undef;
  55     }
  56 }
  57
  58 sub has_coercion {
  59     return defined $_[0]->coercion;
  60 }
  61
  62 sub _actually_compile_type_constraint {
  63     my $self = shift;
  64
  65     my @constraints = @{ $self->type_constraints };
  66
  67     return sub {
  68         my $value = shift;
  69         foreach my $type (@constraints) {
  70             return 1 if $type->check($value);
  71         }
  72         return undef;
  73     };
  74 }
  75
  76
  77 sub equals {
  78     my ( $self, $type_or_name ) = @_;
  79
  80     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  81
  82     return unless $other->isa(__PACKAGE__);
  83
  84     my @self_constraints  = @{ $self->type_constraints };
  85     my @other_constraints = @{ $other->type_constraints };
  86
  87     return unless @self_constraints == @other_constraints;
  88
  89     # FIXME presort type constraints for efficiency?
  90     constraint: foreach my $constraint ( @self_constraints ) {
  91         for ( my $i = 0; $i < @other_constraints; $i++ ) {
  92             if ( $constraint->equals($other_constraints[$i]) ) {
  93                 splice @other_constraints, $i, 1;
  94                 next constraint;
  95             }
  96         }
  97     }
  98
  99     return @other_constraints == 0;
 100 }
 101
 102 sub parents {
 103     my $self = shift;
 104     $self->type_constraints;
 105 }
 106
 107 sub validate {
 108     my ($self, $value) = @_;
 109     my $message;
 110     foreach my $type (@{$self->type_constraints}) {
 111         my $err = $type->validate($value);
 112         return unless defined $err;
 113         $message .= ($message ? ' and ' : '') . $err
 114             if defined $err;
 115     }
 116     return ($message . ' in (' . $self->name . ')') ;
 117 }
 118
 119 sub find_type_for {
 120     my ($self, $value) = @_;
 121
 122     return first { $_->check($value) } @{ $self->type_constraints };
 123 }
 124
 125 sub is_a_type_of {
 126     my ($self, $type_name) = @_;
 127     foreach my $type (@{$self->type_constraints}) {
 128         return 1 if $type->is_a_type_of($type_name);
 129     }
 130     return 0;
 131 }
 132
 133 sub is_subtype_of {
 134     my ($self, $type_name) = @_;
 135     foreach my $type (@{$self->type_constraints}) {
 136         return 1 if $type->is_subtype_of($type_name);
 137     }
 138     return 0;
 139 }
 140
 141 sub create_child_type {
 142     my ( $self, %opts ) = @_;
 143
 144     my $constraint
 145         = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
 146
 147     # if we have a type constraint union, and no
 148     # type check, this means we are just aliasing
 149     # the union constraint, which means we need to
 150     # handle this differently.
 151     # - SL
 152     if ( not( defined $opts{constraint} )
 153         && $self->has_coercion ) {
 154         $constraint->coercion(
 155             Moose::Meta::TypeCoercion::Union->new(
 156                 type_constraint => $self,
 157             )
 158         );
 159     }
 160
 161     return $constraint;
 162 }
 163
 164 1;
 165
 166 __END__
 167
 168 =pod
 169
 170 =head1 NAME
 171
 172 Moose::Meta::TypeConstraint::Union - A union of Moose type constraints
 173
 174 =head1 DESCRIPTION
 175
 176 This metaclass represents a union of type constraints. A union takes
 177 multiple type constraints, and is true if any one of its member
 178 constraints is true.
 179
 180 =head1 INHERITANCE
 181
 182 C<Moose::Meta::TypeConstraint::Union> is a subclass of
 183 L<Moose::Meta::TypeConstraint>.
 184
 185 =over 4
 186
 187 =item B<< Moose::Meta::TypeConstraint::Union->new(%options) >>
 188
 189 This creates a new class type constraint based on the given
 190 C<%options>.
 191
 192 It takes the same options as its parent. It also requires an
 193 additional option, C<type_constraints>. This is an array reference
 194 containing the L<Moose::Meta::TypeConstraint> objects that are the
 195 members of the union type. The C<name> option defaults to the names
 196 all of these member types sorted and then joined by a pipe (|).
 197
 198 The constructor sets the implementation of the constraint so that is
 199 simply calls C<check> on the newly created object.
 200
 201 Finally, the constructor also makes sure that the object's C<coercion>
 202 attribute is a L<Moose::Meta::TypeCoercion::Union> object.
 203
 204 =item B<< $constraint->type_constraints >>
 205
 206 This returns the array reference of C<type_constraints> provided to
 207 the constructor.
 208
 209 =item B<< $constraint->parents >>
 210
 211 This returns the same constraint as the C<type_constraints> method.
 212
 213 =item B<< $constraint->check($value) >>
 214
 215 =item B<< $constraint->validate($value) >>
 216
 217 These two methods simply call the relevant method on each of the
 218 member type constraints in the union. If any type accepts the value,
 219 the value is valid.
 220
 221 With C<validate> the error message returned includes all of the error
 222 messages returned by the member type constraints.
 223
 224 =item B<< $constraint->equals($type_name_or_object) >>
 225
 226 A type is considered equal if it is also a union type, and the two
 227 unions have the same member types.
 228
 229 =item B<< $constraint->find_type_for($value) >>
 230
 231 This returns the first member type constraint for which C<check($value)> is
 232 true, allowing you to determine which of the Union's member type constraints
 233 a given value matches.
 234
 235 =item B<< $constraint->is_a_type_of($type_name_or_object) >>
 236
 237 This returns true if any of the member type constraints return true
 238 for the C<is_a_type_of> method.
 239
 240 =item B<< $constraint->is_subtype_of >>
 241
 242 This returns true if any of the member type constraints return true
 243 for the C<is_a_subtype_of> method.
 244
 245 =item B<< $constraint->create_child_type(%options) >>
 246
 247 This returns a new L<Moose::Meta::TypeConstraint> object with the type
 248 as its parent.
 249
 250 =back
 251
 252 =head1 BUGS
 253
 254 See L<Moose/BUGS> for details on reporting bugs.
 255
 256 =head1 AUTHOR
 257
 258 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 259
 260 =head1 COPYRIGHT AND LICENSE
 261
 262 Copyright 2006-2010 by Infinity Interactive, Inc.
 263
 264 L<http://www.iinteractive.com>
 265
 266 This library is free software; you can redistribute it and/or modify
 267 it under the same terms as Perl itself.
 268
 269 =cut