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