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