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