Commit | Line | Data |
a15dff8d |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a28e50e4 |
6 | use Test::More; |
a15dff8d |
7 | |
94ab1609 |
8 | use IO::File; |
964294c1 |
9 | use Moose::Util::TypeConstraints; |
94ab1609 |
10 | use Scalar::Util qw( blessed openhandle ); |
a15dff8d |
11 | |
94ab1609 |
12 | my $ZERO = 0; |
13 | my $ONE = 1; |
14 | my $INT = 100; |
15 | my $NEG_INT = -100; |
16 | my $NUM = 42.42; |
17 | my $NEG_NUM = -42.42; |
18 | |
19 | my $EMPTY_STRING = q{}; |
20 | my $STRING = 'foo'; |
21 | my $NUM_IN_STRING = 'has 42 in it'; |
743ec002 |
22 | my $INT_WITH_NL1 = "1\n"; |
23 | my $INT_WITH_NL2 = "\n1"; |
94ab1609 |
24 | |
25 | my $SCALAR_REF = \( my $var ); |
26 | my $SCALAR_REF_REF = \$SCALAR_REF; |
27 | my $ARRAY_REF = []; |
28 | my $HASH_REF = {}; |
29 | my $CODE_REF = sub { }; |
30 | |
4ba256d5 |
31 | my $GLOB = do { no warnings 'once'; *GLOB_REF }; |
94ab1609 |
32 | my $GLOB_REF = \$GLOB; |
33 | |
34 | open my $FH, '<', $0 or die "Could not open $0 for the test"; |
a15dff8d |
35 | |
94ab1609 |
36 | my $FH_OBJECT = IO::File->new( $0, 'r' ) |
37 | or die "Could not open $0 for the test"; |
38 | |
4ba256d5 |
39 | my $REGEX = qr/../; |
40 | my $REGEX_OBJ = bless qr/../, 'BlessedQR'; |
6b5fae23 |
41 | my $FAKE_REGEX = bless {}, 'Regexp'; |
94ab1609 |
42 | |
43 | my $OBJECT = bless {}, 'Foo'; |
44 | |
45 | my $UNDEF = undef; |
5030b52f |
46 | |
47 | { |
94ab1609 |
48 | package Thing; |
5d776bdf |
49 | |
94ab1609 |
50 | sub foo { } |
5030b52f |
51 | } |
52 | |
94ab1609 |
53 | my $CLASS_NAME = 'Thing'; |
f0cac16f |
54 | |
55 | { |
94ab1609 |
56 | package Role; |
57 | use Moose::Role; |
58 | |
59 | sub foo { } |
f0cac16f |
60 | } |
61 | |
94ab1609 |
62 | my $ROLE_NAME = 'Role'; |
63 | |
64 | my %tests = ( |
65 | Any => { |
66 | accept => [ |
67 | $ZERO, |
68 | $ONE, |
69 | $INT, |
70 | $NEG_INT, |
71 | $NUM, |
72 | $NEG_NUM, |
73 | $EMPTY_STRING, |
74 | $STRING, |
75 | $NUM_IN_STRING, |
743ec002 |
76 | $INT_WITH_NL1, |
77 | $INT_WITH_NL2, |
94ab1609 |
78 | $SCALAR_REF, |
79 | $SCALAR_REF_REF, |
80 | $ARRAY_REF, |
81 | $HASH_REF, |
82 | $CODE_REF, |
83 | $GLOB, |
84 | $GLOB_REF, |
85 | $FH, |
86 | $FH_OBJECT, |
87 | $REGEX, |
88 | $REGEX_OBJ, |
6b5fae23 |
89 | $FAKE_REGEX, |
94ab1609 |
90 | $OBJECT, |
91 | $UNDEF, |
92 | ], |
93 | }, |
94 | Item => { |
95 | accept => [ |
96 | $ZERO, |
97 | $ONE, |
98 | $INT, |
99 | $NEG_INT, |
100 | $NUM, |
101 | $NEG_NUM, |
102 | $EMPTY_STRING, |
103 | $STRING, |
104 | $NUM_IN_STRING, |
743ec002 |
105 | $INT_WITH_NL1, |
106 | $INT_WITH_NL2, |
94ab1609 |
107 | $SCALAR_REF, |
108 | $SCALAR_REF_REF, |
109 | $ARRAY_REF, |
110 | $HASH_REF, |
111 | $CODE_REF, |
112 | $GLOB, |
113 | $GLOB_REF, |
114 | $FH, |
115 | $FH_OBJECT, |
116 | $REGEX, |
117 | $REGEX_OBJ, |
6b5fae23 |
118 | $FAKE_REGEX, |
94ab1609 |
119 | $OBJECT, |
120 | $UNDEF, |
121 | ], |
122 | }, |
123 | Defined => { |
124 | accept => [ |
125 | $ZERO, |
126 | $ONE, |
127 | $INT, |
128 | $NEG_INT, |
129 | $NUM, |
130 | $NEG_NUM, |
131 | $EMPTY_STRING, |
132 | $STRING, |
133 | $NUM_IN_STRING, |
743ec002 |
134 | $INT_WITH_NL1, |
135 | $INT_WITH_NL2, |
94ab1609 |
136 | $SCALAR_REF, |
137 | $SCALAR_REF_REF, |
138 | $ARRAY_REF, |
139 | $HASH_REF, |
140 | $CODE_REF, |
141 | $GLOB, |
142 | $GLOB_REF, |
143 | $FH, |
144 | $FH_OBJECT, |
145 | $REGEX, |
146 | $REGEX_OBJ, |
6b5fae23 |
147 | $FAKE_REGEX, |
94ab1609 |
148 | $OBJECT, |
149 | ], |
150 | reject => [ |
151 | $UNDEF, |
152 | ], |
153 | }, |
154 | Undef => { |
155 | accept => [ |
156 | $UNDEF, |
157 | ], |
158 | reject => [ |
159 | $ZERO, |
160 | $ONE, |
161 | $INT, |
162 | $NEG_INT, |
163 | $NUM, |
164 | $NEG_NUM, |
165 | $EMPTY_STRING, |
166 | $STRING, |
167 | $NUM_IN_STRING, |
743ec002 |
168 | $INT_WITH_NL1, |
169 | $INT_WITH_NL2, |
94ab1609 |
170 | $SCALAR_REF, |
171 | $SCALAR_REF_REF, |
172 | $ARRAY_REF, |
173 | $HASH_REF, |
174 | $CODE_REF, |
175 | $GLOB, |
176 | $GLOB_REF, |
177 | $FH, |
178 | $FH_OBJECT, |
179 | $REGEX, |
180 | $REGEX_OBJ, |
6b5fae23 |
181 | $FAKE_REGEX, |
94ab1609 |
182 | $OBJECT, |
183 | ], |
184 | }, |
185 | Bool => { |
186 | accept => [ |
187 | $ZERO, |
188 | $ONE, |
189 | $EMPTY_STRING, |
190 | $UNDEF, |
191 | ], |
192 | reject => [ |
193 | $INT, |
194 | $NEG_INT, |
195 | $NUM, |
196 | $NEG_NUM, |
197 | $STRING, |
198 | $NUM_IN_STRING, |
743ec002 |
199 | $INT_WITH_NL1, |
200 | $INT_WITH_NL2, |
94ab1609 |
201 | $SCALAR_REF, |
202 | $SCALAR_REF_REF, |
203 | $ARRAY_REF, |
204 | $HASH_REF, |
205 | $CODE_REF, |
206 | $GLOB, |
207 | $GLOB_REF, |
208 | $FH, |
209 | $FH_OBJECT, |
210 | $REGEX, |
211 | $REGEX_OBJ, |
6b5fae23 |
212 | $FAKE_REGEX, |
94ab1609 |
213 | $OBJECT, |
214 | ], |
215 | }, |
7fb4b360 |
216 | Maybe => { |
217 | accept => [ |
218 | $ZERO, |
219 | $ONE, |
220 | $INT, |
221 | $NEG_INT, |
222 | $NUM, |
223 | $NEG_NUM, |
224 | $EMPTY_STRING, |
225 | $STRING, |
226 | $NUM_IN_STRING, |
743ec002 |
227 | $INT_WITH_NL1, |
228 | $INT_WITH_NL2, |
7fb4b360 |
229 | $SCALAR_REF, |
230 | $SCALAR_REF_REF, |
231 | $ARRAY_REF, |
232 | $HASH_REF, |
233 | $CODE_REF, |
234 | $GLOB, |
235 | $GLOB_REF, |
236 | $FH, |
237 | $FH_OBJECT, |
238 | $REGEX, |
239 | $REGEX_OBJ, |
6b5fae23 |
240 | $FAKE_REGEX, |
7fb4b360 |
241 | $OBJECT, |
242 | $UNDEF, |
243 | ], |
244 | }, |
94ab1609 |
245 | Value => { |
246 | accept => [ |
247 | $ZERO, |
248 | $ONE, |
249 | $INT, |
250 | $NEG_INT, |
251 | $NUM, |
252 | $NEG_NUM, |
253 | $EMPTY_STRING, |
254 | $STRING, |
255 | $NUM_IN_STRING, |
743ec002 |
256 | $INT_WITH_NL1, |
257 | $INT_WITH_NL2, |
94ab1609 |
258 | $GLOB, |
259 | ], |
260 | reject => [ |
261 | $SCALAR_REF, |
262 | $SCALAR_REF_REF, |
263 | $ARRAY_REF, |
264 | $HASH_REF, |
265 | $CODE_REF, |
266 | $GLOB_REF, |
267 | $FH, |
268 | $FH_OBJECT, |
269 | $REGEX, |
270 | $REGEX_OBJ, |
6b5fae23 |
271 | $FAKE_REGEX, |
94ab1609 |
272 | $OBJECT, |
273 | $UNDEF, |
274 | ], |
275 | }, |
276 | Ref => { |
277 | accept => [ |
278 | $SCALAR_REF, |
279 | $SCALAR_REF_REF, |
280 | $ARRAY_REF, |
281 | $HASH_REF, |
282 | $CODE_REF, |
283 | $GLOB_REF, |
284 | $FH, |
285 | $FH_OBJECT, |
286 | $REGEX, |
287 | $REGEX_OBJ, |
6b5fae23 |
288 | $FAKE_REGEX, |
94ab1609 |
289 | $OBJECT, |
290 | ], |
291 | reject => [ |
292 | $ZERO, |
293 | $ONE, |
294 | $INT, |
295 | $NEG_INT, |
296 | $NUM, |
297 | $NEG_NUM, |
298 | $EMPTY_STRING, |
299 | $STRING, |
300 | $NUM_IN_STRING, |
743ec002 |
301 | $INT_WITH_NL1, |
302 | $INT_WITH_NL2, |
94ab1609 |
303 | $GLOB, |
304 | $UNDEF, |
305 | ], |
306 | }, |
307 | Num => { |
308 | accept => [ |
309 | $ZERO, |
310 | $ONE, |
311 | $INT, |
312 | $NEG_INT, |
313 | $NUM, |
314 | $NEG_NUM, |
743ec002 |
315 | $INT_WITH_NL1, |
316 | $INT_WITH_NL2, |
94ab1609 |
317 | ], |
318 | reject => [ |
319 | $EMPTY_STRING, |
320 | $STRING, |
321 | $NUM_IN_STRING, |
322 | $SCALAR_REF, |
323 | $SCALAR_REF_REF, |
324 | $ARRAY_REF, |
325 | $HASH_REF, |
326 | $CODE_REF, |
327 | $GLOB, |
328 | $GLOB_REF, |
329 | $FH, |
330 | $FH_OBJECT, |
331 | $REGEX, |
332 | $REGEX_OBJ, |
6b5fae23 |
333 | $FAKE_REGEX, |
94ab1609 |
334 | $OBJECT, |
335 | $UNDEF, |
336 | ], |
337 | }, |
338 | Int => { |
339 | accept => [ |
340 | $ZERO, |
341 | $ONE, |
342 | $INT, |
343 | $NEG_INT, |
344 | ], |
345 | reject => [ |
346 | $NUM, |
347 | $NEG_NUM, |
348 | $EMPTY_STRING, |
349 | $STRING, |
350 | $NUM_IN_STRING, |
743ec002 |
351 | $INT_WITH_NL1, |
352 | $INT_WITH_NL2, |
94ab1609 |
353 | $SCALAR_REF, |
354 | $SCALAR_REF_REF, |
355 | $ARRAY_REF, |
356 | $HASH_REF, |
357 | $CODE_REF, |
358 | $GLOB, |
359 | $GLOB_REF, |
360 | $FH, |
361 | $FH_OBJECT, |
362 | $REGEX, |
363 | $REGEX_OBJ, |
6b5fae23 |
364 | $FAKE_REGEX, |
94ab1609 |
365 | $OBJECT, |
366 | $UNDEF, |
367 | ], |
368 | }, |
369 | Str => { |
370 | accept => [ |
371 | $ZERO, |
372 | $ONE, |
373 | $INT, |
374 | $NEG_INT, |
375 | $NUM, |
376 | $NEG_NUM, |
377 | $EMPTY_STRING, |
378 | $STRING, |
379 | $NUM_IN_STRING, |
743ec002 |
380 | $INT_WITH_NL1, |
381 | $INT_WITH_NL2, |
94ab1609 |
382 | ], |
383 | reject => [ |
384 | $SCALAR_REF, |
385 | $SCALAR_REF_REF, |
386 | $ARRAY_REF, |
387 | $HASH_REF, |
388 | $CODE_REF, |
389 | $GLOB, |
390 | $GLOB_REF, |
391 | $FH, |
392 | $FH_OBJECT, |
393 | $REGEX, |
394 | $REGEX_OBJ, |
6b5fae23 |
395 | $FAKE_REGEX, |
94ab1609 |
396 | $OBJECT, |
397 | $UNDEF, |
398 | ], |
399 | }, |
400 | ScalarRef => { |
401 | accept => [ |
402 | $SCALAR_REF, |
403 | $SCALAR_REF_REF, |
404 | ], |
405 | reject => [ |
406 | $ZERO, |
407 | $ONE, |
408 | $INT, |
409 | $NEG_INT, |
410 | $NUM, |
411 | $NEG_NUM, |
412 | $EMPTY_STRING, |
413 | $STRING, |
414 | $NUM_IN_STRING, |
743ec002 |
415 | $INT_WITH_NL1, |
416 | $INT_WITH_NL2, |
94ab1609 |
417 | $ARRAY_REF, |
418 | $HASH_REF, |
419 | $CODE_REF, |
420 | $GLOB, |
421 | $GLOB_REF, |
422 | $FH, |
423 | $FH_OBJECT, |
424 | $REGEX, |
425 | $REGEX_OBJ, |
6b5fae23 |
426 | $FAKE_REGEX, |
94ab1609 |
427 | $OBJECT, |
428 | $UNDEF, |
429 | ], |
430 | }, |
431 | ArrayRef => { |
432 | accept => [ |
433 | $ARRAY_REF, |
434 | ], |
435 | reject => [ |
436 | $ZERO, |
437 | $ONE, |
438 | $INT, |
439 | $NEG_INT, |
440 | $NUM, |
441 | $NEG_NUM, |
442 | $EMPTY_STRING, |
443 | $STRING, |
444 | $NUM_IN_STRING, |
743ec002 |
445 | $INT_WITH_NL1, |
446 | $INT_WITH_NL2, |
94ab1609 |
447 | $SCALAR_REF, |
448 | $SCALAR_REF_REF, |
449 | $HASH_REF, |
450 | $CODE_REF, |
451 | $GLOB, |
452 | $GLOB_REF, |
453 | $FH, |
454 | $FH_OBJECT, |
455 | $REGEX, |
456 | $REGEX_OBJ, |
6b5fae23 |
457 | $FAKE_REGEX, |
94ab1609 |
458 | $OBJECT, |
459 | $UNDEF, |
460 | ], |
461 | }, |
462 | HashRef => { |
463 | accept => [ |
464 | $HASH_REF, |
465 | ], |
466 | reject => [ |
467 | $ZERO, |
468 | $ONE, |
469 | $INT, |
470 | $NEG_INT, |
471 | $NUM, |
472 | $NEG_NUM, |
473 | $EMPTY_STRING, |
474 | $STRING, |
475 | $NUM_IN_STRING, |
743ec002 |
476 | $INT_WITH_NL1, |
477 | $INT_WITH_NL2, |
94ab1609 |
478 | $SCALAR_REF, |
479 | $SCALAR_REF_REF, |
480 | $ARRAY_REF, |
481 | $CODE_REF, |
482 | $GLOB, |
483 | $GLOB_REF, |
484 | $FH, |
485 | $FH_OBJECT, |
486 | $REGEX, |
487 | $REGEX_OBJ, |
6b5fae23 |
488 | $FAKE_REGEX, |
94ab1609 |
489 | $OBJECT, |
490 | $UNDEF, |
491 | ], |
492 | }, |
493 | CodeRef => { |
494 | accept => [ |
495 | $CODE_REF, |
496 | ], |
497 | reject => [ |
498 | $ZERO, |
499 | $ONE, |
500 | $INT, |
501 | $NEG_INT, |
502 | $NUM, |
503 | $NEG_NUM, |
504 | $EMPTY_STRING, |
505 | $STRING, |
506 | $NUM_IN_STRING, |
743ec002 |
507 | $INT_WITH_NL1, |
508 | $INT_WITH_NL2, |
94ab1609 |
509 | $SCALAR_REF, |
510 | $SCALAR_REF_REF, |
511 | $ARRAY_REF, |
512 | $HASH_REF, |
513 | $GLOB, |
514 | $GLOB_REF, |
515 | $FH, |
516 | $FH_OBJECT, |
517 | $REGEX, |
518 | $REGEX_OBJ, |
6b5fae23 |
519 | $FAKE_REGEX, |
94ab1609 |
520 | $OBJECT, |
521 | $UNDEF, |
522 | ], |
523 | }, |
524 | RegexpRef => { |
525 | accept => [ |
526 | $REGEX, |
527 | $REGEX_OBJ, |
528 | ], |
529 | reject => [ |
530 | $ZERO, |
531 | $ONE, |
532 | $INT, |
533 | $NEG_INT, |
534 | $NUM, |
535 | $NEG_NUM, |
536 | $EMPTY_STRING, |
537 | $STRING, |
538 | $NUM_IN_STRING, |
743ec002 |
539 | $INT_WITH_NL1, |
540 | $INT_WITH_NL2, |
94ab1609 |
541 | $SCALAR_REF, |
542 | $SCALAR_REF_REF, |
543 | $ARRAY_REF, |
544 | $HASH_REF, |
545 | $CODE_REF, |
546 | $GLOB, |
547 | $GLOB_REF, |
548 | $FH, |
549 | $FH_OBJECT, |
550 | $OBJECT, |
551 | $UNDEF, |
6b5fae23 |
552 | $FAKE_REGEX, |
94ab1609 |
553 | ], |
554 | }, |
555 | GlobRef => { |
556 | accept => [ |
557 | $GLOB_REF, |
558 | $FH, |
559 | ], |
560 | reject => [ |
561 | $ZERO, |
562 | $ONE, |
563 | $INT, |
564 | $NEG_INT, |
565 | $NUM, |
566 | $NEG_NUM, |
567 | $EMPTY_STRING, |
568 | $STRING, |
569 | $NUM_IN_STRING, |
743ec002 |
570 | $INT_WITH_NL1, |
571 | $INT_WITH_NL2, |
94ab1609 |
572 | $SCALAR_REF, |
573 | $SCALAR_REF_REF, |
574 | $ARRAY_REF, |
575 | $HASH_REF, |
576 | $CODE_REF, |
577 | $GLOB, |
578 | $FH_OBJECT, |
579 | $OBJECT, |
580 | $REGEX, |
581 | $REGEX_OBJ, |
6b5fae23 |
582 | $FAKE_REGEX, |
94ab1609 |
583 | $UNDEF, |
584 | ], |
585 | }, |
586 | FileHandle => { |
587 | accept => [ |
588 | $FH, |
589 | $FH_OBJECT, |
590 | ], |
591 | reject => [ |
592 | $ZERO, |
593 | $ONE, |
594 | $INT, |
595 | $NEG_INT, |
596 | $NUM, |
597 | $NEG_NUM, |
598 | $EMPTY_STRING, |
599 | $STRING, |
600 | $NUM_IN_STRING, |
743ec002 |
601 | $INT_WITH_NL1, |
602 | $INT_WITH_NL2, |
94ab1609 |
603 | $SCALAR_REF, |
604 | $SCALAR_REF_REF, |
605 | $ARRAY_REF, |
606 | $HASH_REF, |
607 | $CODE_REF, |
608 | $GLOB, |
609 | $GLOB_REF, |
610 | $OBJECT, |
611 | $REGEX, |
612 | $REGEX_OBJ, |
6b5fae23 |
613 | $FAKE_REGEX, |
94ab1609 |
614 | $UNDEF, |
615 | ], |
616 | }, |
617 | Object => { |
618 | accept => [ |
619 | $FH_OBJECT, |
620 | $REGEX, |
621 | $REGEX_OBJ, |
6b5fae23 |
622 | $FAKE_REGEX, |
94ab1609 |
623 | $OBJECT, |
624 | ], |
625 | reject => [ |
626 | $ZERO, |
627 | $ONE, |
628 | $INT, |
629 | $NEG_INT, |
630 | $NUM, |
631 | $NEG_NUM, |
632 | $EMPTY_STRING, |
633 | $STRING, |
634 | $NUM_IN_STRING, |
743ec002 |
635 | $INT_WITH_NL1, |
636 | $INT_WITH_NL2, |
94ab1609 |
637 | $SCALAR_REF, |
638 | $SCALAR_REF_REF, |
639 | $ARRAY_REF, |
640 | $HASH_REF, |
641 | $CODE_REF, |
642 | $GLOB, |
643 | $GLOB_REF, |
644 | $FH, |
645 | $UNDEF, |
646 | ], |
647 | }, |
648 | ClassName => { |
649 | accept => [ |
650 | $CLASS_NAME, |
651 | $ROLE_NAME, |
652 | ], |
653 | reject => [ |
654 | $ZERO, |
655 | $ONE, |
656 | $INT, |
657 | $NEG_INT, |
658 | $NUM, |
659 | $NEG_NUM, |
660 | $EMPTY_STRING, |
661 | $STRING, |
662 | $NUM_IN_STRING, |
743ec002 |
663 | $INT_WITH_NL1, |
664 | $INT_WITH_NL2, |
94ab1609 |
665 | $SCALAR_REF, |
666 | $SCALAR_REF_REF, |
667 | $ARRAY_REF, |
668 | $HASH_REF, |
669 | $CODE_REF, |
670 | $GLOB, |
671 | $GLOB_REF, |
672 | $FH, |
673 | $FH_OBJECT, |
674 | $REGEX, |
675 | $REGEX_OBJ, |
6b5fae23 |
676 | $FAKE_REGEX, |
94ab1609 |
677 | $OBJECT, |
678 | $UNDEF, |
679 | ], |
680 | }, |
681 | RoleName => { |
682 | accept => [ |
683 | $ROLE_NAME, |
684 | ], |
685 | reject => [ |
686 | $CLASS_NAME, |
687 | $ZERO, |
688 | $ONE, |
689 | $INT, |
690 | $NEG_INT, |
691 | $NUM, |
692 | $NEG_NUM, |
693 | $EMPTY_STRING, |
694 | $STRING, |
695 | $NUM_IN_STRING, |
743ec002 |
696 | $INT_WITH_NL1, |
697 | $INT_WITH_NL2, |
94ab1609 |
698 | $SCALAR_REF, |
699 | $SCALAR_REF_REF, |
700 | $ARRAY_REF, |
701 | $HASH_REF, |
702 | $CODE_REF, |
703 | $GLOB, |
704 | $GLOB_REF, |
705 | $FH, |
706 | $FH_OBJECT, |
707 | $REGEX, |
708 | $REGEX_OBJ, |
6b5fae23 |
709 | $FAKE_REGEX, |
94ab1609 |
710 | $OBJECT, |
711 | $UNDEF, |
712 | ], |
713 | }, |
714 | ); |
715 | |
716 | for my $name ( sort keys %tests ) { |
964294c1 |
717 | test_constraint( $name, $tests{$name} ); |
718 | } |
719 | |
bb4cf777 |
720 | # We need to test that the Str constraint accepts the return val of substr() - |
721 | # which means passing that return val directly to the checking code |
722 | { |
723 | my $str = 'some string'; |
724 | |
725 | my $type = Moose::Util::TypeConstraints::find_type_constraint('Str'); |
726 | |
727 | my $unoptimized |
728 | = $type->has_parent |
729 | ? $type->_compile_subtype( $type->constraint ) |
730 | : $type->_compile_type( $type->constraint ); |
731 | |
732 | my $inlined; |
733 | { |
734 | local $@; |
735 | $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }'; |
736 | die $@ if $@; |
737 | } |
738 | |
739 | ok( |
740 | $type->check( substr( $str, 1, 3 ) ), |
741 | 'Str accepts return val from substr using ->check' |
742 | ); |
743 | ok( |
744 | $unoptimized->( substr( $str, 1, 3 ) ), |
745 | 'Str accepts return val from substr using unoptimized constraint' |
746 | ); |
747 | ok( |
748 | $inlined->( substr( $str, 1, 3 ) ), |
749 | 'Str accepts return val from substr using inlined constraint' |
750 | ); |
751 | |
752 | ok( |
753 | $type->check( substr( $str, 0, 0 ) ), |
754 | 'Str accepts empty return val from substr using ->check' |
755 | ); |
756 | ok( |
757 | $unoptimized->( substr( $str, 0, 0 ) ), |
758 | 'Str accepts empty return val from substr using unoptimized constraint' |
759 | ); |
760 | ok( |
761 | $inlined->( substr( $str, 0, 0 ) ), |
762 | 'Str accepts empty return val from substr using inlined constraint' |
763 | ); |
764 | } |
765 | |
964294c1 |
766 | { |
767 | my $class_tc = class_type('Thing'); |
768 | |
769 | test_constraint( |
770 | $class_tc, { |
771 | accept => [ |
772 | ( bless {}, 'Thing' ), |
773 | ], |
774 | reject => [ |
775 | 'Thing', |
776 | $ZERO, |
777 | $ONE, |
778 | $INT, |
779 | $NEG_INT, |
780 | $NUM, |
781 | $NEG_NUM, |
782 | $EMPTY_STRING, |
783 | $STRING, |
784 | $NUM_IN_STRING, |
743ec002 |
785 | $INT_WITH_NL1, |
786 | $INT_WITH_NL2, |
964294c1 |
787 | $SCALAR_REF, |
788 | $SCALAR_REF_REF, |
789 | $ARRAY_REF, |
790 | $HASH_REF, |
791 | $CODE_REF, |
792 | $GLOB, |
793 | $GLOB_REF, |
794 | $FH, |
795 | $FH_OBJECT, |
796 | $REGEX, |
797 | $REGEX_OBJ, |
6b5fae23 |
798 | $FAKE_REGEX, |
964294c1 |
799 | $OBJECT, |
800 | $UNDEF, |
801 | ], |
802 | } |
803 | ); |
804 | } |
805 | |
806 | { |
807 | package Duck; |
808 | |
743ec002 |
809 | sub quack { } |
810 | sub flap { } |
964294c1 |
811 | } |
812 | |
813 | { |
814 | package DuckLike; |
815 | |
743ec002 |
816 | sub quack { } |
817 | sub flap { } |
964294c1 |
818 | } |
819 | |
820 | { |
821 | package Bird; |
822 | |
743ec002 |
823 | sub flap { } |
964294c1 |
824 | } |
825 | |
826 | { |
827 | my @methods = qw( quack flap ); |
828 | duck_type 'Duck' => @methods; |
829 | |
830 | test_constraint( |
831 | 'Duck', { |
832 | accept => [ |
833 | ( bless {}, 'Duck' ), |
834 | ( bless {}, 'DuckLike' ), |
835 | ], |
836 | reject => [ |
964294c1 |
837 | $ZERO, |
838 | $ONE, |
839 | $INT, |
840 | $NEG_INT, |
841 | $NUM, |
842 | $NEG_NUM, |
843 | $EMPTY_STRING, |
844 | $STRING, |
845 | $NUM_IN_STRING, |
743ec002 |
846 | $INT_WITH_NL1, |
847 | $INT_WITH_NL2, |
964294c1 |
848 | $SCALAR_REF, |
849 | $SCALAR_REF_REF, |
850 | $ARRAY_REF, |
851 | $HASH_REF, |
852 | $CODE_REF, |
853 | $GLOB, |
854 | $GLOB_REF, |
855 | $FH, |
856 | $FH_OBJECT, |
857 | $REGEX, |
858 | $REGEX_OBJ, |
6b5fae23 |
859 | $FAKE_REGEX, |
964294c1 |
860 | $OBJECT, |
861 | ( bless {}, 'Bird' ), |
862 | $UNDEF, |
863 | ], |
864 | } |
865 | ); |
866 | } |
867 | |
868 | { |
869 | my @allowed = qw( bar baz quux ); |
870 | enum 'Enumerated' => @allowed; |
871 | |
872 | test_constraint( |
873 | 'Enumerated', { |
874 | accept => \@allowed, |
875 | reject => [ |
964294c1 |
876 | $ZERO, |
877 | $ONE, |
878 | $INT, |
879 | $NEG_INT, |
880 | $NUM, |
881 | $NEG_NUM, |
882 | $EMPTY_STRING, |
883 | $STRING, |
884 | $NUM_IN_STRING, |
743ec002 |
885 | $INT_WITH_NL1, |
886 | $INT_WITH_NL2, |
964294c1 |
887 | $SCALAR_REF, |
888 | $SCALAR_REF_REF, |
889 | $ARRAY_REF, |
890 | $HASH_REF, |
891 | $CODE_REF, |
892 | $GLOB, |
893 | $GLOB_REF, |
894 | $FH, |
895 | $FH_OBJECT, |
896 | $REGEX, |
897 | $REGEX_OBJ, |
6b5fae23 |
898 | $FAKE_REGEX, |
964294c1 |
899 | $OBJECT, |
900 | $UNDEF, |
901 | ], |
902 | } |
903 | ); |
904 | } |
905 | |
906 | { |
09532816 |
907 | my $union = Moose::Meta::TypeConstraint::Union->new( |
908 | type_constraints => [ |
909 | find_type_constraint('Int'), |
910 | find_type_constraint('Object'), |
911 | ], |
912 | ); |
913 | |
914 | test_constraint( |
915 | $union, { |
916 | accept => [ |
917 | $ZERO, |
918 | $ONE, |
919 | $INT, |
920 | $NEG_INT, |
921 | $FH_OBJECT, |
922 | $REGEX, |
923 | $REGEX_OBJ, |
6b5fae23 |
924 | $FAKE_REGEX, |
09532816 |
925 | $OBJECT, |
926 | ], |
927 | reject => [ |
928 | $NUM, |
929 | $NEG_NUM, |
930 | $EMPTY_STRING, |
931 | $STRING, |
932 | $NUM_IN_STRING, |
743ec002 |
933 | $INT_WITH_NL1, |
934 | $INT_WITH_NL2, |
09532816 |
935 | $SCALAR_REF, |
936 | $SCALAR_REF_REF, |
937 | $ARRAY_REF, |
938 | $HASH_REF, |
939 | $CODE_REF, |
940 | $GLOB, |
941 | $GLOB_REF, |
942 | $FH, |
943 | $UNDEF, |
944 | ], |
945 | } |
946 | ); |
947 | } |
948 | |
949 | { |
964294c1 |
950 | package DoesRole; |
951 | |
952 | use Moose; |
953 | |
954 | with 'Role'; |
955 | } |
956 | |
957 | # Test how $_ is used in XS implementation |
958 | { |
959 | local $_ = qr/./; |
960 | ok( |
961 | Moose::Util::TypeConstraints::Builtins::_RegexpRef(), |
962 | '$_ is RegexpRef' |
963 | ); |
964 | ok( |
965 | !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1), |
966 | '$_ is not read when param provided' |
967 | ); |
968 | |
969 | $_ = bless qr/./, 'Blessed'; |
970 | |
971 | ok( |
972 | Moose::Util::TypeConstraints::Builtins::_RegexpRef(), |
973 | '$_ is RegexpRef' |
974 | ); |
975 | |
976 | $_ = 42; |
977 | ok( |
978 | !Moose::Util::TypeConstraints::Builtins::_RegexpRef(), |
979 | '$_ is not RegexpRef' |
980 | ); |
981 | ok( |
982 | Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./), |
983 | '$_ is not read when param provided' |
984 | ); |
985 | } |
986 | |
987 | close $FH |
988 | or warn "Could not close the filehandle $0 for test"; |
989 | $FH_OBJECT->close |
990 | or warn "Could not close the filehandle $0 for test"; |
991 | |
992 | done_testing; |
993 | |
994 | sub test_constraint { |
995 | my $type = shift; |
996 | my $tests = shift; |
997 | |
998 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
999 | |
1000 | unless ( blessed $type ) { |
1001 | $type = Moose::Util::TypeConstraints::find_type_constraint($type) |
1002 | or BAIL_OUT("No such type $type!"); |
1003 | } |
1004 | |
1005 | my $name = $type->name; |
94ab1609 |
1006 | |
1007 | my $unoptimized |
1008 | = $type->has_parent |
1009 | ? $type->_compile_subtype( $type->constraint ) |
1010 | : $type->_compile_type( $type->constraint ); |
1011 | |
1012 | my $inlined; |
1013 | if ( $type->has_inlined_type_constraint ) { |
1014 | local $@; |
964294c1 |
1015 | $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }'; |
94ab1609 |
1016 | die $@ if $@; |
1017 | } |
1018 | |
964294c1 |
1019 | for my $accept ( @{ $tests->{accept} || [] } ) { |
94ab1609 |
1020 | my $described = describe($accept); |
1021 | ok( |
1022 | $type->check($accept), |
1023 | "$name accepts $described using ->check" |
1024 | ); |
1025 | ok( |
1026 | $unoptimized->($accept), |
1027 | "$name accepts $described using unoptimized constraint" |
1028 | ); |
1029 | if ($inlined) { |
1030 | ok( |
1031 | $inlined->($accept), |
1032 | "$name accepts $described using inlined constraint" |
1033 | ); |
1034 | } |
1035 | } |
1036 | |
964294c1 |
1037 | for my $reject ( @{ $tests->{reject} || [] } ) { |
94ab1609 |
1038 | my $described = describe($reject); |
1039 | ok( |
1040 | !$type->check($reject), |
1041 | "$name rejects $described using ->check" |
1042 | ); |
1043 | ok( |
1044 | !$unoptimized->($reject), |
1045 | "$name rejects $described using unoptimized constraint" |
1046 | ); |
1047 | if ($inlined) { |
1048 | ok( |
1049 | !$inlined->($reject), |
1050 | "$name rejects $described using inlined constraint" |
1051 | ); |
1052 | } |
1053 | } |
1054 | } |
1055 | |
94ab1609 |
1056 | sub describe { |
1057 | my $val = shift; |
1058 | |
1059 | return 'undef' unless defined $val; |
1060 | |
1061 | if ( !ref $val ) { |
1062 | return q{''} if $val eq q{}; |
94ab1609 |
1063 | |
743ec002 |
1064 | $val =~ s/\n/\\n/g; |
1065 | |
1066 | return $val; |
1067 | } |
94ab1609 |
1068 | |
1069 | return 'open filehandle' |
1070 | if openhandle $val && !blessed $val; |
1071 | |
964294c1 |
1072 | return blessed $val |
1073 | ? ( ref $val ) . ' object' |
1074 | : ( ref $val ) . ' reference'; |
94ab1609 |
1075 | } |