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
  23 my $SCALAR_REF     = \( my $var );
  24 my $SCALAR_REF_REF = \$SCALAR_REF;
  25 my $ARRAY_REF      = [];
  26 my $HASH_REF       = {};
  27 my $CODE_REF       = sub { };
  28
  29 no warnings 'once';    # << I *hates* that warning ...
  30 my $GLOB     = *GLOB_REF;
  31 my $GLOB_REF = \$GLOB;
  32
  33 open my $FH, '<', $0 or die "Could not open $0 for the test";
  34
  35 my $FH_OBJECT = IO::File->new( $0, 'r' )
  36     or die "Could not open $0 for the test";
  37
  38 my $REGEX = qr/../;
  39 my $REGEX_OBJ = bless qr/../, 'BlessedQR';
  40
  41 my $OBJECT = bless {}, 'Foo';
  42
  43 my $UNDEF = undef;
  44
  45 {
  46     package Thing;
  47
  48     sub foo { }
  49 }
  50
  51 my $CLASS_NAME = 'Thing';
  52
  53 {
  54     package Role;
  55     use Moose::Role;
  56
  57     sub foo { }
  58 }
  59
  60 my $ROLE_NAME = 'Role';
  61
  62 my %tests = (
  63     Any => {
  64         accept => [
  65             $ZERO,
  66             $ONE,
  67             $INT,
  68             $NEG_INT,
  69             $NUM,
  70             $NEG_NUM,
  71             $EMPTY_STRING,
  72             $STRING,
  73             $NUM_IN_STRING,
  74             $SCALAR_REF,
  75             $SCALAR_REF_REF,
  76             $ARRAY_REF,
  77             $HASH_REF,
  78             $CODE_REF,
  79             $GLOB,
  80             $GLOB_REF,
  81             $FH,
  82             $FH_OBJECT,
  83             $REGEX,
  84             $REGEX_OBJ,
  85             $OBJECT,
  86             $UNDEF,
  87         ],
  88     },
  89     Item => {
  90         accept => [
  91             $ZERO,
  92             $ONE,
  93             $INT,
  94             $NEG_INT,
  95             $NUM,
  96             $NEG_NUM,
  97             $EMPTY_STRING,
  98             $STRING,
  99             $NUM_IN_STRING,
 100             $SCALAR_REF,
 101             $SCALAR_REF_REF,
 102             $ARRAY_REF,
 103             $HASH_REF,
 104             $CODE_REF,
 105             $GLOB,
 106             $GLOB_REF,
 107             $FH,
 108             $FH_OBJECT,
 109             $REGEX,
 110             $REGEX_OBJ,
 111             $OBJECT,
 112             $UNDEF,
 113         ],
 114     },
 115     Defined => {
 116         accept => [
 117             $ZERO,
 118             $ONE,
 119             $INT,
 120             $NEG_INT,
 121             $NUM,
 122             $NEG_NUM,
 123             $EMPTY_STRING,
 124             $STRING,
 125             $NUM_IN_STRING,
 126             $SCALAR_REF,
 127             $SCALAR_REF_REF,
 128             $ARRAY_REF,
 129             $HASH_REF,
 130             $CODE_REF,
 131             $GLOB,
 132             $GLOB_REF,
 133             $FH,
 134             $FH_OBJECT,
 135             $REGEX,
 136             $REGEX_OBJ,
 137             $OBJECT,
 138         ],
 139         reject => [
 140             $UNDEF,
 141         ],
 142     },
 143     Undef => {
 144         accept => [
 145             $UNDEF,
 146         ],
 147         reject => [
 148             $ZERO,
 149             $ONE,
 150             $INT,
 151             $NEG_INT,
 152             $NUM,
 153             $NEG_NUM,
 154             $EMPTY_STRING,
 155             $STRING,
 156             $NUM_IN_STRING,
 157             $SCALAR_REF,
 158             $SCALAR_REF_REF,
 159             $ARRAY_REF,
 160             $HASH_REF,
 161             $CODE_REF,
 162             $GLOB,
 163             $GLOB_REF,
 164             $FH,
 165             $FH_OBJECT,
 166             $REGEX,
 167             $REGEX_OBJ,
 168             $OBJECT,
 169         ],
 170     },
 171     Bool => {
 172         accept => [
 173             $ZERO,
 174             $ONE,
 175             $EMPTY_STRING,
 176             $UNDEF,
 177         ],
 178         reject => [
 179             $INT,
 180             $NEG_INT,
 181             $NUM,
 182             $NEG_NUM,
 183             $STRING,
 184             $NUM_IN_STRING,
 185             $SCALAR_REF,
 186             $SCALAR_REF_REF,
 187             $ARRAY_REF,
 188             $HASH_REF,
 189             $CODE_REF,
 190             $GLOB,
 191             $GLOB_REF,
 192             $FH,
 193             $FH_OBJECT,
 194             $REGEX,
 195             $REGEX_OBJ,
 196             $OBJECT,
 197         ],
 198     },
 199     Value => {
 200         accept => [
 201             $ZERO,
 202             $ONE,
 203             $INT,
 204             $NEG_INT,
 205             $NUM,
 206             $NEG_NUM,
 207             $EMPTY_STRING,
 208             $STRING,
 209             $NUM_IN_STRING,
 210             $GLOB,
 211         ],
 212         reject => [
 213             $SCALAR_REF,
 214             $SCALAR_REF_REF,
 215             $ARRAY_REF,
 216             $HASH_REF,
 217             $CODE_REF,
 218             $GLOB_REF,
 219             $FH,
 220             $FH_OBJECT,
 221             $REGEX,
 222             $REGEX_OBJ,
 223             $OBJECT,
 224             $UNDEF,
 225         ],
 226     },
 227     Ref => {
 228         accept => [
 229             $SCALAR_REF,
 230             $SCALAR_REF_REF,
 231             $ARRAY_REF,
 232             $HASH_REF,
 233             $CODE_REF,
 234             $GLOB_REF,
 235             $FH,
 236             $FH_OBJECT,
 237             $REGEX,
 238             $REGEX_OBJ,
 239             $OBJECT,
 240         ],
 241         reject => [
 242             $ZERO,
 243             $ONE,
 244             $INT,
 245             $NEG_INT,
 246             $NUM,
 247             $NEG_NUM,
 248             $EMPTY_STRING,
 249             $STRING,
 250             $NUM_IN_STRING,
 251             $GLOB,
 252             $UNDEF,
 253         ],
 254     },
 255     Num => {
 256         accept => [
 257             $ZERO,
 258             $ONE,
 259             $INT,
 260             $NEG_INT,
 261             $NUM,
 262             $NEG_NUM,
 263         ],
 264         reject => [
 265             $EMPTY_STRING,
 266             $STRING,
 267             $NUM_IN_STRING,
 268             $SCALAR_REF,
 269             $SCALAR_REF_REF,
 270             $ARRAY_REF,
 271             $HASH_REF,
 272             $CODE_REF,
 273             $GLOB,
 274             $GLOB_REF,
 275             $FH,
 276             $FH_OBJECT,
 277             $REGEX,
 278             $REGEX_OBJ,
 279             $OBJECT,
 280             $UNDEF,
 281         ],
 282     },
 283     Int => {
 284         accept => [
 285             $ZERO,
 286             $ONE,
 287             $INT,
 288             $NEG_INT,
 289         ],
 290         reject => [
 291             $NUM,
 292             $NEG_NUM,
 293             $EMPTY_STRING,
 294             $STRING,
 295             $NUM_IN_STRING,
 296             $SCALAR_REF,
 297             $SCALAR_REF_REF,
 298             $ARRAY_REF,
 299             $HASH_REF,
 300             $CODE_REF,
 301             $GLOB,
 302             $GLOB_REF,
 303             $FH,
 304             $FH_OBJECT,
 305             $REGEX,
 306             $REGEX_OBJ,
 307             $OBJECT,
 308             $UNDEF,
 309         ],
 310     },
 311     Str => {
 312         accept => [
 313             $ZERO,
 314             $ONE,
 315             $INT,
 316             $NEG_INT,
 317             $NUM,
 318             $NEG_NUM,
 319             $EMPTY_STRING,
 320             $STRING,
 321             $NUM_IN_STRING,
 322         ],
 323         reject => [
 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             $OBJECT,
 336             $UNDEF,
 337         ],
 338     },
 339     ScalarRef => {
 340         accept => [
 341             $SCALAR_REF,
 342             $SCALAR_REF_REF,
 343         ],
 344         reject => [
 345             $ZERO,
 346             $ONE,
 347             $INT,
 348             $NEG_INT,
 349             $NUM,
 350             $NEG_NUM,
 351             $EMPTY_STRING,
 352             $STRING,
 353             $NUM_IN_STRING,
 354             $ARRAY_REF,
 355             $HASH_REF,
 356             $CODE_REF,
 357             $GLOB,
 358             $GLOB_REF,
 359             $FH,
 360             $FH_OBJECT,
 361             $REGEX,
 362             $REGEX_OBJ,
 363             $OBJECT,
 364             $UNDEF,
 365         ],
 366     },
 367     ArrayRef => {
 368         accept => [
 369             $ARRAY_REF,
 370         ],
 371         reject => [
 372             $ZERO,
 373             $ONE,
 374             $INT,
 375             $NEG_INT,
 376             $NUM,
 377             $NEG_NUM,
 378             $EMPTY_STRING,
 379             $STRING,
 380             $NUM_IN_STRING,
 381             $SCALAR_REF,
 382             $SCALAR_REF_REF,
 383             $HASH_REF,
 384             $CODE_REF,
 385             $GLOB,
 386             $GLOB_REF,
 387             $FH,
 388             $FH_OBJECT,
 389             $REGEX,
 390             $REGEX_OBJ,
 391             $OBJECT,
 392             $UNDEF,
 393         ],
 394     },
 395     HashRef => {
 396         accept => [
 397             $HASH_REF,
 398         ],
 399         reject => [
 400             $ZERO,
 401             $ONE,
 402             $INT,
 403             $NEG_INT,
 404             $NUM,
 405             $NEG_NUM,
 406             $EMPTY_STRING,
 407             $STRING,
 408             $NUM_IN_STRING,
 409             $SCALAR_REF,
 410             $SCALAR_REF_REF,
 411             $ARRAY_REF,
 412             $CODE_REF,
 413             $GLOB,
 414             $GLOB_REF,
 415             $FH,
 416             $FH_OBJECT,
 417             $REGEX,
 418             $REGEX_OBJ,
 419             $OBJECT,
 420             $UNDEF,
 421         ],
 422     },
 423     CodeRef => {
 424         accept => [
 425             $CODE_REF,
 426         ],
 427         reject => [
 428             $ZERO,
 429             $ONE,
 430             $INT,
 431             $NEG_INT,
 432             $NUM,
 433             $NEG_NUM,
 434             $EMPTY_STRING,
 435             $STRING,
 436             $NUM_IN_STRING,
 437             $SCALAR_REF,
 438             $SCALAR_REF_REF,
 439             $ARRAY_REF,
 440             $HASH_REF,
 441             $GLOB,
 442             $GLOB_REF,
 443             $FH,
 444             $FH_OBJECT,
 445             $REGEX,
 446             $REGEX_OBJ,
 447             $OBJECT,
 448             $UNDEF,
 449         ],
 450     },
 451     RegexpRef => {
 452         accept => [
 453             $REGEX,
 454             $REGEX_OBJ,
 455         ],
 456         reject => [
 457             $ZERO,
 458             $ONE,
 459             $INT,
 460             $NEG_INT,
 461             $NUM,
 462             $NEG_NUM,
 463             $EMPTY_STRING,
 464             $STRING,
 465             $NUM_IN_STRING,
 466             $SCALAR_REF,
 467             $SCALAR_REF_REF,
 468             $ARRAY_REF,
 469             $HASH_REF,
 470             $CODE_REF,
 471             $GLOB,
 472             $GLOB_REF,
 473             $FH,
 474             $FH_OBJECT,
 475             $OBJECT,
 476             $UNDEF,
 477         ],
 478     },
 479     GlobRef => {
 480         accept => [
 481             $GLOB_REF,
 482             $FH,
 483         ],
 484         reject => [
 485             $ZERO,
 486             $ONE,
 487             $INT,
 488             $NEG_INT,
 489             $NUM,
 490             $NEG_NUM,
 491             $EMPTY_STRING,
 492             $STRING,
 493             $NUM_IN_STRING,
 494             $SCALAR_REF,
 495             $SCALAR_REF_REF,
 496             $ARRAY_REF,
 497             $HASH_REF,
 498             $CODE_REF,
 499             $GLOB,
 500             $FH_OBJECT,
 501             $OBJECT,
 502             $REGEX,
 503             $REGEX_OBJ,
 504             $UNDEF,
 505         ],
 506     },
 507     FileHandle => {
 508         accept => [
 509             $FH,
 510             $FH_OBJECT,
 511         ],
 512         reject => [
 513             $ZERO,
 514             $ONE,
 515             $INT,
 516             $NEG_INT,
 517             $NUM,
 518             $NEG_NUM,
 519             $EMPTY_STRING,
 520             $STRING,
 521             $NUM_IN_STRING,
 522             $SCALAR_REF,
 523             $SCALAR_REF_REF,
 524             $ARRAY_REF,
 525             $HASH_REF,
 526             $CODE_REF,
 527             $GLOB,
 528             $GLOB_REF,
 529             $OBJECT,
 530             $REGEX,
 531             $REGEX_OBJ,
 532             $UNDEF,
 533         ],
 534     },
 535     Object => {
 536         accept => [
 537             $FH_OBJECT,
 538             $REGEX,
 539             $REGEX_OBJ,
 540             $OBJECT,
 541         ],
 542         reject => [
 543             $ZERO,
 544             $ONE,
 545             $INT,
 546             $NEG_INT,
 547             $NUM,
 548             $NEG_NUM,
 549             $EMPTY_STRING,
 550             $STRING,
 551             $NUM_IN_STRING,
 552             $SCALAR_REF,
 553             $SCALAR_REF_REF,
 554             $ARRAY_REF,
 555             $HASH_REF,
 556             $CODE_REF,
 557             $GLOB,
 558             $GLOB_REF,
 559             $FH,
 560             $UNDEF,
 561         ],
 562     },
 563     ClassName => {
 564         accept => [
 565             $CLASS_NAME,
 566             $ROLE_NAME,
 567         ],
 568         reject => [
 569             $ZERO,
 570             $ONE,
 571             $INT,
 572             $NEG_INT,
 573             $NUM,
 574             $NEG_NUM,
 575             $EMPTY_STRING,
 576             $STRING,
 577             $NUM_IN_STRING,
 578             $SCALAR_REF,
 579             $SCALAR_REF_REF,
 580             $ARRAY_REF,
 581             $HASH_REF,
 582             $CODE_REF,
 583             $GLOB,
 584             $GLOB_REF,
 585             $FH,
 586             $FH_OBJECT,
 587             $REGEX,
 588             $REGEX_OBJ,
 589             $OBJECT,
 590             $UNDEF,
 591         ],
 592     },
 593     RoleName => {
 594         accept => [
 595             $ROLE_NAME,
 596         ],
 597         reject => [
 598             $CLASS_NAME,
 599             $ZERO,
 600             $ONE,
 601             $INT,
 602             $NEG_INT,
 603             $NUM,
 604             $NEG_NUM,
 605             $EMPTY_STRING,
 606             $STRING,
 607             $NUM_IN_STRING,
 608             $SCALAR_REF,
 609             $SCALAR_REF_REF,
 610             $ARRAY_REF,
 611             $HASH_REF,
 612             $CODE_REF,
 613             $GLOB,
 614             $GLOB_REF,
 615             $FH,
 616             $FH_OBJECT,
 617             $REGEX,
 618             $REGEX_OBJ,
 619             $OBJECT,
 620             $UNDEF,
 621         ],
 622     },
 623 );
 624
 625 for my $name ( sort keys %tests ) {
 626     my $type = Moose::Util::TypeConstraints::find_type_constraint($name)
 627         or BAIL_OUT("No such type $name!");
 628
 629     my $unoptimized
 630         = $type->has_parent
 631         ? $type->_compile_subtype( $type->constraint )
 632         : $type->_compile_type( $type->constraint );
 633
 634     my $inlined;
 635     if ( $type->has_inlined_type_constraint ) {
 636         local $@;
 637         $inlined = eval 'sub { ( ' . $type->inlined->('$_[0]') . ' ) }';
 638         die $@ if $@;
 639     }
 640
 641     for my $accept ( @{ $tests{$name}{accept} || [] } ) {
 642         my $described = describe($accept);
 643         ok(
 644             $type->check($accept),
 645             "$name accepts $described using ->check"
 646         );
 647         ok(
 648             $unoptimized->($accept),
 649             "$name accepts $described using unoptimized constraint"
 650         );
 651         if ($inlined) {
 652             ok(
 653                 $inlined->($accept),
 654                 "$name accepts $described using inlined constraint"
 655             );
 656         }
 657     }
 658
 659     for my $reject ( @{ $tests{$name}{reject} || [] } ) {
 660         my $described = describe($reject);
 661         ok(
 662             !$type->check($reject),
 663             "$name rejects $described using ->check"
 664         );
 665         ok(
 666             !$unoptimized->($reject),
 667             "$name rejects $described using unoptimized constraint"
 668         );
 669         if ($inlined) {
 670             ok(
 671                 !$inlined->($reject),
 672                 "$name rejects $described using inlined constraint"
 673             );
 674         }
 675     }
 676 }
 677
 678 # Test how $_ is used in XS implementation
 679 {
 680     local $_ = qr/./;
 681     ok(
 682         Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
 683         '$_ is RegexpRef'
 684     );
 685     ok(
 686         !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
 687         '$_ is not read when param provided'
 688     );
 689
 690     $_ = bless qr/./, 'Blessed';
 691
 692     ok(
 693         Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
 694         '$_ is RegexpRef'
 695     );
 696
 697     $_ = 42;
 698     ok(
 699         !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
 700         '$_ is not RegexpRef'
 701     );
 702     ok(
 703         Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
 704         '$_ is not read when param provided'
 705     );
 706 }
 707
 708 close $FH
 709     or warn "Could not close the filehandle $0 for test";
 710 $FH_OBJECT->close
 711     or warn "Could not close the filehandle $0 for test";
 712
 713 done_testing;
 714
 715 sub describe {
 716     my $val = shift;
 717
 718     return 'undef' unless defined $val;
 719
 720     if ( !ref $val ) {
 721         return q{''} if $val eq q{};
 722     }
 723
 724     return $val unless ref $val;
 725
 726     return 'open filehandle'
 727         if openhandle $val && !blessed $val;
 728
 729     return ( ref $val ) . ' reference';
 730 }