This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid premature free of referent in list assign
[perl5.git] / t / op / aassign.t
CommitLineData
a5f48505
DM
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';
a5f48505 18 require './test.pl';
624c42e2 19 set_up_inc('../lib')
a5f48505
DM
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
90ce4d05
DM
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
ebc643ce
DM
272SKIP: {
273 use Config;
274 # debugging builds will detect this failure and panic
43f4a416
CB
275 skip "DEBUGGING build" if $::Config{ccflags} =~ /DEBUGGING/
276 or $^O eq 'VMS' && $::Config{usedebugging_perl} eq 'Y';
90ce4d05
DM
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
808ce557
DM
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
8c1e192f
DM
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.
8b0c3377
DM
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.
8c1e192f
DM
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
8b0c3377
DM
317 # PADTMP - hence it returns a non-COW string. It also returns a couple
318 # of key strings for the hash tests
8c1e192f
DM
319 sub f18 {
320 my $x = "abc";
8b0c3377 321 ($x . $long, "key1", "key2");
8c1e192f
DM
322 }
323
8b0c3377 324 my (@a, %h);
8c1e192f
DM
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];
8b0c3377
DM
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]');
8c1e192f
DM
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];
8b0c3377
DM
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]');
8c1e192f 353
8b0c3377
DM
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");
8c1e192f
DM
392}
393
9ae0115f
DM
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
0072721c
TC
402{ # magic handling, see #126633
403 use v5.22;
5c1db569 404 my $set;
0072721c
TC
405 package ArrayProxy {
406 sub TIEARRAY { bless [ $_[1] ] }
5c1db569 407 sub STORE { $_[0][0]->[$_[1]] = $_[2]; $set = 1 }
0072721c
TC
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");
0072721c 419 is($real[1], "a", "tied left second");
0072721c
TC
420 @real = @base;
421 @real[0, 1] = @proxy[1, 0];
422 is($real[0], "b", "tied right first");
0072721c 423 is($real[1], "a", "tied right second");
0072721c
TC
424 @real = @base;
425 @proxy[0, 1] = @proxy[1, 0];
426 is($real[0], "b", "tied both first");
beb08a1e 427 is($real[1], "a", "tied both second");
0072721c
TC
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");
5c1db569
TC
437 $set = 0;
438 my $orig;
439 ($proxy[0], $orig) = (1, $set);
440 is($orig, 0, 'previous value of $set');
2f9365dc
DM
441
442 # from cpan #110278
a64a1748
JH
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 }
0072721c 452}
90ce4d05 453
8b0c3377
DM
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
b09ed995
DM
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 this 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
94a5f659
DM
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}
b09ed995 561
d24e3eb1
DM
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}
b09ed995 596
a5f48505 597done_testing();