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 # 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     {
 742         $inlined = eval_closure(
 743             source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
 744         );
 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
 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,
 793                 $INT_WITH_NL1,
 794                 $INT_WITH_NL2,
 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,
 806                 $FAKE_REGEX,
 807                 $OBJECT,
 808                 $UNDEF,
 809             ],
 810         }
 811     );
 812 }
 813
 814 {
 815     package Duck;
 816
 817     sub quack { }
 818     sub flap  { }
 819 }
 820
 821 {
 822     package DuckLike;
 823
 824     sub quack { }
 825     sub flap  { }
 826 }
 827
 828 {
 829     package Bird;
 830
 831     sub flap { }
 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 => [
 845                 $ZERO,
 846                 $ONE,
 847                 $INT,
 848                 $NEG_INT,
 849                 $NUM,
 850                 $NEG_NUM,
 851                 $EMPTY_STRING,
 852                 $STRING,
 853                 $NUM_IN_STRING,
 854                 $INT_WITH_NL1,
 855                 $INT_WITH_NL2,
 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,
 867                 $FAKE_REGEX,
 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 => [
 884                 $ZERO,
 885                 $ONE,
 886                 $INT,
 887                 $NEG_INT,
 888                 $NUM,
 889                 $NEG_NUM,
 890                 $EMPTY_STRING,
 891                 $STRING,
 892                 $NUM_IN_STRING,
 893                 $INT_WITH_NL1,
 894                 $INT_WITH_NL2,
 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,
 906                 $FAKE_REGEX,
 907                 $OBJECT,
 908                 $UNDEF,
 909             ],
 910         }
 911     );
 912 }
 913
 914 {
 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,
 932                 $FAKE_REGEX,
 933                 $OBJECT,
 934             ],
 935             reject => [
 936                 $NUM,
 937                 $NEG_NUM,
 938                 $EMPTY_STRING,
 939                 $STRING,
 940                 $NUM_IN_STRING,
 941                 $INT_WITH_NL1,
 942                 $INT_WITH_NL2,
 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 {
 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 {
 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;
1054
1055     my $unoptimized
1056         = $type->has_parent
1057         ? $type->_compile_subtype( $type->constraint )
1058         : $type->_compile_type( $type->constraint );
1059
1060     my $inlined;
1061     if ( $type->can_be_inlined ) {
1062         $inlined = eval_closure(
1063             source      => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
1064             environment => $type->inline_environment,
1065         );
1066     }
1067
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     );
1077
1078     $class->add_attribute(
1079         collection => (
1080             traits  => ['Array'],
1081             isa     => 'ArrayRef[' . $type->name . ']',
1082             default => sub { [] },
1083             handles => { add_to_collection => 'push' },
1084         )
1085     );
1086
1087     my $anon_class = $class->name;
1088
1089     for my $accept ( @{ $tests->{accept} || [] } ) {
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         }
1105
1106         is(
1107             exception {
1108                 $anon_class->new( simple => $accept );
1109             },
1110             undef,
1111             "no exception passing $described to constructor with $name"
1112         );
1113
1114         is(
1115             exception {
1116                 $anon_class->new()->add_to_collection($accept);
1117             },
1118             undef,
1119             "no exception passing $described to native trait push method with $name"
1120         );
1121     }
1122
1123     for my $reject ( @{ $tests->{reject} || [] } ) {
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         }
1139
1140         ok(
1141             exception {
1142                 $anon_class->new( simple => $reject );
1143             },
1144             "got exception passing $described to constructor with $name"
1145         );
1146
1147         ok(
1148             exception {
1149                 $anon_class->new()->add_to_collection($reject);
1150             },
1151             "got exception passing $described to native trait push method with $name"
1152         );
1153     }
1154 }
1155
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{};
1163
1164         $val =~ s/\n/\\n/g;
1165
1166         return $val;
1167     }
1168
1169     return 'open filehandle'
1170         if openhandle $val && !blessed $val;
1171
1172     return blessed $val
1173         ? ( ref $val ) . ' object'
1174         : ( ref $val ) . ' reference';
1175 }