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
 722 # We need to test that the Str constraint accepts the return val of substr() -
 723 # which means passing that return val directly to the checking code
 724 {
 725     my $str = 'some string';
 726
 727     my $type = Moose::Util::TypeConstraints::find_type_constraint('Str');
 728
 729     my $unoptimized
 730         = $type->has_parent
 731         ? $type->_compile_subtype( $type->constraint )
 732         : $type->_compile_type( $type->constraint );
 733
 734     my $inlined;
 735     {
 736         $inlined = eval_closure(
 737             source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
 738         );
 739     }
 740
 741     ok(
 742         $type->check( substr( $str, 1, 3 ) ),
 743         'Str accepts return val from substr using ->check'
 744     );
 745     ok(
 746         $unoptimized->( substr( $str, 1, 3 ) ),
 747         'Str accepts return val from substr using unoptimized constraint'
 748     );
 749     ok(
 750         $inlined->( substr( $str, 1, 3 ) ),
 751         'Str accepts return val from substr using inlined constraint'
 752     );
 753
 754     ok(
 755         $type->check( substr( $str, 0, 0 ) ),
 756         'Str accepts empty return val from substr using ->check'
 757     );
 758     ok(
 759         $unoptimized->( substr( $str, 0, 0 ) ),
 760         'Str accepts empty return val from substr using unoptimized constraint'
 761     );
 762     ok(
 763         $inlined->( substr( $str, 0, 0 ) ),
 764         'Str accepts empty return val from substr using inlined constraint'
 765     );
 766 }
 767
 768 {
 769     my $class_tc = class_type('Thing');
 770
 771     test_constraint(
 772         $class_tc, {
 773             accept => [
 774                 ( bless {}, 'Thing' ),
 775             ],
 776             reject => [
 777                 'Thing',
 778                 $ZERO,
 779                 $ONE,
 780                 $INT,
 781                 $NEG_INT,
 782                 $NUM,
 783                 $NEG_NUM,
 784                 $EMPTY_STRING,
 785                 $STRING,
 786                 $NUM_IN_STRING,
 787                 $INT_WITH_NL1,
 788                 $INT_WITH_NL2,
 789                 $SCALAR_REF,
 790                 $SCALAR_REF_REF,
 791                 $ARRAY_REF,
 792                 $HASH_REF,
 793                 $CODE_REF,
 794                 $GLOB,
 795                 $GLOB_REF,
 796                 $FH,
 797                 $FH_OBJECT,
 798                 $REGEX,
 799                 $REGEX_OBJ,
 800                 $FAKE_REGEX,
 801                 $OBJECT,
 802                 $UNDEF,
 803             ],
 804         }
 805     );
 806 }
 807
 808 {
 809     package Duck;
 810
 811     sub quack { }
 812     sub flap  { }
 813 }
 814
 815 {
 816     package DuckLike;
 817
 818     sub quack { }
 819     sub flap  { }
 820 }
 821
 822 {
 823     package Bird;
 824
 825     sub flap { }
 826 }
 827
 828 {
 829     my @methods = qw( quack flap );
 830     duck_type 'Duck' => @methods;
 831
 832     test_constraint(
 833         'Duck', {
 834             accept => [
 835                 ( bless {}, 'Duck' ),
 836                 ( bless {}, 'DuckLike' ),
 837             ],
 838             reject => [
 839                 $ZERO,
 840                 $ONE,
 841                 $INT,
 842                 $NEG_INT,
 843                 $NUM,
 844                 $NEG_NUM,
 845                 $EMPTY_STRING,
 846                 $STRING,
 847                 $NUM_IN_STRING,
 848                 $INT_WITH_NL1,
 849                 $INT_WITH_NL2,
 850                 $SCALAR_REF,
 851                 $SCALAR_REF_REF,
 852                 $ARRAY_REF,
 853                 $HASH_REF,
 854                 $CODE_REF,
 855                 $GLOB,
 856                 $GLOB_REF,
 857                 $FH,
 858                 $FH_OBJECT,
 859                 $REGEX,
 860                 $REGEX_OBJ,
 861                 $FAKE_REGEX,
 862                 $OBJECT,
 863                 ( bless {}, 'Bird' ),
 864                 $UNDEF,
 865             ],
 866         }
 867     );
 868 }
 869
 870 {
 871     my @allowed = qw( bar baz quux );
 872     enum 'Enumerated' => @allowed;
 873
 874     test_constraint(
 875         'Enumerated', {
 876             accept => \@allowed,
 877             reject => [
 878                 $ZERO,
 879                 $ONE,
 880                 $INT,
 881                 $NEG_INT,
 882                 $NUM,
 883                 $NEG_NUM,
 884                 $EMPTY_STRING,
 885                 $STRING,
 886                 $NUM_IN_STRING,
 887                 $INT_WITH_NL1,
 888                 $INT_WITH_NL2,
 889                 $SCALAR_REF,
 890                 $SCALAR_REF_REF,
 891                 $ARRAY_REF,
 892                 $HASH_REF,
 893                 $CODE_REF,
 894                 $GLOB,
 895                 $GLOB_REF,
 896                 $FH,
 897                 $FH_OBJECT,
 898                 $REGEX,
 899                 $REGEX_OBJ,
 900                 $FAKE_REGEX,
 901                 $OBJECT,
 902                 $UNDEF,
 903             ],
 904         }
 905     );
 906 }
 907
 908 {
 909     my $union = Moose::Meta::TypeConstraint::Union->new(
 910         type_constraints => [
 911             find_type_constraint('Int'),
 912             find_type_constraint('Object'),
 913         ],
 914     );
 915
 916     test_constraint(
 917         $union, {
 918             accept => [
 919                 $ZERO,
 920                 $ONE,
 921                 $INT,
 922                 $NEG_INT,
 923                 $FH_OBJECT,
 924                 $REGEX,
 925                 $REGEX_OBJ,
 926                 $FAKE_REGEX,
 927                 $OBJECT,
 928             ],
 929             reject => [
 930                 $NUM,
 931                 $NEG_NUM,
 932                 $EMPTY_STRING,
 933                 $STRING,
 934                 $NUM_IN_STRING,
 935                 $INT_WITH_NL1,
 936                 $INT_WITH_NL2,
 937                 $SCALAR_REF,
 938                 $SCALAR_REF_REF,
 939                 $ARRAY_REF,
 940                 $HASH_REF,
 941                 $CODE_REF,
 942                 $GLOB,
 943                 $GLOB_REF,
 944                 $FH,
 945                 $UNDEF,
 946             ],
 947         }
 948     );
 949 }
 950
 951 {
 952     package DoesRole;
 953
 954     use Moose;
 955
 956     with 'Role';
 957 }
 958
 959 # Test how $_ is used in XS implementation
 960 {
 961     local $_ = qr/./;
 962     ok(
 963         Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
 964         '$_ is RegexpRef'
 965     );
 966     ok(
 967         !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
 968         '$_ is not read when param provided'
 969     );
 970
 971     $_ = bless qr/./, 'Blessed';
 972
 973     ok(
 974         Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
 975         '$_ is RegexpRef'
 976     );
 977
 978     $_ = 42;
 979     ok(
 980         !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
 981         '$_ is not RegexpRef'
 982     );
 983     ok(
 984         Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
 985         '$_ is not read when param provided'
 986     );
 987 }
 988
 989 close $FH
 990     or warn "Could not close the filehandle $0 for test";
 991 $FH_OBJECT->close
 992     or warn "Could not close the filehandle $0 for test";
 993
 994 done_testing;
 995
 996 sub test_constraint {
 997     my $type  = shift;
 998     my $tests = shift;
 999
1000     local $Test::Builder::Level = $Test::Builder::Level + 1;
1001
1002     unless ( blessed $type ) {
1003         $type = Moose::Util::TypeConstraints::find_type_constraint($type)
1004             or BAIL_OUT("No such type $type!");
1005     }
1006
1007     my $name = $type->name;
1008
1009     my $unoptimized
1010         = $type->has_parent
1011         ? $type->_compile_subtype( $type->constraint )
1012         : $type->_compile_type( $type->constraint );
1013
1014     my $inlined;
1015     if ( $type->can_be_inlined ) {
1016         $inlined = eval_closure(
1017             source      => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }',
1018             environment => $type->inline_environment,
1019         );
1020     }
1021
1022     my $class = Moose::Meta::Class->create_anon(
1023         superclasses => ['Moose::Object'],
1024     );
1025     $class->add_attribute(
1026         simple => (
1027             is  => 'ro',
1028             isa => $type,
1029         )
1030     );
1031
1032     $class->add_attribute(
1033         collection => (
1034             traits  => ['Array'],
1035             isa     => 'ArrayRef[' . $type->name . ']',
1036             default => sub { [] },
1037             handles => { add_to_collection => 'push' },
1038         )
1039     );
1040
1041     my $anon_class = $class->name;
1042
1043     for my $accept ( @{ $tests->{accept} || [] } ) {
1044         my $described = describe($accept);
1045         ok(
1046             $type->check($accept),
1047             "$name accepts $described using ->check"
1048         );
1049         ok(
1050             $unoptimized->($accept),
1051             "$name accepts $described using unoptimized constraint"
1052         );
1053         if ($inlined) {
1054             ok(
1055                 $inlined->($accept),
1056                 "$name accepts $described using inlined constraint"
1057             );
1058         }
1059
1060         is(
1061             exception {
1062                 $anon_class->new( simple => $accept );
1063             },
1064             undef,
1065             "no exception passing $described to constructor with $name"
1066         );
1067
1068         is(
1069             exception {
1070                 $anon_class->new()->add_to_collection($accept);
1071             },
1072             undef,
1073             "no exception passing $described to native trait push method with $name"
1074         );
1075     }
1076
1077     for my $reject ( @{ $tests->{reject} || [] } ) {
1078         my $described = describe($reject);
1079         ok(
1080             !$type->check($reject),
1081             "$name rejects $described using ->check"
1082         );
1083         ok(
1084             !$unoptimized->($reject),
1085             "$name rejects $described using unoptimized constraint"
1086         );
1087         if ($inlined) {
1088             ok(
1089                 !$inlined->($reject),
1090                 "$name rejects $described using inlined constraint"
1091             );
1092         }
1093
1094         ok(
1095             exception {
1096                 $anon_class->new( simple => $reject );
1097             },
1098             "got exception passing $described to constructor with $name"
1099         );
1100
1101         ok(
1102             exception {
1103                 $anon_class->new()->add_to_collection($reject);
1104             },
1105             "got exception passing $described to native trait push method with $name"
1106         );
1107     }
1108 }
1109
1110 sub describe {
1111     my $val = shift;
1112
1113     return 'undef' unless defined $val;
1114
1115     if ( !ref $val ) {
1116         return q{''} if $val eq q{};
1117
1118         $val =~ s/\n/\\n/g;
1119
1120         return $val;
1121     }
1122
1123     return 'open filehandle'
1124         if openhandle $val && !blessed $val;
1125
1126     return blessed $val
1127         ? ( ref $val ) . ' object'
1128         : ( ref $val ) . ' reference';
1129 }