Commit | Line | Data |
3cfd35fd |
1 | package ## Hide from PAUSE |
a588ee00 |
2 | MooseX::Dependent::Meta::TypeConstraint::Dependent; |
3cfd35fd |
3 | |
4 | use Moose; |
5 | use Moose::Util::TypeConstraints (); |
0a9f5b94 |
6 | use Scalar::Util qw(blessed); |
7 | |
3cfd35fd |
8 | extends 'Moose::Meta::TypeConstraint'; |
9 | |
10 | =head1 NAME |
11 | |
a588ee00 |
12 | MooseX::Dependent::Meta::TypeConstraint::Dependent - Metaclass for Dependent type constraints. |
3cfd35fd |
13 | |
14 | =head1 DESCRIPTION |
15 | |
a588ee00 |
16 | see L<MooseX::Dependent> for examples and details of how to use dependent |
3cfd35fd |
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 | |
a588ee00 |
24 | =head2 parent_type_constraint |
3cfd35fd |
25 | |
a588ee00 |
26 | The type constraint whose validity is being made dependent. |
3cfd35fd |
27 | |
28 | =cut |
29 | |
a588ee00 |
30 | has 'parent_type_constraint' => ( |
3cfd35fd |
31 | is=>'ro', |
3a5dab74 |
32 | isa=>'Object', |
a588ee00 |
33 | default=> sub { |
34 | Moose::Util::TypeConstraints::find_type_constraint("Any"); |
3a5dab74 |
35 | }, |
a588ee00 |
36 | required=>1, |
3cfd35fd |
37 | ); |
38 | |
a588ee00 |
39 | =head2 constraining_value_type_constraint |
3cfd35fd |
40 | |
41 | This is a type constraint which defines what kind of value is allowed to be the |
a588ee00 |
42 | constraining value of the dependent type. |
3cfd35fd |
43 | |
44 | =cut |
45 | |
a588ee00 |
46 | has 'constraining_value_type_constraint' => ( |
3cfd35fd |
47 | is=>'ro', |
3a5dab74 |
48 | isa=>'Object', |
a588ee00 |
49 | default=> sub { |
50 | Moose::Util::TypeConstraints::find_type_constraint("Any"); |
3a5dab74 |
51 | }, |
a588ee00 |
52 | required=>1, |
3cfd35fd |
53 | ); |
54 | |
0a9f5b94 |
55 | =head2 constraining_value |
3cfd35fd |
56 | |
a588ee00 |
57 | This is the actual value that constraints the L</parent_type_constraint> |
01a12424 |
58 | |
3cfd35fd |
59 | =cut |
60 | |
a588ee00 |
61 | has 'constraining_value' => ( |
0a9f5b94 |
62 | is=>'ro', |
a588ee00 |
63 | predicate=>'has_constraining_value', |
3cfd35fd |
64 | ); |
65 | |
66 | =head2 constraint_generator |
67 | |
68 | A subref or closure that contains the way we validate incoming values against |
69 | a set of type constraints. |
70 | |
3cfd35fd |
71 | |
72 | has 'constraint_generator' => ( |
73 | is=>'ro', |
74 | isa=>'CodeRef', |
75 | predicate=>'has_constraint_generator', |
3a5dab74 |
76 | required=>1, |
3cfd35fd |
77 | ); |
78 | |
79 | =head1 METHODS |
80 | |
81 | This class defines the following methods. |
82 | |
41cf7457 |
83 | =head2 validate |
84 | |
0712792e |
85 | We intercept validate in order to custom process the message. |
41cf7457 |
86 | |
0712792e |
87 | override 'validate' => sub { |
88 | my ($self, @args) = @_; |
ae1d0652 |
89 | my $compiled_type_constraint = $self->_compiled_type_constraint; |
90 | my $message = bless {message=>undef}, 'MooseX::Types::Dependent::Message'; |
91 | my $result = $compiled_type_constraint->(@args, $message); |
92 | |
41cf7457 |
93 | if($result) { |
94 | return $result; |
95 | } else { |
ae1d0652 |
96 | my $args = Devel::PartialDump::dump(@args); |
97 | if(my $message = $message->{message}) { |
98 | return $self->get_message("$args, Internal Validation Error is: $message"); |
99 | } else { |
100 | return $self->get_message($args); |
41cf7457 |
101 | } |
102 | } |
103 | }; |
104 | |
3cfd35fd |
105 | =head2 generate_constraint_for ($type_constraints) |
106 | |
107 | Given some type constraints, use them to generate validation rules for an ref |
108 | of values (to be passed at check time) |
109 | |
3cfd35fd |
110 | |
111 | sub generate_constraint_for { |
9b6d2e22 |
112 | my ($self, $callback) = @_; |
3a5dab74 |
113 | return sub { |
41cf7457 |
114 | my $dependent_pair = shift @_; |
9b6d2e22 |
115 | my ($dependent, $constraining) = @$dependent_pair; |
3313d2a6 |
116 | |
117 | ## First need to test the bits |
9b6d2e22 |
118 | unless($self->check_dependent($dependent)) { |
ae1d0652 |
119 | $_[0]->{message} = $self->get_message_dependent($dependent) |
120 | if $_[0]; |
121 | return; |
3313d2a6 |
122 | } |
123 | |
9b6d2e22 |
124 | unless($self->check_constraining($constraining)) { |
ae1d0652 |
125 | $_[0]->{message} = $self->get_message_constraining($constraining) |
126 | if $_[0]; |
3313d2a6 |
127 | return; |
128 | } |
129 | |
3cfd35fd |
130 | my $constraint_generator = $self->constraint_generator; |
3a5dab74 |
131 | return $constraint_generator->( |
9b6d2e22 |
132 | $dependent, |
3a5dab74 |
133 | $callback, |
9b6d2e22 |
134 | $constraining, |
3a5dab74 |
135 | ); |
3cfd35fd |
136 | }; |
137 | } |
138 | |
0a9f5b94 |
139 | =head2 parameterize (@args) |
3cfd35fd |
140 | |
141 | Given a ref of type constraints, create a structured type. |
0a9f5b94 |
142 | |
3cfd35fd |
143 | =cut |
144 | |
145 | sub parameterize { |
0a9f5b94 |
146 | my $self = shift @_; |
3cfd35fd |
147 | my $class = ref $self; |
0a9f5b94 |
148 | |
149 | if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) { |
150 | my $arg1 = shift @_; |
151 | my $arg2 = shift @_ || $self->constraining_value_type_constraint; |
152 | |
153 | Moose->throw_error("$arg2 is not a type constraint") |
154 | unless $arg2->isa('Moose::Meta::TypeConstraint'); |
155 | |
156 | Moose->throw_error('Too Many Args! Two are allowed.') if @_; |
157 | |
158 | return $class->new( |
159 | name => $self->_generate_subtype_name($arg1, $arg2), |
160 | parent => $self, |
161 | constraint => $self->constraint, |
162 | parent_type_constraint=>$arg1, |
163 | constraining_value_type_constraint => $arg2, |
164 | ); |
165 | |
166 | } else { |
167 | Moose->throw_error("$self already has a constraining value.") if |
168 | $self->has_constraining_value; |
169 | |
170 | my $args; |
171 | ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}] |
172 | if(@_) { |
173 | if($#_) { |
174 | if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) { |
175 | $args = {@_}; |
176 | } else { |
177 | $args = [@_]; |
178 | } |
179 | } else { |
180 | $args = $_[0]; |
181 | } |
182 | |
183 | } else { |
184 | ## TODO: Is there a use case for parameterizing null or undef? |
185 | Moose->throw_error('Cannot Parameterize null values.'); |
186 | } |
187 | |
188 | if(my $err = $self->constraining_value_type_constraint->validate($args)) { |
189 | Moose->throw_error($err); |
190 | } else { |
191 | ## TODO memorize or do a registry lookup on the name as an optimization |
192 | return $class->new( |
193 | name => $self->name."[$args]", |
194 | parent => $self, |
195 | constraint => $self->constraint, |
196 | constraining_value => $args, |
197 | parent_type_constraint=>$self->parent_type_constraint, |
198 | constraining_value_type_constraint => $self->constraining_value_type_constraint, |
199 | ); |
200 | } |
201 | } |
3cfd35fd |
202 | } |
203 | |
204 | =head2 _generate_subtype_name |
205 | |
206 | Returns a name for the dependent type that should be unique |
207 | |
208 | =cut |
209 | |
210 | sub _generate_subtype_name { |
a588ee00 |
211 | my ($self, $parent_tc, $constraining_tc) = @_; |
3cfd35fd |
212 | return sprintf( |
0a9f5b94 |
213 | $self."[%s, %s]", |
a588ee00 |
214 | $parent_tc, $constraining_tc, |
3cfd35fd |
215 | ); |
216 | } |
217 | |
0a9f5b94 |
218 | =head2 create_child_type |
3cfd35fd |
219 | |
0a9f5b94 |
220 | modifier to make sure we get the constraint_generator |
3cfd35fd |
221 | |
222 | =cut |
223 | |
0a9f5b94 |
224 | around 'create_child_type' => sub { |
225 | my ($create_child_type, $self, %opts) = @_; |
226 | return $self->$create_child_type( |
227 | %opts, |
228 | parent=> $self, |
229 | parent_type_constraint=>$self->parent_type_constraint, |
230 | constraining_value_type_constraint => $self->constraining_value_type_constraint, |
231 | ); |
232 | }; |
3cfd35fd |
233 | |
0a9f5b94 |
234 | =head2 equals ($type_constraint) |
3cfd35fd |
235 | |
0a9f5b94 |
236 | Override the base class behavior so that a dependent type equal both the parent |
237 | type and the overall dependent container. This behavior may change if we can |
238 | figure out what a dependent type is (multiply inheritance or a role...) |
1e87d1a7 |
239 | |
0a9f5b94 |
240 | =cut |
3cfd35fd |
241 | |
0a9f5b94 |
242 | around 'equals' => sub { |
243 | my ( $equals, $self, $type_or_name ) = @_; |
3cfd35fd |
244 | |
0a9f5b94 |
245 | my $other = defined $type_or_name ? |
246 | Moose::Util::TypeConstraints::find_type_constraint($type_or_name) : |
247 | Moose->throw_error("Can't call $self ->equals without a parameter"); |
248 | |
249 | Moose->throw_error("$type_or_name is not a registered Type") |
250 | unless $other; |
251 | |
252 | if(my $parent = $other->parent) { |
253 | return $self->$equals($other) |
254 | || $self->parent->equals($parent); |
255 | } else { |
256 | return $self->$equals($other); |
3cfd35fd |
257 | } |
3cfd35fd |
258 | }; |
259 | |
0a9f5b94 |
260 | around 'is_subtype_of' => sub { |
261 | my ( $is_subtype_of, $self, $type_or_name ) = @_; |
3cfd35fd |
262 | |
0a9f5b94 |
263 | my $other = defined $type_or_name ? |
264 | Moose::Util::TypeConstraints::find_type_constraint($type_or_name) : |
265 | Moose->throw_error("Can't call $self ->equals without a parameter"); |
266 | |
267 | Moose->throw_error("$type_or_name is not a registered Type") |
268 | unless $other; |
269 | |
270 | return $self->$is_subtype_of($other) |
271 | || $self->parent_type_constraint->is_subtype_of($other); |
9b6d2e22 |
272 | |
3cfd35fd |
273 | }; |
274 | |
0a9f5b94 |
275 | sub is_a_type_of { |
276 | my ($self, @args) = @_; |
277 | return ($self->equals(@args) || |
278 | $self->is_subtype_of(@args)); |
279 | } |
3cfd35fd |
280 | |
0a9f5b94 |
281 | around 'check' => sub { |
282 | my ($check, $self, @args) = @_; |
283 | if($self->has_constraining_value) { |
284 | push @args, $self->constraining_value; |
285 | } |
286 | return $self->parent_type_constraint->check(@args) && $self->$check(@args) |
287 | }; |
3cfd35fd |
288 | |
0a9f5b94 |
289 | around 'validate' => sub { |
290 | my ($validate, $self, @args) = @_; |
291 | if($self->has_constraining_value) { |
292 | push @args, $self->constraining_value; |
293 | } |
294 | return $self->parent_type_constraint->validate(@args) || $self->$validate(@args); |
295 | }; |
3cfd35fd |
296 | |
3cfd35fd |
297 | =head2 get_message |
298 | |
ae1d0652 |
299 | Give you a better peek into what's causing the error. |
3cfd35fd |
300 | |
3cfd35fd |
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 | |
1e87d1a7 |
323 | __PACKAGE__->meta->make_immutable(inline_constructor => 0); |
324 | |