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