t/op/smartmatch.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8 use strict;
   9 use warnings;
  10 no warnings 'uninitialized';
  11
  12 use Tie::Array;
  13 use Tie::Hash;
  14
  15 # Predeclare vars used in the tests:
  16 my @empty;
  17 my %empty;
  18 my @sparse; $sparse[2] = 2;
  19
  20 my $deep1 = []; push @$deep1, $deep1;
  21 my $deep2 = []; push @$deep2, $deep2;
  22
  23 my @nums = (1..10);
  24 tie my @tied_nums, 'Tie::StdArray';
  25 @tied_nums =  (1..10);
  26
  27 my %hash = (foo => 17, bar => 23);
  28 tie my %tied_hash, 'Tie::StdHash';
  29 %tied_hash = %hash;
  30
  31 {
  32     package Test::Object::NoOverload;
  33     sub new { bless { key => 1 } }
  34 }
  35
  36 {
  37     package Test::Object::StringOverload;
  38     use overload '""' => sub { "object" }, fallback => 1;
  39     sub new { bless { key => 1 } }
  40 }
  41
  42 {
  43     package Test::Object::WithOverload;
  44     sub new { bless { key => ($_[1] // 'magic') } }
  45     use overload '~~' => sub {
  46         my %hash = %{ $_[0] };
  47         if ($_[2]) { # arguments reversed ?
  48             return $_[1] eq reverse $hash{key};
  49         }
  50         else {
  51             return $_[1] eq $hash{key};
  52         }
  53     };
  54     use overload '""' => sub { "stringified" };
  55     use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
  56 }
  57
  58 our $ov_obj = Test::Object::WithOverload->new;
  59 our $ov_obj_2 = Test::Object::WithOverload->new("object");
  60 our $obj = Test::Object::NoOverload->new;
  61 our $str_obj = Test::Object::StringOverload->new;
  62
  63 my %refh;
  64 unless (is_miniperl()) {
  65     require Tie::RefHash;
  66     tie %refh, 'Tie::RefHash';
  67     $refh{$ov_obj} = 1;
  68 }
  69
  70 my @keyandmore = qw(key and more);
  71 my @fooormore = qw(foo or more);
  72 my %keyandmore = map { $_ => 0 } @keyandmore;
  73 my %fooormore = map { $_ => 0 } @fooormore;
  74
  75 # Load and run the tests
  76 plan tests => 351;
  77
  78 while (<DATA>) {
  79   SKIP: {
  80     next if /^#/ || !/\S/;
  81     chomp;
  82     my ($yn, $left, $right, $note) = split /\t+/;
  83
  84     local $::TODO = $note =~ /TODO/;
  85
  86     die "Bad test spec: ($yn, $left, $right)" if $yn =~ /[^!@=]/;
  87
  88     my $tstr = "$left ~~ $right";
  89
  90     test_again:
  91     my $res;
  92     if ($note =~ /NOWARNINGS/) {
  93         $res = eval "no warnings; $tstr";
  94     }
  95     else {
  96         skip_if_miniperl("Doesn't work with miniperl", $yn =~ /=/ ? 2 : 1)
  97             if $note =~ /MINISKIP/;
  98         $res = eval $tstr;
  99     }
 100
 101     chomp $@;
 102
 103     if ( $yn =~ /@/ ) {
 104         ok( $@ ne '', "$tstr dies" )
 105             and print "# \$\@ was: $@\n";
 106     } else {
 107         my $test_name = $tstr . ($yn =~ /!/ ? " does not match" : " matches");
 108         if ( $@ ne '' ) {
 109             fail($test_name);
 110             print "# \$\@ was: $@\n";
 111         } else {
 112             ok( ($yn =~ /!/ xor $res), $test_name );
 113         }
 114     }
 115
 116     if ( $yn =~ s/=// ) {
 117         $tstr = "$right ~~ $left";
 118         goto test_again;
 119     }
 120   }
 121 }
 122
 123 sub foo {}
 124 sub bar {42}
 125 sub gorch {42}
 126 sub fatal {die "fatal sub\n"}
 127
 128 # to test constant folding
 129 sub FALSE() { 0 }
 130 sub TRUE() { 1 }
 131 sub NOT_DEF() { undef }
 132
 133 # Prefix character :
 134 #   - expected to match
 135 # ! - expected to not match
 136 # @ - expected to be a compilation failure
 137 # = - expected to match symmetrically (runs test twice)
 138 # Data types to test :
 139 #   undef
 140 #   Object-overloaded
 141 #   Object
 142 #   Coderef
 143 #   Hash
 144 #   Hashref
 145 #   Array
 146 #   Arrayref
 147 #   Tied arrays and hashes
 148 #   Arrays that reference themselves
 149 #   Regex (// and qr//)
 150 #   Range
 151 #   Num
 152 #   Str
 153 # Other syntactic items of interest:
 154 #   Constants
 155 #   Values returned by a sub call
 156 __DATA__
 157 # Any ~~ undef
 158 !       $ov_obj         undef
 159 !       $obj            undef
 160 !       sub {}          undef
 161 !       %hash           undef
 162 !       \%hash          undef
 163 !       {}              undef
 164 !       @nums           undef
 165 !       \@nums          undef
 166 !       []              undef
 167 !       %tied_hash      undef
 168 !       @tied_nums      undef
 169 !       $deep1          undef
 170 !       /foo/           undef
 171 !       qr/foo/         undef
 172 !       21..30          undef
 173 !       189             undef
 174 !       "foo"           undef
 175 !       ""              undef
 176 !       !1              undef
 177         undef           undef
 178         (my $u)         undef
 179         NOT_DEF         undef
 180         &NOT_DEF        undef
 181
 182 # Any ~~ object overloaded
 183 !       \&fatal         $ov_obj
 184         'cigam'         $ov_obj
 185 !       'cigam on'      $ov_obj
 186 !       ['cigam']       $ov_obj
 187 !       ['stringified'] $ov_obj
 188 !       { cigam => 1 }  $ov_obj
 189 !       { stringified => 1 }    $ov_obj
 190 !       $obj            $ov_obj
 191 !       undef           $ov_obj
 192
 193 # regular object
 194 @       $obj            $obj
 195 @       $ov_obj         $obj
 196 =@      \&fatal         $obj
 197 @       \&FALSE         $obj
 198 @       \&foo           $obj
 199 @       sub { 1 }       $obj
 200 @       sub { 0 }       $obj
 201 @       %keyandmore     $obj
 202 @       {"key" => 1}    $obj
 203 @       @fooormore      $obj
 204 @       ["key" => 1]    $obj
 205 @       /key/           $obj
 206 @       qr/key/         $obj
 207 @       "key"           $obj
 208 @       FALSE           $obj
 209
 210 # regular object with "" overload
 211 @       $obj            $str_obj
 212 =@      \&fatal         $str_obj
 213 @       \&FALSE         $str_obj
 214 @       \&foo           $str_obj
 215 @       sub { 1 }       $str_obj
 216 @       sub { 0 }       $str_obj
 217 @       %keyandmore     $str_obj
 218 @       {"object" => 1} $str_obj
 219 @       @fooormore      $str_obj
 220 @       ["object" => 1] $str_obj
 221 @       /object/        $str_obj
 222 @       qr/object/      $str_obj
 223 @       "object"        $str_obj
 224 @       FALSE           $str_obj
 225 # Those will treat the $str_obj as a string because of fallback:
 226 !       $ov_obj         $str_obj
 227         $ov_obj_2       $str_obj
 228
 229 # object (overloaded or not) ~~ Any
 230         $obj            qr/NoOverload/
 231         $ov_obj         qr/^stringified$/
 232 =       "$ov_obj"       "stringified"
 233 =       "$str_obj"      "object"
 234 !=      $ov_obj         "stringified"
 235         $str_obj        "object"
 236         $ov_obj         'magic'
 237 !       $ov_obj         'not magic'
 238
 239 # ~~ Coderef
 240         sub{0}          sub { ref $_[0] eq "CODE" }
 241         %fooormore      sub { $_[0] =~ /^(foo|or|more)$/ }
 242 !       %fooormore      sub { $_[0] =~ /^(foo|or|less)$/ }
 243         \%fooormore     sub { $_[0] =~ /^(foo|or|more)$/ }
 244 !       \%fooormore     sub { $_[0] =~ /^(foo|or|less)$/ }
 245         +{%fooormore}   sub { $_[0] =~ /^(foo|or|more)$/ }
 246 !       +{%fooormore}   sub { $_[0] =~ /^(foo|or|less)$/ }
 247         @fooormore      sub { $_[0] =~ /^(foo|or|more)$/ }
 248 !       @fooormore      sub { $_[0] =~ /^(foo|or|less)$/ }
 249         \@fooormore     sub { $_[0] =~ /^(foo|or|more)$/ }
 250 !       \@fooormore     sub { $_[0] =~ /^(foo|or|less)$/ }
 251         [@fooormore]    sub { $_[0] =~ /^(foo|or|more)$/ }
 252 !       [@fooormore]    sub { $_[0] =~ /^(foo|or|less)$/ }
 253         %fooormore      sub{@_==1}
 254         @fooormore      sub{@_==1}
 255         "foo"           sub { $_[0] =~ /^(foo|or|more)$/ }
 256 !       "more"          sub { $_[0] =~ /^(foo|or|less)$/ }
 257         /fooormore/     sub{ref $_[0] eq 'Regexp'}
 258         qr/fooormore/   sub{ref $_[0] eq 'Regexp'}
 259         1               sub{shift}
 260 !       0               sub{shift}
 261 !       undef           sub{shift}
 262         undef           sub{not shift}
 263         NOT_DEF         sub{not shift}
 264         &NOT_DEF        sub{not shift}
 265         FALSE           sub{not shift}
 266         [1]             \&bar
 267         {a=>1}          \&bar
 268         qr//            \&bar
 269 !       [1]             \&foo
 270 !       {a=>1}          \&foo
 271         $obj            sub { ref($_[0]) =~ /NoOverload/ }
 272         $ov_obj         sub { ref($_[0]) =~ /WithOverload/ }
 273 # empty stuff matches, because the sub is never called:
 274         []              \&foo
 275         {}              \&foo
 276         @empty          \&foo
 277         %empty          \&foo
 278 !       qr//            \&foo
 279 !       undef           \&foo
 280         undef           \&bar
 281 @       undef           \&fatal
 282 @       1               \&fatal
 283 @       [1]             \&fatal
 284 @       {a=>1}          \&fatal
 285 @       "foo"           \&fatal
 286 @       qr//            \&fatal
 287 # sub is not called on empty hashes / arrays
 288         []              \&fatal
 289         +{}             \&fatal
 290         @empty          \&fatal
 291         %empty          \&fatal
 292 # sub is not special on the left
 293         sub {0}         qr/^CODE/
 294         sub {0}         sub { ref shift eq "CODE" }
 295
 296 # HASH ref against:
 297 #   - another hash ref
 298         {}              {}
 299 =!      {}              {1 => 2}
 300         {1 => 2}        {1 => 2}
 301         {1 => 2}        {1 => 3}
 302 =!      {1 => 2}        {2 => 3}
 303 =       \%main::        {map {$_ => 'x'} keys %main::}
 304
 305 #  - tied hash ref
 306 =       \%hash          \%tied_hash
 307         \%tied_hash     \%tied_hash
 308 !=      {"a"=>"b"}      \%tied_hash
 309 =       %hash           %tied_hash
 310         %tied_hash      %tied_hash
 311 !=      {"a"=>"b"}      %tied_hash
 312         $ov_obj         %refh           MINISKIP
 313 !       "$ov_obj"       %refh           MINISKIP
 314         [$ov_obj]       %refh           MINISKIP
 315 !       ["$ov_obj"]     %refh           MINISKIP
 316         %refh           %refh           MINISKIP
 317
 318 #  - an array ref
 319 #  (since this is symmetrical, tests as well hash~~array)
 320 =       [keys %main::]  \%::
 321 =       [qw[STDIN STDOUT]]      \%::
 322 =!      []              \%::
 323 =!      [""]            {}
 324 =!      []              {}
 325 =!      @empty          {}
 326 =       [undef]         {"" => 1}
 327 =       [""]            {"" => 1}
 328 =       ["foo"]         { foo => 1 }
 329 =       ["foo", "bar"]  { foo => 1 }
 330 =       ["foo", "bar"]  \%hash
 331 =       ["foo"]         \%hash
 332 =!      ["quux"]        \%hash
 333 =       [qw(foo quux)]  \%hash
 334 =       @fooormore      { foo => 1, or => 2, more => 3 }
 335 =       @fooormore      %fooormore
 336 =       @fooormore      \%fooormore
 337 =       \@fooormore     %fooormore
 338
 339 #  - a regex
 340 =       qr/^(fo[ox])$/          {foo => 1}
 341 =       /^(fo[ox])$/            %fooormore
 342 =!      qr/[13579]$/            +{0..99}
 343 =!      qr/a*/                  {}
 344 =       qr/a*/                  {b=>2}
 345 =       qr/B/i                  {b=>2}
 346 =       /B/i                    {b=>2}
 347 =!      qr/a+/                  {b=>2}
 348 =       qr/^à/                 {"à"=>2}
 349
 350 #  - a scalar
 351         "foo"           +{foo => 1, bar => 2}
 352         "foo"           %fooormore
 353 !       "baz"           +{foo => 1, bar => 2}
 354 !       "boz"           %fooormore
 355 !       1               +{foo => 1, bar => 2}
 356 !       1               %fooormore
 357         1               { 1 => 3 }
 358         1.0             { 1 => 3 }
 359 !       "1.0"           { 1 => 3 }
 360 !       "1.0"           { 1.0 => 3 }
 361         "1.0"           { "1.0" => 3 }
 362         "à"            { "à" => "À" }
 363
 364 #  - undef
 365 !       undef           { hop => 'zouu' }
 366 !       undef           %hash
 367 !       undef           +{"" => "empty key"}
 368 !       undef           {}
 369
 370 # ARRAY ref against:
 371 #  - another array ref
 372         []                      []
 373 =!      []                      [1]
 374         [["foo"], ["bar"]]      [qr/o/, qr/a/]
 375 !       [["foo"], ["bar"]]      [qr/ARRAY/, qr/ARRAY/]
 376         ["foo", "bar"]          [qr/o/, qr/a/]
 377 !       [qr/o/, qr/a/]          ["foo", "bar"]
 378         ["foo", "bar"]          [["foo"], ["bar"]]
 379 !       ["foo", "bar"]          [qr/o/, "foo"]
 380         ["foo", undef, "bar"]   [qr/o/, undef, "bar"]
 381 !       ["foo", undef, "bar"]   [qr/o/, "",    "bar"]
 382 !       ["foo", "", "bar"]      [qr/o/, undef, "bar"]
 383         $deep1                  $deep1
 384         @$deep1                 @$deep1
 385 !       $deep1                  $deep2
 386
 387 =       \@nums                  \@tied_nums
 388 =       @nums                   \@tied_nums
 389 =       \@nums                  @tied_nums
 390 =       @nums                   @tied_nums
 391
 392 #  - an object
 393 !       $obj            @fooormore
 394         $obj            [sub{ref shift}]
 395
 396 #  - a regex
 397 =       qr/x/           [qw(foo bar baz quux)]
 398 =!      qr/y/           [qw(foo bar baz quux)]
 399 =       /x/             [qw(foo bar baz quux)]
 400 =!      /y/             [qw(foo bar baz quux)]
 401 =       /FOO/i          @fooormore
 402 =!      /bar/           @fooormore
 403
 404 # - a number
 405         2               [qw(1.00 2.00)]
 406         2               [qw(foo 2)]
 407         2.0_0e+0        [qw(foo 2)]
 408 !       2               [qw(1foo bar2)]
 409
 410 # - a string
 411 !       "2"             [qw(1foo 2bar)]
 412         "2bar"          [qw(1foo 2bar)]
 413
 414 # - undef
 415         undef           [1, 2, undef, 4]
 416 !       undef           [1, 2, [undef], 4]
 417 !       undef           @fooormore
 418         undef           @sparse
 419         undef           [undef]
 420 !       0               [undef]
 421 !       ""              [undef]
 422 !       undef           [0]
 423 !       undef           [""]
 424
 425 # - nested arrays and ~~ distributivity
 426         11              [[11]]
 427 !       11              [[12]]
 428         "foo"           [{foo => "bar"}]
 429 !       "bar"           [{foo => "bar"}]
 430
 431 # Number against number
 432         2               2
 433         20              2_0
 434 !       2               3
 435         0               FALSE
 436         3-2             TRUE
 437 !       undef           0
 438 !       (my $u)         0
 439
 440 # Number against string
 441 =       2               "2"
 442 =       2               "2.0"
 443 !       2               "2bananas"
 444 !=      2_3             "2_3"           NOWARNINGS
 445         FALSE           "0"
 446 !       undef           "0"
 447 !       undef           ""
 448
 449 # Regex against string
 450         "x"             qr/x/
 451 !       "x"             qr/y/
 452
 453 # Regex against number
 454         12345           qr/3/
 455 !       12345           qr/7/
 456
 457 # array/hash against string
 458         @fooormore      "".\@fooormore
 459 !       @keyandmore     "".\@fooormore
 460         %fooormore      "".\%fooormore
 461 !       %keyandmore     "".\%fooormore
 462
 463 # Test the implicit referencing
 464         7               @nums
 465         @nums           \@nums
 466 !       @nums           \\@nums
 467         @nums           [1..10]
 468 !       @nums           [0..9]
 469
 470         "foo"           %hash
 471         /bar/           %hash
 472         [qw(bar)]       %hash
 473 !       [qw(a b c)]     %hash
 474         %hash           %hash
 475         %hash           +{%hash}
 476         %hash           \%hash
 477         %hash           %tied_hash
 478         %tied_hash      %tied_hash
 479         %hash           { foo => 5, bar => 10 }
 480 !       %hash           { foo => 5, bar => 10, quux => 15 }
 481
 482         @nums           {  1, '',  2, '' }
 483         @nums           {  1, '', 12, '' }
 484 !       @nums           { 11, '', 12, '' }
 485
 486 # array slices
 487         @nums[0..-1]    []
 488         @nums[0..0]     [1]
 489 !       @nums[0..1]     [0..2]
 490         @nums[0..4]     [1..5]
 491
 492 !       undef           @nums[0..-1]
 493         1               @nums[0..0]
 494         2               @nums[0..1]
 495 !       @nums[0..1]     2
 496
 497         @nums[0..1]     @nums[0..1]
 498
 499 # hash slices
 500         @keyandmore{qw(not)}            [undef]
 501         @keyandmore{qw(key)}            [0]
 502
 503         undef                           @keyandmore{qw(not)}
 504         0                               @keyandmore{qw(key and more)}
 505 !       2                               @keyandmore{qw(key and)}
 506
 507         @fooormore{qw(foo)}             @keyandmore{qw(key)}
 508         @fooormore{qw(foo or more)}     @keyandmore{qw(key and more)}
 509
 510 # UNDEF
 511 !       3               undef
 512 !       1               undef
 513 !       []              undef
 514 !       {}              undef
 515 !       \%::main        undef
 516 !       [1,2]           undef
 517 !       %hash           undef
 518 !       @nums           undef
 519 !       "foo"           undef
 520 !       ""              undef
 521 !       !1              undef
 522 !       \&foo           undef
 523 !       sub { }         undef