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 our $VERSION   = '0.06';
   9 our $AUTHORITY = 'cpan:STEVAN';
  10
  11 # NOTE:
  12 # this is not really correct, but
  13 # I think it shoul be here anyway.
  14 # In truth, this should implement
  15 # the same abstract base/interface
  16 # as the TC moule.
  17 # - SL
  18 use base 'Moose::Meta::TypeConstraint';
  19
  20 __PACKAGE__->meta->add_attribute('type_constraints' => (
  21     accessor  => 'type_constraints',
  22     default   => sub { [] }
  23 ));
  24
  25 sub new {
  26     my $class = shift;
  27     my $self  = $class->meta->new_object(@_);
  28     return $self;
  29 }
  30
  31 sub name { join ' | ' => map { $_->name } @{$_[0]->type_constraints} }
  32
  33 # NOTE:
  34 # this should probably never be used
  35 # but we include it here for completeness
  36 sub constraint    {
  37     my $self = shift;
  38     sub { $self->check($_[0]) };
  39 }
  40
  41 # conform to the TypeConstraint API
  42 sub parent        { undef  }
  43 sub message       { undef  }
  44 sub has_message   { 0      }
  45
  46 # FIXME:
  47 # not sure what this should actually do here
  48 sub coercion { undef  }
  49
  50 # this should probably be memoized
  51 sub has_coercion  {
  52     my $self  = shift;
  53     foreach my $type (@{$self->type_constraints}) {
  54         return 1 if $type->has_coercion
  55     }
  56     return 0;
  57 }
  58
  59 # NOTE:
  60 # this feels too simple, and may not always DWIM
  61 # correctly, especially in the presence of
  62 # close subtype relationships, however it should
  63 # work for a fair percentage of the use cases
  64 sub coerce {
  65     my $self  = shift;
  66     my $value = shift;
  67     foreach my $type (@{$self->type_constraints}) {
  68         if ($type->has_coercion) {
  69             my $temp = $type->coerce($value);
  70             return $temp if $self->check($temp);
  71         }
  72     }
  73     return undef;
  74 }
  75
  76 sub _compiled_type_constraint {
  77     my $self  = shift;
  78     return sub {
  79         my $value = shift;
  80         foreach my $type (@{$self->type_constraints}) {
  81             return 1 if $type->check($value);
  82         }
  83         return undef;
  84     }
  85 }
  86
  87 sub check {
  88     my $self  = shift;
  89     my $value = shift;
  90     $self->_compiled_type_constraint->($value);
  91 }
  92
  93 sub validate {
  94     my $self  = shift;
  95     my $value = shift;
  96     my $message;
  97     foreach my $type (@{$self->type_constraints}) {
  98         my $err = $type->validate($value);
  99         return unless defined $err;
 100         $message .= ($message ? ' and ' : '') . $err
 101             if defined $err;
 102     }
 103     return ($message . ' in (' . $self->name . ')') ;
 104 }
 105
 106 sub is_a_type_of {
 107     my ($self, $type_name) = @_;
 108     foreach my $type (@{$self->type_constraints}) {
 109         return 1 if $type->is_a_type_of($type_name);
 110     }
 111     return 0;
 112 }
 113
 114 sub is_subtype_of {
 115     my ($self, $type_name) = @_;
 116     foreach my $type (@{$self->type_constraints}) {
 117         return 1 if $type->is_subtype_of($type_name);
 118     }
 119     return 0;
 120 }
 121
 122 ## hand optimized constraints
 123
 124 # NOTE:
 125 # it will just use all the hand optimized
 126 # type constraints from it's list of type
 127 # constraints automatically, but there is
 128 # no simple way to optimize it even more
 129 # (without B::Deparse or something). So
 130 # we just stop here.
 131 # - SL
 132
 133 sub has_hand_optimized_type_constraint { 0 }
 134 sub hand_optimized_type_constraint     { undef }
 135
 136 1;
 137
 138 __END__
 139
 140 =pod
 141
 142 =head1 NAME
 143
 144 Moose::Meta::TypeConstraint::Union - A union of Moose type constraints
 145
 146 =head1 DESCRIPTION
 147
 148 This metaclass represents a union of Moose type constraints. More
 149 details to be explained later (possibly in a Cookbook::Recipe).
 150
 151 This actually used to be part of Moose::Meta::TypeConstraint, but it
 152 is now better off in it's own file.
 153
 154 =head1 METHODS
 155
 156 This class is not a subclass of Moose::Meta::TypeConstraint,
 157 but it does provide the same API
 158
 159 =over 4
 160
 161 =item B<meta>
 162
 163 =item B<new>
 164
 165 =item B<name>
 166
 167 =item B<type_constraints>
 168
 169 =item B<constraint>
 170
 171 =back
 172
 173 =head2 Overriden methods
 174
 175 =over 4
 176
 177 =item B<check>
 178
 179 =item B<coerce>
 180
 181 =item B<validate>
 182
 183 =item B<is_a_type_of>
 184
 185 =item B<is_subtype_of>
 186
 187 =back
 188
 189 =head2 Empty or Stub methods
 190
 191 These methods tend to not be very relevant in
 192 the context of a union. Either that or they are
 193 just difficult to specify and not very useful
 194 anyway. They are here for completeness.
 195
 196 =over 4
 197
 198 =item B<parent>
 199
 200 =item B<coercion>
 201
 202 =item B<has_coercion>
 203
 204 =item B<message>
 205
 206 =item B<has_message>
 207
 208 =item B<hand_optimized_type_constraint>
 209
 210 =item B<has_hand_optimized_type_constraint>
 211
 212 =back
 213
 214 =head1 BUGS
 215
 216 All complex software has bugs lurking in it, and this module is no
 217 exception. If you find a bug please either email me, or add the bug
 218 to cpan-RT.
 219
 220 =head1 AUTHOR
 221
 222 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 223
 224 =head1 COPYRIGHT AND LICENSE
 225
 226 Copyright 2006, 2007 by Infinity Interactive, Inc.
 227
 228 L<http://www.iinteractive.com>
 229
 230 This library is free software; you can redistribute it and/or modify
 231 it under the same terms as Perl itself.
 232
 233 =cut