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