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