This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #126633] check children of OA_DANGEROUS ops for common scalars
[perl5.git] / 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     @INC = '../lib';
19     require './test.pl';
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} =~ /DEBUGGING/
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
307 {
308     # a string long enough for COW and buffer stealing to be enabled
309     my $long = 'def' . ('x' x 2000);
310
311     # a sub that is intended to return a TEMP string that isn't COW
312     # the concat returns a non-COW PADTMP; pp_leavesub sees a long
313     # stealable string, so creates a TEMP with the stolen buffer from the
314     # PADTMP - hence it returns a non-COW string
315     sub f18 {
316         my $x = "abc";
317         $x . $long;
318     }
319
320     my @a;
321
322     # with @a initially empty,the code path creates a new copy of each
323     # RHS element to store in the array
324
325     @a = (f18())[0,0];
326     is (substr($a[0], 0, 7), "abcdefx", 'NOSTEAL empty $a[0]');
327     is (substr($a[1], 0, 7), "abcdefx", 'NOSTEAL empty $a[1]');
328
329     # with @a initially non-empty, it takes a different code path that
330     # makes a mortal copy of each RHS element
331     @a = 1..3;
332     @a = (f18())[0,0];
333     is (substr($a[0], 0, 7), "abcdefx", 'NOSTEAL non-empty $a[0]');
334     is (substr($a[1], 0, 7), "abcdefx", 'NOSTEAL non-empty $a[1]');
335
336 }
337
338 {
339     my $x = 1;
340     my $y = 2;
341     ($x,$y) = (undef, $x);
342     is($x, undef, 'single scalar on RHS, but two on LHS: x');
343     is($y, 1, 'single scalar on RHS, but two on LHS: y');
344 }
345
346 { # magic handling, see #126633
347     use v5.22;
348     my $set;
349     package ArrayProxy {
350         sub TIEARRAY { bless [ $_[1] ] }
351         sub STORE { $_[0][0]->[$_[1]] = $_[2]; $set = 1 }
352         sub FETCH { $_[0][0]->[$_[1]] }
353         sub CLEAR { @{$_[0][0]} = () }
354         sub EXTEND {}
355     };
356     my @base = ( "a", "b" );
357     my @real = @base;
358     my @proxy;
359     my $temp;
360     tie @proxy, "ArrayProxy", \@real;
361     @proxy[0, 1] = @real[1, 0];
362     is($real[0], "b", "tied left first");
363     is($real[1], "a", "tied left second");
364     @real = @base;
365     @real[0, 1] = @proxy[1, 0];
366     is($real[0], "b", "tied right first");
367     is($real[1], "a", "tied right second");
368     @real = @base;
369     @proxy[0, 1] = @proxy[1, 0];
370     is($real[0], "b", "tied both first");
371     is($real[1], "a", "tied both second");
372     @real = @base;
373     ($temp, @real) = @proxy[1, 0];
374     is($real[0], "a", "scalar/array tied right");
375     @real = @base;
376     ($temp, @proxy) = @real[1, 0];
377     is($real[0], "a", "scalar/array tied left");
378     @real = @base;
379     ($temp, @proxy) = @proxy[1, 0];
380     is($real[0], "a", "scalar/array tied both");
381     $set = 0;
382     my $orig;
383     ($proxy[0], $orig) = (1, $set);
384     is($orig, 0, 'previous value of $set');
385
386     # from cpan #110278
387     use List::Util qw(min);
388     my $x = 1;
389     my $y = 2;
390     ( $x, $y ) = ( min($y), min($x) );
391     is($x, 2, "check swap for \$x");
392     is($y, 1, "check swap for \$y");
393 }
394
395 done_testing();