t/op/aassign.t

   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
  16 BEGIN {
  17     chdir 't' if -d 't';
  18     require './test.pl';
  19     set_up_inc('../lib')
  20 }
  21
  22 use warnings;
  23 use strict;
  24
  25 # general purpose package vars
  26
  27 our $pkg_scalar;
  28 our @pkg_array;
  29 our %pkg_hash;
  30
  31 sub f_ret_14 { return 1..4 }
  32
  33 # stringify a hash ref
  34
  35 sub 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
 272 SKIP: {
 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 done_testing();