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.62_02';
  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     my $self = $class->SUPER::new(
  24         name     => (join '|' => sort {$a cmp $b}
  25                      map { $_->name } @{$options{type_constraints}}),
  26         parent   => undef,
  27         message  => undef,
  28         hand_optimized_type_constraint => undef,
  29         compiled_type_constraint => sub {
  30             my $value = shift;
  31             foreach my $type (@{$options{type_constraints}}) {
  32                 return 1 if $type->check($value);
  33             }
  34             return undef;
  35         },
  36         %options
  37     );
  38     $self->_set_constraint(sub { $self->check($_[0]) });
  39     $self->coercion(Moose::Meta::TypeCoercion::Union->new(
  40         type_constraint => $self
  41     ));
  42     return $self;
  43 }
  44
  45 sub equals {
  46     my ( $self, $type_or_name ) = @_;
  47
  48     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  49
  50     return unless $other->isa(__PACKAGE__);
  51
  52     my @self_constraints  = @{ $self->type_constraints };
  53     my @other_constraints = @{ $other->type_constraints };
  54
  55     return unless @self_constraints == @other_constraints;
  56
  57     # FIXME presort type constraints for efficiency?
  58     constraint: foreach my $constraint ( @self_constraints ) {
  59         for ( my $i = 0; $i < @other_constraints; $i++ ) {
  60             if ( $constraint->equals($other_constraints[$i]) ) {
  61                 splice @other_constraints, $i, 1;
  62                 next constraint;
  63             }
  64         }
  65     }
  66
  67     return @other_constraints == 0;
  68 }
  69
  70 sub parents {
  71     my $self = shift;
  72     $self->type_constraints;
  73 }
  74
  75 sub validate {
  76     my ($self, $value) = @_;
  77     my $message;
  78     foreach my $type (@{$self->type_constraints}) {
  79         my $err = $type->validate($value);
  80         return unless defined $err;
  81         $message .= ($message ? ' and ' : '') . $err
  82             if defined $err;
  83     }
  84     return ($message . ' in (' . $self->name . ')') ;
  85 }
  86
  87 sub is_a_type_of {
  88     my ($self, $type_name) = @_;
  89     foreach my $type (@{$self->type_constraints}) {
  90         return 1 if $type->is_a_type_of($type_name);
  91     }
  92     return 0;
  93 }
  94
  95 sub is_subtype_of {
  96     my ($self, $type_name) = @_;
  97     foreach my $type (@{$self->type_constraints}) {
  98         return 1 if $type->is_subtype_of($type_name);
  99     }
 100     return 0;
 101 }
 102
 103 sub create_child_type {
 104     my ( $self, %opts ) = @_;
 105
 106     my $constraint
 107         = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
 108
 109     # if we have a type constraint union, and no
 110     # type check, this means we are just aliasing
 111     # the union constraint, which means we need to
 112     # handle this differently.
 113     # - SL
 114     if ( not( defined $opts{constraint} )
 115         && $self->has_coercion ) {
 116         $constraint->coercion(
 117             Moose::Meta::TypeCoercion::Union->new(
 118                 type_constraint => $self,
 119             )
 120         );
 121     }
 122
 123     return $constraint;
 124 }
 125
 126 1;
 127
 128 __END__
 129
 130 =pod
 131
 132 =head1 NAME
 133
 134 Moose::Meta::TypeConstraint::Union - A union of Moose type constraints
 135
 136 =head1 DESCRIPTION
 137
 138 This metaclass represents a union of Moose type constraints. More
 139 details to be explained later (possibly in a Cookbook recipe).
 140
 141 This actually used to be part of Moose::Meta::TypeConstraint, but it
 142 is now better off in it's own file.
 143
 144 =head1 METHODS
 145
 146 This class is not a subclass of Moose::Meta::TypeConstraint,
 147 but it does provide the same API
 148
 149 =over 4
 150
 151 =item B<meta>
 152
 153 =item B<new>
 154
 155 =item B<name>
 156
 157 =item B<type_constraints>
 158
 159 =item B<parents>
 160
 161 =item B<constraint>
 162
 163 =item B<includes_type>
 164
 165 =item B<equals>
 166
 167 =back
 168
 169 =head2 Overriden methods
 170
 171 =over 4
 172
 173 =item B<check>
 174
 175 =item B<coerce>
 176
 177 =item B<validate>
 178
 179 =item B<is_a_type_of>
 180
 181 =item B<is_subtype_of>
 182
 183 =back
 184
 185 =head2 Empty or Stub methods
 186
 187 These methods tend to not be very relevant in
 188 the context of a union. Either that or they are
 189 just difficult to specify and not very useful
 190 anyway. They are here for completeness.
 191
 192 =over 4
 193
 194 =item B<parent>
 195
 196 =item B<coercion>
 197
 198 =item B<has_coercion>
 199
 200 =item B<message>
 201
 202 =item B<has_message>
 203
 204 =item B<hand_optimized_type_constraint>
 205
 206 =item B<has_hand_optimized_type_constraint>
 207
 208 =item B<create_child_type>
 209
 210 =back
 211
 212 =head1 BUGS
 213
 214 All complex software has bugs lurking in it, and this module is no
 215 exception. If you find a bug please either email me, or add the bug
 216 to cpan-RT.
 217
 218 =head1 AUTHOR
 219
 220 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 221
 222 =head1 COPYRIGHT AND LICENSE
 223
 224 Copyright 2006-2008 by Infinity Interactive, Inc.
 225
 226 L<http://www.iinteractive.com>
 227
 228 This library is free software; you can redistribute it and/or modify
 229 it under the same terms as Perl itself.
 230
 231 =cut