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 | |
5569c072 |
10 | our $VERSION = '0.02'; |
a15dff8d |
11 | |
4e036ee4 |
12 | use Moose::Meta::TypeConstraint; |
2ca63f5d |
13 | use Moose::Meta::TypeCoercion; |
4e036ee4 |
14 | |
a15dff8d |
15 | sub import { |
16 | shift; |
17 | my $pkg = shift || caller(); |
34a66aa3 |
18 | return if $pkg eq '-no-export'; |
a15dff8d |
19 | no strict 'refs'; |
7c13858b |
20 | foreach my $export (qw(type subtype as where coerce from via find_type_constraint)) { |
a15dff8d |
21 | *{"${pkg}::${export}"} = \&{"${export}"}; |
a15dff8d |
22 | } |
a15dff8d |
23 | } |
24 | |
182134e8 |
25 | { |
26 | my %TYPES; |
0e6614c3 |
27 | sub find_type_constraint { $TYPES{$_[0]}->[1] } |
182134e8 |
28 | |
7c13858b |
29 | sub _create_type_constraint { |
a27aa600 |
30 | my ($name, $parent, $check) = @_; |
0e6614c3 |
31 | my $pkg_defined_in = scalar(caller(1)); |
32 | ($TYPES{$name}->[0] eq $pkg_defined_in) |
a27aa600 |
33 | || confess "The type constraint '$name' has already been created" |
0e6614c3 |
34 | if defined $name && exists $TYPES{$name}; |
35 | $parent = find_type_constraint($parent) if defined $parent; |
a27aa600 |
36 | my $constraint = Moose::Meta::TypeConstraint->new( |
37 | name => $name || '__ANON__', |
66811d63 |
38 | parent => $parent, |
a27aa600 |
39 | constraint => $check, |
4e036ee4 |
40 | ); |
0e6614c3 |
41 | $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name; |
a27aa600 |
42 | return $constraint; |
182134e8 |
43 | } |
182134e8 |
44 | |
7c13858b |
45 | sub _install_type_coercions { |
a27aa600 |
46 | my ($type_name, $coercion_map) = @_; |
0e6614c3 |
47 | my $type = find_type_constraint($type_name); |
4e036ee4 |
48 | (!$type->has_coercion) |
d46a48f3 |
49 | || confess "The type coercion for '$type_name' has already been registered"; |
a27aa600 |
50 | my $type_coercion = Moose::Meta::TypeCoercion->new( |
51 | type_coercion_map => $coercion_map, |
52 | type_constraint => $type |
53 | ); |
54 | $type->coercion($type_coercion); |
182134e8 |
55 | } |
66811d63 |
56 | |
57 | sub export_type_contstraints_as_functions { |
58 | my $pkg = caller(); |
59 | no strict 'refs'; |
60 | foreach my $constraint (keys %TYPES) { |
0e6614c3 |
61 | *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint; |
66811d63 |
62 | } |
63 | } |
182134e8 |
64 | } |
a15dff8d |
65 | |
7c13858b |
66 | # type constructors |
a15dff8d |
67 | |
68 | sub type ($$) { |
69 | my ($name, $check) = @_; |
7c13858b |
70 | _create_type_constraint($name, undef, $check); |
a15dff8d |
71 | } |
72 | |
73 | sub subtype ($$;$) { |
a27aa600 |
74 | unshift @_ => undef if scalar @_ == 2; |
7c13858b |
75 | _create_type_constraint(@_); |
a15dff8d |
76 | } |
77 | |
4b598ea3 |
78 | sub coerce ($@) { |
66811d63 |
79 | my ($type_name, @coercion_map) = @_; |
7c13858b |
80 | _install_type_coercions($type_name, \@coercion_map); |
182134e8 |
81 | } |
82 | |
a15dff8d |
83 | sub as ($) { $_[0] } |
d6e2d9a1 |
84 | sub from ($) { $_[0] } |
a15dff8d |
85 | sub where (&) { $_[0] } |
d6e2d9a1 |
86 | sub via (&) { $_[0] } |
a15dff8d |
87 | |
88 | # define some basic types |
89 | |
90 | type Any => where { 1 }; |
91 | |
92 | type Value => where { !ref($_) }; |
93 | type Ref => where { ref($_) }; |
94 | |
95 | subtype Int => as Value => where { Scalar::Util::looks_like_number($_) }; |
96 | subtype Str => as Value => where { !Scalar::Util::looks_like_number($_) }; |
97 | |
98 | subtype ScalarRef => as Ref => where { ref($_) eq 'SCALAR' }; |
99 | subtype ArrayRef => as Ref => where { ref($_) eq 'ARRAY' }; |
100 | subtype HashRef => as Ref => where { ref($_) eq 'HASH' }; |
101 | subtype CodeRef => as Ref => where { ref($_) eq 'CODE' }; |
102 | subtype RegexpRef => as Ref => where { ref($_) eq 'Regexp' }; |
103 | |
104 | # NOTE: |
105 | # blessed(qr/.../) returns true,.. how odd |
106 | subtype Object => as Ref => where { blessed($_) && blessed($_) ne 'Regexp' }; |
107 | |
108 | 1; |
109 | |
110 | __END__ |
111 | |
112 | =pod |
113 | |
114 | =head1 NAME |
115 | |
e522431d |
116 | Moose::Util::TypeConstraints - Type constraint system for Moose |
a15dff8d |
117 | |
118 | =head1 SYNOPSIS |
119 | |
120 | use Moose::Util::TypeConstraints; |
121 | |
122 | type Num => where { Scalar::Util::looks_like_number($_) }; |
123 | |
124 | subtype Natural |
125 | => as Num |
126 | => where { $_ > 0 }; |
127 | |
128 | subtype NaturalLessThanTen |
129 | => as Natural |
130 | => where { $_ < 10 }; |
6b8bd8d3 |
131 | |
132 | coerce Num |
d6e2d9a1 |
133 | => from Str |
134 | => via { 0+$_ }; |
a15dff8d |
135 | |
136 | =head1 DESCRIPTION |
137 | |
e522431d |
138 | This module provides Moose with the ability to create type contraints |
139 | to be are used in both attribute definitions and for method argument |
140 | validation. |
141 | |
6ba6d68c |
142 | =head2 Important Caveat |
143 | |
144 | This is B<NOT> a type system for Perl 5. These are type constraints, |
145 | and they are not used by Moose unless you tell it to. No type |
146 | inference is performed, expression are not typed, etc. etc. etc. |
147 | |
148 | This is simply a means of creating small constraint functions which |
149 | can be used to simply your own type-checking code. |
150 | |
151 | =head2 Default Type Constraints |
e522431d |
152 | |
e522431d |
153 | This module also provides a simple hierarchy for Perl 5 types, this |
154 | could probably use some work, but it works for me at the moment. |
155 | |
156 | Any |
157 | Value |
158 | Int |
159 | Str |
160 | Ref |
161 | ScalarRef |
162 | ArrayRef |
163 | HashRef |
164 | CodeRef |
165 | RegexpRef |
166 | Object |
167 | |
6ba6d68c |
168 | Suggestions for improvement are welcome. |
e522431d |
169 | |
a15dff8d |
170 | =head1 FUNCTIONS |
171 | |
182134e8 |
172 | =head2 Type Constraint Registry |
173 | |
174 | =over 4 |
175 | |
176 | =item B<find_type_constraint ($type_name)> |
177 | |
6ba6d68c |
178 | This function can be used to locate a specific type constraint |
179 | meta-object. What you do with it from there is up to you :) |
182134e8 |
180 | |
181 | =item B<export_type_contstraints_as_functions> |
182 | |
6ba6d68c |
183 | This will export all the current type constraints as functions |
184 | into the caller's namespace. Right now, this is mostly used for |
185 | testing, but it might prove useful to others. |
186 | |
182134e8 |
187 | =back |
188 | |
a15dff8d |
189 | =head2 Type Constraint Constructors |
190 | |
6ba6d68c |
191 | The following functions are used to create type constraints. |
192 | They will then register the type constraints in a global store |
193 | where Moose can get to them if it needs to. |
a15dff8d |
194 | |
6ba6d68c |
195 | See the L<SYNOPOSIS> for an example of how to use these. |
a15dff8d |
196 | |
6ba6d68c |
197 | =over 4 |
a15dff8d |
198 | |
6ba6d68c |
199 | =item B<type ($name, $where_clause)> |
a15dff8d |
200 | |
6ba6d68c |
201 | This creates a base type, which has no parent. |
a15dff8d |
202 | |
6ba6d68c |
203 | =item B<subtype ($name, $parent, $where_clause)> |
182134e8 |
204 | |
6ba6d68c |
205 | This creates a named subtype. |
d6e2d9a1 |
206 | |
6ba6d68c |
207 | =item B<subtype ($parent, $where_clause)> |
182134e8 |
208 | |
6ba6d68c |
209 | This creates an unnamed subtype and will return the type |
210 | constraint meta-object, which will be an instance of |
211 | L<Moose::Meta::TypeConstraint>. |
a15dff8d |
212 | |
6ba6d68c |
213 | =item B<as> |
a15dff8d |
214 | |
6ba6d68c |
215 | This is just sugar for the type constraint construction syntax. |
a15dff8d |
216 | |
6ba6d68c |
217 | =item B<where> |
a15dff8d |
218 | |
6ba6d68c |
219 | This is just sugar for the type constraint construction syntax. |
a15dff8d |
220 | |
6ba6d68c |
221 | =back |
a15dff8d |
222 | |
6ba6d68c |
223 | =head2 Type Coercion Constructors |
a15dff8d |
224 | |
6ba6d68c |
225 | Type constraints can also contain type coercions as well. In most |
226 | cases Moose will run the type-coercion code first, followed by the |
227 | type constraint check. This feature should be used carefully as it |
228 | is very powerful and could easily take off a limb if you are not |
229 | careful. |
a15dff8d |
230 | |
6ba6d68c |
231 | See the L<SYNOPOSIS> for an example of how to use these. |
a15dff8d |
232 | |
6ba6d68c |
233 | =over 4 |
a15dff8d |
234 | |
6ba6d68c |
235 | =item B<coerce> |
a15dff8d |
236 | |
6ba6d68c |
237 | =item B<from> |
a15dff8d |
238 | |
6ba6d68c |
239 | This is just sugar for the type coercion construction syntax. |
240 | |
241 | =item B<via> |
a15dff8d |
242 | |
6ba6d68c |
243 | This is just sugar for the type coercion construction syntax. |
a15dff8d |
244 | |
245 | =back |
246 | |
247 | =head1 BUGS |
248 | |
249 | All complex software has bugs lurking in it, and this module is no |
250 | exception. If you find a bug please either email me, or add the bug |
251 | to cpan-RT. |
252 | |
a15dff8d |
253 | =head1 AUTHOR |
254 | |
255 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
256 | |
257 | =head1 COPYRIGHT AND LICENSE |
258 | |
259 | Copyright 2006 by Infinity Interactive, Inc. |
260 | |
261 | L<http://www.iinteractive.com> |
262 | |
263 | This library is free software; you can redistribute it and/or modify |
264 | it under the same terms as Perl itself. |
265 | |
266 | =cut |