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