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