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.72';
  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 Moose type constraints. More
 148 details to be explained later (possibly in a Cookbook recipe).
 149
 150 This actually used to be part of Moose::Meta::TypeConstraint, but it
 151 is now better off in it's own file.
 152
 153 =head1 METHODS
 154
 155 This class is not a subclass of Moose::Meta::TypeConstraint,
 156 but it does provide the same API
 157
 158 =over 4
 159
 160 =item B<meta>
 161
 162 =item B<new>
 163
 164 =item B<name>
 165
 166 =item B<type_constraints>
 167
 168 =item B<parents>
 169
 170 =item B<constraint>
 171
 172 =item B<includes_type>
 173
 174 =item B<equals>
 175
 176 =back
 177
 178 =head2 Overridden methods
 179
 180 =over 4
 181
 182 =item B<check>
 183
 184 =item B<coerce>
 185
 186 =item B<validate>
 187
 188 =item B<is_a_type_of>
 189
 190 =item B<is_subtype_of>
 191
 192 =back
 193
 194 =head2 Empty or Stub methods
 195
 196 These methods tend to not be very relevant in
 197 the context of a union. Either that or they are
 198 just difficult to specify and not very useful
 199 anyway. They are here for completeness.
 200
 201 =over 4
 202
 203 =item B<parent>
 204
 205 =item B<coercion>
 206
 207 =item B<has_coercion>
 208
 209 =item B<message>
 210
 211 =item B<has_message>
 212
 213 =item B<hand_optimized_type_constraint>
 214
 215 =item B<has_hand_optimized_type_constraint>
 216
 217 =item B<create_child_type>
 218
 219 =back
 220
 221 =head1 BUGS
 222
 223 All complex software has bugs lurking in it, and this module is no
 224 exception. If you find a bug please either email me, or add the bug
 225 to cpan-RT.
 226
 227 =head1 AUTHOR
 228
 229 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 230
 231 =head1 COPYRIGHT AND LICENSE
 232
 233 Copyright 2006-2009 by Infinity Interactive, Inc.
 234
 235 L<http://www.iinteractive.com>
 236
 237 This library is free software; you can redistribute it and/or modify
 238 it under the same terms as Perl itself.
 239
 240 =cut