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