xref: /openbsd/gnu/usr.bin/perl/t/op/lvref.t (revision 4cfece93)
1BEGIN {
2    chdir 't';
3    require './test.pl';
4    set_up_inc("../lib");
5}
6
7plan 164;
8
9eval '\$x = \$y';
10like $@, qr/^Experimental aliasing via reference not enabled/,
11    'error when feature is disabled';
12eval '\($x) = \$y';
13like $@, qr/^Experimental aliasing via reference not enabled/,
14    'error when feature is disabled (aassign)';
15
16use feature 'refaliasing', 'state';
17
18{
19    my($w,$c);
20    local $SIG{__WARN__} = sub { $c++; $w = shift };
21    eval '\$x = \$y';
22    is $c, 1, 'one warning from lv ref assignment';
23    like $w, qr/^Aliasing via reference is experimental/,
24        'experimental warning';
25    undef $c;
26    eval '\($x) = \$y';
27    is $c, 1, 'one warning from lv ref list assignment';
28    like $w, qr/^Aliasing via reference is experimental/,
29        'experimental warning';
30}
31
32no warnings 'experimental::refaliasing';
33
34# Scalars
35
36\$x = \$y;
37is \$x, \$y, '\$pkg_scalar = ...';
38my $m;
39\$m = \$y;
40is \$m, \$y, '\$lexical = ...';
41\my $n = \$y;
42is \$n, \$y, '\my $lexical = ...';
43@_ = \$_;
44\($x) = @_;
45is \$x, \$_, '\($pkgvar) = ... gives list context';
46undef *x;
47(\$x) = @_;
48is \$x, \$_, '(\$pkgvar) = ... gives list context';
49my $o;
50\($o) = @_;
51is \$o, \$_, '\($lexical) = ... gives list cx';
52my $q;
53(\$q) = @_;
54is \$q, \$_, '(\$lexical) = ... gives list cx';
55\(my $p) = @_;
56is \$p, \$_, '\(my $lexical) = ... gives list cx';
57(\my $r) = @_;
58is \$r, \$_, '(\my $lexical) = ... gives list cx';
59\my($s) = @_;
60is \$s, \$_, '\my($lexical) = ... gives list cx';
61\($_a, my $a) = @{[\$b, \$c]};
62is \$_a, \$b, 'package scalar in \(...)';
63is \$a, \$c, 'lex scalar in \(...)';
64(\$_b, \my $b) = @{[\$b, \$c]};
65is \$_b, \$::b, 'package scalar in (\$foo, \$bar)';
66is \$b, \$c, 'lex scalar in (\$foo, \$bar)';
67is do { \local $l = \3; $l }, 3, '\local $scalar assignment';
68is $l, undef, 'localisation unwound';
69is do { \(local $l) = \4; $l }, 4, '\(local $scalar) assignment';
70is $l, undef, 'localisation unwound';
71\$foo = \*bar;
72is *foo{SCALAR}, *bar{GLOB}, 'globref-to-scalarref assignment';
73for (1,2) {
74  \my $x = \3,
75  \my($y) = \3,
76  \state $a = \3,
77  \state($b) = \3 if $_ == 1;
78  if ($_ == 2) {
79    is $x, undef, '\my $x = ... clears $x on scope exit';
80    is $y, undef, '\my($x) = ... clears $x on scope exit';
81    is $a, 3, '\state $x = ... does not clear $x on scope exit';
82    is $b, 3, '\state($x) = ... does not clear $x on scope exit';
83  }
84}
85
86# Array Elements
87
88sub expect_scalar_cx { wantarray ? 0 : \$_ }
89sub expect_list_cx { wantarray ? (\$_,\$_) : 0 }
90\$a[0] = expect_scalar_cx;
91is \$a[0], \$_, '\$array[0]';
92\($a[1]) = expect_list_cx;
93is \$a[1], \$_, '\($array[0])';
94{
95  my @a;
96  \$a[0] = expect_scalar_cx;
97  is \$a[0], \$_, '\$lexical_array[0]';
98  \($a[1]) = expect_list_cx;
99  is \$a[1], \$_, '\($lexical_array[0])';
100  my $tmp;
101  {
102    \local $a[0] = \$tmp;
103    is \$a[0], \$tmp, '\local $a[0]';
104  }
105  is \$a[0], \$_, '\local $a[0] unwound';
106  {
107    \local ($a[1]) = \$tmp;
108    is \$a[1], \$tmp, '\local ($a[0])';
109  }
110  is \$a[1], \$_, '\local $a[0] unwound';
111}
112{
113  my @a;
114  \@a[0,1] = expect_list_cx;
115  is \$a[0].\$a[1], \$_.\$_, '\@array[indices]';
116  \(@a[2,3]) = expect_list_cx;
117  is \$a[0].\$a[1], \$_.\$_, '\(@array[indices])';
118  my $tmp;
119  {
120    \local @a[0,1] = (\$tmp)x2;
121    is \$a[0].\$a[1], \$tmp.\$tmp, '\local @a[indices]';
122  }
123  is \$a[0].\$a[1], \$_.\$_, '\local @a[indices] unwound';
124}
125
126# Hash Elements
127
128\$h{a} = expect_scalar_cx;
129is \$h{a}, \$_, '\$hash{a}';
130\($h{b}) = expect_list_cx;
131is \$h{b}, \$_, '\($hash{a})';
132{
133  my %h;
134  \$h{a} = expect_scalar_cx;
135  is \$h{a}, \$_, '\$lexical_array{a}';
136  \($h{b}) = expect_list_cx;
137  is \$h{b}, \$_, '\($lexical_array{a})';
138  my $tmp;
139  {
140    \local $h{a} = \$tmp;
141    is \$h{a}, \$tmp, '\local $h{a}';
142  }
143  is \$h{a}, \$_, '\local $h{a} unwound';
144  {
145    \local ($h{b}) = \$tmp;
146    is \$h{b}, \$tmp, '\local ($h{a})';
147  }
148  is \$h{b}, \$_, '\local $h{a} unwound';
149}
150{
151  my %h;
152  \@h{"a","b"} = expect_list_cx;
153  is \$h{a}.\$h{b}, \$_.\$_, '\@hash{indices}';
154  \(@h{2,3}) = expect_list_cx;
155  is \$h{a}.\$h{b}, \$_.\$_, '\(@hash{indices})';
156  my $tmp;
157  {
158    \local @h{"a","b"} = (\$tmp)x2;
159    is \$h{a}.\$h{b}, \$tmp.\$tmp, '\local @h{indices}';
160  }
161  is \$h{a}.\$h{b}, \$_.\$_, '\local @h{indices} unwound';
162}
163
164# Arrays
165
166package ArrayTest {
167  BEGIN { *is = *main::is }
168  sub expect_scalar_cx { wantarray ? 0 : \@ThatArray }
169  sub expect_list_cx   { wantarray ? (\$_,\$_) : 0 }
170  sub expect_list_cx_a { wantarray ? (\@ThatArray)x2 : 0 }
171  \@a = expect_scalar_cx;
172  is \@a, \@ThatArray, '\@pkg';
173  my @a;
174  \@a = expect_scalar_cx;
175  is \@a, \@ThatArray, '\@lexical';
176  (\@b) = expect_list_cx_a;
177  is \@b, \@ThatArray, '(\@pkg)';
178  my @b;
179  (\@b) = expect_list_cx_a;
180  is \@b, \@ThatArray, '(\@lexical)';
181  \my @c = expect_scalar_cx;
182  is \@c, \@ThatArray, '\my @lexical';
183  (\my @d) = expect_list_cx_a;
184  is \@d, \@ThatArray, '(\my @lexical)';
185  \(@e) = expect_list_cx;
186  is \$e[0].\$e[1], \$_.\$_, '\(@pkg)';
187  my @e;
188  \(@e) = expect_list_cx;
189  is \$e[0].\$e[1], \$_.\$_, '\(@lexical)';
190  \(my @f) = expect_list_cx;
191  is \$f[0].\$f[1], \$_.\$_, '\(my @lexical)';
192  \my(@g) = expect_list_cx;
193  is \$g[0].\$g[1], \$_.\$_, '\my(@lexical)';
194  my $old = \@h;
195  {
196    \local @h = \@ThatArray;
197    is \@h, \@ThatArray, '\local @a';
198  }
199  is \@h, $old, '\local @a unwound';
200  $old = \@i;
201  {
202    (\local @i) = \@ThatArray;
203    is \@i, \@ThatArray, '(\local @a)';
204  }
205  is \@i, $old, '(\local @a) unwound';
206}
207for (1,2) {
208  \my @x = [1..3],
209  \my(@y) = \3,
210  \state @a = [1..3],
211  \state(@b) = \3 if $_ == 1;
212  if ($_ == 2) {
213    is @x, 0, '\my @x = ... clears @x on scope exit';
214    is @y, 0, '\my(@x) = ... clears @x on scope exit';
215    is "@a", "1 2 3", '\state @x = ... does not clear @x on scope exit';
216    is "@b", 3, '\state(@x) = ... does not clear @x on scope exit';
217  }
218}
219
220# Hashes
221
222package HashTest {
223  BEGIN { *is = *main::is }
224  sub expect_scalar_cx { wantarray ? 0 : \%ThatHash }
225  sub expect_list_cx   { wantarray ? (\%ThatHash)x2 : 0 }
226  \%a = expect_scalar_cx;
227  is \%a, \%ThatHash, '\%pkg';
228  my %a;
229  \%a = expect_scalar_cx;
230  is \%a, \%ThatHash, '\%lexical';
231  (\%b) = expect_list_cx;
232  is \%b, \%ThatHash, '(\%pkg)';
233  my %b;
234  (\%b) = expect_list_cx;
235  is \%b, \%ThatHash, '(\%lexical)';
236  \my %c = expect_scalar_cx;
237  is \%c, \%ThatHash, '\my %lexical';
238  (\my %d) = expect_list_cx;
239  is \%d, \%ThatHash, '(\my %lexical)';
240  my $old = \%h;
241  {
242    \local %h = \%ThatHash;
243    is \%h, \%ThatHash, '\local %a';
244  }
245  is \%h, $old, '\local %a unwound';
246  $old = \%i;
247  {
248    (\local %i) = \%ThatHash;
249    is \%i, \%ThatHash, '(\local %a)';
250  }
251  is \%i, $old, '(\local %a) unwound';
252}
253for (1,2) {
254  \state %y = {1,2},
255  \my %x = {1,2} if $_ == 1;
256  if ($_ == 2) {
257    is %x, 0, '\my %x = ... clears %x on scope exit';
258    is "@{[%y]}", "1 2", '\state %x = ... does not clear %x on scope exit';
259  }
260}
261
262# Subroutines
263
264package CodeTest {
265  BEGIN { *is = *main::is; }
266  use feature 'lexical_subs';
267  no warnings 'experimental::lexical_subs';
268  sub expect_scalar_cx { wantarray ? 0 : \&ThatSub }
269  sub expect_list_cx   { wantarray ? (\&ThatSub)x2 : 0 }
270  \&a = expect_scalar_cx;
271  is \&a, \&ThatSub, '\&pkg';
272  my sub a;
273  \&a = expect_scalar_cx;
274  is \&a, \&ThatSub, '\&mysub';
275  state sub as;
276  \&as = expect_scalar_cx;
277  is \&as, \&ThatSub, '\&statesub';
278  (\&b) = expect_list_cx;
279  is \&b, \&ThatSub, '(\&pkg)';
280  my sub b;
281  (\&b) = expect_list_cx;
282  is \&b, \&ThatSub, '(\&mysub)';
283  my sub bs;
284  (\&bs) = expect_list_cx;
285  is \&bs, \&ThatSub, '(\&statesub)';
286  \(&c) = expect_list_cx;
287  is \&c, \&ThatSub, '\(&pkg)';
288  my sub b;
289  \(&c) = expect_list_cx;
290  is \&c, \&ThatSub, '\(&mysub)';
291  my sub bs;
292  \(&cs) = expect_list_cx;
293  is \&cs, \&ThatSub, '\(&statesub)';
294}
295
296# Mixed List Assignments
297
298(\$tahi, $rua) = \(1,2);
299is join(' ', $tahi, $$rua), '1 2',
300  'mixed scalar ref and scalar list assignment';
301$_ = 1;
302\($bb, @cc, %dd, &ee, $_==1 ? $ff : @ff, $_==2 ? $gg : @gg, (@hh)) =
303    (\$BB, \@CC, \%DD, \&EE, \$FF, \@GG, \1, \2, \3);
304is \$bb, \$BB, '\$scalar in list assignment';
305is \@cc, \@CC, '\@array in list assignment';
306is \%dd, \%DD, '\%hash in list assignment';
307is \&ee, \&EE, '\&code in list assignment';
308is \$ff, \$FF, '$scalar in \ternary in list assignment';
309is \@gg, \@GG, '@gg in \ternary in list assignment';
310is "@hh", '1 2 3', '\(@array) in list assignment';
311
312# Conditional expressions
313
314$_ = 3;
315$_ == 3 ? \$tahi : $rua = \3;
316is $tahi, 3, 'cond assignment resolving to scalar ref';
317$_ == 0 ? \$toru : $wha = \3;
318is $$wha, 3, 'cond assignment resolving to scalar';
319$_ == 3 ? \$rima : \$ono = \5;
320is $rima, 5, 'cond assignment with refgens on both branches';
321\($_ == 3 ? $whitu : $waru) = \5;
322is $whitu, 5, '\( ?: ) assignment';
323\($_ == 3 ? $_ < 4 ? $ii : $_ : $_) = \$_;
324is \$ii, \$_, 'nested \ternary assignment';
325
326# Foreach
327
328for \my $topic (\$for1, \$for2) {
329    push @for, \$topic;
330}
331is "@for", \$for1 . ' ' . \$for2, 'foreach \my $a';
332is \$topic, \$::topic, 'for \my scoping';
333
334@for = ();
335for \$::a(\$for1, \$for2) {
336    push @for, \$::a;
337}
338is "@for", \$for1 . ' ' . \$for2, 'foreach \$::a';
339
340@for = ();
341for \my @a([1,2], [3,4]) {
342    push @for, @a;
343}
344is "@for", "1 2 3 4", 'foreach \my @a [perl #22335]';
345
346@for = ();
347for \@::a([1,2], [3,4]) {
348    push @for, @::a;
349}
350is "@for", "1 2 3 4", 'foreach \@::a [perl #22335]';
351
352@for = ();
353for \my %a({5,6}, {7,8}) {
354    push @for, %a;
355}
356is "@for", "5 6 7 8", 'foreach \my %a [perl #22335]';
357
358@for = ();
359for \%::a({5,6}, {7,8}) {
360    push @for, %::a;
361}
362is "@for", "5 6 7 8", 'foreach \%::a [perl #22335]';
363
364@for = ();
365{
366  use feature 'lexical_subs';
367  no warnings 'experimental::lexical_subs';
368  my sub a;
369  for \&a(sub {9}, sub {10}) {
370    push @for, &a;
371  }
372}
373is "@for", "9 10", 'foreach \&padcv';
374
375@for = ();
376for \&::a(sub {9}, sub {10}) {
377  push @for, &::a;
378}
379is "@for", "9 10", 'foreach \&rv2cv';
380
381# Errors
382
383eval { my $x; \$x = 3 };
384like $@, qr/^Assigned value is not a reference at/, 'assigning non-ref';
385eval { my $x; \$x = [] };
386like $@, qr/^Assigned value is not a SCALAR reference at/,
387    'assigning non-scalar ref to scalar ref';
388eval { \$::x = [] };
389like $@, qr/^Assigned value is not a SCALAR reference at/,
390    'assigning non-scalar ref to package scalar ref';
391eval { my @x; \@x = {} };
392like $@, qr/^Assigned value is not an ARRAY reference at/,
393    'assigning non-array ref to array ref';
394eval { \@::x = {} };
395like $@, qr/^Assigned value is not an ARRAY reference at/,
396    'assigning non-array ref to package array ref';
397eval { my %x; \%x = [] };
398like $@, qr/^Assigned value is not a HASH reference at/,
399    'assigning non-hash ref to hash ref';
400eval { \%::x = [] };
401like $@, qr/^Assigned value is not a HASH reference at/,
402    'assigning non-hash ref to package hash ref';
403eval { use feature 'lexical_subs';
404       no warnings 'experimental::lexical_subs';
405       my sub x; \&x = [] };
406like $@, qr/^Assigned value is not a CODE reference at/,
407    'assigning non-code ref to lexical code ref';
408eval { \&::x = [] };
409like $@, qr/^Assigned value is not a CODE reference at/,
410    'assigning non-code ref to package code ref';
411
412eval { my $x; (\$x) = 3 };
413like $@, qr/^Assigned value is not a reference at/,
414    'list-assigning non-ref';
415eval { my $x; (\$x) = [] };
416like $@, qr/^Assigned value is not a SCALAR reference at/,
417    'list-assigning non-scalar ref to scalar ref';
418eval { (\$::x = []) };
419like $@, qr/^Assigned value is not a SCALAR reference at/,
420    'list-assigning non-scalar ref to package scalar ref';
421eval { my @x; (\@x) = {} };
422like $@, qr/^Assigned value is not an ARRAY reference at/,
423    'list-assigning non-array ref to array ref';
424eval { (\@::x) = {} };
425like $@, qr/^Assigned value is not an ARRAY reference at/,
426    'list-assigning non-array ref to package array ref';
427eval { my %x; (\%x) = [] };
428like $@, qr/^Assigned value is not a HASH reference at/,
429    'list-assigning non-hash ref to hash ref';
430eval { (\%::x) = [] };
431like $@, qr/^Assigned value is not a HASH reference at/,
432    'list-assigning non-hash ref to package hash ref';
433eval { use feature 'lexical_subs';
434       no warnings 'experimental::lexical_subs';
435       my sub x; (\&x) = [] };
436like $@, qr/^Assigned value is not a CODE reference at/,
437    'list-assigning non-code ref to lexical code ref';
438eval { (\&::x) = [] };
439like $@, qr/^Assigned value is not a CODE reference at/,
440    'list-assigning non-code ref to package code ref';
441
442eval '(\do{}) = 42';
443like $@, qr/^Can't modify reference to do block in list assignment at /,
444    "Can't modify reference to do block in list assignment";
445eval '(\pos) = 42';
446like $@,
447     qr/^Can't modify reference to match position in list assignment at /,
448    "Can't modify ref to some scalar-returning op in list assignment";
449eval '(\glob) = 42';
450like $@,
451     qr/^Can't modify reference to glob in list assignment at /,
452    "Can't modify reference to some list-returning op in list assignment";
453eval '\pos = 42';
454like $@,
455    qr/^Can't modify reference to match position in scalar assignment at /,
456   "Can't modify ref to some scalar-returning op in scalar assignment";
457eval '\(local @b) = 42';
458like $@,
459    qr/^Can't modify reference to localized parenthesized array in list(?x:
460      ) assignment at /,
461   q"Can't modify \(local @array) in list assignment";
462eval '\local(@b) = 42';
463like $@,
464    qr/^Can't modify reference to localized parenthesized array in list(?x:
465      ) assignment at /,
466   q"Can't modify \local(@array) in list assignment";
467eval '\local(@{foo()}) = 42';
468like $@,
469    qr/^Can't modify reference to array dereference in list assignment at/,
470   q"'Array deref' error takes prec. over 'local paren' error";
471eval '\(%b) = 42';
472like $@,
473    qr/^Can't modify reference to parenthesized hash in list assignment a/,
474   "Can't modify ref to parenthesized package hash in scalar assignment";
475eval '\(my %b) = 42';
476like $@,
477    qr/^Can't modify reference to parenthesized hash in list assignment a/,
478   "Can't modify ref to parenthesized hash (\(my %b)) in list assignment";
479eval '\my(%b) = 42';
480like $@,
481    qr/^Can't modify reference to parenthesized hash in list assignment a/,
482   "Can't modify ref to parenthesized hash (\my(%b)) in list assignment";
483eval '\%{"42"} = 42';
484like $@,
485    qr/^Can't modify reference to hash dereference in scalar assignment a/,
486   "Can't modify reference to hash dereference in scalar assignment";
487eval '$foo ? \%{"42"} : \%43 = 42';
488like $@,
489    qr/^Can't modify reference to hash dereference in scalar assignment a/,
490   "Can't modify ref to whatever in scalar assignment via cond expr";
491eval '\$0=~y///=0';
492like $@,
493    qr#^Can't modify transliteration \(tr///\) in scalar assignment a#,
494   "Can't modify transliteration (tr///) in scalar assignment";
495
496# Miscellaneous
497
498{
499  local $::TODO = ' ';
500  my($x,$y);
501  sub {
502    sub {
503      \$x = \$y;
504    }->();
505    is \$x, \$y, 'lexical alias affects outer closure';
506  }->();
507  is \$x, \$y, 'lexical alias affects outer sub where vars are declared';
508}
509
510{ # PADSTALE has a double meaning
511  use feature 'lexical_subs', 'signatures';
512  no warnings 'experimental';
513  my $c;
514  my sub s ($arg) {
515    state $x = ++$c;
516    if ($arg == 3) { return $c }
517    goto skip if $arg == 2;
518    my $y;
519   skip:
520    # $y is PADSTALE the 2nd time
521    \$x = \$y if $arg == 2;
522  }
523  s(1);
524  s(2);
525  is s(3), 1, 'padstale alias should not reset state'
526}
527
528SKIP: {
529    skip_without_dynamic_extension('List/Util');
530    require Scalar::Util;
531    my $a;
532    Scalar::Util::weaken($r = \$a);
533    \$a = $r;
534    pass 'no crash when assigning \$lex = $weakref_to_lex'
535}
536
537{
538    \my $x = \my $y;
539    $x = 3;
540    ($x, my $z) = (1, $y);
541    is $z, 3, 'list assignment after aliasing lexical scalars';
542}
543{
544    (\my $x) = \my $y;
545    $x = 3;
546    ($x, my $z) = (1, $y);
547    is $z, 3,
548      'regular list assignment after aliasing via list assignment';
549}
550{
551    my $y;
552    goto do_aliasing;
553
554   do_test:
555    $y = 3;
556    my($x,$z) = (1, $y);
557    is $z, 3, 'list assignment "before" aliasing lexical scalars';
558    last;
559
560   do_aliasing:
561    \$x = \$y;
562    goto do_test;
563}
564{
565    my $y;
566    goto do_aliasing2;
567
568   do_test2:
569    $y = 3;
570    my($x,$z) = (1, $y);
571    is $z, 3,
572     'list assignment "before" aliasing lex scalars via list assignment';
573    last;
574
575   do_aliasing2:
576    \($x) = \$y;
577    goto do_test2;
578}
579{
580    my @a;
581    goto do_aliasing3;
582
583   do_test3:
584    @a[0,1] = qw<a b>;
585    my($y,$x) = ($a[0],$a[1]);
586    is "@a", 'b a',
587       'aelemfast_lex-to-scalar list assignment "before" aliasing';
588    last;
589
590   do_aliasing3:
591    \(@a) = \($x,$y);
592    goto do_test3;
593}
594
595# Used to fail an assertion [perl #123821]
596eval '\(&$0)=0';
597pass("RT #123821");
598
599# Used to fail an assertion [perl #128252]
600{
601    no feature 'refaliasing';
602    use warnings;
603    eval q{sub{\@0[0]=0};};
604    pass("RT #128252");
605}
606
607# RT #133538 slices were inadvertently always localising
608
609{
610    use feature 'refaliasing';
611    no warnings 'experimental';
612
613    my @src = (100,200,300);
614
615    my @a = (1,2,3);
616    my %h = qw(one 10 two 20 three 30);
617
618    {
619        use feature 'declared_refs';
620        local \(@a[0,1,2]) = \(@src);
621        local \(@h{qw(one two three)}) = \(@src);
622        $src[0]++;
623        is("@a", "101 200 300", "rt #133538 \@a aliased");
624        is("$h{one} $h{two} $h{three}", "101 200 300", "rt #133538 %h aliased");
625    }
626    is("@a", "1 2 3", "rt #133538 \@a restored");
627    is("$h{one} $h{two} $h{three}", "10 20 30", "rt #133538 %h restored");
628
629    {
630        \(@a[0,1,2]) = \(@src);
631        \(@h{qw(one two three)}) = \(@src);
632        $src[0]++;
633        is("@a", "102 200 300", "rt #133538 \@a aliased try 2");
634        is("$h{one} $h{two} $h{three}", "102 200 300",
635                "rt #133538 %h aliased try 2");
636    }
637    $src[2]++;
638    is("@a", "102 200 301", "rt #133538 \@a still aliased");
639    is("$h{one} $h{two} $h{three}", "102 200 301", "rt #133538 %h still aliased");
640
641}
642