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