1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7} 8use strict; 9use warnings; 10no warnings 'uninitialized'; 11no warnings 'experimental::smartmatch'; 12 13++$|; 14 15use Tie::Array; 16use Tie::Hash; 17 18# Predeclare vars used in the tests: 19my @empty; 20my %empty; 21my @sparse; $sparse[2] = 2; 22 23my $deep1 = []; push @$deep1, $deep1; 24my $deep2 = []; push @$deep2, $deep2; 25 26my @nums = (1..10); 27tie my @tied_nums, 'Tie::StdArray'; 28@tied_nums = (1..10); 29 30my %hash = (foo => 17, bar => 23); 31tie 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 61our $ov_obj = Test::Object::WithOverload->new; 62our $ov_obj_2 = Test::Object::WithOverload->new("object"); 63our $obj = Test::Object::NoOverload->new; 64our $str_obj = Test::Object::StringOverload->new; 65 66my %refh; 67unless (is_miniperl()) { 68 require Tie::RefHash; 69 tie %refh, 'Tie::RefHash'; 70 $refh{$ov_obj} = 1; 71} 72 73my @keyandmore = qw(key and more); 74my @fooormore = qw(foo or more); 75my %keyandmore = map { $_ => 0 } @keyandmore; 76my %fooormore = map { $_ => 0 } @fooormore; 77 78# Load and run the tests 79plan tests => 349+4; 80 81while (<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 126sub foo {} 127sub bar {42} 128sub gorch {42} 129sub fatal {die "fatal sub\n"} 130 131# to test constant folding 132sub FALSE() { 0 } 133sub TRUE() { 1 } 134sub 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{ 186 # [perl #130705] 187 # Perl_ck_smartmatch would turn the match in: 188 # 0 =~ qr/1/ ~~ 0 # parsed as (0 =~ qr/1/) ~~ 0 189 # into a qr, leaving the initial 0 on the stack after execution 190 # 191 # Similarly for: 0 ~~ (0 =~ qr/1/) 192 # 193 # Either caused an assertion failure in the context of warn (or print) 194 # if there was some other operator's arguments left on the stack, as with 195 # the test cases. 196 fresh_perl_is('print(0->[0 =~ qr/1/ ~~ 0])', '', 197 { switches => [ "-M-warnings=experimental::smartmatch" ] }, 198 "don't qr-ify left-side match against a stacked argument"); 199 fresh_perl_is('print(0->[0 ~~ (0 =~ qr/1/)])', '', 200 { switches => [ "-M-warnings=experimental::smartmatch" ] }, 201 "don't qr-ify right-side match against a stacked argument"); 202} 203 204# Prefix character : 205# - expected to match 206# ! - expected to not match 207# @ - expected to be a compilation failure 208# = - expected to match symmetrically (runs test twice) 209# Data types to test : 210# undef 211# Object-overloaded 212# Object 213# Coderef 214# Hash 215# Hashref 216# Array 217# Arrayref 218# Tied arrays and hashes 219# Arrays that reference themselves 220# Regex (// and qr//) 221# Range 222# Num 223# Str 224# Other syntactic items of interest: 225# Constants 226# Values returned by a sub call 227__DATA__ 228# Any ~~ undef 229! $ov_obj undef 230! $obj undef 231! sub {} undef 232! %hash undef 233! \%hash undef 234! {} undef 235! @nums undef 236! \@nums undef 237! [] undef 238! %tied_hash undef 239! @tied_nums undef 240! $deep1 undef 241! /foo/ undef 242! qr/foo/ undef 243! 21..30 undef 244! 189 undef 245! "foo" undef 246! "" undef 247! !1 undef 248 undef undef 249 (my $u) undef 250 NOT_DEF undef 251 &NOT_DEF undef 252 253# Any ~~ object overloaded 254! \&fatal $ov_obj 255 'cigam' $ov_obj 256! 'cigam on' $ov_obj 257! ['cigam'] $ov_obj 258! ['stringified'] $ov_obj 259! { cigam => 1 } $ov_obj 260! { stringified => 1 } $ov_obj 261! $obj $ov_obj 262! undef $ov_obj 263 264# regular object 265@ $obj $obj 266@ $ov_obj $obj 267=@ \&fatal $obj 268@ \&FALSE $obj 269@ \&foo $obj 270@ sub { 1 } $obj 271@ sub { 0 } $obj 272@ %keyandmore $obj 273@ {"key" => 1} $obj 274@ @fooormore $obj 275@ ["key" => 1] $obj 276@ /key/ $obj 277@ qr/key/ $obj 278@ "key" $obj 279@ FALSE $obj 280 281# regular object with "" overload 282@ $obj $str_obj 283=@ \&fatal $str_obj 284@ \&FALSE $str_obj 285@ \&foo $str_obj 286@ sub { 1 } $str_obj 287@ sub { 0 } $str_obj 288@ %keyandmore $str_obj 289@ {"object" => 1} $str_obj 290@ @fooormore $str_obj 291@ ["object" => 1] $str_obj 292@ /object/ $str_obj 293@ qr/object/ $str_obj 294@ "object" $str_obj 295@ FALSE $str_obj 296# Those will treat the $str_obj as a string because of fallback: 297 298# object (overloaded or not) ~~ Any 299 $obj qr/NoOverload/ 300 $ov_obj qr/^stringified$/ 301= "$ov_obj" "stringified" 302= "$str_obj" "object" 303!= $ov_obj "stringified" 304 $str_obj "object" 305 $ov_obj 'magic' 306! $ov_obj 'not magic' 307 308# ~~ Coderef 309 sub{0} sub { ref $_[0] eq "CODE" } 310 %fooormore sub { $_[0] =~ /^(foo|or|more)$/ } 311! %fooormore sub { $_[0] =~ /^(foo|or|less)$/ } 312 \%fooormore sub { $_[0] =~ /^(foo|or|more)$/ } 313! \%fooormore sub { $_[0] =~ /^(foo|or|less)$/ } 314 +{%fooormore} sub { $_[0] =~ /^(foo|or|more)$/ } 315! +{%fooormore} sub { $_[0] =~ /^(foo|or|less)$/ } 316 @fooormore sub { $_[0] =~ /^(foo|or|more)$/ } 317! @fooormore sub { $_[0] =~ /^(foo|or|less)$/ } 318 \@fooormore sub { $_[0] =~ /^(foo|or|more)$/ } 319! \@fooormore sub { $_[0] =~ /^(foo|or|less)$/ } 320 [@fooormore] sub { $_[0] =~ /^(foo|or|more)$/ } 321! [@fooormore] sub { $_[0] =~ /^(foo|or|less)$/ } 322 %fooormore sub{@_==1} 323 @fooormore sub{@_==1} 324 "foo" sub { $_[0] =~ /^(foo|or|more)$/ } 325! "more" sub { $_[0] =~ /^(foo|or|less)$/ } 326 /fooormore/ sub{ref $_[0] eq 'Regexp'} 327 qr/fooormore/ sub{ref $_[0] eq 'Regexp'} 328 1 sub{shift} 329! 0 sub{shift} 330! undef sub{shift} 331 undef sub{not shift} 332 NOT_DEF sub{not shift} 333 &NOT_DEF sub{not shift} 334 FALSE sub{not shift} 335 [1] \&bar 336 {a=>1} \&bar 337 qr// \&bar 338! [1] \&foo 339! {a=>1} \&foo 340 $obj sub { ref($_[0]) =~ /NoOverload/ } 341 $ov_obj sub { ref($_[0]) =~ /WithOverload/ } 342# empty stuff matches, because the sub is never called: 343 [] \&foo 344 {} \&foo 345 @empty \&foo 346 %empty \&foo 347! qr// \&foo 348! undef \&foo 349 undef \&bar 350@ undef \&fatal 351@ 1 \&fatal 352@ [1] \&fatal 353@ {a=>1} \&fatal 354@ "foo" \&fatal 355@ qr// \&fatal 356# sub is not called on empty hashes / arrays 357 [] \&fatal 358 +{} \&fatal 359 @empty \&fatal 360 %empty \&fatal 361# sub is not special on the left 362 sub {0} qr/^CODE/ 363 sub {0} sub { ref shift eq "CODE" } 364 365# HASH ref against: 366# - another hash ref 367 {} {} 368=! {} {1 => 2} 369 {1 => 2} {1 => 2} 370 {1 => 2} {1 => 3} 371=! {1 => 2} {2 => 3} 372= \%main:: {map {$_ => 'x'} keys %main::} 373 374# - tied hash ref 375= \%hash \%tied_hash 376 \%tied_hash \%tied_hash 377!= {"a"=>"b"} \%tied_hash 378= %hash %tied_hash 379 %tied_hash %tied_hash 380!= {"a"=>"b"} %tied_hash 381 $ov_obj %refh MINISKIP 382! "$ov_obj" %refh MINISKIP 383 [$ov_obj] %refh MINISKIP 384! ["$ov_obj"] %refh MINISKIP 385 %refh %refh MINISKIP 386 387# - an array ref 388# (since this is symmetrical, tests as well hash~~array) 389= [keys %main::] \%:: 390= [qw[STDIN STDOUT]] \%:: 391=! [] \%:: 392=! [""] {} 393=! [] {} 394=! @empty {} 395= [undef] {"" => 1} 396= [""] {"" => 1} 397= ["foo"] { foo => 1 } 398= ["foo", "bar"] { foo => 1 } 399= ["foo", "bar"] \%hash 400= ["foo"] \%hash 401=! ["quux"] \%hash 402= [qw(foo quux)] \%hash 403= @fooormore { foo => 1, or => 2, more => 3 } 404= @fooormore %fooormore 405= @fooormore \%fooormore 406= \@fooormore %fooormore 407 408# - a regex 409= qr/^(fo[ox])$/ {foo => 1} 410= /^(fo[ox])$/ %fooormore 411=! qr/[13579]$/ +{0..99} 412=! qr/a*/ {} 413= qr/a*/ {b=>2} 414= qr/B/i {b=>2} 415= /B/i {b=>2} 416=! qr/a+/ {b=>2} 417= qr/^à/ {"à"=>2} 418 419# - a scalar 420 "foo" +{foo => 1, bar => 2} 421 "foo" %fooormore 422! "baz" +{foo => 1, bar => 2} 423! "boz" %fooormore 424! 1 +{foo => 1, bar => 2} 425! 1 %fooormore 426 1 { 1 => 3 } 427 1.0 { 1 => 3 } 428! "1.0" { 1 => 3 } 429! "1.0" { 1.0 => 3 } 430 "1.0" { "1.0" => 3 } 431 "à" { "à" => "À" } 432 433# - undef 434! undef { hop => 'zouu' } 435! undef %hash 436! undef +{"" => "empty key"} 437! undef {} 438 439# ARRAY ref against: 440# - another array ref 441 [] [] 442=! [] [1] 443 [["foo"], ["bar"]] [qr/o/, qr/a/] 444! [["foo"], ["bar"]] [qr/ARRAY/, qr/ARRAY/] 445 ["foo", "bar"] [qr/o/, qr/a/] 446! [qr/o/, qr/a/] ["foo", "bar"] 447 ["foo", "bar"] [["foo"], ["bar"]] 448! ["foo", "bar"] [qr/o/, "foo"] 449 ["foo", undef, "bar"] [qr/o/, undef, "bar"] 450! ["foo", undef, "bar"] [qr/o/, "", "bar"] 451! ["foo", "", "bar"] [qr/o/, undef, "bar"] 452 $deep1 $deep1 453 @$deep1 @$deep1 454! $deep1 $deep2 455 456= \@nums \@tied_nums 457= @nums \@tied_nums 458= \@nums @tied_nums 459= @nums @tied_nums 460 461# - an object 462! $obj @fooormore 463 $obj [sub{ref shift}] 464 465# - a regex 466= qr/x/ [qw(foo bar baz quux)] 467=! qr/y/ [qw(foo bar baz quux)] 468= /x/ [qw(foo bar baz quux)] 469=! /y/ [qw(foo bar baz quux)] 470= /FOO/i @fooormore 471=! /bar/ @fooormore 472 473# - a number 474 2 [qw(1.00 2.00)] 475 2 [qw(foo 2)] 476 2.0_0e+0 [qw(foo 2)] 477! 2 [qw(1foo bar2)] 478 479# - a string 480! "2" [qw(1foo 2bar)] 481 "2bar" [qw(1foo 2bar)] 482 483# - undef 484 undef [1, 2, undef, 4] 485! undef [1, 2, [undef], 4] 486! undef @fooormore 487 undef @sparse 488 undef [undef] 489! 0 [undef] 490! "" [undef] 491! undef [0] 492! undef [""] 493 494# - nested arrays and ~~ distributivity 495 11 [[11]] 496! 11 [[12]] 497 "foo" [{foo => "bar"}] 498! "bar" [{foo => "bar"}] 499 500# Number against number 501 2 2 502 20 2_0 503! 2 3 504 0 FALSE 505 3-2 TRUE 506! undef 0 507! (my $u) 0 508 509# Number against string 510= 2 "2" 511= 2 "2.0" 512! 2 "2bananas" 513!= 2_3 "2_3" NOWARNINGS 514 FALSE "0" 515! undef "0" 516! undef "" 517 518# Regex against string 519 "x" qr/x/ 520! "x" qr/y/ 521 522# Regex against number 523 12345 qr/3/ 524! 12345 qr/7/ 525 526# array/hash against string 527 @fooormore "".\@fooormore 528! @keyandmore "".\@fooormore 529 %fooormore "".\%fooormore 530! %keyandmore "".\%fooormore 531 532# Test the implicit referencing 533 7 @nums 534 @nums \@nums 535! @nums \\@nums 536 @nums [1..10] 537! @nums [0..9] 538 539 "foo" %hash 540 /bar/ %hash 541 [qw(bar)] %hash 542! [qw(a b c)] %hash 543 %hash %hash 544 %hash +{%hash} 545 %hash \%hash 546 %hash %tied_hash 547 %tied_hash %tied_hash 548 %hash { foo => 5, bar => 10 } 549! %hash { foo => 5, bar => 10, quux => 15 } 550 551 @nums { 1, '', 2, '' } 552 @nums { 1, '', 12, '' } 553! @nums { 11, '', 12, '' } 554 555# array slices 556 @nums[0..-1] [] 557 @nums[0..0] [1] 558! @nums[0..1] [0..2] 559 @nums[0..4] [1..5] 560 561! undef @nums[0..-1] 562 1 @nums[0..0] 563 2 @nums[0..1] 564! @nums[0..1] 2 565 566 @nums[0..1] @nums[0..1] 567 568# hash slices 569 @keyandmore{qw(not)} [undef] 570 @keyandmore{qw(key)} [0] 571 572 undef @keyandmore{qw(not)} 573 0 @keyandmore{qw(key and more)} 574! 2 @keyandmore{qw(key and)} 575 576 @fooormore{qw(foo)} @keyandmore{qw(key)} 577 @fooormore{qw(foo or more)} @keyandmore{qw(key and more)} 578 579# UNDEF 580! 3 undef 581! 1 undef 582! [] undef 583! {} undef 584! \%::main undef 585! [1,2] undef 586! %hash undef 587! @nums undef 588! "foo" undef 589! "" undef 590! !1 undef 591! \&foo undef 592! sub { } undef 593