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