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