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