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