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 | |
6c67366e |
39 | |
a588ee00 |
40 | =head2 constraining_value_type_constraint |
3cfd35fd |
41 | |
42 | This is a type constraint which defines what kind of value is allowed to be the |
a588ee00 |
43 | constraining value of the dependent type. |
3cfd35fd |
44 | |
45 | =cut |
46 | |
a588ee00 |
47 | has 'constraining_value_type_constraint' => ( |
3cfd35fd |
48 | is=>'ro', |
3a5dab74 |
49 | isa=>'Object', |
a588ee00 |
50 | default=> sub { |
51 | Moose::Util::TypeConstraints::find_type_constraint("Any"); |
3a5dab74 |
52 | }, |
a588ee00 |
53 | required=>1, |
3cfd35fd |
54 | ); |
55 | |
0a9f5b94 |
56 | =head2 constraining_value |
3cfd35fd |
57 | |
a588ee00 |
58 | This is the actual value that constraints the L</parent_type_constraint> |
01a12424 |
59 | |
3cfd35fd |
60 | =cut |
61 | |
a588ee00 |
62 | has 'constraining_value' => ( |
0a9f5b94 |
63 | is=>'ro', |
a588ee00 |
64 | predicate=>'has_constraining_value', |
3cfd35fd |
65 | ); |
66 | |
3cfd35fd |
67 | =head1 METHODS |
68 | |
69 | This class defines the following methods. |
70 | |
0a9f5b94 |
71 | =head2 parameterize (@args) |
3cfd35fd |
72 | |
73 | Given a ref of type constraints, create a structured type. |
0a9f5b94 |
74 | |
3cfd35fd |
75 | =cut |
76 | |
77 | sub parameterize { |
0a9f5b94 |
78 | my $self = shift @_; |
3cfd35fd |
79 | my $class = ref $self; |
6c67366e |
80 | |
81 | Moose->throw_error("$self already has a constraining value.") if |
82 | $self->has_constraining_value; |
83 | |
0a9f5b94 |
84 | if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) { |
85 | my $arg1 = shift @_; |
0a9f5b94 |
86 | |
6c67366e |
87 | if(blessed $_[0] && $_[0]->isa('Moose::Meta::TypeConstraint')) { |
88 | my $arg2 = shift @_ || $self->constraining_value_type_constraint; |
89 | |
90 | ## TODO fix this crap! |
91 | Moose->throw_error("$arg2 is not a type constraint") |
92 | unless $arg2->isa('Moose::Meta::TypeConstraint'); |
93 | |
94 | Moose->throw_error("$arg1 is not a type of: ".$self->parent_type_constraint->name) |
95 | unless $arg1->is_a_type_of($self->parent_type_constraint); |
96 | |
97 | Moose->throw_error("$arg2 is not a type of: ".$self->constraining_value_type_constraint->name) |
98 | unless $arg2->is_a_type_of($self->constraining_value_type_constraint); |
99 | |
100 | Moose->throw_error('Too Many Args! Two are allowed.') if @_; |
101 | |
102 | return $class->new( |
103 | name => $self->_generate_subtype_name($arg1, $arg2), |
104 | parent => $self, |
105 | constraint => $self->constraint, |
106 | parent_type_constraint=>$arg1, |
107 | constraining_value_type_constraint => $arg2, |
108 | ); |
109 | } else { |
110 | Moose->throw_error("$arg1 is not a type of: ".$self->constraining_value_type_constraint->name) |
111 | unless $arg1->is_a_type_of($self->constraining_value_type_constraint); |
112 | |
113 | return $class->new( |
114 | name => $self->_generate_subtype_name($self->parent_type_constraint, $arg1), |
115 | parent => $self, |
116 | constraint => $self->constraint, |
117 | parent_type_constraint=>$self->parent_type_constraint, |
118 | constraining_value_type_constraint => $arg1, |
119 | ); |
120 | } |
0a9f5b94 |
121 | } else { |
0a9f5b94 |
122 | my $args; |
123 | ## Jump through some hoops to let them do tc[key=>10] and tc[{key=>10}] |
124 | if(@_) { |
125 | if($#_) { |
126 | if($self->constraining_value_type_constraint->is_a_type_of('HashRef')) { |
127 | $args = {@_}; |
128 | } else { |
129 | $args = [@_]; |
130 | } |
131 | } else { |
132 | $args = $_[0]; |
133 | } |
134 | |
135 | } else { |
136 | ## TODO: Is there a use case for parameterizing null or undef? |
137 | Moose->throw_error('Cannot Parameterize null values.'); |
138 | } |
139 | |
140 | if(my $err = $self->constraining_value_type_constraint->validate($args)) { |
141 | Moose->throw_error($err); |
142 | } else { |
143 | ## TODO memorize or do a registry lookup on the name as an optimization |
144 | return $class->new( |
145 | name => $self->name."[$args]", |
146 | parent => $self, |
147 | constraint => $self->constraint, |
148 | constraining_value => $args, |
149 | parent_type_constraint=>$self->parent_type_constraint, |
150 | constraining_value_type_constraint => $self->constraining_value_type_constraint, |
151 | ); |
152 | } |
153 | } |
3cfd35fd |
154 | } |
155 | |
156 | =head2 _generate_subtype_name |
157 | |
158 | Returns a name for the dependent type that should be unique |
159 | |
160 | =cut |
161 | |
162 | sub _generate_subtype_name { |
a588ee00 |
163 | my ($self, $parent_tc, $constraining_tc) = @_; |
3cfd35fd |
164 | return sprintf( |
0a9f5b94 |
165 | $self."[%s, %s]", |
a588ee00 |
166 | $parent_tc, $constraining_tc, |
3cfd35fd |
167 | ); |
168 | } |
169 | |
0a9f5b94 |
170 | =head2 create_child_type |
3cfd35fd |
171 | |
0a9f5b94 |
172 | modifier to make sure we get the constraint_generator |
3cfd35fd |
173 | |
174 | =cut |
175 | |
0a9f5b94 |
176 | around 'create_child_type' => sub { |
177 | my ($create_child_type, $self, %opts) = @_; |
66efbe23 |
178 | if($self->has_constraining_value) { |
179 | $opts{constraining_value} = $self->constraining_value; |
180 | } |
0a9f5b94 |
181 | return $self->$create_child_type( |
182 | %opts, |
183 | parent=> $self, |
184 | parent_type_constraint=>$self->parent_type_constraint, |
185 | constraining_value_type_constraint => $self->constraining_value_type_constraint, |
186 | ); |
187 | }; |
3cfd35fd |
188 | |
0a9f5b94 |
189 | =head2 equals ($type_constraint) |
3cfd35fd |
190 | |
0a9f5b94 |
191 | Override the base class behavior so that a dependent type equal both the parent |
192 | type and the overall dependent container. This behavior may change if we can |
193 | figure out what a dependent type is (multiply inheritance or a role...) |
1e87d1a7 |
194 | |
0a9f5b94 |
195 | =cut |
3cfd35fd |
196 | |
0a9f5b94 |
197 | around 'equals' => sub { |
198 | my ( $equals, $self, $type_or_name ) = @_; |
3cfd35fd |
199 | |
0a9f5b94 |
200 | my $other = defined $type_or_name ? |
201 | Moose::Util::TypeConstraints::find_type_constraint($type_or_name) : |
202 | Moose->throw_error("Can't call $self ->equals without a parameter"); |
203 | |
204 | Moose->throw_error("$type_or_name is not a registered Type") |
205 | unless $other; |
206 | |
207 | if(my $parent = $other->parent) { |
208 | return $self->$equals($other) |
209 | || $self->parent->equals($parent); |
210 | } else { |
211 | return $self->$equals($other); |
3cfd35fd |
212 | } |
3cfd35fd |
213 | }; |
214 | |
0a9f5b94 |
215 | around 'is_subtype_of' => sub { |
216 | my ( $is_subtype_of, $self, $type_or_name ) = @_; |
3cfd35fd |
217 | |
0a9f5b94 |
218 | my $other = defined $type_or_name ? |
219 | Moose::Util::TypeConstraints::find_type_constraint($type_or_name) : |
220 | Moose->throw_error("Can't call $self ->equals without a parameter"); |
221 | |
222 | Moose->throw_error("$type_or_name is not a registered Type") |
223 | unless $other; |
224 | |
225 | return $self->$is_subtype_of($other) |
226 | || $self->parent_type_constraint->is_subtype_of($other); |
9b6d2e22 |
227 | |
3cfd35fd |
228 | }; |
229 | |
0a9f5b94 |
230 | sub is_a_type_of { |
231 | my ($self, @args) = @_; |
232 | return ($self->equals(@args) || |
233 | $self->is_subtype_of(@args)); |
234 | } |
3cfd35fd |
235 | |
0a9f5b94 |
236 | around 'check' => sub { |
237 | my ($check, $self, @args) = @_; |
6c67366e |
238 | return ( |
239 | $self->parent_type_constraint->check(@args) && |
240 | $self->$check(@args) |
241 | ); |
0a9f5b94 |
242 | }; |
3cfd35fd |
243 | |
0a9f5b94 |
244 | around 'validate' => sub { |
245 | my ($validate, $self, @args) = @_; |
6c67366e |
246 | return ( |
247 | $self->parent_type_constraint->validate(@args) || |
248 | $self->$validate(@args) |
249 | ); |
0a9f5b94 |
250 | }; |
3cfd35fd |
251 | |
66efbe23 |
252 | around '_compiled_type_constraint' => sub { |
253 | my ($method, $self, @args) = @_; |
254 | my $coderef = $self->$method(@args); |
6c67366e |
255 | my $constraining; |
256 | if($self->has_constraining_value) { |
257 | $constraining = $self->constraining_value; |
258 | } |
259 | |
66efbe23 |
260 | return sub { |
261 | my @local_args = @_; |
6c67366e |
262 | if(my $err = $self->constraining_value_type_constraint->validate($constraining)) { |
263 | Moose->throw_error($err); |
264 | } |
265 | $coderef->(@local_args, $constraining); |
66efbe23 |
266 | }; |
267 | }; |
268 | |
3cfd35fd |
269 | =head2 get_message |
270 | |
ae1d0652 |
271 | Give you a better peek into what's causing the error. |
3cfd35fd |
272 | |
3cfd35fd |
273 | around 'get_message' => sub { |
274 | my ($get_message, $self, $value) = @_; |
ae1d0652 |
275 | return $self->$get_message($value); |
3cfd35fd |
276 | }; |
277 | |
278 | =head1 SEE ALSO |
279 | |
280 | The following modules or resources may be of interest. |
281 | |
282 | L<Moose>, L<Moose::Meta::TypeConstraint> |
283 | |
284 | =head1 AUTHOR |
285 | |
286 | John Napiorkowski, C<< <jjnapiork@cpan.org> >> |
287 | |
288 | =head1 COPYRIGHT & LICENSE |
289 | |
290 | This program is free software; you can redistribute it and/or modify |
291 | it under the same terms as Perl itself. |
292 | |
293 | =cut |
294 | |
1e87d1a7 |
295 | __PACKAGE__->meta->make_immutable(inline_constructor => 0); |
296 | |