Commit | Line | Data |
06d02aac |
1 | package Moose::Util::TypeConstraints::Builtins; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
7fb4b360 |
6 | use List::MoreUtils (); |
9882ca98 |
7 | use Scalar::Util qw( blessed looks_like_number reftype ); |
06d02aac |
8 | |
9 | sub type { goto &Moose::Util::TypeConstraints::type } |
10 | sub subtype { goto &Moose::Util::TypeConstraints::subtype } |
11 | sub as { goto &Moose::Util::TypeConstraints::as } |
12 | sub where (&) { goto &Moose::Util::TypeConstraints::where } |
13 | sub optimize_as (&) { goto &Moose::Util::TypeConstraints::optimize_as } |
4e36cf24 |
14 | sub inline_as (&) { goto &Moose::Util::TypeConstraints::inline_as } |
06d02aac |
15 | |
16 | sub define_builtins { |
17 | my $registry = shift; |
18 | |
4e36cf24 |
19 | type 'Any' # meta-type including all |
20 | => where {1} |
21 | => inline_as { '1' }; |
06d02aac |
22 | |
d5807e74 |
23 | subtype 'Item' # base type |
94ab1609 |
24 | => as 'Any' |
25 | => inline_as { '1' }; |
4e36cf24 |
26 | |
27 | subtype 'Undef' |
28 | => as 'Item' |
29 | => where { !defined($_) } |
d5807e74 |
30 | => inline_as { |
31 | $_[0]->parent()->_inline_check($_[1]) |
32 | . ' && !defined(' . $_[1] . ')' |
33 | }; |
4e36cf24 |
34 | |
35 | subtype 'Defined' |
36 | => as 'Item' |
37 | => where { defined($_) } |
d5807e74 |
38 | => inline_as { |
39 | $_[0]->parent()->_inline_check($_[1]) |
40 | . ' && defined(' . $_[1] . ')' |
41 | }; |
06d02aac |
42 | |
43 | subtype 'Bool' |
44 | => as 'Item' |
4e36cf24 |
45 | => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' } |
3975b592 |
46 | => inline_as { |
d5807e74 |
47 | $_[0]->parent()->_inline_check($_[1]) |
48 | . ' && (' |
49 | . '!defined(' . $_[1] . ') ' |
50 | . '|| ' . $_[1] . ' eq "" ' |
51 | . '|| "' . $_[1] . '" eq "1" ' |
52 | . '|| "' . $_[1] . '" eq "0"' |
53 | . ')' |
3975b592 |
54 | }; |
06d02aac |
55 | |
56 | subtype 'Value' |
57 | => as 'Defined' |
58 | => where { !ref($_) } |
d5807e74 |
59 | => inline_as { |
60 | $_[0]->parent()->_inline_check($_[1]) |
61 | . ' && !ref(' . $_[1] . ')' |
62 | }; |
06d02aac |
63 | |
64 | subtype 'Ref' |
65 | => as 'Defined' |
66 | => where { ref($_) } |
d5807e74 |
67 | # no need to call parent - ref also checks for definedness |
3975b592 |
68 | => inline_as { 'ref(' . $_[1] . ')' }; |
06d02aac |
69 | |
70 | subtype 'Str' |
71 | => as 'Value' |
a79639df |
72 | => where { ref(\$_) eq 'SCALAR' || ref(\(my $val = $_)) eq 'SCALAR' } |
4e36cf24 |
73 | => inline_as { |
d5807e74 |
74 | $_[0]->parent()->_inline_check($_[1]) |
75 | . ' && (' |
76 | . 'ref(\\' . $_[1] . ') eq "SCALAR"' |
77 | . ' || ref(\\(my $val = ' . $_[1] . ')) eq "SCALAR"' |
78 | . ')' |
4e36cf24 |
79 | }; |
06d02aac |
80 | |
b47527bf |
81 | my $value_type = Moose::Util::TypeConstraints::find_type_constraint('Value'); |
06d02aac |
82 | subtype 'Num' |
83 | => as 'Str' |
84 | => where { Scalar::Util::looks_like_number($_) } |
3975b592 |
85 | => inline_as { |
d5807e74 |
86 | # the long Str tests are redundant here |
b47527bf |
87 | $value_type->_inline_check($_[1]) |
d5807e74 |
88 | . ' && Scalar::Util::looks_like_number(' . $_[1] . ')' |
3975b592 |
89 | }; |
06d02aac |
90 | |
91 | subtype 'Int' |
92 | => as 'Num' |
a79639df |
93 | => where { (my $val = $_) =~ /\A-?[0-9]+\z/ } |
4e36cf24 |
94 | => inline_as { |
b47527bf |
95 | $value_type->_inline_check($_[1]) |
d5807e74 |
96 | . ' && (my $val = ' . $_[1] . ') =~ /\A-?[0-9]+\z/' |
4e36cf24 |
97 | }; |
06d02aac |
98 | |
99 | subtype 'CodeRef' |
100 | => as 'Ref' |
101 | => where { ref($_) eq 'CODE' } |
3975b592 |
102 | => inline_as { 'ref(' . $_[1] . ') eq "CODE"' }; |
06d02aac |
103 | |
104 | subtype 'RegexpRef' |
105 | => as 'Ref' |
9882ca98 |
106 | => where( \&_RegexpRef ) |
3975b592 |
107 | => inline_as { |
108 | 'Moose::Util::TypeConstraints::Builtins::_RegexpRef(' . $_[1] . ')' |
109 | }; |
06d02aac |
110 | |
111 | subtype 'GlobRef' |
112 | => as 'Ref' |
113 | => where { ref($_) eq 'GLOB' } |
3975b592 |
114 | => inline_as { 'ref(' . $_[1] . ') eq "GLOB"' }; |
06d02aac |
115 | |
116 | # NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a |
117 | # filehandle |
118 | subtype 'FileHandle' |
94ab1609 |
119 | => as 'Ref' |
06d02aac |
120 | => where { |
188ba420 |
121 | (ref($_) eq "GLOB" && Scalar::Util::openhandle($_)) |
122 | || (blessed($_) && $_->isa("IO::Handle")); |
06d02aac |
123 | } |
4e36cf24 |
124 | => inline_as { |
3975b592 |
125 | '(ref(' . $_[1] . ') eq "GLOB" ' |
d5807e74 |
126 | . '&& Scalar::Util::openhandle(' . $_[1] . ')) ' |
127 | . '|| (Scalar::Util::blessed(' . $_[1] . ') ' |
128 | . '&& ' . $_[1] . '->isa("IO::Handle"))' |
4e36cf24 |
129 | }; |
06d02aac |
130 | |
131 | subtype 'Object' |
132 | => as 'Ref' |
133 | => where { blessed($_) } |
3975b592 |
134 | => inline_as { 'Scalar::Util::blessed(' . $_[1] . ')' }; |
06d02aac |
135 | |
136 | # This type is deprecated. |
137 | subtype 'Role' |
138 | => as 'Object' |
43837b8a |
139 | => where { $_->can('does') }; |
06d02aac |
140 | |
141 | subtype 'ClassName' |
142 | => as 'Str' |
143 | => where { Class::MOP::is_class_loaded($_) } |
d5807e74 |
144 | # the long Str tests are redundant here |
3975b592 |
145 | => inline_as { 'Class::MOP::is_class_loaded(' . $_[1] . ')' }; |
06d02aac |
146 | |
147 | subtype 'RoleName' |
148 | => as 'ClassName' |
149 | => where { |
150 | (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role'); |
151 | } |
4e36cf24 |
152 | => inline_as { |
d5807e74 |
153 | $_[0]->parent()->_inline_check($_[1]) |
154 | . ' && do {' |
155 | . 'my $meta = Class::MOP::class_of(' . $_[1] . ');' |
156 | . '$meta && $meta->isa("Moose::Meta::Role");' |
157 | . '}' |
4e36cf24 |
158 | }; |
06d02aac |
159 | |
160 | $registry->add_type_constraint( |
161 | Moose::Meta::TypeConstraint::Parameterizable->new( |
162 | name => 'ScalarRef', |
163 | package_defined_in => __PACKAGE__, |
164 | parent => |
165 | Moose::Util::TypeConstraints::find_type_constraint('Ref'), |
166 | constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' }, |
06d02aac |
167 | constraint_generator => sub { |
168 | my $type_parameter = shift; |
169 | my $check = $type_parameter->_compiled_type_constraint; |
170 | return sub { |
171 | return $check->( ${$_} ); |
172 | }; |
7fb4b360 |
173 | }, |
3975b592 |
174 | inlined => sub { |
175 | 'ref(' . $_[1] . ') eq "SCALAR" ' |
176 | . '|| ref(' . $_[1] . ') eq "REF"' |
177 | }, |
7fb4b360 |
178 | inline_generator => sub { |
964294c1 |
179 | my $self = shift; |
7fb4b360 |
180 | my $type_parameter = shift; |
181 | my $val = shift; |
3975b592 |
182 | '(ref(' . $val . ') eq "SCALAR" || ref(' . $val . ') eq "REF") ' |
183 | . '&& ' . $type_parameter->_inline_check('${(' . $val . ')}') |
7fb4b360 |
184 | }, |
06d02aac |
185 | ) |
186 | ); |
187 | |
188 | $registry->add_type_constraint( |
189 | Moose::Meta::TypeConstraint::Parameterizable->new( |
190 | name => 'ArrayRef', |
191 | package_defined_in => __PACKAGE__, |
192 | parent => |
193 | Moose::Util::TypeConstraints::find_type_constraint('Ref'), |
194 | constraint => sub { ref($_) eq 'ARRAY' }, |
06d02aac |
195 | constraint_generator => sub { |
196 | my $type_parameter = shift; |
197 | my $check = $type_parameter->_compiled_type_constraint; |
198 | return sub { |
199 | foreach my $x (@$_) { |
200 | ( $check->($x) ) || return; |
201 | } |
202 | 1; |
203 | } |
7fb4b360 |
204 | }, |
3975b592 |
205 | inlined => sub { 'ref(' . $_[1] . ') eq "ARRAY"' }, |
7fb4b360 |
206 | inline_generator => sub { |
964294c1 |
207 | my $self = shift; |
7fb4b360 |
208 | my $type_parameter = shift; |
209 | my $val = shift; |
d6874ac6 |
210 | |
211 | 'do {' |
212 | . 'my $check = ' . $val . ';' |
213 | . 'ref($check) eq "ARRAY" ' |
214 | . '&& &List::MoreUtils::all(' |
215 | . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, ' |
216 | . '@{$check}' |
217 | . ')' |
218 | . '}'; |
7fb4b360 |
219 | }, |
06d02aac |
220 | ) |
221 | ); |
222 | |
223 | $registry->add_type_constraint( |
224 | Moose::Meta::TypeConstraint::Parameterizable->new( |
225 | name => 'HashRef', |
226 | package_defined_in => __PACKAGE__, |
227 | parent => |
228 | Moose::Util::TypeConstraints::find_type_constraint('Ref'), |
229 | constraint => sub { ref($_) eq 'HASH' }, |
06d02aac |
230 | constraint_generator => sub { |
231 | my $type_parameter = shift; |
232 | my $check = $type_parameter->_compiled_type_constraint; |
233 | return sub { |
234 | foreach my $x ( values %$_ ) { |
235 | ( $check->($x) ) || return; |
236 | } |
237 | 1; |
238 | } |
7fb4b360 |
239 | }, |
3975b592 |
240 | inlined => sub { 'ref(' . $_[1] . ') eq "HASH"' }, |
7fb4b360 |
241 | inline_generator => sub { |
964294c1 |
242 | my $self = shift; |
7fb4b360 |
243 | my $type_parameter = shift; |
244 | my $val = shift; |
d6874ac6 |
245 | |
246 | 'do {' |
247 | . 'my $check = ' . $val . ';' |
248 | . 'ref($check) eq "HASH" ' |
249 | . '&& &List::MoreUtils::all(' |
250 | . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, ' |
251 | . 'values %{$check}' |
252 | . ')' |
253 | . '}'; |
7fb4b360 |
254 | }, |
06d02aac |
255 | ) |
256 | ); |
257 | |
258 | $registry->add_type_constraint( |
259 | Moose::Meta::TypeConstraint::Parameterizable->new( |
260 | name => 'Maybe', |
261 | package_defined_in => __PACKAGE__, |
262 | parent => |
263 | Moose::Util::TypeConstraints::find_type_constraint('Item'), |
264 | constraint => sub {1}, |
265 | constraint_generator => sub { |
266 | my $type_parameter = shift; |
267 | my $check = $type_parameter->_compiled_type_constraint; |
268 | return sub { |
269 | return 1 if not( defined($_) ) || $check->($_); |
270 | return; |
271 | } |
7fb4b360 |
272 | }, |
273 | inlined => sub {'1'}, |
274 | inline_generator => sub { |
964294c1 |
275 | my $self = shift; |
7fb4b360 |
276 | my $type_parameter = shift; |
277 | my $val = shift; |
3975b592 |
278 | '!defined(' . $val . ') ' |
279 | . '|| (' . $type_parameter->_inline_check($val) . ')' |
7fb4b360 |
280 | }, |
06d02aac |
281 | ) |
282 | ); |
283 | } |
284 | |
285 | 1; |
297899d1 |
286 | |
287 | __END__ |
288 | |
289 | =pod |
290 | |
291 | =for pod_coverage_needs_some_pod |
292 | |
293 | =cut |
294 | |