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 1;
  72
  73 __END__
  74
  75 =pod
  76
  77 =head1 NAME
  78
  79 Moose::Meta::TypeConstraint::Union - A union of Moose type constraints
  80
  81 =head1 DESCRIPTION
  82
  83 This metaclass represents a union of Moose type constraints. More
  84 details to be explained later (possibly in a Cookbook::Recipe).
  85
  86 This actually used to be part of Moose::Meta::TypeConstraint, but it
  87 is now better off in it's own file.
  88
  89 =head1 METHODS
  90
  91 This class is not a subclass of Moose::Meta::TypeConstraint,
  92 but it does provide the same API
  93
  94 =over 4
  95
  96 =item B<meta>
  97
  98 =item B<new>
  99
 100 =item B<name>
 101
 102 =item B<type_constraints>
 103
 104 =item B<constraint>
 105
 106 =back
 107
 108 =head2 Overriden methods
 109
 110 =over 4
 111
 112 =item B<check>
 113
 114 =item B<coerce>
 115
 116 =item B<validate>
 117
 118 =item B<is_a_type_of>
 119
 120 =item B<is_subtype_of>
 121
 122 =back
 123
 124 =head2 Empty or Stub methods
 125
 126 These methods tend to not be very relevant in
 127 the context of a union. Either that or they are
 128 just difficult to specify and not very useful
 129 anyway. They are here for completeness.
 130
 131 =over 4
 132
 133 =item B<parent>
 134
 135 =item B<coercion>
 136
 137 =item B<has_coercion>
 138
 139 =item B<message>
 140
 141 =item B<has_message>
 142
 143 =item B<hand_optimized_type_constraint>
 144
 145 =item B<has_hand_optimized_type_constraint>
 146
 147 =back
 148
 149 =head1 BUGS
 150
 151 All complex software has bugs lurking in it, and this module is no
 152 exception. If you find a bug please either email me, or add the bug
 153 to cpan-RT.
 154
 155 =head1 AUTHOR
 156
 157 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 158
 159 =head1 COPYRIGHT AND LICENSE
 160
 161 Copyright 2006, 2007 by Infinity Interactive, Inc.
 162
 163 L<http://www.iinteractive.com>
 164
 165 This library is free software; you can redistribute it and/or modify
 166 it under the same terms as Perl itself.
 167
 168 =cut