t/op/smartmatch.t

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