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', |
32 | predicate=>'has_dependent_type_constraint', |
33 | ); |
34 | |
35 | =head2 constraining_type_constraint |
36 | |
37 | This is a type constraint which defines what kind of value is allowed to be the |
38 | constraining value of the depending type. |
39 | |
40 | =cut |
41 | |
42 | has 'constraining_type_constraint' => ( |
43 | is=>'ro', |
44 | predicate=>'has_constraining_type_constraint', |
45 | ); |
46 | |
47 | =head2 comparision_callback |
48 | |
49 | This is a callback which returns a boolean value. It get's passed the value |
50 | L</constraining_type_constraint> validates as well as the check value. |
51 | |
52 | This callback is executed in addition to anything you put into a 'where' clause. |
53 | However, the 'where' clause only get's the check value. |
54 | |
55 | Exercise some sanity, this should be limited to actual comparision operations, |
56 | not as a sneaky way to mess with the constraining value. |
57 | |
58 | =cut |
59 | |
60 | has 'comparision_callback' => ( |
61 | is=>'ro', |
62 | isa=>'CodeRef', |
63 | predicate=>'has_comparision_callback', |
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 | |
71 | =cut |
72 | |
73 | has 'constraint_generator' => ( |
74 | is=>'ro', |
75 | isa=>'CodeRef', |
76 | predicate=>'has_constraint_generator', |
77 | ); |
78 | |
79 | =head1 METHODS |
80 | |
81 | This class defines the following methods. |
82 | |
83 | =head2 new |
84 | |
85 | Initialization stuff. |
86 | |
87 | =cut |
88 | |
89 | around 'new' => sub { |
90 | my ($new, $class, @args) = @_; |
91 | my $self = $class->$new(@args); |
92 | $self->coercion(MooseX::Meta::TypeCoercion::Structured->new( |
93 | type_constraint => $self, |
94 | )); |
95 | return $self; |
96 | }; |
97 | |
98 | =head2 generate_constraint_for ($type_constraints) |
99 | |
100 | Given some type constraints, use them to generate validation rules for an ref |
101 | of values (to be passed at check time) |
102 | |
103 | =cut |
104 | |
105 | sub generate_constraint_for { |
106 | my ($self, $dependent, $callback, $constraining) = @_; |
107 | return sub { |
108 | my (@args) = @_; |
109 | my $constraint_generator = $self->constraint_generator; |
110 | return $constraint_generator->($dependent, $callback, $constraining, @args); |
111 | }; |
112 | } |
113 | |
114 | =head2 parameterize (@type_constraints) |
115 | |
116 | Given a ref of type constraints, create a structured type. |
117 | |
118 | =cut |
119 | |
120 | sub parameterize { |
121 | |
122 | my ($self, $dependent, $callback, $constraining) = @_; |
123 | my $class = ref $self; |
124 | my $name = $self->_generate_subtype_name($dependent, $constraining); |
125 | my $constraint_generator = $self->__infer_constraint_generator; |
126 | |
127 | return $class->new( |
128 | name => $name, |
129 | parent => $self, |
130 | dependent_type_constraint=>$dependent, |
131 | comparision_callback=>$callback, |
132 | constraint_generator => $constraint_generator, |
133 | ); |
134 | } |
135 | |
136 | =head2 _generate_subtype_name |
137 | |
138 | Returns a name for the dependent type that should be unique |
139 | |
140 | =cut |
141 | |
142 | sub _generate_subtype_name { |
143 | my ($self, $dependent, $constraining) = @_; |
144 | return sprintf( |
145 | "%s_depends_on_%s", |
146 | $dependent, $constraining |
147 | ); |
148 | } |
149 | |
150 | =head2 __infer_constraint_generator |
151 | |
152 | This returns a CODEREF which generates a suitable constraint generator. Not |
153 | user servicable, you'll never call this directly. |
154 | |
155 | TBD, this is definitely going to need some work. |
156 | |
157 | =cut |
158 | |
159 | sub __infer_constraint_generator { |
160 | my ($self) = @_; |
161 | if($self->has_constraint_generator) { |
162 | return $self->constraint_generator; |
163 | } else { |
164 | return sub { |
165 | ## I'm not sure about this stuff but everything seems to work |
166 | my $tc = shift @_; |
167 | my $merged_tc = [ |
168 | @$tc, |
169 | $self->dependent_type_constraint, |
170 | $self->comparision_callback, |
171 | $self->constraining_type_constraint, |
172 | ]; |
173 | |
174 | $self->constraint->($merged_tc, @_); |
175 | }; |
176 | } |
177 | } |
178 | |
179 | =head2 compile_type_constraint |
180 | |
181 | hook into compile_type_constraint so we can set the correct validation rules. |
182 | |
183 | =cut |
184 | |
185 | around 'compile_type_constraint' => sub { |
186 | my ($compile_type_constraint, $self, @args) = @_; |
187 | |
188 | if($self->has_type_constraints) { |
189 | my $type_constraints = $self->type_constraints; |
190 | my $constraint = $self->generate_constraint_for($type_constraints); |
191 | $self->_set_constraint($constraint); |
192 | } |
193 | |
194 | return $self->$compile_type_constraint(@args); |
195 | }; |
196 | |
197 | =head2 create_child_type |
198 | |
199 | modifier to make sure we get the constraint_generator |
200 | |
201 | =cut |
202 | |
203 | around 'create_child_type' => sub { |
204 | my ($create_child_type, $self, %opts) = @_; |
205 | return $self->$create_child_type( |
206 | %opts, |
207 | constraint_generator => $self->__infer_constraint_generator, |
208 | ); |
209 | }; |
210 | |
211 | =head2 is_a_type_of |
212 | |
213 | =head2 is_subtype_of |
214 | |
215 | =head2 equals |
216 | |
217 | Override the base class behavior. |
218 | |
219 | TBD |
220 | |
221 | sub equals { |
222 | my ( $self, $type_or_name ) = @_; |
223 | my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); |
224 | |
225 | return unless $other->isa(__PACKAGE__); |
226 | |
227 | return ( |
228 | $self->type_constraints_equals($other) |
229 | and |
230 | $self->parent->equals( $other->parent ) |
231 | ); |
232 | } |
233 | |
234 | =head2 type_constraints_equals |
235 | |
236 | Checks to see if the internal type contraints are equal. |
237 | |
238 | TBD |
239 | |
240 | sub type_constraints_equals { |
241 | my ($self, $other) = @_; |
242 | my @self_type_constraints = @{$self->type_constraints||[]}; |
243 | my @other_type_constraints = @{$other->type_constraints||[]}; |
244 | |
245 | ## Incoming ay be either arrayref or hashref, need top compare both |
246 | while(@self_type_constraints) { |
247 | my $self_type_constraint = shift @self_type_constraints; |
248 | my $other_type_constraint = shift @other_type_constraints |
249 | || return; ## $other needs the same number of children. |
250 | |
251 | if( ref $self_type_constraint) { |
252 | $self_type_constraint->equals($other_type_constraint) |
253 | || return; ## type constraints obviously need top be equal |
254 | } else { |
255 | $self_type_constraint eq $other_type_constraint |
256 | || return; ## strings should be equal |
257 | } |
258 | |
259 | } |
260 | |
261 | return 1; ##If we get this far, everything is good. |
262 | } |
263 | |
264 | =head2 get_message |
265 | |
266 | Give you a better peek into what's causing the error. For now we stringify the |
267 | incoming deep value with L<Devel::PartialDump> and pass that on to either your |
268 | custom error message or the default one. In the future we'll try to provide a |
269 | more complete stack trace of the actual offending elements |
270 | |
271 | TBD |
272 | |
273 | around 'get_message' => sub { |
274 | my ($get_message, $self, $value) = @_; |
275 | my $new_value = Devel::PartialDump::dump($value); |
276 | return $self->$get_message($new_value); |
277 | }; |
278 | |
279 | =head1 SEE ALSO |
280 | |
281 | The following modules or resources may be of interest. |
282 | |
283 | L<Moose>, L<Moose::Meta::TypeConstraint> |
284 | |
285 | =head1 AUTHOR |
286 | |
287 | John Napiorkowski, C<< <jjnapiork@cpan.org> >> |
288 | |
289 | =head1 COPYRIGHT & LICENSE |
290 | |
291 | This program is free software; you can redistribute it and/or modify |
292 | it under the same terms as Perl itself. |
293 | |
294 | =cut |
295 | |
296 | __PACKAGE__->meta->make_immutable; |