Commit | Line | Data |
---|---|---|
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 | ||
16 | BEGIN { | |
17 | chdir 't' if -d 't'; | |
a5f48505 | 18 | require './test.pl'; |
624c42e2 | 19 | set_up_inc('../lib') |
a5f48505 DM |
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 | ||
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 |
272 | SKIP: { |
273 | use Config; | |
274 | # debugging builds will detect this failure and panic | |
81962cbb | 275 | skip "DEBUGGING build" if $::Config{ccflags} =~ /(?<!\S)-DDEBUGGING(?!\S)/ |
43f4a416 | 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 | |
a3815e44 | 543 | # Note that this just codifies existing behaviour - it may not be |
b09ed995 DM |
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 | |
5b354d2a | 597 | { |
77242fe8 | 598 | # GH #17816 |
5b354d2a DM |
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 | ||
282d9dfe | 606 | { |
77242fe8 | 607 | # GH #16685 |
282d9dfe DM |
608 | # honour trailing undef's in list context |
609 | my $x = 1; | |
610 | my @a = (($x, undef, undef) = (1)); | |
77242fe8 | 611 | is(scalar @a, 3, "GH #16685"); |
282d9dfe DM |
612 | } |
613 | ||
5b354d2a | 614 | |
a5f48505 | 615 | done_testing(); |