t/type_constraints/util_std_type_constraints.t

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