Commit | Line | Data |
3cfd35fd |
1 | package ## Hide from PAUSE |
ca01e833 |
2 | MooseX::Meta::TypeConstraint::Parameterizable; |
3cfd35fd |
3 | |
4 | use Moose; |
5 | use Moose::Util::TypeConstraints (); |
ca01e833 |
6 | use MooseX::Meta::TypeCoercion::Parameterizable; |
0a9f5b94 |
7 | use Scalar::Util qw(blessed); |
9c319add |
8 | use Data::Dump; |
9 | use Digest::MD5; |
10 | |
3cfd35fd |
11 | extends 'Moose::Meta::TypeConstraint'; |
12 | |
13 | =head1 NAME |
14 | |
9e662b6a |
15 | MooseX::Meta::TypeConstraint::Parameterizable - Parameterizable Meta Class. |
3cfd35fd |
16 | |
17 | =head1 DESCRIPTION |
18 | |
9e662b6a |
19 | See L<MooseX::Types::Parameterizable> for how to use parameterizable |
3cfd35fd |
20 | types. This class is a subclass of L<Moose::Meta::TypeConstraint> which |
88f7dcd2 |
21 | provides the gut functionality to enable parameterizable type constraints. |
3cfd35fd |
22 | |
9e662b6a |
23 | You probably won't need to subclass or consume this class directly. |
91623f94 |
24 | |
3cfd35fd |
25 | =head1 ATTRIBUTES |
26 | |
27 | This class defines the following attributes. |
28 | |
a588ee00 |
29 | =head2 parent_type_constraint |
3cfd35fd |
30 | |
88f7dcd2 |
31 | The type constraint whose validity is being made parameterizable. |
3cfd35fd |
32 | |
33 | =cut |
34 | |
a588ee00 |
35 | has 'parent_type_constraint' => ( |
3cfd35fd |
36 | is=>'ro', |
9e662b6a |
37 | isa=>Moose::Util::TypeConstraints::class_type('Moose::Meta::TypeConstraint'), |
a588ee00 |
38 | default=> sub { |
39 | Moose::Util::TypeConstraints::find_type_constraint("Any"); |
3a5dab74 |
40 | }, |
a588ee00 |
41 | required=>1, |
3cfd35fd |
42 | ); |
43 | |
6c67366e |
44 | |
a588ee00 |
45 | =head2 constraining_value_type_constraint |
3cfd35fd |
46 | |
47 | This is a type constraint which defines what kind of value is allowed to be the |
88f7dcd2 |
48 | constraining value of the parameterizable type. |
3cfd35fd |
49 | |
50 | =cut |
51 | |
a588ee00 |
52 | has 'constraining_value_type_constraint' => ( |
3cfd35fd |
53 | is=>'ro', |
9e662b6a |
54 | isa=>Moose::Util::TypeConstraints::class_type('Moose::Meta::TypeConstraint'), |
a588ee00 |
55 | default=> sub { |
56 | Moose::Util::TypeConstraints::find_type_constraint("Any"); |
3a5dab74 |
57 | }, |
a588ee00 |
58 | required=>1, |
3cfd35fd |
59 | ); |
60 | |
0a9f5b94 |
61 | =head2 constraining_value |
3cfd35fd |
62 | |
a588ee00 |
63 | This is the actual value that constraints the L</parent_type_constraint> |
01a12424 |
64 | |
3cfd35fd |
65 | =cut |
66 | |
9e662b6a |
67 | ## TODO, this is where we probably should break out Parameterized stuff from |
68 | ## parameterizable... |
69 | |
a588ee00 |
70 | has 'constraining_value' => ( |
0a9f5b94 |
71 | is=>'ro', |
a588ee00 |
72 | predicate=>'has_constraining_value', |
3cfd35fd |
73 | ); |
74 | |
3cfd35fd |
75 | =head1 METHODS |
76 | |
77 | This class defines the following methods. |
78 | |
1a6ad4bd |
79 | =head2 new |
21df4517 |
80 | |
9e662b6a |
81 | Do some post build stuff, mostly make sure we set the correct coercion object. |
21df4517 |
82 | |
83 | =cut |
1a6ad4bd |
84 | |
26cf337e |
85 | around 'new' => sub { |
86 | my ($new, $class, @args) = @_; |
87 | my $self = $class->$new(@args); |
ca01e833 |
88 | my $coercion = MooseX::Meta::TypeCoercion::Parameterizable->new(type_constraint => $self); |
26cf337e |
89 | $self->coercion($coercion); |
90 | return $self; |
91 | }; |
21df4517 |
92 | |
0a9f5b94 |
93 | =head2 parameterize (@args) |
3cfd35fd |
94 | |
6ff72600 |
95 | Given a ref of type constraints, create a parameterized constraint |
0a9f5b94 |
96 | |
3cfd35fd |
97 | =cut |
98 | |
99 | sub parameterize { |
0a9f5b94 |
100 | my $self = shift @_; |
3cfd35fd |
101 | my $class = ref $self; |
6c67366e |
102 | |
103 | Moose->throw_error("$self already has a constraining value.") if |
104 | $self->has_constraining_value; |
105 | |
0a9f5b94 |
106 | if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) { |
107 | my $arg1 = shift @_; |
0a9f5b94 |
108 | |
6c67366e |
109 | if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) { |
110 | my $arg2 = shift @_ || $self->constraining_value_type_constraint; |
111 | |
112 | ## TODO fix this crap! |
113 | Moose->throw_error("$arg2 is not a type constraint") |
114 | unless $arg2->isa('Moose::Meta::TypeConstraint'); |
115 | |
116 | Moose->throw_error("$arg1 is not a type of: ".$self->parent_type_constraint->name) |
117 | unless $arg1->is_a_type_of($self->parent_type_constraint); |
118 | |
119 | Moose->throw_error("$arg2 is not a type of: ".$self->constraining_value_type_constraint->name) |
120 | unless $arg2->is_a_type_of($self->constraining_value_type_constraint); |
121 | |
122 | Moose->throw_error('Too Many Args! Two are allowed.') if @_; |
123 | |
9c319add |
124 | my $name = $self->_generate_subtype_name($arg1, $arg2); |
125 | if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) { |
126 | return $exists; |
127 | } else { |
128 | my $type_constraint = $class->new( |
129 | name => $name, |
130 | parent => $self, |
131 | constraint => $self->constraint, |
132 | parent_type_constraint=>$arg1, |
133 | constraining_value_type_constraint => $arg2, |
134 | ); |
135 | Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint); |
136 | return $type_constraint; |
137 | } |
6c67366e |
138 | } else { |
139 | Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name) |
140 | unless $arg1->is_a_type_of($self->constraining_value_type_constraint); |
141 | |
9c319add |
142 | my $name = $self->_generate_subtype_name($self->parent_type_constraint, $arg1); |
143 | if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) { |
144 | return $exists; |
145 | } else { |
146 | my $type_constraint = $class->new( |
147 | name => $name, |
148 | parent => $self, |
149 | constraint => $self->constraint, |
150 | parent_type_constraint=>$self->parent_type_constraint, |
151 | constraining_value_type_constraint => $arg1, |
152 | ); |
153 | Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint); |
154 | return $type_constraint; |
155 | } |
6c67366e |
156 | } |
0a9f5b94 |
157 | } else { |
0a9f5b94 |
158 | my $args; |
159 | ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}] |
160 | if(@_) { |
161 | if($#_) { |
162 | if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) { |
163 | $args = {@_}; |
164 | } else { |
165 | $args = [@_]; |
166 | } |
167 | } else { |
168 | $args = $_[0]; |
169 | } |
170 | |
171 | } else { |
172 | ## TODO: Is there a use case for parameterizing null or undef? |
173 | Moose->throw_error('Cannot Parameterize null values.'); |
174 | } |
175 | |
176 | if(my $err = $self->constraining_value_type_constraint->validate($args)) { |
177 | Moose->throw_error($err); |
178 | } else { |
9c319add |
179 | |
180 | my $sig = $args; |
181 | if(ref $sig) { |
182 | $sig = Digest::MD5::md5_hex(Data::Dump::dump($args)); |
183 | } |
184 | my $name = $self->name."[$sig]"; |
185 | if(my $exists = Moose::Util::TypeConstraints::find_type_constraint($name)) { |
186 | return $exists; |
187 | } else { |
9e662b6a |
188 | return $class->new( |
9c319add |
189 | name => $name, |
190 | parent => $self, |
191 | constraint => $self->constraint, |
192 | constraining_value => $args, |
193 | parent_type_constraint=>$self->parent_type_constraint, |
194 | constraining_value_type_constraint => $self->constraining_value_type_constraint, |
cbac5987 |
195 | ($self->has_message ? (message => $self->message) : ()), |
9c319add |
196 | ); |
9c319add |
197 | } |
0a9f5b94 |
198 | } |
199 | } |
3cfd35fd |
200 | } |
201 | |
202 | =head2 _generate_subtype_name |
203 | |
88f7dcd2 |
204 | Returns a name for the parameterizable type that should be unique |
3cfd35fd |
205 | |
206 | =cut |
207 | |
208 | sub _generate_subtype_name { |
a588ee00 |
209 | my ($self, $parent_tc, $constraining_tc) = @_; |
3cfd35fd |
210 | return sprintf( |
0a9f5b94 |
211 | $self."[%s, %s]", |
a588ee00 |
212 | $parent_tc, $constraining_tc, |
3cfd35fd |
213 | ); |
214 | } |
215 | |
0a9f5b94 |
216 | =head2 create_child_type |
3cfd35fd |
217 | |
0a9f5b94 |
218 | modifier to make sure we get the constraint_generator |
3cfd35fd |
219 | |
220 | =cut |
221 | |
0a9f5b94 |
222 | around 'create_child_type' => sub { |
223 | my ($create_child_type, $self, %opts) = @_; |
66efbe23 |
224 | if($self->has_constraining_value) { |
225 | $opts{constraining_value} = $self->constraining_value; |
226 | } |
0a9f5b94 |
227 | return $self->$create_child_type( |
228 | %opts, |
229 | parent=> $self, |
230 | parent_type_constraint=>$self->parent_type_constraint, |
231 | constraining_value_type_constraint => $self->constraining_value_type_constraint, |
232 | ); |
233 | }; |
3cfd35fd |
234 | |
0a9f5b94 |
235 | =head2 equals ($type_constraint) |
3cfd35fd |
236 | |
88f7dcd2 |
237 | Override the base class behavior so that a parameterizable type equal both the parent |
238 | type and the overall parameterizable container. This behavior may change if we can |
239 | figure out what a parameterizable type is (multiply inheritance or a role...) |
1e87d1a7 |
240 | |
0a9f5b94 |
241 | =cut |
3cfd35fd |
242 | |
0a9f5b94 |
243 | around 'equals' => sub { |
244 | my ( $equals, $self, $type_or_name ) = @_; |
3cfd35fd |
245 | |
0a9f5b94 |
246 | my $other = defined $type_or_name ? |
247 | Moose::Util::TypeConstraints::find_type_constraint($type_or_name) : |
248 | Moose->throw_error("Can't call $self ->equals without a parameter"); |
249 | |
250 | Moose->throw_error("$type_or_name is not a registered Type") |
251 | unless $other; |
252 | |
253 | if(my $parent = $other->parent) { |
254 | return $self->$equals($other) |
255 | || $self->parent->equals($parent); |
256 | } else { |
257 | return $self->$equals($other); |
3cfd35fd |
258 | } |
3cfd35fd |
259 | }; |
260 | |
0af9bd45 |
261 | =head2 is_subtype_of |
262 | |
88f7dcd2 |
263 | Method modifier to make sure we match on subtype for both the parameterizable type |
264 | as well as the type being made parameterizable |
0af9bd45 |
265 | |
266 | =cut |
267 | |
0a9f5b94 |
268 | around 'is_subtype_of' => sub { |
269 | my ( $is_subtype_of, $self, $type_or_name ) = @_; |
3cfd35fd |
270 | |
0a9f5b94 |
271 | my $other = defined $type_or_name ? |
272 | Moose::Util::TypeConstraints::find_type_constraint($type_or_name) : |
273 | Moose->throw_error("Can't call $self ->equals without a parameter"); |
274 | |
275 | Moose->throw_error("$type_or_name is not a registered Type") |
276 | unless $other; |
277 | |
278 | return $self->$is_subtype_of($other) |
279 | || $self->parent_type_constraint->is_subtype_of($other); |
9b6d2e22 |
280 | |
3cfd35fd |
281 | }; |
282 | |
0af9bd45 |
283 | =head2 check |
284 | |
285 | As with 'is_subtype_of', we need to dual dispatch the method request |
286 | |
287 | =cut |
3cfd35fd |
288 | |
0a9f5b94 |
289 | around 'check' => sub { |
290 | my ($check, $self, @args) = @_; |
6c67366e |
291 | return ( |
292 | $self->parent_type_constraint->check(@args) && |
293 | $self->$check(@args) |
294 | ); |
0a9f5b94 |
295 | }; |
3cfd35fd |
296 | |
0af9bd45 |
297 | =head2 validate |
298 | |
299 | As with 'is_subtype_of', we need to dual dispatch the method request |
300 | |
301 | =cut |
302 | |
0a9f5b94 |
303 | around 'validate' => sub { |
304 | my ($validate, $self, @args) = @_; |
6c67366e |
305 | return ( |
306 | $self->parent_type_constraint->validate(@args) || |
307 | $self->$validate(@args) |
308 | ); |
0a9f5b94 |
309 | }; |
3cfd35fd |
310 | |
0af9bd45 |
311 | =head2 _compiled_type_constraint |
312 | |
313 | modify this method so that we pass along the constraining value to the constraint |
314 | coderef and also throw the correct error message if the constraining value does |
315 | not match it's requirement. |
316 | |
317 | =cut |
318 | |
66efbe23 |
319 | around '_compiled_type_constraint' => sub { |
320 | my ($method, $self, @args) = @_; |
321 | my $coderef = $self->$method(@args); |
6c67366e |
322 | my $constraining; |
323 | if($self->has_constraining_value) { |
324 | $constraining = $self->constraining_value; |
325 | } |
326 | |
66efbe23 |
327 | return sub { |
328 | my @local_args = @_; |
6c67366e |
329 | if(my $err = $self->constraining_value_type_constraint->validate($constraining)) { |
330 | Moose->throw_error($err); |
331 | } |
332 | $coderef->(@local_args, $constraining); |
66efbe23 |
333 | }; |
334 | }; |
335 | |
0af9bd45 |
336 | =head2 coerce |
337 | |
338 | More method modification to support dispatch coerce to a parent. |
339 | |
340 | =cut |
341 | |
9c319add |
342 | around 'coerce' => sub { |
343 | my ($coerce, $self, @args) = @_; |
26cf337e |
344 | if($self->has_constraining_value) { |
345 | push @args, $self->constraining_value; |
2d8c1bf6 |
346 | } |
347 | if(@{$self->coercion->type_coercion_map}) { |
348 | my $coercion = $self->coercion; |
349 | my $coerced = $coercion->coerce(@args); |
350 | if(defined $coerced) { |
351 | return $coerced; |
26cf337e |
352 | } else { |
353 | my $parent = $self->parent; |
26cf337e |
354 | return $parent->coerce(@args); |
2d8c1bf6 |
355 | } |
356 | } else { |
357 | my $parent = $self->parent; |
358 | return $parent->coerce(@args); |
359 | } |
3cfd35fd |
360 | }; |
361 | |
362 | =head1 SEE ALSO |
363 | |
364 | The following modules or resources may be of interest. |
365 | |
366 | L<Moose>, L<Moose::Meta::TypeConstraint> |
367 | |
368 | =head1 AUTHOR |
369 | |
370 | John Napiorkowski, C<< <jjnapiork@cpan.org> >> |
371 | |
372 | =head1 COPYRIGHT & LICENSE |
373 | |
374 | This program is free software; you can redistribute it and/or modify |
375 | it under the same terms as Perl itself. |
376 | |
377 | =cut |
378 | |
1a6ad4bd |
379 | __PACKAGE__->meta->make_immutable(inline_constructor => 0); |
1e87d1a7 |
380 | |