trim excess whitespace
[gitmo/Moose.git] / lib / Moose / Meta / TypeConstraint / Intersection.pm
CommitLineData
8aab053a 1
2package Moose::Meta::TypeConstraint::Intersection;
3
4use strict;
5use warnings;
6use metaclass;
7
8use Moose::Meta::TypeCoercion::Intersection;
9
10our $VERSION = '0.70';
11$VERSION = eval $VERSION;
12our $AUTHORITY = 'cpan:STEVAN';
13
14use base 'Moose::Meta::TypeConstraint';
15
16__PACKAGE__->meta->add_attribute('type_constraints' => (
17 accessor => 'type_constraints',
18 default => sub { [] }
19));
20
d32a2302 21sub new {
8aab053a 22 my ($class, %options) = @_;
23 my $self = $class->SUPER::new(
24 name => (join '&' => sort {$a cmp $b}
25 map { $_->name } @{$options{type_constraints}}),
26 parent => undef,
27 message => undef,
28 hand_optimized_type_constraint => undef,
29 compiled_type_constraint => sub {
30 my $value = shift;
31 my $count = 0;
32 foreach my $type (@{$options{type_constraints}}) {
33 $count++ if $type->check($value);
34 }
35 return $count == scalar @{$options{type_constraints}} ? 1 : undef;
36 },
37 %options
38 );
39 $self->_set_constraint(sub { $self->check($_[0]) });
40 $self->coercion(Moose::Meta::TypeCoercion::Intersection->new(
41 type_constraint => $self
42 ));
43 return $self;
44}
45
46sub equals {
47 my ( $self, $type_or_name ) = @_;
48
49 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
50
51 return unless $other->isa(__PACKAGE__);
52
53 my @self_constraints = @{ $self->type_constraints };
54 my @other_constraints = @{ $other->type_constraints };
55
56 return unless @self_constraints == @other_constraints;
57
58 # FIXME presort type constraints for efficiency?
59 constraint: foreach my $constraint ( @self_constraints ) {
60 for ( my $i = 0; $i < @other_constraints; $i++ ) {
61 if ( $constraint->equals($other_constraints[$i]) ) {
62 splice @other_constraints, $i, 1;
63 next constraint;
64 }
65 }
66 }
67
68 return @other_constraints == 0;
69}
70
71sub parents {
72 my $self = shift;
73 $self->type_constraints;
74}
75
76sub validate {
77 my ($self, $value) = @_;
78 my $message;
79 foreach my $type (@{$self->type_constraints}) {
80 my $err = $type->validate($value);
81 return unless defined $err;
82 $message .= ($message ? ' and ' : '') . $err
83 if defined $err;
84 }
d32a2302 85 return ($message . ' in (' . $self->name . ')') ;
8aab053a 86}
87
88sub is_a_type_of {
89 my ($self, $type_name) = @_;
90 foreach my $type (@{$self->type_constraints}) {
91 return 1 if $type->is_a_type_of($type_name);
92 }
d32a2302 93 return 0;
8aab053a 94}
95
96sub is_subtype_of {
97 my ($self, $type_name) = @_;
98 foreach my $type (@{$self->type_constraints}) {
99 return 1 if $type->is_subtype_of($type_name);
100 }
101 return 0;
102}
103
104sub create_child_type {
105 my ( $self, %opts ) = @_;
106
107 my $constraint
108 = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
109
110 # if we have a type constraint intersection, and no
111 # type check, this means we are just aliasing
112 # the intersection constraint, which means we need to
113 # handle this differently.
114 # - SL
115 if ( not( defined $opts{constraint} )
116 && $self->has_coercion ) {
117 $constraint->coercion(
118 Moose::Meta::TypeCoercion::Intersection->new(
119 type_constraint => $self,
120 )
121 );
122 }
123
124 return $constraint;
125}
126
1271;
128
129__END__
130
131=pod
132
133=head1 NAME
134
135Moose::Meta::TypeConstraint::Intersection - An intersection of Moose type constraints
136
137=head1 DESCRIPTION
138
d32a2302 139This metaclass represents an intersection of Moose type constraints. More
8aab053a 140details to be explained later (possibly in a Cookbook recipe).
141
d32a2302 142This actually used to be part of Moose::Meta::TypeConstraint, but it
143is now better off in it's own file.
8aab053a 144
145=head1 METHODS
146
d32a2302 147This class is not a subclass of Moose::Meta::TypeConstraint,
8aab053a 148but 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<parents>
161
162=item B<constraint>
163
164=item B<includes_type>
165
166=item B<equals>
167
168=back
169
d32a2302 170=head2 Overridden methods
8aab053a 171
172=over 4
173
174=item B<check>
175
176=item B<coerce>
177
178=item B<validate>
179
180=item B<is_a_type_of>
181
182=item B<is_subtype_of>
183
184=back
185
186=head2 Empty or Stub methods
187
d32a2302 188These methods tend to not be very relevant in
189the context of an intersection. Either that or they are
190just difficult to specify and not very useful
8aab053a 191anyway. They are here for completeness.
192
193=over 4
194
195=item B<parent>
196
197=item B<coercion>
198
199=item B<has_coercion>
200
201=item B<message>
202
203=item B<has_message>
204
205=item B<hand_optimized_type_constraint>
206
207=item B<has_hand_optimized_type_constraint>
208
209=item B<create_child_type>
210
211=back
212
213=head1 BUGS
214
d32a2302 215All complex software has bugs lurking in it, and this module is no
8aab053a 216exception. If you find a bug please either email me, or add the bug
217to cpan-RT.
218
219=head1 AUTHOR
220
221Stevan Little E<lt>stevan@iinteractive.comE<gt> and
222Adam Foxson E<lt>afoxson@pobox.comE<gt>
223
224=head1 COPYRIGHT AND LICENSE
225
226Copyright 2006-2009 by Infinity Interactive, Inc.
227
228L<http://www.iinteractive.com>
229
230This library is free software; you can redistribute it and/or modify
231it under the same terms as Perl itself.
232
233=cut