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