t/type_constraints/util_std_type_constraints.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::Fatal;
   7 use Test::More;
   8
   9 use Eval::Closure;
  10 use IO::File;
  11 use Moose::Util::TypeConstraints;
  12 use Scalar::Util qw( blessed openhandle );
  13
  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';
  24 my $INT_WITH_NL1  = "1\n";
  25 my $INT_WITH_NL2  = "\n1";
  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
  33 my $GLOB     = do { no warnings 'once'; *GLOB_REF };
  34 my $GLOB_REF = \$GLOB;
  35
  36 open my $FH, '<', $0 or die "Could not open $0 for the test";
  37
  38 my $FH_OBJECT = IO::File->new( $0, 'r' )
  39     or die "Could not open $0 for the test";
  40
  41 my $REGEX      = qr/../;
  42 my $REGEX_OBJ  = bless qr/../, 'BlessedQR';
  43 my $FAKE_REGEX = bless {}, 'Regexp';
  44
  45 my $OBJECT = bless {}, 'Foo';
  46
  47 my $UNDEF = undef;
  48
  49 {
  50     package Thing;
  51
  52     sub foo { }
  53 }
  54
  55 my $CLASS_NAME = 'Thing';
  56
  57 {
  58     package Role;
  59     use Moose::Role;
  60
  61     sub foo { }
  62 }
  63
  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,
  78             $INT_WITH_NL1,
  79             $INT_WITH_NL2,
  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,
  91             $FAKE_REGEX,
  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,
 107             $INT_WITH_NL1,
 108             $INT_WITH_NL2,
 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,
 120             $FAKE_REGEX,
 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,
 136             $INT_WITH_NL1,
 137             $INT_WITH_NL2,
 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,
 149             $FAKE_REGEX,
 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,
 170             $INT_WITH_NL1,
 171             $INT_WITH_NL2,
 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,
 183             $FAKE_REGEX,
 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,
 201             $INT_WITH_NL1,
 202             $INT_WITH_NL2,
 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,
 214             $FAKE_REGEX,
 215             $OBJECT,
 216         ],
 217     },
 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,
 229             $INT_WITH_NL1,
 230             $INT_WITH_NL2,
 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,
 242             $FAKE_REGEX,
 243             $OBJECT,
 244             $UNDEF,
 245         ],
 246     },
 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,
 258             $INT_WITH_NL1,
 259             $INT_WITH_NL2,
 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,
 273             $FAKE_REGEX,
 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,
 290             $FAKE_REGEX,
 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,
 303             $INT_WITH_NL1,
 304             $INT_WITH_NL2,
 305             $GLOB,
 306             $UNDEF,
 307         ],
 308     },
 309     Num => {
 310         accept => [
 311             $ZERO,
 312             $ONE,
 313             $INT,
 314             $NEG_INT,
 315             $NUM,
 316             $NEG_NUM,
 317             $INT_WITH_NL1,
 318             $INT_WITH_NL2,
 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,
 335             $FAKE_REGEX,
 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,
 353             $INT_WITH_NL1,
 354             $INT_WITH_NL2,
 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,
 366             $FAKE_REGEX,
 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,
 382             $INT_WITH_NL1,
 383             $INT_WITH_NL2,
 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,
 397             $FAKE_REGEX,
 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,
 417             $INT_WITH_NL1,
 418             $INT_WITH_NL2,
 419             $ARRAY_REF,
 420             $HASH_REF,
 421             $CODE_REF,
 422             $GLOB,
 423             $GLOB_REF,
 424             $FH,
 425             $FH_OBJECT,
 426             $REGEX,
 427             $REGEX_OBJ,
 428             $FAKE_REGEX,
 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,
 447             $INT_WITH_NL1,
 448             $INT_WITH_NL2,
 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,
 459             $FAKE_REGEX,
 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,
 478             $INT_WITH_NL1,
 479             $INT_WITH_NL2,
 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,
 490             $FAKE_REGEX,
 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,
 509             $INT_WITH_NL1,
 510             $INT_WITH_NL2,
 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,
 521             $FAKE_REGEX,
 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,
 541             $INT_WITH_NL1,
 542             $INT_WITH_NL2,
 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,
 554             $FAKE_REGEX,
 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,
 572             $INT_WITH_NL1,
 573             $INT_WITH_NL2,
 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,
 584             $FAKE_REGEX,
 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,
 603             $INT_WITH_NL1,
 604             $INT_WITH_NL2,
 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,
 615             $FAKE_REGEX,
 616             $UNDEF,
 617         ],
 618     },
 619     Object => {
 620         accept => [
 621             $FH_OBJECT,
 622             $REGEX,
 623             $REGEX_OBJ,
 624             $FAKE_REGEX,
 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,
 637             $INT_WITH_NL1,
 638             $INT_WITH_NL2,
 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,
 665             $INT_WITH_NL1,
 666             $INT_WITH_NL2,
 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,
 678             $FAKE_REGEX,
 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,
 698             $INT_WITH_NL1,
 699             $INT_WITH_NL2,
 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,
 711             $FAKE_REGEX,
 712             $OBJECT,
 713             $UNDEF,
 714         ],
 715     },
 716 );
 717
 718 for my $name ( sort keys %tests ) {
 719     test_constraint( $name, $tests{$name} );
 720
 721     test_constraint(
 722         Moose::Util::TypeConstraints::find_or_create_type_constraint(
 723             "$name|$name"),
 724         $tests{$name}
 725     );
 726 }
 727
 728 my %substr_test_str = (
 729     ClassName   => 'x' . $CLASS_NAME,
 730     RoleName    => 'x' . $ROLE_NAME,
 731 );
 732
 733 # We need to test that the Str constraint (and types that derive from it)
 734 # accept the return val of substr() - which means passing that return val
 735 # directly to the checking code
 736 foreach my $type_name (qw(Str Num Int ClassName RoleName))
 737 {
 738     my $str = $substr_test_str{$type_name} || '123456789';
 739
 740     my $type = Moose::Util::TypeConstraints::find_type_constraint($type_name);
 741
 742     my $unoptimized
 743         = $type->has_parent
 744         ? $type->_compile_subtype( $type->constraint )
 745         : $type->_compile_type( $type->constraint );
 746
 747     my $inlined;
 748     {
 749         $inlined = eval_closure(
 750             source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
 751         );
 752     }
 753
 754     ok(
 755         $type->check( substr( $str, 1, 5 ) ),
 756         $type_name . ' accepts return val from substr using ->check'
 757     );
 758     ok(
 759         $unoptimized->( substr( $str, 1, 5 ) ),
 760         $type_name . ' accepts return val from substr using unoptimized constraint'
 761     );
 762     ok(
 763         $inlined->( substr( $str, 1, 5 ) ),
 764         $type_name . ' accepts return val from substr using inlined constraint'
 765     );
 766
 767     # only Str accepts empty strings.
 768     next unless $type_name eq 'Str';
 769
 770     ok(
 771         $type->check( substr( $str, 0, 0 ) ),
 772         $type_name . ' accepts empty return val from substr using ->check'
 773     );
 774     ok(
 775         $unoptimized->( substr( $str, 0, 0 ) ),
 776         $type_name . ' accepts empty return val from substr using unoptimized constraint'
 777     );
 778     ok(
 779         $inlined->( substr( $str, 0, 0 ) ),
 780         $type_name . ' accepts empty return val from substr using inlined constraint'
 781     );
 782 }
 783
 784 {
 785     my $class_tc = class_type('Thing');
 786
 787     test_constraint(
 788         $class_tc, {
 789             accept => [
 790                 ( bless {}, 'Thing' ),
 791             ],
 792             reject => [
 793                 'Thing',
 794                 $ZERO,
 795                 $ONE,
 796                 $INT,
 797                 $NEG_INT,
 798                 $NUM,
 799                 $NEG_NUM,
 800                 $EMPTY_STRING,
 801                 $STRING,
 802                 $NUM_IN_STRING,
 803                 $INT_WITH_NL1,
 804                 $INT_WITH_NL2,
 805                 $SCALAR_REF,
 806                 $SCALAR_REF_REF,
 807                 $ARRAY_REF,
 808                 $HASH_REF,
 809                 $CODE_REF,
 810                 $GLOB,
 811                 $GLOB_REF,
 812                 $FH,
 813                 $FH_OBJECT,
 814                 $REGEX,
 815                 $REGEX_OBJ,
 816                 $FAKE_REGEX,
 817                 $OBJECT,
 818                 $UNDEF,
 819             ],
 820         }
 821     );
 822 }
 823
 824 {
 825     package Duck;
 826
 827     sub quack { }
 828     sub flap  { }
 829 }
 830
 831 {
 832     package DuckLike;
 833
 834     sub quack { }
 835     sub flap  { }
 836 }
 837
 838 {
 839     package Bird;
 840
 841     sub flap { }
 842 }
 843
 844 {
 845     my @methods = qw( quack flap );
 846     duck_type 'Duck' => \@methods;
 847
 848     test_constraint(
 849         'Duck', {
 850             accept => [
 851                 ( bless {}, 'Duck' ),
 852                 ( bless {}, 'DuckLike' ),
 853             ],
 854             reject => [
 855                 $ZERO,
 856                 $ONE,
 857                 $INT,
 858                 $NEG_INT,
 859                 $NUM,
 860                 $NEG_NUM,
 861                 $EMPTY_STRING,
 862                 $STRING,
 863                 $NUM_IN_STRING,
 864                 $INT_WITH_NL1,
 865                 $INT_WITH_NL2,
 866                 $SCALAR_REF,
 867                 $SCALAR_REF_REF,
 868                 $ARRAY_REF,
 869                 $HASH_REF,
 870                 $CODE_REF,
 871                 $GLOB,
 872                 $GLOB_REF,
 873                 $FH,
 874                 $FH_OBJECT,
 875                 $REGEX,
 876                 $REGEX_OBJ,
 877                 $FAKE_REGEX,
 878                 $OBJECT,
 879                 ( bless {}, 'Bird' ),
 880                 $UNDEF,
 881             ],
 882         }
 883     );
 884 }
 885
 886 {
 887     my @allowed = qw( bar baz quux );
 888     enum 'Enumerated' => \@allowed;
 889
 890     test_constraint(
 891         'Enumerated', {
 892             accept => \@allowed,
 893             reject => [
 894                 $ZERO,
 895                 $ONE,
 896                 $INT,
 897                 $NEG_INT,
 898                 $NUM,
 899                 $NEG_NUM,
 900                 $EMPTY_STRING,
 901                 $STRING,
 902                 $NUM_IN_STRING,
 903                 $INT_WITH_NL1,
 904                 $INT_WITH_NL2,
 905                 $SCALAR_REF,
 906                 $SCALAR_REF_REF,
 907                 $ARRAY_REF,
 908                 $HASH_REF,
 909                 $CODE_REF,
 910                 $GLOB,
 911                 $GLOB_REF,
 912                 $FH,
 913                 $FH_OBJECT,
 914                 $REGEX,
 915                 $REGEX_OBJ,
 916                 $FAKE_REGEX,
 917                 $OBJECT,
 918                 $UNDEF,
 919             ],
 920         }
 921     );
 922 }
 923
 924 {
 925     my $union = Moose::Meta::TypeConstraint::Union->new(
 926         type_constraints => [
 927             find_type_constraint('Int'),
 928             find_type_constraint('Object'),
 929         ],
 930     );
 931
 932     test_constraint(
 933         $union, {
 934             accept => [
 935                 $ZERO,
 936                 $ONE,
 937                 $INT,
 938                 $NEG_INT,
 939                 $FH_OBJECT,
 940                 $REGEX,
 941                 $REGEX_OBJ,
 942                 $FAKE_REGEX,
 943                 $OBJECT,
 944             ],
 945             reject => [
 946                 $NUM,
 947                 $NEG_NUM,
 948                 $EMPTY_STRING,
 949                 $STRING,
 950                 $NUM_IN_STRING,
 951                 $INT_WITH_NL1,
 952                 $INT_WITH_NL2,
 953                 $SCALAR_REF,
 954                 $SCALAR_REF_REF,
 955                 $ARRAY_REF,
 956                 $HASH_REF,
 957                 $CODE_REF,
 958                 $GLOB,
 959                 $GLOB_REF,
 960                 $FH,
 961                 $UNDEF,
 962             ],
 963         }
 964     );
 965 }
 966 {
 967     note 'Anonymous Union Test';
 968
 969     my $union = union(['Int','Object']);
 970
 971     test_constraint(
 972         $union, {
 973             accept => [
 974                 $ZERO,
 975                 $ONE,
 976                 $INT,
 977                 $NEG_INT,
 978                 $FH_OBJECT,
 979                 $REGEX,
 980                 $REGEX_OBJ,
 981                 $FAKE_REGEX,
 982                 $OBJECT,
 983             ],
 984             reject => [
 985                 $NUM,
 986                 $NEG_NUM,
 987                 $EMPTY_STRING,
 988                 $STRING,
 989                 $NUM_IN_STRING,
 990                 $INT_WITH_NL1,
 991                 $INT_WITH_NL2,
 992                 $SCALAR_REF,
 993                 $SCALAR_REF_REF,
 994                 $ARRAY_REF,
 995                 $HASH_REF,
 996                 $CODE_REF,
 997                 $GLOB,
 998                 $GLOB_REF,
 999                 $FH,
1000                 $UNDEF,
1001             ],
1002         }
1003     );
1004 }
1005 {
1006     note 'Named Union Test';
1007     union 'NamedUnion' => ['Int','Object'];
1008
1009     test_constraint(
1010         'NamedUnion', {
1011             accept => [
1012                 $ZERO,
1013                 $ONE,
1014                 $INT,
1015                 $NEG_INT,
1016                 $FH_OBJECT,
1017                 $REGEX,
1018                 $REGEX_OBJ,
1019                 $FAKE_REGEX,
1020                 $OBJECT,
1021             ],
1022             reject => [
1023                 $NUM,
1024                 $NEG_NUM,
1025                 $EMPTY_STRING,
1026                 $STRING,
1027                 $NUM_IN_STRING,
1028                 $INT_WITH_NL1,
1029                 $INT_WITH_NL2,
1030                 $SCALAR_REF,
1031                 $SCALAR_REF_REF,
1032                 $ARRAY_REF,
1033                 $HASH_REF,
1034                 $CODE_REF,
1035                 $GLOB,
1036                 $GLOB_REF,
1037                 $FH,
1038                 $UNDEF,
1039             ],
1040         }
1041     );
1042 }
1043
1044 {
1045     note 'Combined Union Test';
1046     my $union = union( [ 'Int', enum( [qw[ red green blue ]] ) ] );
1047
1048     test_constraint(
1049         $union, {
1050             accept => [
1051                 $ZERO,
1052                 $ONE,
1053                 $INT,
1054                 $NEG_INT,
1055                 'red',
1056                 'green',
1057                 'blue',
1058             ],
1059             reject => [
1060                 'yellow',
1061                 'pink',
1062                 $FH_OBJECT,
1063                 $REGEX,
1064                 $REGEX_OBJ,
1065                 $FAKE_REGEX,
1066                 $OBJECT,
1067                 $NUM,
1068                 $NEG_NUM,
1069                 $EMPTY_STRING,
1070                 $STRING,
1071                 $NUM_IN_STRING,
1072                 $INT_WITH_NL1,
1073                 $INT_WITH_NL2,
1074                 $SCALAR_REF,
1075                 $SCALAR_REF_REF,
1076                 $ARRAY_REF,
1077                 $HASH_REF,
1078                 $CODE_REF,
1079                 $GLOB,
1080                 $GLOB_REF,
1081                 $FH,
1082                 $UNDEF,
1083             ],
1084         }
1085     );
1086 }
1087
1088
1089 {
1090     enum 'Enum1' => ['a', 'b'];
1091     enum 'Enum2' => ['x', 'y'];
1092
1093     subtype 'EnumUnion', as 'Enum1 | Enum2';
1094
1095     test_constraint(
1096         'EnumUnion', {
1097             accept => [qw( a b x y )],
1098             reject => [
1099                 $ZERO,
1100                 $ONE,
1101                 $INT,
1102                 $NEG_INT,
1103                 $NUM,
1104                 $NEG_NUM,
1105                 $EMPTY_STRING,
1106                 $STRING,
1107                 $NUM_IN_STRING,
1108                 $INT_WITH_NL1,
1109                 $INT_WITH_NL2,
1110                 $SCALAR_REF,
1111                 $SCALAR_REF_REF,
1112                 $ARRAY_REF,
1113                 $HASH_REF,
1114                 $CODE_REF,
1115                 $GLOB,
1116                 $GLOB_REF,
1117                 $FH,
1118                 $FH_OBJECT,
1119                 $REGEX,
1120                 $REGEX_OBJ,
1121                 $FAKE_REGEX,
1122                 $OBJECT,
1123                 $UNDEF,
1124             ],
1125         }
1126     );
1127 }
1128
1129 {
1130     package DoesRole;
1131
1132     use Moose;
1133
1134     with 'Role';
1135 }
1136
1137 # Test how $_ is used in XS implementation
1138 {
1139     local $_ = qr/./;
1140     ok(
1141         Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1142         '$_ is RegexpRef'
1143     );
1144     ok(
1145         !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
1146         '$_ is not read when param provided'
1147     );
1148
1149     $_ = bless qr/./, 'Blessed';
1150
1151     ok(
1152         Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1153         '$_ is RegexpRef'
1154     );
1155
1156     $_ = 42;
1157     ok(
1158         !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
1159         '$_ is not RegexpRef'
1160     );
1161     ok(
1162         Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
1163         '$_ is not read when param provided'
1164     );
1165 }
1166
1167 close $FH
1168     or warn "Could not close the filehandle $0 for test";
1169 $FH_OBJECT->close
1170     or warn "Could not close the filehandle $0 for test";
1171
1172 done_testing;
1173
1174 sub test_constraint {
1175     my $type  = shift;
1176     my $tests = shift;
1177
1178     local $Test::Builder::Level = $Test::Builder::Level + 1;
1179
1180     unless ( blessed $type ) {
1181         $type = Moose::Util::TypeConstraints::find_type_constraint($type)
1182             or BAIL_OUT("No such type $type!");
1183     }
1184
1185     my $name = $type->name;
1186
1187     my $unoptimized
1188         = $type->has_parent
1189         ? $type->_compile_subtype( $type->constraint )
1190         : $type->_compile_type( $type->constraint );
1191
1192     my $inlined;
1193     if ( $type->can_be_inlined ) {
1194         $inlined = eval_closure(
1195             source      => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
1196             environment => $type->inline_environment,
1197         );
1198     }
1199
1200     my $class = Moose::Meta::Class->create_anon(
1201         superclasses => ['Moose::Object'],
1202     );
1203     $class->add_attribute(
1204         simple => (
1205             is  => 'ro',
1206             isa => $type,
1207         )
1208     );
1209
1210     $class->add_attribute(
1211         collection => (
1212             traits  => ['Array'],
1213             isa     => 'ArrayRef[' . $type->name . ']',
1214             default => sub { [] },
1215             handles => { add_to_collection => 'push' },
1216         )
1217     );
1218
1219     my $anon_class = $class->name;
1220
1221     for my $accept ( @{ $tests->{accept} || [] } ) {
1222         my $described = describe($accept);
1223         ok(
1224             $type->check($accept),
1225             "$name accepts $described using ->check"
1226         );
1227         ok(
1228             $unoptimized->($accept),
1229             "$name accepts $described using unoptimized constraint"
1230         );
1231         if ($inlined) {
1232             ok(
1233                 $inlined->($accept),
1234                 "$name accepts $described using inlined constraint"
1235             );
1236         }
1237
1238         is(
1239             exception {
1240                 $anon_class->new( simple => $accept );
1241             },
1242             undef,
1243             "no exception passing $described to constructor with $name"
1244         );
1245
1246         is(
1247             exception {
1248                 $anon_class->new()->add_to_collection($accept);
1249             },
1250             undef,
1251             "no exception passing $described to native trait push method with $name"
1252         );
1253     }
1254
1255     for my $reject ( @{ $tests->{reject} || [] } ) {
1256         my $described = describe($reject);
1257         ok(
1258             !$type->check($reject),
1259             "$name rejects $described using ->check"
1260         );
1261         ok(
1262             !$unoptimized->($reject),
1263             "$name rejects $described using unoptimized constraint"
1264         );
1265         if ($inlined) {
1266             ok(
1267                 !$inlined->($reject),
1268                 "$name rejects $described using inlined constraint"
1269             );
1270         }
1271
1272         ok(
1273             exception {
1274                 $anon_class->new( simple => $reject );
1275             },
1276             "got exception passing $described to constructor with $name"
1277         );
1278
1279         ok(
1280             exception {
1281                 $anon_class->new()->add_to_collection($reject);
1282             },
1283             "got exception passing $described to native trait push method with $name"
1284         );
1285     }
1286 }
1287
1288 sub describe {
1289     my $val = shift;
1290
1291     return 'undef' unless defined $val;
1292
1293     if ( !ref $val ) {
1294         return q{''} if $val eq q{};
1295
1296         $val =~ s/\n/\\n/g;
1297
1298         return $val;
1299     }
1300
1301     return 'open filehandle'
1302         if openhandle $val && !blessed $val;
1303
1304     return blessed $val
1305         ? ( ref $val ) . ' object'
1306         : ( ref $val ) . ' reference';
1307 }