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 Sub::Name 'subname'; |
9 | use Scalar::Util 'blessed'; |
10 | |
5569c072 |
11 | our $VERSION = '0.02'; |
a15dff8d |
12 | |
4e036ee4 |
13 | use Moose::Meta::TypeConstraint; |
2ca63f5d |
14 | use Moose::Meta::TypeCoercion; |
4e036ee4 |
15 | |
a15dff8d |
16 | sub import { |
17 | shift; |
18 | my $pkg = shift || caller(); |
19 | return if $pkg eq ':no_export'; |
20 | no strict 'refs'; |
d6e2d9a1 |
21 | foreach my $export (qw(type subtype as where coerce from via)) { |
a15dff8d |
22 | *{"${pkg}::${export}"} = \&{"${export}"}; |
a15dff8d |
23 | } |
a15dff8d |
24 | } |
25 | |
182134e8 |
26 | { |
27 | my %TYPES; |
82168dbb |
28 | sub find_type_constraint { $TYPES{$_[0]} } |
182134e8 |
29 | |
82168dbb |
30 | sub create_type_constraint { |
66811d63 |
31 | my ($name, $parent, $constraint) = @_; |
32 | (not exists $TYPES{$name}) |
82168dbb |
33 | || confess "The type constraint '$name' has already been created"; |
66811d63 |
34 | $parent = find_type_constraint($parent) if defined $parent; |
35 | $TYPES{$name} = Moose::Meta::TypeConstraint->new( |
36 | name => $name, |
37 | parent => $parent, |
38 | constraint => $constraint, |
4e036ee4 |
39 | ); |
182134e8 |
40 | } |
182134e8 |
41 | |
182134e8 |
42 | sub find_type_coercion { |
43 | my $type_name = shift; |
4e036ee4 |
44 | $TYPES{$type_name}->coercion_code; |
182134e8 |
45 | } |
46 | |
47 | sub register_type_coercion { |
48 | my ($type_name, $type_coercion) = @_; |
4e036ee4 |
49 | my $type = $TYPES{$type_name}; |
50 | (!$type->has_coercion) |
d46a48f3 |
51 | || confess "The type coercion for '$type_name' has already been registered"; |
4e036ee4 |
52 | $type->set_coercion_code($type_coercion); |
182134e8 |
53 | } |
66811d63 |
54 | |
55 | sub export_type_contstraints_as_functions { |
56 | my $pkg = caller(); |
57 | no strict 'refs'; |
58 | foreach my $constraint (keys %TYPES) { |
59 | *{"${pkg}::${constraint}"} = $TYPES{$constraint}->constraint_code; |
60 | } |
61 | } |
182134e8 |
62 | } |
a15dff8d |
63 | |
a15dff8d |
64 | |
65 | sub type ($$) { |
66 | my ($name, $check) = @_; |
82168dbb |
67 | create_type_constraint($name, undef, $check); |
a15dff8d |
68 | } |
69 | |
70 | sub subtype ($$;$) { |
66811d63 |
71 | if (scalar @_ == 3) { |
72 | my ($name, $parent, $check) = @_; |
82168dbb |
73 | create_type_constraint($name, $parent, $check); |
a15dff8d |
74 | } |
75 | else { |
66811d63 |
76 | my ($parent, $check) = @_; |
77 | $parent = find_type_constraint($parent); |
78 | return Moose::Meta::TypeConstraint->new( |
79 | name => '__ANON__', |
80 | parent => $parent, |
81 | constraint => $check, |
82 | ); |
a15dff8d |
83 | } |
84 | } |
85 | |
4b598ea3 |
86 | sub coerce ($@) { |
66811d63 |
87 | my ($type_name, @coercion_map) = @_; |
e90c03d0 |
88 | my @coercions; |
89 | while (@coercion_map) { |
90 | my ($constraint_name, $action) = splice(@coercion_map, 0, 2); |
01bf4112 |
91 | my $constraint = find_type_constraint($constraint_name)->constraint_code; |
e90c03d0 |
92 | (defined $constraint) |
93 | || confess "Could not find the type constraint ($constraint_name)"; |
94 | push @coercions => [ $constraint, $action ]; |
95 | } |
182134e8 |
96 | register_type_coercion($type_name, sub { |
e90c03d0 |
97 | my $thing = shift; |
98 | foreach my $coercion (@coercions) { |
99 | my ($constraint, $converter) = @$coercion; |
100 | if (defined $constraint->($thing)) { |
b841b2a3 |
101 | local $_ = $thing; |
e90c03d0 |
102 | return $converter->($thing); |
103 | } |
104 | } |
105 | return $thing; |
182134e8 |
106 | }); |
107 | } |
108 | |
a15dff8d |
109 | sub as ($) { $_[0] } |
d6e2d9a1 |
110 | sub from ($) { $_[0] } |
a15dff8d |
111 | sub where (&) { $_[0] } |
d6e2d9a1 |
112 | sub via (&) { $_[0] } |
a15dff8d |
113 | |
114 | # define some basic types |
115 | |
116 | type Any => where { 1 }; |
117 | |
118 | type Value => where { !ref($_) }; |
119 | type Ref => where { ref($_) }; |
120 | |
121 | subtype Int => as Value => where { Scalar::Util::looks_like_number($_) }; |
122 | subtype Str => as Value => where { !Scalar::Util::looks_like_number($_) }; |
123 | |
124 | subtype ScalarRef => as Ref => where { ref($_) eq 'SCALAR' }; |
125 | subtype ArrayRef => as Ref => where { ref($_) eq 'ARRAY' }; |
126 | subtype HashRef => as Ref => where { ref($_) eq 'HASH' }; |
127 | subtype CodeRef => as Ref => where { ref($_) eq 'CODE' }; |
128 | subtype RegexpRef => as Ref => where { ref($_) eq 'Regexp' }; |
129 | |
130 | # NOTE: |
131 | # blessed(qr/.../) returns true,.. how odd |
132 | subtype Object => as Ref => where { blessed($_) && blessed($_) ne 'Regexp' }; |
133 | |
134 | 1; |
135 | |
136 | __END__ |
137 | |
138 | =pod |
139 | |
140 | =head1 NAME |
141 | |
e522431d |
142 | Moose::Util::TypeConstraints - Type constraint system for Moose |
a15dff8d |
143 | |
144 | =head1 SYNOPSIS |
145 | |
146 | use Moose::Util::TypeConstraints; |
147 | |
148 | type Num => where { Scalar::Util::looks_like_number($_) }; |
149 | |
150 | subtype Natural |
151 | => as Num |
152 | => where { $_ > 0 }; |
153 | |
154 | subtype NaturalLessThanTen |
155 | => as Natural |
156 | => where { $_ < 10 }; |
6b8bd8d3 |
157 | |
158 | coerce Num |
d6e2d9a1 |
159 | => from Str |
160 | => via { 0+$_ }; |
a15dff8d |
161 | |
162 | =head1 DESCRIPTION |
163 | |
e522431d |
164 | This module provides Moose with the ability to create type contraints |
165 | to be are used in both attribute definitions and for method argument |
166 | validation. |
167 | |
168 | This is B<NOT> a type system for Perl 5. |
169 | |
e522431d |
170 | This module also provides a simple hierarchy for Perl 5 types, this |
171 | could probably use some work, but it works for me at the moment. |
172 | |
173 | Any |
174 | Value |
175 | Int |
176 | Str |
177 | Ref |
178 | ScalarRef |
179 | ArrayRef |
180 | HashRef |
181 | CodeRef |
182 | RegexpRef |
183 | Object |
184 | |
185 | Suggestions for improvement are welcome. |
186 | |
a15dff8d |
187 | =head1 FUNCTIONS |
188 | |
182134e8 |
189 | =head2 Type Constraint Registry |
190 | |
191 | =over 4 |
192 | |
193 | =item B<find_type_constraint ($type_name)> |
194 | |
82168dbb |
195 | =item B<create_type_constraint ($type_name, $type_constraint)> |
182134e8 |
196 | |
197 | =item B<find_type_coercion> |
198 | |
199 | =item B<register_type_coercion> |
200 | |
201 | =item B<export_type_contstraints_as_functions> |
202 | |
4b598ea3 |
203 | =item B<dump_type_constraints> |
204 | |
182134e8 |
205 | =back |
206 | |
a15dff8d |
207 | =head2 Type Constraint Constructors |
208 | |
209 | =over 4 |
210 | |
211 | =item B<type> |
212 | |
213 | =item B<subtype> |
214 | |
215 | =item B<as> |
216 | |
217 | =item B<where> |
218 | |
182134e8 |
219 | =item B<coerce> |
220 | |
d6e2d9a1 |
221 | =item B<from> |
222 | |
223 | =item B<via> |
182134e8 |
224 | |
a15dff8d |
225 | =back |
226 | |
227 | =head2 Built-in Type Constraints |
228 | |
229 | =over 4 |
230 | |
231 | =item B<Any> |
232 | |
233 | =item B<Value> |
234 | |
235 | =item B<Int> |
236 | |
237 | =item B<Str> |
238 | |
239 | =item B<Ref> |
240 | |
241 | =item B<ArrayRef> |
242 | |
243 | =item B<CodeRef> |
244 | |
245 | =item B<HashRef> |
246 | |
247 | =item B<RegexpRef> |
248 | |
249 | =item B<ScalarRef> |
250 | |
251 | =item B<Object> |
252 | |
253 | =back |
254 | |
255 | =head1 BUGS |
256 | |
257 | All complex software has bugs lurking in it, and this module is no |
258 | exception. If you find a bug please either email me, or add the bug |
259 | to cpan-RT. |
260 | |
a15dff8d |
261 | =head1 AUTHOR |
262 | |
263 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
264 | |
265 | =head1 COPYRIGHT AND LICENSE |
266 | |
267 | Copyright 2006 by Infinity Interactive, Inc. |
268 | |
269 | L<http://www.iinteractive.com> |
270 | |
271 | This library is free software; you can redistribute it and/or modify |
272 | it under the same terms as Perl itself. |
273 | |
274 | =cut |