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