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     Maybe => {
 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             $SCALAR_REF,
 211             $SCALAR_REF_REF,
 212             $ARRAY_REF,
 213             $HASH_REF,
 214             $CODE_REF,
 215             $GLOB,
 216             $GLOB_REF,
 217             $FH,
 218             $FH_OBJECT,
 219             $REGEX,
 220             $REGEX_OBJ,
 221             $OBJECT,
 222             $UNDEF,
 223         ],
 224     },
 225     Value => {
 226         accept => [
 227             $ZERO,
 228             $ONE,
 229             $INT,
 230             $NEG_INT,
 231             $NUM,
 232             $NEG_NUM,
 233             $EMPTY_STRING,
 234             $STRING,
 235             $NUM_IN_STRING,
 236             $GLOB,
 237         ],
 238         reject => [
 239             $SCALAR_REF,
 240             $SCALAR_REF_REF,
 241             $ARRAY_REF,
 242             $HASH_REF,
 243             $CODE_REF,
 244             $GLOB_REF,
 245             $FH,
 246             $FH_OBJECT,
 247             $REGEX,
 248             $REGEX_OBJ,
 249             $OBJECT,
 250             $UNDEF,
 251         ],
 252     },
 253     Ref => {
 254         accept => [
 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         ],
 267         reject => [
 268             $ZERO,
 269             $ONE,
 270             $INT,
 271             $NEG_INT,
 272             $NUM,
 273             $NEG_NUM,
 274             $EMPTY_STRING,
 275             $STRING,
 276             $NUM_IN_STRING,
 277             $GLOB,
 278             $UNDEF,
 279         ],
 280     },
 281     Num => {
 282         accept => [
 283             $ZERO,
 284             $ONE,
 285             $INT,
 286             $NEG_INT,
 287             $NUM,
 288             $NEG_NUM,
 289         ],
 290         reject => [
 291             $EMPTY_STRING,
 292             $STRING,
 293             $NUM_IN_STRING,
 294             $SCALAR_REF,
 295             $SCALAR_REF_REF,
 296             $ARRAY_REF,
 297             $HASH_REF,
 298             $CODE_REF,
 299             $GLOB,
 300             $GLOB_REF,
 301             $FH,
 302             $FH_OBJECT,
 303             $REGEX,
 304             $REGEX_OBJ,
 305             $OBJECT,
 306             $UNDEF,
 307         ],
 308     },
 309     Int => {
 310         accept => [
 311             $ZERO,
 312             $ONE,
 313             $INT,
 314             $NEG_INT,
 315         ],
 316         reject => [
 317             $NUM,
 318             $NEG_NUM,
 319             $EMPTY_STRING,
 320             $STRING,
 321             $NUM_IN_STRING,
 322             $SCALAR_REF,
 323             $SCALAR_REF_REF,
 324             $ARRAY_REF,
 325             $HASH_REF,
 326             $CODE_REF,
 327             $GLOB,
 328             $GLOB_REF,
 329             $FH,
 330             $FH_OBJECT,
 331             $REGEX,
 332             $REGEX_OBJ,
 333             $OBJECT,
 334             $UNDEF,
 335         ],
 336     },
 337     Str => {
 338         accept => [
 339             $ZERO,
 340             $ONE,
 341             $INT,
 342             $NEG_INT,
 343             $NUM,
 344             $NEG_NUM,
 345             $EMPTY_STRING,
 346             $STRING,
 347             $NUM_IN_STRING,
 348         ],
 349         reject => [
 350             $SCALAR_REF,
 351             $SCALAR_REF_REF,
 352             $ARRAY_REF,
 353             $HASH_REF,
 354             $CODE_REF,
 355             $GLOB,
 356             $GLOB_REF,
 357             $FH,
 358             $FH_OBJECT,
 359             $REGEX,
 360             $REGEX_OBJ,
 361             $OBJECT,
 362             $UNDEF,
 363         ],
 364     },
 365     ScalarRef => {
 366         accept => [
 367             $SCALAR_REF,
 368             $SCALAR_REF_REF,
 369         ],
 370         reject => [
 371             $ZERO,
 372             $ONE,
 373             $INT,
 374             $NEG_INT,
 375             $NUM,
 376             $NEG_NUM,
 377             $EMPTY_STRING,
 378             $STRING,
 379             $NUM_IN_STRING,
 380             $ARRAY_REF,
 381             $HASH_REF,
 382             $CODE_REF,
 383             $GLOB,
 384             $GLOB_REF,
 385             $FH,
 386             $FH_OBJECT,
 387             $REGEX,
 388             $REGEX_OBJ,
 389             $OBJECT,
 390             $UNDEF,
 391         ],
 392     },
 393     ArrayRef => {
 394         accept => [
 395             $ARRAY_REF,
 396         ],
 397         reject => [
 398             $ZERO,
 399             $ONE,
 400             $INT,
 401             $NEG_INT,
 402             $NUM,
 403             $NEG_NUM,
 404             $EMPTY_STRING,
 405             $STRING,
 406             $NUM_IN_STRING,
 407             $SCALAR_REF,
 408             $SCALAR_REF_REF,
 409             $HASH_REF,
 410             $CODE_REF,
 411             $GLOB,
 412             $GLOB_REF,
 413             $FH,
 414             $FH_OBJECT,
 415             $REGEX,
 416             $REGEX_OBJ,
 417             $OBJECT,
 418             $UNDEF,
 419         ],
 420     },
 421     HashRef => {
 422         accept => [
 423             $HASH_REF,
 424         ],
 425         reject => [
 426             $ZERO,
 427             $ONE,
 428             $INT,
 429             $NEG_INT,
 430             $NUM,
 431             $NEG_NUM,
 432             $EMPTY_STRING,
 433             $STRING,
 434             $NUM_IN_STRING,
 435             $SCALAR_REF,
 436             $SCALAR_REF_REF,
 437             $ARRAY_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     CodeRef => {
 450         accept => [
 451             $CODE_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             $SCALAR_REF,
 464             $SCALAR_REF_REF,
 465             $ARRAY_REF,
 466             $HASH_REF,
 467             $GLOB,
 468             $GLOB_REF,
 469             $FH,
 470             $FH_OBJECT,
 471             $REGEX,
 472             $REGEX_OBJ,
 473             $OBJECT,
 474             $UNDEF,
 475         ],
 476     },
 477     RegexpRef => {
 478         accept => [
 479             $REGEX,
 480             $REGEX_OBJ,
 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             $SCALAR_REF,
 493             $SCALAR_REF_REF,
 494             $ARRAY_REF,
 495             $HASH_REF,
 496             $CODE_REF,
 497             $GLOB,
 498             $GLOB_REF,
 499             $FH,
 500             $FH_OBJECT,
 501             $OBJECT,
 502             $UNDEF,
 503         ],
 504     },
 505     GlobRef => {
 506         accept => [
 507             $GLOB_REF,
 508             $FH,
 509         ],
 510         reject => [
 511             $ZERO,
 512             $ONE,
 513             $INT,
 514             $NEG_INT,
 515             $NUM,
 516             $NEG_NUM,
 517             $EMPTY_STRING,
 518             $STRING,
 519             $NUM_IN_STRING,
 520             $SCALAR_REF,
 521             $SCALAR_REF_REF,
 522             $ARRAY_REF,
 523             $HASH_REF,
 524             $CODE_REF,
 525             $GLOB,
 526             $FH_OBJECT,
 527             $OBJECT,
 528             $REGEX,
 529             $REGEX_OBJ,
 530             $UNDEF,
 531         ],
 532     },
 533     FileHandle => {
 534         accept => [
 535             $FH,
 536             $FH_OBJECT,
 537         ],
 538         reject => [
 539             $ZERO,
 540             $ONE,
 541             $INT,
 542             $NEG_INT,
 543             $NUM,
 544             $NEG_NUM,
 545             $EMPTY_STRING,
 546             $STRING,
 547             $NUM_IN_STRING,
 548             $SCALAR_REF,
 549             $SCALAR_REF_REF,
 550             $ARRAY_REF,
 551             $HASH_REF,
 552             $CODE_REF,
 553             $GLOB,
 554             $GLOB_REF,
 555             $OBJECT,
 556             $REGEX,
 557             $REGEX_OBJ,
 558             $UNDEF,
 559         ],
 560     },
 561     Object => {
 562         accept => [
 563             $FH_OBJECT,
 564             $REGEX,
 565             $REGEX_OBJ,
 566             $OBJECT,
 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             $UNDEF,
 587         ],
 588     },
 589     ClassName => {
 590         accept => [
 591             $CLASS_NAME,
 592             $ROLE_NAME,
 593         ],
 594         reject => [
 595             $ZERO,
 596             $ONE,
 597             $INT,
 598             $NEG_INT,
 599             $NUM,
 600             $NEG_NUM,
 601             $EMPTY_STRING,
 602             $STRING,
 603             $NUM_IN_STRING,
 604             $SCALAR_REF,
 605             $SCALAR_REF_REF,
 606             $ARRAY_REF,
 607             $HASH_REF,
 608             $CODE_REF,
 609             $GLOB,
 610             $GLOB_REF,
 611             $FH,
 612             $FH_OBJECT,
 613             $REGEX,
 614             $REGEX_OBJ,
 615             $OBJECT,
 616             $UNDEF,
 617         ],
 618     },
 619     RoleName => {
 620         accept => [
 621             $ROLE_NAME,
 622         ],
 623         reject => [
 624             $CLASS_NAME,
 625             $ZERO,
 626             $ONE,
 627             $INT,
 628             $NEG_INT,
 629             $NUM,
 630             $NEG_NUM,
 631             $EMPTY_STRING,
 632             $STRING,
 633             $NUM_IN_STRING,
 634             $SCALAR_REF,
 635             $SCALAR_REF_REF,
 636             $ARRAY_REF,
 637             $HASH_REF,
 638             $CODE_REF,
 639             $GLOB,
 640             $GLOB_REF,
 641             $FH,
 642             $FH_OBJECT,
 643             $REGEX,
 644             $REGEX_OBJ,
 645             $OBJECT,
 646             $UNDEF,
 647         ],
 648     },
 649 );
 650
 651 for my $name ( sort keys %tests ) {
 652     test_constraint( $name, $tests{$name} );
 653 }
 654
 655 {
 656     my $class_tc = class_type('Thing');
 657
 658     test_constraint(
 659         $class_tc, {
 660             accept => [
 661                 ( bless {}, 'Thing' ),
 662             ],
 663             reject => [
 664                 'Thing',
 665                 $ZERO,
 666                 $ONE,
 667                 $INT,
 668                 $NEG_INT,
 669                 $NUM,
 670                 $NEG_NUM,
 671                 $EMPTY_STRING,
 672                 $STRING,
 673                 $NUM_IN_STRING,
 674                 $SCALAR_REF,
 675                 $SCALAR_REF_REF,
 676                 $ARRAY_REF,
 677                 $HASH_REF,
 678                 $CODE_REF,
 679                 $GLOB,
 680                 $GLOB_REF,
 681                 $FH,
 682                 $FH_OBJECT,
 683                 $REGEX,
 684                 $REGEX_OBJ,
 685                 $OBJECT,
 686                 $UNDEF,
 687             ],
 688         }
 689     );
 690 }
 691
 692 {
 693     package Duck;
 694
 695     sub quack {}
 696     sub flap {}
 697 }
 698
 699 {
 700     package DuckLike;
 701
 702     sub quack {}
 703     sub flap {}
 704 }
 705
 706 {
 707     package Bird;
 708
 709     sub flap {}
 710 }
 711
 712 {
 713     my @methods = qw( quack flap );
 714     duck_type 'Duck' => @methods;
 715
 716     test_constraint(
 717         'Duck', {
 718             accept => [
 719                 ( bless {}, 'Duck' ),
 720                 ( bless {}, 'DuckLike' ),
 721             ],
 722             reject => [
 723                 'Thing',
 724                 $ZERO,
 725                 $ONE,
 726                 $INT,
 727                 $NEG_INT,
 728                 $NUM,
 729                 $NEG_NUM,
 730                 $EMPTY_STRING,
 731                 $STRING,
 732                 $NUM_IN_STRING,
 733                 $SCALAR_REF,
 734                 $SCALAR_REF_REF,
 735                 $ARRAY_REF,
 736                 $HASH_REF,
 737                 $CODE_REF,
 738                 $GLOB,
 739                 $GLOB_REF,
 740                 $FH,
 741                 $FH_OBJECT,
 742                 $REGEX,
 743                 $REGEX_OBJ,
 744                 $OBJECT,
 745                 ( bless {}, 'Bird' ),
 746                 $UNDEF,
 747             ],
 748         }
 749     );
 750 }
 751
 752 {
 753     my @allowed = qw( bar baz quux );
 754     enum 'Enumerated' => @allowed;
 755
 756     test_constraint(
 757         'Enumerated', {
 758             accept => \@allowed,
 759             reject => [
 760                 'Thing',
 761                 $ZERO,
 762                 $ONE,
 763                 $INT,
 764                 $NEG_INT,
 765                 $NUM,
 766                 $NEG_NUM,
 767                 $EMPTY_STRING,
 768                 $STRING,
 769                 $NUM_IN_STRING,
 770                 $SCALAR_REF,
 771                 $SCALAR_REF_REF,
 772                 $ARRAY_REF,
 773                 $HASH_REF,
 774                 $CODE_REF,
 775                 $GLOB,
 776                 $GLOB_REF,
 777                 $FH,
 778                 $FH_OBJECT,
 779                 $REGEX,
 780                 $REGEX_OBJ,
 781                 $OBJECT,
 782                 $UNDEF,
 783             ],
 784         }
 785     );
 786 }
 787
 788 {
 789     package DoesRole;
 790
 791     use Moose;
 792
 793     with 'Role';
 794 }
 795
 796 # Test how $_ is used in XS implementation
 797 {
 798     local $_ = qr/./;
 799     ok(
 800         Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
 801         '$_ is RegexpRef'
 802     );
 803     ok(
 804         !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1),
 805         '$_ is not read when param provided'
 806     );
 807
 808     $_ = bless qr/./, 'Blessed';
 809
 810     ok(
 811         Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
 812         '$_ is RegexpRef'
 813     );
 814
 815     $_ = 42;
 816     ok(
 817         !Moose::Util::TypeConstraints::Builtins::_RegexpRef(),
 818         '$_ is not RegexpRef'
 819     );
 820     ok(
 821         Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./),
 822         '$_ is not read when param provided'
 823     );
 824 }
 825
 826 close $FH
 827     or warn "Could not close the filehandle $0 for test";
 828 $FH_OBJECT->close
 829     or warn "Could not close the filehandle $0 for test";
 830
 831 done_testing;
 832
 833 sub test_constraint {
 834     my $type  = shift;
 835     my $tests = shift;
 836
 837     local $Test::Builder::Level = $Test::Builder::Level + 1;
 838
 839     unless ( blessed $type ) {
 840         $type = Moose::Util::TypeConstraints::find_type_constraint($type)
 841             or BAIL_OUT("No such type $type!");
 842     }
 843
 844     my $name = $type->name;
 845
 846     my $unoptimized
 847         = $type->has_parent
 848         ? $type->_compile_subtype( $type->constraint )
 849         : $type->_compile_type( $type->constraint );
 850
 851     my $inlined;
 852     if ( $type->has_inlined_type_constraint ) {
 853         local $@;
 854         $inlined = eval 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }';
 855         die $@ if $@;
 856     }
 857
 858     for my $accept ( @{ $tests->{accept} || [] } ) {
 859         my $described = describe($accept);
 860         ok(
 861             $type->check($accept),
 862             "$name accepts $described using ->check"
 863         );
 864         ok(
 865             $unoptimized->($accept),
 866             "$name accepts $described using unoptimized constraint"
 867         );
 868         if ($inlined) {
 869             ok(
 870                 $inlined->($accept),
 871                 "$name accepts $described using inlined constraint"
 872             );
 873         }
 874     }
 875
 876     for my $reject ( @{ $tests->{reject} || [] } ) {
 877         my $described = describe($reject);
 878         ok(
 879             !$type->check($reject),
 880             "$name rejects $described using ->check"
 881         );
 882         ok(
 883             !$unoptimized->($reject),
 884             "$name rejects $described using unoptimized constraint"
 885         );
 886         if ($inlined) {
 887             ok(
 888                 !$inlined->($reject),
 889                 "$name rejects $described using inlined constraint"
 890             );
 891         }
 892     }
 893 }
 894
 895 sub describe {
 896     my $val = shift;
 897
 898     return 'undef' unless defined $val;
 899
 900     if ( !ref $val ) {
 901         return q{''} if $val eq q{};
 902     }
 903
 904     return $val unless ref $val;
 905
 906     return 'open filehandle'
 907         if openhandle $val && !blessed $val;
 908
 909     return blessed $val
 910         ? ( ref $val ) . ' object'
 911         : ( ref $val ) . ' reference';
 912 }