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