Commit | Line | Data |
3cfd35fd |
1 | package ## Hide from PAUSE |
2 | MooseX::Meta::TypeConstraint::Dependent; |
3 | |
4 | use Moose; |
5 | use Moose::Util::TypeConstraints (); |
6 | use MooseX::Meta::TypeCoercion::Dependent; |
7 | extends 'Moose::Meta::TypeConstraint'; |
8 | |
9 | =head1 NAME |
10 | |
11 | MooseX::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints. |
12 | |
13 | =head1 DESCRIPTION |
14 | |
15 | see L<MooseX::Types::Dependent> for examples and details of how to use dependent |
16 | types. This class is a subclass of L<Moose::Meta::TypeConstraint> which |
17 | provides the gut functionality to enable dependent type constraints. |
18 | |
19 | =head1 ATTRIBUTES |
20 | |
21 | This class defines the following attributes. |
22 | |
23 | =head2 dependent_type_constraint |
24 | |
25 | The type constraint whose validity is being made dependent on a value that is a |
26 | L</constraining_type_constraint> |
27 | |
28 | =cut |
29 | |
30 | has 'dependent_type_constraint' => ( |
31 | is=>'ro', |
3a5dab74 |
32 | isa=>'Object', |
3cfd35fd |
33 | predicate=>'has_dependent_type_constraint', |
3a5dab74 |
34 | handles=>{ |
41cf7457 |
35 | check_dependent=>'check', |
36 | get_message_dependent=>'get_message', |
3a5dab74 |
37 | }, |
3cfd35fd |
38 | ); |
39 | |
40 | =head2 constraining_type_constraint |
41 | |
42 | This is a type constraint which defines what kind of value is allowed to be the |
43 | constraining value of the depending type. |
44 | |
45 | =cut |
46 | |
47 | has 'constraining_type_constraint' => ( |
48 | is=>'ro', |
3a5dab74 |
49 | isa=>'Object', |
3cfd35fd |
50 | predicate=>'has_constraining_type_constraint', |
3a5dab74 |
51 | handles=>{ |
52 | check_constraining=>'check', |
53 | }, |
3cfd35fd |
54 | ); |
55 | |
3a5dab74 |
56 | =head2 comparison_callback |
3cfd35fd |
57 | |
58 | This is a callback which returns a boolean value. It get's passed the value |
59 | L</constraining_type_constraint> validates as well as the check value. |
60 | |
61 | This callback is executed in addition to anything you put into a 'where' clause. |
62 | However, the 'where' clause only get's the check value. |
63 | |
64 | Exercise some sanity, this should be limited to actual comparision operations, |
65 | not as a sneaky way to mess with the constraining value. |
66 | |
01a12424 |
67 | This should return a Bool, suitable for ->check (That is true for valid, false |
68 | for fail). |
69 | |
3cfd35fd |
70 | =cut |
71 | |
3a5dab74 |
72 | has 'comparison_callback' => ( |
3cfd35fd |
73 | is=>'ro', |
74 | isa=>'CodeRef', |
3a5dab74 |
75 | predicate=>'has_comparison_callback', |
3cfd35fd |
76 | ); |
77 | |
78 | =head2 constraint_generator |
79 | |
80 | A subref or closure that contains the way we validate incoming values against |
81 | a set of type constraints. |
82 | |
83 | =cut |
84 | |
85 | has 'constraint_generator' => ( |
86 | is=>'ro', |
87 | isa=>'CodeRef', |
88 | predicate=>'has_constraint_generator', |
3a5dab74 |
89 | required=>1, |
3cfd35fd |
90 | ); |
91 | |
92 | =head1 METHODS |
93 | |
94 | This class defines the following methods. |
95 | |
96 | =head2 new |
97 | |
98 | Initialization stuff. |
99 | |
100 | =cut |
101 | |
102 | around 'new' => sub { |
103 | my ($new, $class, @args) = @_; |
104 | my $self = $class->$new(@args); |
3a5dab74 |
105 | $self->coercion(MooseX::Meta::TypeCoercion::Dependent->new( |
3cfd35fd |
106 | type_constraint => $self, |
107 | )); |
108 | return $self; |
109 | }; |
110 | |
41cf7457 |
111 | =head2 validate |
112 | |
113 | We intercept validate in order to custom process the message |
114 | |
115 | |
116 | =cut |
117 | |
118 | around 'check' => sub { |
119 | my ($check, $self, @args) = @_; |
120 | my ($result, $message) = $self->_compiled_type_constraint->(@args); |
121 | warn $result; |
122 | return $result; |
123 | }; |
124 | |
125 | around 'validate' => sub { |
126 | my ($validate, $self, @args) = @_; |
127 | my ($result, $message) = $self->_compiled_type_constraint->(@args); |
128 | |
129 | if($result) { |
130 | return $result; |
131 | } else { |
132 | if(defined $message) { |
133 | return "Inner: $message"; |
134 | } else { warn '......................'; |
135 | return $self->get_message(@args); |
136 | } |
137 | } |
138 | }; |
139 | |
3cfd35fd |
140 | =head2 generate_constraint_for ($type_constraints) |
141 | |
142 | Given some type constraints, use them to generate validation rules for an ref |
143 | of values (to be passed at check time) |
144 | |
145 | =cut |
146 | |
147 | sub generate_constraint_for { |
9b6d2e22 |
148 | my ($self, $callback) = @_; |
3a5dab74 |
149 | return sub { |
41cf7457 |
150 | my $dependent_pair = shift @_; |
9b6d2e22 |
151 | my ($dependent, $constraining) = @$dependent_pair; |
3313d2a6 |
152 | |
153 | ## First need to test the bits |
9b6d2e22 |
154 | unless($self->check_dependent($dependent)) { |
41cf7457 |
155 | return (undef, 'bbbbbb'); |
3313d2a6 |
156 | } |
157 | |
9b6d2e22 |
158 | unless($self->check_constraining($constraining)) { |
3313d2a6 |
159 | return; |
160 | } |
161 | |
3cfd35fd |
162 | my $constraint_generator = $self->constraint_generator; |
3a5dab74 |
163 | return $constraint_generator->( |
9b6d2e22 |
164 | $dependent, |
3a5dab74 |
165 | $callback, |
9b6d2e22 |
166 | $constraining, |
3a5dab74 |
167 | ); |
3cfd35fd |
168 | }; |
169 | } |
170 | |
3a5dab74 |
171 | =head2 parameterize ($dependent, $callback, $constraining) |
3cfd35fd |
172 | |
173 | Given a ref of type constraints, create a structured type. |
174 | |
175 | =cut |
176 | |
177 | sub parameterize { |
9b6d2e22 |
178 | my ($self, $dependent_tc, $callback, $constraining_tc) = @_; |
3cfd35fd |
179 | my $class = ref $self; |
9b6d2e22 |
180 | my $name = $self->_generate_subtype_name($dependent_tc, $callback, $constraining_tc); |
3cfd35fd |
181 | my $constraint_generator = $self->__infer_constraint_generator; |
182 | |
183 | return $class->new( |
184 | name => $name, |
185 | parent => $self, |
9b6d2e22 |
186 | dependent_type_constraint=>$dependent_tc, |
3a5dab74 |
187 | comparison_callback=>$callback, |
3cfd35fd |
188 | constraint_generator => $constraint_generator, |
9b6d2e22 |
189 | constraining_type_constraint => $constraining_tc, |
3cfd35fd |
190 | ); |
191 | } |
192 | |
193 | =head2 _generate_subtype_name |
194 | |
195 | Returns a name for the dependent type that should be unique |
196 | |
197 | =cut |
198 | |
199 | sub _generate_subtype_name { |
9b6d2e22 |
200 | my ($self, $dependent_tc, $callback, $constraining_tc) = @_; |
3cfd35fd |
201 | return sprintf( |
3a5dab74 |
202 | "%s_depends_on_%s_via_%s", |
9b6d2e22 |
203 | $dependent_tc, $constraining_tc, $callback, |
3cfd35fd |
204 | ); |
205 | } |
206 | |
207 | =head2 __infer_constraint_generator |
208 | |
209 | This returns a CODEREF which generates a suitable constraint generator. Not |
210 | user servicable, you'll never call this directly. |
211 | |
212 | TBD, this is definitely going to need some work. |
213 | |
214 | =cut |
215 | |
216 | sub __infer_constraint_generator { |
217 | my ($self) = @_; |
218 | if($self->has_constraint_generator) { |
219 | return $self->constraint_generator; |
220 | } else { |
9b6d2e22 |
221 | warn "I'm doing the questioning infer generator thing"; |
3cfd35fd |
222 | return sub { |
223 | ## I'm not sure about this stuff but everything seems to work |
224 | my $tc = shift @_; |
225 | my $merged_tc = [ |
226 | @$tc, |
3a5dab74 |
227 | $self->comparison_callback, |
3cfd35fd |
228 | $self->constraining_type_constraint, |
229 | ]; |
230 | |
231 | $self->constraint->($merged_tc, @_); |
232 | }; |
233 | } |
234 | } |
235 | |
236 | =head2 compile_type_constraint |
237 | |
238 | hook into compile_type_constraint so we can set the correct validation rules. |
239 | |
240 | =cut |
241 | |
242 | around 'compile_type_constraint' => sub { |
3a5dab74 |
243 | my ($compile_type_constraint, $self) = @_; |
3cfd35fd |
244 | |
3a5dab74 |
245 | if($self->has_comparison_callback && |
246 | $self->has_constraining_type_constraint) { |
247 | my $generated_constraint = $self->generate_constraint_for( |
248 | $self->comparison_callback, |
3a5dab74 |
249 | ); |
250 | $self->_set_constraint($generated_constraint); |
3cfd35fd |
251 | } |
252 | |
3a5dab74 |
253 | return $self->$compile_type_constraint; |
3cfd35fd |
254 | }; |
255 | |
256 | =head2 create_child_type |
257 | |
258 | modifier to make sure we get the constraint_generator |
259 | |
9b6d2e22 |
260 | =cut |
261 | |
3cfd35fd |
262 | around 'create_child_type' => sub { |
263 | my ($create_child_type, $self, %opts) = @_; |
264 | return $self->$create_child_type( |
265 | %opts, |
266 | constraint_generator => $self->__infer_constraint_generator, |
267 | ); |
268 | }; |
269 | |
270 | =head2 is_a_type_of |
271 | |
272 | =head2 is_subtype_of |
273 | |
274 | =head2 equals |
275 | |
276 | Override the base class behavior. |
277 | |
278 | TBD |
279 | |
280 | sub equals { |
281 | my ( $self, $type_or_name ) = @_; |
282 | my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); |
283 | |
284 | return unless $other->isa(__PACKAGE__); |
285 | |
286 | return ( |
287 | $self->type_constraints_equals($other) |
288 | and |
289 | $self->parent->equals( $other->parent ) |
290 | ); |
291 | } |
292 | |
293 | =head2 type_constraints_equals |
294 | |
295 | Checks to see if the internal type contraints are equal. |
296 | |
297 | TBD |
298 | |
299 | sub type_constraints_equals { |
300 | my ($self, $other) = @_; |
301 | my @self_type_constraints = @{$self->type_constraints||[]}; |
302 | my @other_type_constraints = @{$other->type_constraints||[]}; |
303 | |
304 | ## Incoming ay be either arrayref or hashref, need top compare both |
305 | while(@self_type_constraints) { |
306 | my $self_type_constraint = shift @self_type_constraints; |
307 | my $other_type_constraint = shift @other_type_constraints |
308 | || return; ## $other needs the same number of children. |
309 | |
310 | if( ref $self_type_constraint) { |
311 | $self_type_constraint->equals($other_type_constraint) |
312 | || return; ## type constraints obviously need top be equal |
313 | } else { |
314 | $self_type_constraint eq $other_type_constraint |
315 | || return; ## strings should be equal |
316 | } |
317 | |
318 | } |
319 | |
320 | return 1; ##If we get this far, everything is good. |
321 | } |
322 | |
323 | =head2 get_message |
324 | |
325 | Give you a better peek into what's causing the error. For now we stringify the |
326 | incoming deep value with L<Devel::PartialDump> and pass that on to either your |
327 | custom error message or the default one. In the future we'll try to provide a |
328 | more complete stack trace of the actual offending elements |
329 | |
330 | TBD |
331 | |
332 | around 'get_message' => sub { |
333 | my ($get_message, $self, $value) = @_; |
334 | my $new_value = Devel::PartialDump::dump($value); |
335 | return $self->$get_message($new_value); |
336 | }; |
337 | |
338 | =head1 SEE ALSO |
339 | |
340 | The following modules or resources may be of interest. |
341 | |
342 | L<Moose>, L<Moose::Meta::TypeConstraint> |
343 | |
344 | =head1 AUTHOR |
345 | |
346 | John Napiorkowski, C<< <jjnapiork@cpan.org> >> |
347 | |
348 | =head1 COPYRIGHT & LICENSE |
349 | |
350 | This program is free software; you can redistribute it and/or modify |
351 | it under the same terms as Perl itself. |
352 | |
353 | =cut |
354 | |
3a5dab74 |
355 | __PACKAGE__->meta->make_immutable; |