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