1#!./perl -w 2 3# Some miscellaneous checks for the list assignment operator, OP_AASSIGN. 4# 5# This file was only added in 2015; before then, such tests were 6# typically in various other random places like op/array.t. This test file 7# doesn't therefore attempt to be comprehensive; it merely provides a 8# central place to new put additional tests, especially those related to 9# the trickiness of commonality, e.g. ($a,$b) = ($b,$a). 10# 11# In particular, it's testing the flags 12# OPpASSIGN_COMMON_SCALAR 13# OPpASSIGN_COMMON_RC1 14# OPpASSIGN_COMMON_AGG 15 16BEGIN { 17 chdir 't' if -d 't'; 18 require './test.pl'; 19 set_up_inc('../lib') 20} 21 22use warnings; 23use strict; 24 25# general purpose package vars 26 27our $pkg_scalar; 28our @pkg_array; 29our %pkg_hash; 30 31sub f_ret_14 { return 1..4 } 32 33# stringify a hash ref 34 35sub sh { 36 my $rh = $_[0]; 37 join ',', map "$_:$rh->{$_}", sort keys %$rh; 38} 39 40 41# where the RHS has surplus elements 42 43{ 44 my ($a,$b); 45 ($a,$b) = f_ret_14(); 46 is("$a:$b", "1:2", "surplus"); 47} 48 49# common with slices 50 51{ 52 my @a = (1,2); 53 @a[0,1] = @a[1,0]; 54 is("$a[0]:$a[1]", "2:1", "lex array slice"); 55} 56 57# package alias 58 59{ 60 my ($a, $b) = 1..2; 61 for $pkg_scalar ($a) { 62 ($pkg_scalar, $b) = (3, $a); 63 is($pkg_scalar, 3, "package alias pkg"); 64 is("$a:$b", "3:1", "package alias a:b"); 65 } 66} 67 68# my array/hash populated via closure 69 70{ 71 my $ra = f1(); 72 my ($x, @a) = @$ra; 73 sub f1 { $x = 1; @a = 2..4; \@a } 74 is($x, 2, "my: array closure x"); 75 is("@a", "3 4", "my: array closure a"); 76 77 my $rh = f2(); 78 my ($k, $v, %h) = (d => 4, %$rh, e => 6); 79 sub f2 { $k = 'a'; $v = 1; %h = qw(b 2 c 3); \%h } 80 is("$k:$v", "d:4", "my: hash closure k:v"); 81 is(sh(\%h), "b:2,c:3,e:6", "my: hash closure h"); 82} 83 84 85# various shared element scenarios within a my (...) 86 87{ 88 my ($x,$y) = f3(); # $x and $y on both sides 89 sub f3 : lvalue { ($x,$y) = (1,2); $y, $x } 90 is ("$x:$y", "2:1", "my: scalar and lvalue sub"); 91} 92 93{ 94 my $ra = f4(); 95 my @a = @$ra; # elements of @a on both sides 96 sub f4 { @a = 1..4; \@a } 97 is("@a", "1 2 3 4", "my: array and elements"); 98} 99 100{ 101 my $rh = f5(); 102 my %h = %$rh; # elements of %h on both sides 103 sub f5 { %h = qw(a 1 b 2 c 3); \%h } 104 is(sh(\%h), "a:1,b:2,c:3", "my: hash and elements"); 105} 106 107{ 108 f6(); 109 our $xalias6; 110 my ($x, $y) = (2, $xalias6); 111 sub f6 { $x = 1; *xalias6 = \$x; } 112 is ("$x:$y", "2:1", "my: pkg var aliased to lexical"); 113} 114 115 116{ 117 my @a; 118 f7(); 119 my ($x,$y) = @a; 120 is ("$x:$y", "2:1", "my: lex array elements aliased"); 121 122 sub f7 { 123 ($x, $y) = (1,2); 124 use feature 'refaliasing'; 125 no warnings 'experimental'; 126 \($a[0], $a[1]) = \($y,$x); 127 } 128} 129 130{ 131 @pkg_array = (); 132 f8(); 133 my ($x,$y) = @pkg_array; 134 is ("$x:$y", "2:1", "my: pkg array elements aliased"); 135 136 sub f8 { 137 ($x, $y) = (1,2); 138 use feature 'refaliasing'; 139 no warnings 'experimental'; 140 \($pkg_array[0], $pkg_array[1]) = \($y,$x); 141 } 142} 143 144{ 145 f9(); 146 my ($x,$y) = f9(); 147 is ("$x:$y", "2:1", "my: pkg scalar alias"); 148 149 our $xalias9; 150 sub f9 : lvalue { 151 ($x, $y) = (1,2); 152 *xalias9 = \$x; 153 $y, $xalias9; 154 } 155} 156 157{ 158 use feature 'refaliasing'; 159 no warnings 'experimental'; 160 161 f10(); 162 our $pkg10; 163 \(my $lex) = \$pkg10; 164 my @a = ($lex,3); # equivalent to ($a[0],3) 165 is("@a", "1 3", "my: lex alias of array alement"); 166 167 sub f10 { 168 @a = (1,2); 169 \$pkg10 = \$a[0]; 170 } 171 172} 173 174{ 175 use feature 'refaliasing'; 176 no warnings 'experimental'; 177 178 f11(); 179 my @b; 180 my @a = (@b); 181 is("@a", "2 1", "my: lex alias of array alements"); 182 183 sub f11 { 184 @a = (1,2); 185 \$b[0] = \$a[1]; 186 \$b[1] = \$a[0]; 187 } 188} 189 190# package aliasing 191 192{ 193 my ($x, $y) = (1,2); 194 195 for $pkg_scalar ($x) { 196 ($pkg_scalar, $y) = (3, $x); 197 is("$pkg_scalar,$y", "3,1", "package scalar aliased"); 198 } 199} 200 201# lvalue subs on LHS 202 203{ 204 my @a; 205 sub f12 : lvalue { @a } 206 (f12()) = 1..3; 207 is("@a", "1 2 3", "lvalue sub on RHS returns array"); 208} 209 210{ 211 my ($x,$y); 212 sub f13 : lvalue { $x,$y } 213 (f13()) = 1..3; 214 is("$x:$y", "1:2", "lvalue sub on RHS returns scalars"); 215} 216 217 218# package shared scalar vars 219 220{ 221 our $pkg14a = 1; 222 our $pkg14b = 2; 223 ($pkg14a,$pkg14b) = ($pkg14b,$pkg14a); 224 is("$pkg14a:$pkg14b", "2:1", "shared package scalars"); 225} 226 227# lexical shared scalar vars 228 229{ 230 my $a = 1; 231 my $b = 2; 232 ($a,$b) = ($b,$a); 233 is("$a:$b", "2:1", "shared lexical scalars"); 234} 235 236 237# lexical nested array elem swap 238 239{ 240 my @a; 241 $a[0][0] = 1; 242 $a[0][1] = 2; 243 ($a[0][0],$a[0][1]) = ($a[0][1],$a[0][0]); 244 is("$a[0][0]:$a[0][1]", "2:1", "lexical nested array elem swap"); 245} 246 247# package nested array elem swap 248 249{ 250 our @a15; 251 $a15[0][0] = 1; 252 $a15[0][1] = 2; 253 ($a15[0][0],$a15[0][1]) = ($a15[0][1],$a15[0][0]); 254 is("$a15[0][0]:$a15[0][1]", "2:1", "package nested array elem swap"); 255} 256 257# surplus RHS junk 258# 259{ 260 our ($a16, $b16); 261 ($a16, undef, $b16) = 1..30; 262 is("$a16:$b16", "1:3", "surplus RHS junk"); 263} 264 265# my ($scalar,....) = @_ 266# 267# technically this is an unsafe usage commonality-wise, but 268# a) you have to try really hard to break it, as this test shows; 269# b) it's such an important usage that for performance reasons we 270# mark it as safe even though it isn't really. Hence it's a TODO. 271 272SKIP: { 273 use Config; 274 # debugging builds will detect this failure and panic 275 skip "DEBUGGING build" if $::Config{ccflags} =~ /(?<!\S)-DDEBUGGING(?!\S)/ 276 or $^O eq 'VMS' && $::Config{usedebugging_perl} eq 'Y'; 277 local $::TODO = 'cheat and optimise my (....) = @_'; 278 local @_ = 1..3; 279 &f17; 280 my ($a, @b) = @_; 281 is("($a)(@b)", "(3)(2 1)", 'my (....) = @_'); 282 283 sub f17 { 284 use feature 'refaliasing'; 285 no warnings 'experimental'; 286 ($a, @b) = @_; 287 \($_[2], $_[1], $_[0]) = \($a, $b[0], $b[1]); 288 } 289} 290 291# single scalar on RHS that's in an aggregate on LHS 292 293{ 294 my @a = 1..3; 295 for my $x ($a[0]) { 296 (@a) = ($x); 297 is ("(@a)", "(1)", 'single scalar on RHS, agg'); 298 } 299} 300 301# TEMP buffer stealing. 302# In something like 303# (...) = (f())[0,0] 304# the same TEMP RHS element may be used more than once, so when copying 305# it, we mustn't steal its buffer. 306# DAPM 10/2016 - but in that case the SvTEMP flag is sometimes getting 307# cleared: using split() instead as a source of temps seems more reliable, 308# so I've added splut variants too. 309 310{ 311 # a string long enough for COW and buffer stealing to be enabled 312 my $long = 'def' . ('x' x 2000); 313 314 # a sub that is intended to return a TEMP string that isn't COW 315 # the concat returns a non-COW PADTMP; pp_leavesub sees a long 316 # stealable string, so creates a TEMP with the stolen buffer from the 317 # PADTMP - hence it returns a non-COW string. It also returns a couple 318 # of key strings for the hash tests 319 sub f18 { 320 my $x = "abc"; 321 ($x . $long, "key1", "key2"); 322 } 323 324 my (@a, %h); 325 326 # with @a initially empty,the code path creates a new copy of each 327 # RHS element to store in the array 328 329 @a = (f18())[0,0]; 330 is (substr($a[0], 0, 7), "abcdefx", 'NOSTEAL f18 empty $a[0]'); 331 is (substr($a[1], 0, 7), "abcdefx", 'NOSTEAL f18 empty $a[1]'); 332 @a = (split /-/, "abc-def")[0,0]; 333 is ($a[0], "abc", 'NOSTEAL split empty $a[0]'); 334 is ($a[1], "abc", 'NOSTEAL split empty $a[1]'); 335 336 # with @a initially non-empty, it takes a different code path that 337 # makes a mortal copy of each RHS element 338 @a = 1..3; 339 @a = (f18())[0,0]; 340 is (substr($a[0], 0, 7), "abcdefx", 'NOSTEAL f18 non-empty $a[0]'); 341 is (substr($a[1], 0, 7), "abcdefx", 'NOSTEAL f18 non-empty $a[1]'); 342 @a = 1..3; 343 @a = (split /-/, "abc-def")[0,0]; 344 is ($a[0], "abc", 'NOSTEAL split non-empty $a[0]'); 345 is ($a[1], "abc", 'NOSTEAL split non-empty $a[1]'); 346 347 # similarly with PADTMPs 348 349 @a = (); 350 @a = ($long . "x")[0,0]; 351 is (substr($a[0], 0, 4), "defx", 'NOSTEAL PADTMP empty $a[0]'); 352 is (substr($a[1], 0, 4), "defx", 'NOSTEAL PADTMP empty $a[1]'); 353 354 @a = 1..3; 355 @a = ($long . "x")[0,0]; 356 is (substr($a[0], 0, 4), "defx", 'NOSTEAL PADTMP non-empty $a[0]'); 357 is (substr($a[1], 0, 4), "defx", 'NOSTEAL PADTMP non-empty $a[1]'); 358 359 # as above, but assigning to a hash 360 361 %h = (f18())[1,0,2,0]; 362 is (substr($h{key1}, 0, 7), "abcdefx", 'NOSTEAL f18 empty $h{key1}'); 363 is (substr($h{key2}, 0, 7), "abcdefx", 'NOSTEAL f18 empty $h{key2}'); 364 %h = (split /-/, "key1-val-key2")[0,1,2,1]; 365 is ($h{key1}, "val", 'NOSTEAL split empty $h{key1}'); 366 is ($h{key2}, "val", 'NOSTEAL split empty $h{key2}'); 367 368 %h = qw(key1 foo key2 bar key3 baz); 369 %h = (f18())[1,0,2,0]; 370 is (substr($h{key1}, 0, 7), "abcdefx", 'NOSTEAL f18 non-empty $h{key1}'); 371 is (substr($h{key2}, 0, 7), "abcdefx", 'NOSTEAL f18 non-empty $h{key2}'); 372 %h = qw(key1 foo key2 bar key3 baz); 373 %h = (split /-/, "key1-val-key2")[0,1,2,1]; 374 is ($h{key1}, "val", 'NOSTEAL split non-empty $h{key1}'); 375 is ($h{key2}, "val", 'NOSTEAL split non-empty $h{key2}'); 376 377 %h = (); 378 %h = ($long . "x", "key1", "key2")[1,0,2,0]; 379 is (substr($h{key1}, 0, 4), "defx", 'NOSTEAL PADTMP empty $h{key1}'); 380 is (substr($h{key2}, 0, 4), "defx", 'NOSTEAL PADTMP empty $h{key2}'); 381 382 %h = qw(key1 foo key2 bar key3 baz); 383 %h = ($long . "x", "key1", "key2")[1,0,2,0]; 384 is (substr($h{key1}, 0, 4), "defx", 'NOSTEAL PADTMP non-empty $h{key1}'); 385 is (substr($h{key2}, 0, 4), "defx", 'NOSTEAL PADTMP non-empty $h{key2}'); 386 387 # both keys and values stealable 388 @a = (%h = (split /-/, "abc-def")[0,1,0,1]); 389 is (join(':', keys %h), "abc", "NOSTEAL split G_ARRAY keys"); 390 is (join(':', values %h), "def", "NOSTEAL split G_ARRAY values"); 391 is (join(':', @a), "abc:def", "NOSTEAL split G_ARRAY result"); 392} 393 394{ 395 my $x = 1; 396 my $y = 2; 397 ($x,$y) = (undef, $x); 398 is($x, undef, 'single scalar on RHS, but two on LHS: x'); 399 is($y, 1, 'single scalar on RHS, but two on LHS: y'); 400} 401 402{ # magic handling, see #126633 403 use v5.22; 404 my $set; 405 package ArrayProxy { 406 sub TIEARRAY { bless [ $_[1] ] } 407 sub STORE { $_[0][0]->[$_[1]] = $_[2]; $set = 1 } 408 sub FETCH { $_[0][0]->[$_[1]] } 409 sub CLEAR { @{$_[0][0]} = () } 410 sub EXTEND {} 411 }; 412 my @base = ( "a", "b" ); 413 my @real = @base; 414 my @proxy; 415 my $temp; 416 tie @proxy, "ArrayProxy", \@real; 417 @proxy[0, 1] = @real[1, 0]; 418 is($real[0], "b", "tied left first"); 419 is($real[1], "a", "tied left second"); 420 @real = @base; 421 @real[0, 1] = @proxy[1, 0]; 422 is($real[0], "b", "tied right first"); 423 is($real[1], "a", "tied right second"); 424 @real = @base; 425 @proxy[0, 1] = @proxy[1, 0]; 426 is($real[0], "b", "tied both first"); 427 is($real[1], "a", "tied both second"); 428 @real = @base; 429 ($temp, @real) = @proxy[1, 0]; 430 is($real[0], "a", "scalar/array tied right"); 431 @real = @base; 432 ($temp, @proxy) = @real[1, 0]; 433 is($real[0], "a", "scalar/array tied left"); 434 @real = @base; 435 ($temp, @proxy) = @proxy[1, 0]; 436 is($real[0], "a", "scalar/array tied both"); 437 $set = 0; 438 my $orig; 439 ($proxy[0], $orig) = (1, $set); 440 is($orig, 0, 'previous value of $set'); 441 442 # from cpan #110278 443 SKIP: { 444 skip "no List::Util::min on miniperl", 2, if is_miniperl; 445 require List::Util; 446 my $x = 1; 447 my $y = 2; 448 ( $x, $y ) = ( List::Util::min($y), List::Util::min($x) ); 449 is($x, 2, "check swap for \$x"); 450 is($y, 1, "check swap for \$y"); 451 } 452} 453 454{ 455 # check that a second aggregate is empted but doesn't suck up 456 # anything random 457 458 my (@a, @b) = qw(x y); 459 is(+@a, 2, "double array A len"); 460 is(+@b, 0, "double array B len"); 461 is("@a", "x y", "double array A contents"); 462 463 @a = 1..10; 464 @b = 100..200; 465 (@a, @b) = qw(x y); 466 is(+@a, 2, "double array non-empty A len"); 467 is(+@b, 0, "double array non-empty B len"); 468 is("@a", "x y", "double array non-empty A contents"); 469 470 my (%a, %b) = qw(k1 v1 k2 v2); 471 is(+(keys %a), 2, "double hash A len"); 472 is(+(keys %b), 0, "double hash B len"); 473 is(join(' ', sort keys %a), "k1 k2", "double hash A keys"); 474 is(join(' ', sort values %a), "v1 v2", "double hash A values"); 475 476 %a = 1..10; 477 %b = 101..200; 478 (%a, %b) = qw(k1 v1 k2 v2); 479 is(+(keys %a), 2, "double hash non-empty A len"); 480 is(+(keys %b), 0, "double hash non-empty B len"); 481 is(join(' ', sort keys %a), "k1 k2", "double hash non-empty A keys"); 482 is(join(' ', sort values %a), "v1 v2", "double hash non-empty A values"); 483} 484 485# list and lval context: filling of missing elements, returning correct 486# lvalues. 487# ( Note that these partially duplicate some tests in hashassign.t which 488# I didn't spot at first - DAPM) 489 490{ 491 my ($x, $y, $z); 492 my (@a, %h); 493 494 sub lval { 495 my $n = shift; 496 my $desc = shift; 497 is($x, $n >= 1 ? "assign1" : undef, "lval: X pre $n $desc"); 498 is($y, $n >= 2 ? "assign2" : undef, "lval: Y pre $n $desc"); 499 is($z, undef, "lval: Z pre $n $desc"); 500 501 my $i = 0; 502 for (@_) { 503 $_ = "lval$i"; 504 $i++; 505 } 506 is($x, "lval0", "lval: a post $n $desc"); 507 is($y, "lval1", "lval: b post $n $desc"); 508 is($z, "lval2", "lval: c post $n $desc"); 509 } 510 lval(0, "XYZ", (($x,$y,$z) = ())); 511 lval(1, "XYZ", (($x,$y,$z) = (qw(assign1)))); 512 lval(2, "XYZ", (($x,$y,$z) = (qw(assign1 assign2)))); 513 514 lval(0, "XYZA", (($x,$y,$z,@a) = ())); 515 lval(1, "XYZA", (($x,$y,$z,@a) = (qw(assign1)))); 516 lval(2, "XYZA", (($x,$y,$z,@a) = (qw(assign1 assign2)))); 517 518 lval(0, "XYAZ", (($x,$y,@a,$z) = ())); 519 lval(1, "XYAZ", (($x,$y,@a,$z) = (qw(assign1)))); 520 lval(2, "XYAZ", (($x,$y,@a,$z) = (qw(assign1 assign2)))); 521 522 lval(0, "XYZH", (($x,$y,$z,%h) = ())); 523 lval(1, "XYZH", (($x,$y,$z,%h) = (qw(assign1)))); 524 lval(2, "XYZH", (($x,$y,$z,%h) = (qw(assign1 assign2)))); 525 526 lval(0, "XYHZ", (($x,$y,%h,$z) = ())); 527 lval(1, "XYHZ", (($x,$y,%h,$z) = (qw(assign1)))); 528 lval(2, "XYHZ", (($x,$y,%h,$z) = (qw(assign1 assign2)))); 529 530 # odd number of hash elements 531 532 { 533 no warnings 'misc'; 534 @a = ((%h) = qw(X)); 535 is (join(":", map $_ // "u", @a), "X:u", "lval odd singleton"); 536 @a = (($x, $y, %h) = qw(X Y K)); 537 is (join(":", map $_ // "u", @a), "X:Y:K:u", "lval odd"); 538 @a = (($x, $y, %h, $z) = qw(X Y K)); 539 is (join(":", map $_ // "u", @a), "X:Y:K:u:u", "lval odd with z"); 540 } 541 542 # undef on LHS uses RHS as lvalue instead 543 # Note that this just codifies existing behaviour - it may not be 544 # correct. See http://nntp.perl.org/group/perl.perl5.porters/240358. 545 546 { 547 ($x, $y, $z) = (0, 10, 20); 548 $_++ for ((undef, $x) = ($y, $z)); 549 is "$x:$y:$z", "21:11:20", "undef as lvalue"; 550 } 551 552} 553 554{ 555 # [perl #129991] assert failure in S_aassign_copy_common 556 # the LHS of a list assign can be aliased to an immortal SV; 557 # we used to assert that this couldn't happen 558 eval { ($_,$0)=(1,0) for 0 gt 0 }; 559 like($@, qr//, "RT #129991"); 560} 561 562{ 563 # [perl #130132] 564 # lexical refs on LHS, dereffed on the RHS 565 566 my $fill; 567 568 my $sref = do { my $tmp = 2; \$tmp }; 569 ($sref, $fill) = (1, $$sref); 570 is ($sref, 1, "RT #130132 scalar 1"); 571 is ($fill, 2, "RT #130132 scalar 2"); 572 573 my $x = 1; 574 $sref = \$x; 575 ($sref, $$sref) = (2, 3); 576 is ($sref, 2, "RT #130132 scalar derefffed 1"); 577 is ($x, 3, "RT #130132 scalar derefffed 2"); 578 579 $x = 1; 580 $sref = \$x; 581 ($sref, $$sref) = (2); 582 is ($sref, 2, "RT #130132 scalar undef 1"); 583 is ($x, undef, "RT #130132 scalar undef 2"); 584 585 my @a; 586 $sref = do { my $tmp = 2; \$tmp }; 587 @a = (($sref) = (1, $$sref)); 588 is ($sref, 1, "RT #130132 scalar list cxt 1"); 589 is ($a[0], 1, "RT #130132 scalar list cxt a[0]"); 590 591 my $aref = [ 1, 2 ]; 592 ($aref, $fill) = @$aref; 593 is ($aref, 1, "RT #130132 array 1"); 594 is ($fill, 2, "RT #130132 array 2"); 595} 596 597{ 598 # GH #16685 599 # don't use the "1-arg on LHS can't be common" optimisation 600 # when there are undef's there 601 my $x = 1; 602 my @a = (($x, undef) = (2 => $x)); 603 is("@a", "2 1", "GH #17816"); 604} 605 606{ 607 # GH #17816 608 # honour trailing undef's in list context 609 my $x = 1; 610 my @a = (($x, undef, undef) = (1)); 611 is(scalar @a, 3, "GH #17816"); 612} 613 614 615done_testing(); 616