Commit | Line | Data |
a15dff8d |
1 | |
2 | package Moose::Util::TypeConstraints; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
e90c03d0 |
7 | use Carp 'confess'; |
a15dff8d |
8 | use Scalar::Util 'blessed'; |
9 | |
3f7376b0 |
10 | our $VERSION = '0.08'; |
a15dff8d |
11 | |
4e036ee4 |
12 | use Moose::Meta::TypeConstraint; |
2ca63f5d |
13 | use Moose::Meta::TypeCoercion; |
4e036ee4 |
14 | |
9e93dd19 |
15 | use Sub::Exporter -setup => { |
16 | exports => [qw/ |
17 | type subtype as where message |
18 | coerce from via |
19 | enum |
20 | find_type_constraint |
21 | /], |
22 | groups => { |
23 | default => [':all'] |
2c0cbef7 |
24 | } |
9e93dd19 |
25 | }; |
a15dff8d |
26 | |
182134e8 |
27 | { |
28 | my %TYPES; |
2c0cbef7 |
29 | sub find_type_constraint ($) { |
446e850f |
30 | return $TYPES{$_[0]}->[1] |
31 | if exists $TYPES{$_[0]}; |
32 | return; |
33 | } |
34 | |
35 | sub _dump_type_constraints { |
36 | require Data::Dumper; |
256903b6 |
37 | Data::Dumper::Dumper(\%TYPES); |
446e850f |
38 | } |
39 | |
2c0cbef7 |
40 | sub _create_type_constraint ($$$;$) { |
76d37e5a |
41 | my ($name, $parent, $check, $message) = @_; |
0e6614c3 |
42 | my $pkg_defined_in = scalar(caller(1)); |
43 | ($TYPES{$name}->[0] eq $pkg_defined_in) |
446e850f |
44 | || confess "The type constraint '$name' has already been created " |
0e6614c3 |
45 | if defined $name && exists $TYPES{$name}; |
46 | $parent = find_type_constraint($parent) if defined $parent; |
a27aa600 |
47 | my $constraint = Moose::Meta::TypeConstraint->new( |
48 | name => $name || '__ANON__', |
66811d63 |
49 | parent => $parent, |
76d37e5a |
50 | constraint => $check, |
51 | message => $message, |
4e036ee4 |
52 | ); |
0e6614c3 |
53 | $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name; |
a27aa600 |
54 | return $constraint; |
182134e8 |
55 | } |
182134e8 |
56 | |
2c0cbef7 |
57 | sub _install_type_coercions ($$) { |
a27aa600 |
58 | my ($type_name, $coercion_map) = @_; |
0e6614c3 |
59 | my $type = find_type_constraint($type_name); |
4e036ee4 |
60 | (!$type->has_coercion) |
d46a48f3 |
61 | || confess "The type coercion for '$type_name' has already been registered"; |
a27aa600 |
62 | my $type_coercion = Moose::Meta::TypeCoercion->new( |
63 | type_coercion_map => $coercion_map, |
64 | type_constraint => $type |
65 | ); |
66 | $type->coercion($type_coercion); |
182134e8 |
67 | } |
66811d63 |
68 | |
2c0cbef7 |
69 | sub create_type_constraint_union (@) { |
c07af9d2 |
70 | my (@type_constraint_names) = @_; |
71 | return Moose::Meta::TypeConstraint->union( |
72 | map { |
73 | find_type_constraint($_) |
74 | } @type_constraint_names |
75 | ); |
76 | } |
77 | |
66811d63 |
78 | sub export_type_contstraints_as_functions { |
79 | my $pkg = caller(); |
80 | no strict 'refs'; |
81 | foreach my $constraint (keys %TYPES) { |
0e6614c3 |
82 | *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint; |
66811d63 |
83 | } |
84 | } |
182134e8 |
85 | } |
a15dff8d |
86 | |
7c13858b |
87 | # type constructors |
a15dff8d |
88 | |
89 | sub type ($$) { |
90 | my ($name, $check) = @_; |
7c13858b |
91 | _create_type_constraint($name, undef, $check); |
a15dff8d |
92 | } |
93 | |
76d37e5a |
94 | sub subtype ($$;$$) { |
95 | unshift @_ => undef if scalar @_ <= 2; |
2c0cbef7 |
96 | goto &_create_type_constraint; |
a15dff8d |
97 | } |
98 | |
4b598ea3 |
99 | sub coerce ($@) { |
66811d63 |
100 | my ($type_name, @coercion_map) = @_; |
7c13858b |
101 | _install_type_coercions($type_name, \@coercion_map); |
182134e8 |
102 | } |
103 | |
76d37e5a |
104 | sub as ($) { $_[0] } |
105 | sub from ($) { $_[0] } |
106 | sub where (&) { $_[0] } |
107 | sub via (&) { $_[0] } |
108 | sub message (&) { $_[0] } |
a15dff8d |
109 | |
2c0cbef7 |
110 | sub enum ($;@) { |
fcec2383 |
111 | my ($type_name, @values) = @_; |
2c0cbef7 |
112 | (scalar @values >= 2) |
113 | || confess "You must have at least two values to enumerate through"; |
fcec2383 |
114 | my $regexp = join '|' => @values; |
115 | _create_type_constraint( |
116 | $type_name, |
117 | 'Str', |
118 | sub { qr/^$regexp$/i } |
119 | ); |
120 | } |
121 | |
a15dff8d |
122 | # define some basic types |
123 | |
f65cb534 |
124 | type 'Any' => where { 1 }; # meta-type including all |
125 | type 'Item' => where { 1 }; # base-type |
a15dff8d |
126 | |
f65cb534 |
127 | subtype 'Undef' => as 'Item' => where { !defined($_) }; |
128 | subtype 'Defined' => as 'Item' => where { defined($_) }; |
a15dff8d |
129 | |
81dc201f |
130 | subtype 'Bool' => as 'Item' => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }; |
5204cd52 |
131 | |
5a4c5493 |
132 | subtype 'Value' => as 'Defined' => where { !ref($_) }; |
133 | subtype 'Ref' => as 'Defined' => where { ref($_) }; |
134 | |
135 | subtype 'Str' => as 'Value' => where { 1 }; |
a15dff8d |
136 | |
81dc201f |
137 | subtype 'Num' => as 'Value' => where { Scalar::Util::looks_like_number($_) }; |
d4634ca2 |
138 | subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ }; |
81dc201f |
139 | |
140 | subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' }; |
451c8248 |
141 | subtype 'ArrayRef' => as 'Ref' => where { ref($_) eq 'ARRAY' }; |
142 | subtype 'HashRef' => as 'Ref' => where { ref($_) eq 'HASH' }; |
e9ec68d6 |
143 | subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' }; |
144 | subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' }; |
3f7376b0 |
145 | subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' }; |
a15dff8d |
146 | |
0a5bd159 |
147 | # NOTE: |
148 | # scalar filehandles are GLOB refs, |
149 | # but a GLOB ref is not always a filehandle |
150 | subtype 'FileHandle' => as 'GlobRef' => where { Scalar::Util::openhandle($_) }; |
151 | |
a15dff8d |
152 | # NOTE: |
153 | # blessed(qr/.../) returns true,.. how odd |
e9ec68d6 |
154 | subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' }; |
a15dff8d |
155 | |
02a0fb52 |
156 | subtype 'Role' => as 'Object' => where { $_->can('does') }; |
157 | |
a15dff8d |
158 | 1; |
159 | |
160 | __END__ |
161 | |
162 | =pod |
163 | |
164 | =head1 NAME |
165 | |
e522431d |
166 | Moose::Util::TypeConstraints - Type constraint system for Moose |
a15dff8d |
167 | |
168 | =head1 SYNOPSIS |
169 | |
170 | use Moose::Util::TypeConstraints; |
171 | |
2c0cbef7 |
172 | type 'Num' => where { Scalar::Util::looks_like_number($_) }; |
a15dff8d |
173 | |
2c0cbef7 |
174 | subtype 'Natural' |
175 | => as 'Num' |
a15dff8d |
176 | => where { $_ > 0 }; |
177 | |
2c0cbef7 |
178 | subtype 'NaturalLessThanTen' |
179 | => as 'Natural' |
79592a54 |
180 | => where { $_ < 10 } |
181 | => message { "This number ($_) is not less than ten!" }; |
6b8bd8d3 |
182 | |
2c0cbef7 |
183 | coerce 'Num' |
184 | => from 'Str' |
d6e2d9a1 |
185 | => via { 0+$_ }; |
98aae381 |
186 | |
2c0cbef7 |
187 | enum 'RGBColors' => qw(red green blue); |
a15dff8d |
188 | |
189 | =head1 DESCRIPTION |
190 | |
e522431d |
191 | This module provides Moose with the ability to create type contraints |
192 | to be are used in both attribute definitions and for method argument |
193 | validation. |
194 | |
6ba6d68c |
195 | =head2 Important Caveat |
196 | |
197 | This is B<NOT> a type system for Perl 5. These are type constraints, |
198 | and they are not used by Moose unless you tell it to. No type |
199 | inference is performed, expression are not typed, etc. etc. etc. |
200 | |
201 | This is simply a means of creating small constraint functions which |
a7d0cd00 |
202 | can be used to simplify your own type-checking code. |
6ba6d68c |
203 | |
2c0cbef7 |
204 | =head2 Slightly Less Important Caveat |
205 | |
206 | It is almost always a good idea to quote your type and subtype names. |
43d599e5 |
207 | This is to prevent perl from trying to execute the call as an indirect |
2c0cbef7 |
208 | object call. This issue only seems to come up when you have a subtype |
209 | the same name as a valid class, but when the issue does arise it tends |
210 | to be quite annoying to debug. |
211 | |
212 | So for instance, this: |
213 | |
214 | subtype DateTime => as Object => where { $_->isa('DateTime') }; |
215 | |
216 | will I<Just Work>, while this: |
217 | |
218 | use DateTime; |
219 | subtype DateTime => as Object => where { $_->isa('DateTime') }; |
220 | |
221 | will fail silently and cause many headaches. The simple way to solve |
222 | this, as well as future proof your subtypes from classes which have |
223 | yet to have been created yet, is to simply do this: |
224 | |
225 | use DateTime; |
226 | subtype 'DateTime' => as Object => where { $_->isa('DateTime') }; |
227 | |
6ba6d68c |
228 | =head2 Default Type Constraints |
e522431d |
229 | |
e522431d |
230 | This module also provides a simple hierarchy for Perl 5 types, this |
231 | could probably use some work, but it works for me at the moment. |
232 | |
233 | Any |
f65cb534 |
234 | Item |
5a4c5493 |
235 | Bool |
f65cb534 |
236 | Undef |
237 | Defined |
5a4c5493 |
238 | Value |
239 | Num |
240 | Int |
241 | Str |
242 | Ref |
243 | ScalarRef |
451c8248 |
244 | ArrayRef |
245 | HashRef |
5a4c5493 |
246 | CodeRef |
247 | RegexpRef |
3f7376b0 |
248 | GlobRef |
0a5bd159 |
249 | FileHandle |
5a4c5493 |
250 | Object |
251 | Role |
e522431d |
252 | |
6ba6d68c |
253 | Suggestions for improvement are welcome. |
2c0cbef7 |
254 | |
255 | B<NOTE:> The C<Undef> type constraint does not work correctly |
256 | in every occasion, please use it sparringly. |
e522431d |
257 | |
a15dff8d |
258 | =head1 FUNCTIONS |
259 | |
182134e8 |
260 | =head2 Type Constraint Registry |
261 | |
262 | =over 4 |
263 | |
264 | =item B<find_type_constraint ($type_name)> |
265 | |
6ba6d68c |
266 | This function can be used to locate a specific type constraint |
267 | meta-object. What you do with it from there is up to you :) |
182134e8 |
268 | |
c07af9d2 |
269 | =item B<create_type_constraint_union (@type_constraint_names)> |
270 | |
271 | Given a list of C<@type_constraint_names>, this will return a |
272 | B<Moose::Meta::TypeConstraint::Union> instance. |
273 | |
182134e8 |
274 | =item B<export_type_contstraints_as_functions> |
275 | |
6ba6d68c |
276 | This will export all the current type constraints as functions |
277 | into the caller's namespace. Right now, this is mostly used for |
278 | testing, but it might prove useful to others. |
279 | |
182134e8 |
280 | =back |
281 | |
a15dff8d |
282 | =head2 Type Constraint Constructors |
283 | |
6ba6d68c |
284 | The following functions are used to create type constraints. |
285 | They will then register the type constraints in a global store |
286 | where Moose can get to them if it needs to. |
a15dff8d |
287 | |
6ba6d68c |
288 | See the L<SYNOPOSIS> for an example of how to use these. |
a15dff8d |
289 | |
6ba6d68c |
290 | =over 4 |
a15dff8d |
291 | |
6ba6d68c |
292 | =item B<type ($name, $where_clause)> |
a15dff8d |
293 | |
6ba6d68c |
294 | This creates a base type, which has no parent. |
a15dff8d |
295 | |
79592a54 |
296 | =item B<subtype ($name, $parent, $where_clause, ?$message)> |
182134e8 |
297 | |
6ba6d68c |
298 | This creates a named subtype. |
d6e2d9a1 |
299 | |
79592a54 |
300 | =item B<subtype ($parent, $where_clause, ?$message)> |
182134e8 |
301 | |
6ba6d68c |
302 | This creates an unnamed subtype and will return the type |
303 | constraint meta-object, which will be an instance of |
304 | L<Moose::Meta::TypeConstraint>. |
a15dff8d |
305 | |
fcec2383 |
306 | =item B<enum ($name, @values)> |
307 | |
2c0cbef7 |
308 | This will create a basic subtype for a given set of strings. |
309 | The resulting constraint will be a subtype of C<Str> and |
310 | will match any of the items in C<@values>. See the L<SYNOPSIS> |
311 | for a simple example. |
312 | |
313 | B<NOTE:> This is not a true proper enum type, it is simple |
314 | a convient constraint builder. |
315 | |
6ba6d68c |
316 | =item B<as> |
a15dff8d |
317 | |
6ba6d68c |
318 | This is just sugar for the type constraint construction syntax. |
a15dff8d |
319 | |
6ba6d68c |
320 | =item B<where> |
a15dff8d |
321 | |
6ba6d68c |
322 | This is just sugar for the type constraint construction syntax. |
76d37e5a |
323 | |
324 | =item B<message> |
325 | |
326 | This is just sugar for the type constraint construction syntax. |
a15dff8d |
327 | |
6ba6d68c |
328 | =back |
a15dff8d |
329 | |
6ba6d68c |
330 | =head2 Type Coercion Constructors |
a15dff8d |
331 | |
6ba6d68c |
332 | Type constraints can also contain type coercions as well. In most |
333 | cases Moose will run the type-coercion code first, followed by the |
334 | type constraint check. This feature should be used carefully as it |
335 | is very powerful and could easily take off a limb if you are not |
336 | careful. |
a15dff8d |
337 | |
6ba6d68c |
338 | See the L<SYNOPOSIS> for an example of how to use these. |
a15dff8d |
339 | |
6ba6d68c |
340 | =over 4 |
a15dff8d |
341 | |
6ba6d68c |
342 | =item B<coerce> |
a15dff8d |
343 | |
6ba6d68c |
344 | =item B<from> |
a15dff8d |
345 | |
6ba6d68c |
346 | This is just sugar for the type coercion construction syntax. |
347 | |
348 | =item B<via> |
a15dff8d |
349 | |
6ba6d68c |
350 | This is just sugar for the type coercion construction syntax. |
a15dff8d |
351 | |
352 | =back |
353 | |
354 | =head1 BUGS |
355 | |
356 | All complex software has bugs lurking in it, and this module is no |
357 | exception. If you find a bug please either email me, or add the bug |
358 | to cpan-RT. |
359 | |
a15dff8d |
360 | =head1 AUTHOR |
361 | |
362 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
363 | |
364 | =head1 COPYRIGHT AND LICENSE |
365 | |
366 | Copyright 2006 by Infinity Interactive, Inc. |
367 | |
368 | L<http://www.iinteractive.com> |
369 | |
370 | This library is free software; you can redistribute it and/or modify |
371 | it under the same terms as Perl itself. |
372 | |
81dc201f |
373 | =cut |