This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Scalar keys assignment through lvalue subs
[perl5.git] / t / op / sub_lval.t
CommitLineData
cd06dffe
GS
1BEGIN {
2 chdir 't' if -d 't';
20822f61 3 @INC = '../lib';
cb949c37 4 require './test.pl';
cd06dffe 5}
fad4a2e4 6plan tests=>156;
cd06dffe 7
78f9721b
SM
8sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary
9sub b : lvalue { ${\shift} }
cd06dffe
GS
10
11my $out = a(b()); # Check that temporaries are allowed.
cb949c37 12is(ref $out, 'main'); # Not reached if error.
cd06dffe
GS
13
14my @out = grep /main/, a(b()); # Check that temporaries are allowed.
cb949c37 15cmp_ok(scalar @out, '==', 1); # Not reached if error.
cd06dffe
GS
16
17my $in;
18
19# Check that we can return localized values from subroutines:
20
a98df962
GS
21sub in : lvalue { $in = shift; }
22sub neg : lvalue { #(num_str) return num_str
cd06dffe
GS
23 local $_ = shift;
24 s/^\+/-/;
25 $_;
26}
27in(neg("+2"));
28
29
cb949c37 30is($in, '-2');
cd06dffe 31
a98df962
GS
32sub get_lex : lvalue { $in }
33sub get_st : lvalue { $blah }
78f9721b 34sub id : lvalue { ${\shift} }
a98df962 35sub id1 : lvalue { $_[0] }
78f9721b 36sub inc : lvalue { ${\++$_[0]} }
cd06dffe
GS
37
38$in = 5;
39$blah = 3;
40
41get_st = 7;
42
cb949c37 43cmp_ok($blah, '==', 7);
cd06dffe
GS
44
45get_lex = 7;
46
cb949c37 47cmp_ok($in, '==', 7);
cd06dffe
GS
48
49++get_st;
50
cb949c37 51cmp_ok($blah, '==', 8);
cd06dffe
GS
52
53++get_lex;
54
cb949c37 55cmp_ok($in, '==', 8);
cd06dffe
GS
56
57id(get_st) = 10;
58
cb949c37 59cmp_ok($blah, '==', 10);
cd06dffe
GS
60
61id(get_lex) = 10;
62
cb949c37 63cmp_ok($in, '==', 10);
cd06dffe
GS
64
65++id(get_st);
66
cb949c37 67cmp_ok($blah, '==', 11);
cd06dffe
GS
68
69++id(get_lex);
70
cb949c37 71cmp_ok($in, '==', 11);
cd06dffe
GS
72
73id1(get_st) = 20;
74
cb949c37 75cmp_ok($blah, '==', 20);
cd06dffe
GS
76
77id1(get_lex) = 20;
78
cb949c37 79cmp_ok($in, '==', 20);
cd06dffe
GS
80
81++id1(get_st);
82
cb949c37 83cmp_ok($blah, '==', 21);
cd06dffe
GS
84
85++id1(get_lex);
86
cb949c37 87cmp_ok($in, '==', 21);
cd06dffe
GS
88
89inc(get_st);
90
cb949c37 91cmp_ok($blah, '==', 22);
cd06dffe
GS
92
93inc(get_lex);
94
cb949c37 95cmp_ok($in, '==', 22);
cd06dffe
GS
96
97inc(id(get_st));
98
cb949c37 99cmp_ok($blah, '==', 23);
cd06dffe
GS
100
101inc(id(get_lex));
102
cb949c37 103cmp_ok($in, '==', 23);
cd06dffe
GS
104
105++inc(id1(id(get_st)));
106
cb949c37 107cmp_ok($blah, '==', 25);
cd06dffe
GS
108
109++inc(id1(id(get_lex)));
110
cb949c37 111cmp_ok($in, '==', 25);
cd06dffe
GS
112
113@a = (1) x 3;
114@b = (undef) x 2;
115$#c = 3; # These slots are not fillable.
116
117# Explanation: empty slots contain &sv_undef.
118
119=for disabled constructs
120
a98df962
GS
121sub a3 :lvalue {@a}
122sub b2 : lvalue {@b}
123sub c4: lvalue {@c}
cd06dffe
GS
124
125$_ = '';
126
127eval <<'EOE' or $_ = $@;
128 ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
129 1;
130EOE
131
132#@out = ($x, a3, $y, b2, $z, c4, $t);
133#@in = (34 .. 41, (undef) x 4, 46);
134#print "# `@out' ne `@in'\nnot " unless "@out" eq "@in";
135
cb949c37
NC
136like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/);
137print "ok 22\n";
138
cd06dffe
GS
139=cut
140
cd06dffe
GS
141
142my $var;
143
a98df962 144sub a::var : lvalue { $var }
cd06dffe
GS
145
146"a"->var = 45;
147
cb949c37 148cmp_ok($var, '==', 45);
cd06dffe
GS
149
150my $oo;
151$o = bless \$oo, "a";
152
153$o->var = 47;
154
cb949c37 155cmp_ok($var, '==', 47);
cd06dffe 156
a98df962 157sub o : lvalue { $o }
cd06dffe
GS
158
159o->var = 49;
160
cb949c37 161cmp_ok($var, '==', 49);
cd06dffe
GS
162
163sub nolv () { $x0, $x1 } # Not lvalue
164
165$_ = '';
166
167eval <<'EOE' or $_ = $@;
168 nolv = (2,3);
169 1;
170EOE
171
cb949c37 172like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
cd06dffe
GS
173
174$_ = '';
175
176eval <<'EOE' or $_ = $@;
177 nolv = (2,3) if $_;
178 1;
179EOE
180
cb949c37 181like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
cd06dffe
GS
182
183$_ = '';
184
185eval <<'EOE' or $_ = $@;
186 &nolv = (2,3) if $_;
187 1;
188EOE
189
cb949c37 190like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
cd06dffe
GS
191
192$x0 = $x1 = $_ = undef;
193$nolv = \&nolv;
194
195eval <<'EOE' or $_ = $@;
196 $nolv->() = (2,3) if $_;
197 1;
198EOE
199
cb949c37 200ok(!defined $_) or diag "'$_', '$x0', '$x1'";
cd06dffe
GS
201
202$x0 = $x1 = $_ = undef;
203$nolv = \&nolv;
204
205eval <<'EOE' or $_ = $@;
206 $nolv->() = (2,3);
207 1;
208EOE
209
cb949c37
NC
210like($_, qr/Can\'t modify non-lvalue subroutine call/)
211 or diag "'$_', '$x0', '$x1'";
cd06dffe 212
e2316ad3 213sub lv0 : lvalue { }
cd06dffe
GS
214
215$_ = undef;
216eval <<'EOE' or $_ = $@;
217 lv0 = (2,3);
218 1;
219EOE
220
c73030b8 221like($_, qr/Can't return undef from lvalue subroutine/);
cd06dffe 222
cd06dffe
GS
223$_ = undef;
224eval <<'EOE' or $_ = $@;
225 (lv0) = (2,3);
226 1;
227EOE
228
cb949c37 229ok(!defined $_) or diag $_;
cd06dffe 230
69b22cd1
FC
231($a,$b)=();
232(lv0($a,$b)) = (3,4);
233is +($a//'undef') . ($b//'undef'), 'undefundef',
234 'list assignment to empty lvalue sub';
235
236
a98df962 237sub lv1u :lvalue { undef }
cd06dffe
GS
238
239$_ = undef;
240eval <<'EOE' or $_ = $@;
241 lv1u = (2,3);
242 1;
243EOE
244
c73030b8 245like($_, qr/Can't return undef from lvalue subroutine/);
cd06dffe
GS
246
247$_ = undef;
248eval <<'EOE' or $_ = $@;
249 (lv1u) = (2,3);
250 1;
251EOE
252
4c8a4e58
JH
253# Fixed by change @10777
254#print "# '$_'.\nnot "
255# unless /Can\'t return an uninitialized value from lvalue subroutine/;
cb949c37 256# print "ok 34 # Skip: removed test\n";
cd06dffe
GS
257
258$x = '1234567';
cd06dffe
GS
259
260$_ = undef;
261eval <<'EOE' or $_ = $@;
78f9721b 262 sub lv1t : lvalue { index $x, 2 }
cd06dffe
GS
263 lv1t = (2,3);
264 1;
265EOE
266
145b2bbb 267like($_, qr/Can\'t return a temporary from lvalue subroutine/);
cd06dffe
GS
268
269$_ = undef;
145b2bbb
FC
270sub lv2t : lvalue { shift }
271(lv2t($_)) = (2,3);
272is($_, 2);
cd06dffe
GS
273
274$xxx = 'xxx';
275sub xxx () { $xxx } # Not lvalue
cd06dffe
GS
276
277$_ = undef;
278eval <<'EOE' or $_ = $@;
78f9721b 279 sub lv1tmp : lvalue { xxx } # is it a TEMP?
cd06dffe
GS
280 lv1tmp = (2,3);
281 1;
282EOE
283
145b2bbb 284is($_, undef, "returning a temp from an lvalue sub in scalar context");
cd06dffe
GS
285
286$_ = undef;
287eval <<'EOE' or $_ = $@;
288 (lv1tmp) = (2,3);
289 1;
290EOE
291
fd6c41ce
FC
292is($_, undef, "returning a temp from an lvalue sub in list context");
293
9a049f1c 294sub yyy () { 'yyy' } # Const, not lvalue
cd06dffe
GS
295
296$_ = undef;
297eval <<'EOE' or $_ = $@;
78f9721b 298 sub lv1tmpr : lvalue { yyy } # is it read-only?
cd06dffe
GS
299 lv1tmpr = (2,3);
300 1;
301EOE
302
145b2bbb 303like($_, qr/Can\'t return a readonly value from lvalue subroutine at/);
cd06dffe
GS
304
305$_ = undef;
306eval <<'EOE' or $_ = $@;
307 (lv1tmpr) = (2,3);
308 1;
309EOE
310
cb949c37 311like($_, qr/Can\'t return a readonly value from lvalue subroutine/);
cd06dffe 312
a98df962 313sub lva : lvalue {@a}
cd06dffe
GS
314
315$_ = undef;
316@a = ();
317$a[1] = 12;
318eval <<'EOE' or $_ = $@;
319 (lva) = (2,3);
320 1;
321EOE
322
cb949c37 323is("'@a' $_", "'2 3' ");
cd06dffe
GS
324
325$_ = undef;
326@a = ();
327$a[0] = undef;
328$a[1] = 12;
329eval <<'EOE' or $_ = $@;
330 (lva) = (2,3);
331 1;
332EOE
333
cb949c37 334is("'@a' $_", "'2 3' ");
cd06dffe 335
40c94d11
FC
336is lva->${\sub { return $_[0] }}, 2,
337 'lvalue->$thing when lvalue returns array';
338
339my @my = qw/ a b c /;
340sub lvmya : lvalue { @my }
341
342is lvmya->${\sub { return $_[0] }}, 3,
343 'lvalue->$thing when lvalue returns lexical array';
344
a98df962 345sub lv1n : lvalue { $newvar }
cd06dffe
GS
346
347$_ = undef;
348eval <<'EOE' or $_ = $@;
349 lv1n = (3,4);
350 1;
351EOE
352
cb949c37 353is("'$newvar' $_", "'4' ");
cd06dffe 354
a98df962 355sub lv1nn : lvalue { $nnewvar }
cd06dffe
GS
356
357$_ = undef;
358eval <<'EOE' or $_ = $@;
359 (lv1nn) = (3,4);
360 1;
361EOE
362
cb949c37 363is("'$nnewvar' $_", "'3' ");
cd06dffe
GS
364
365$a = \&lv1nn;
366$a->() = 8;
cb949c37 367is($nnewvar, '8');
d32f2495 368
84251760 369eval 'sub AUTOLOAD : lvalue { $newvar }';
d32f2495 370foobar() = 12;
cb949c37 371is($newvar, "12");
26191e78 372
78f9721b
SM
373{
374my %hash; my @array;
375sub alv : lvalue { $array[1] }
376sub alv2 : lvalue { $array[$_[0]] }
377sub hlv : lvalue { $hash{"foo"} }
378sub hlv2 : lvalue { $hash{$_[0]} }
379$array[1] = "not ok 51\n";
380alv() = "ok 50\n";
cb949c37 381is(alv(), "ok 50\n");
78f9721b
SM
382
383alv2(20) = "ok 51\n";
cb949c37 384is($array[20], "ok 51\n");
78f9721b
SM
385
386$hash{"foo"} = "not ok 52\n";
387hlv() = "ok 52\n";
cb949c37 388is($hash{foo}, "ok 52\n");
78f9721b
SM
389
390$hash{bar} = "not ok 53\n";
391hlv("bar") = "ok 53\n";
cb949c37 392is(hlv("bar"), "ok 53\n");
78f9721b
SM
393
394sub array : lvalue { @array }
395sub array2 : lvalue { @array2 } # This is a global.
396sub hash : lvalue { %hash }
397sub hash2 : lvalue { %hash2 } # So's this.
398@array2 = qw(foo bar);
399%hash2 = qw(foo bar);
400
401(array()) = qw(ok 54);
cb949c37 402is("@array", "ok 54");
78f9721b
SM
403
404(array2()) = qw(ok 55);
cb949c37 405is("@array2", "ok 55");
78f9721b
SM
406
407(hash()) = qw(ok 56);
cb949c37 408cmp_ok($hash{ok}, '==', 56);
78f9721b
SM
409
410(hash2()) = qw(ok 57);
cb949c37 411cmp_ok($hash2{ok}, '==', 57);
78f9721b
SM
412
413@array = qw(a b c d);
414sub aslice1 : lvalue { @array[0,2] };
415(aslice1()) = ("ok", "already");
cb949c37 416is("@array", "ok b already d");
78f9721b
SM
417
418@array2 = qw(a B c d);
419sub aslice2 : lvalue { @array2[0,2] };
420(aslice2()) = ("ok", "already");
cb949c37 421is("@array2", "ok B already d");
78f9721b
SM
422
423%hash = qw(a Alpha b Beta c Gamma);
424sub hslice : lvalue { @hash{"c", "b"} }
425(hslice()) = ("CISC", "BogoMIPS");
cb949c37 426is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS");
78f9721b
SM
427}
428
429$str = "Hello, world!";
430sub sstr : lvalue { substr($str, 1, 4) }
431sstr() = "i";
cb949c37 432is($str, "Hi, world!");
78f9721b
SM
433
434$str = "Made w/ JavaScript";
435sub veclv : lvalue { vec($str, 2, 32) }
e6b8b224
PP
436if (ord('A') != 193) {
437 veclv() = 0x5065726C;
438}
439else { # EBCDIC?
440 veclv() = 0xD7859993;
441}
cb949c37 442is($str, "Made w/ PerlScript");
78f9721b
SM
443
444sub position : lvalue { pos }
445@p = ();
446$_ = "fee fi fo fum";
447while (/f/g) {
448 push @p, position;
449 position() += 6;
450}
cb949c37 451is("@p", "1 8");
7c8af4ef 452
fad4a2e4
FC
453sub keeze : lvalue { keys %__ }
454%__ = ("a","b");
455keeze = 64;
456is scalar %__, '1/64', 'keys assignment through lvalue sub';
457
7c8af4ef
RG
458# Bug 20001223.002: split thought that the list had only one element
459@ary = qw(4 5 6);
460sub lval1 : lvalue { $ary[0]; }
461sub lval2 : lvalue { $ary[1]; }
462(lval1(), lval2()) = split ' ', "1 2 3 4";
cb949c37
NC
463
464is(join(':', @ary), "1:2:6");
1c4274f4 465
f9bc45ef
TP
466# check that an element of a tied hash/array can be assigned to via lvalueness
467
468package Tie_Hash;
469
470our ($key, $val);
471sub TIEHASH { bless \my $v => __PACKAGE__ }
472sub STORE { ($key, $val) = @_[1,2] }
473
474package main;
475sub lval_tie_hash : lvalue {
476 tie my %t => 'Tie_Hash';
477 $t{key};
478}
479
480eval { lval_tie_hash() = "value"; };
481
cb949c37 482is($@, "", "element of tied hash");
f9bc45ef 483
cb949c37 484is("$Tie_Hash::key-$Tie_Hash::val", "key-value");
f9bc45ef
TP
485
486
487package Tie_Array;
488
489our @val;
490sub TIEARRAY { bless \my $v => __PACKAGE__ }
491sub STORE { $val[ $_[1] ] = $_[2] }
492
493package main;
494sub lval_tie_array : lvalue {
495 tie my @t => 'Tie_Array';
496 $t[0];
497}
498
499eval { lval_tie_array() = "value"; };
500
f9bc45ef 501
cb949c37 502is($@, "", "element of tied array");
f9bc45ef 503
cb949c37 504is ($Tie_Array::val[0], "value");
1c4274f4 505
1c4274f4 506
fa1e92c4
FC
507# Test explicit return of lvalue expression
508{
509 # subs are copies from tests 1-~18 with an explicit return added.
510 # They used not to work, which is why they are ‘badly’ named.
1c4274f4
MS
511 sub bad_get_lex : lvalue { return $in };
512 sub bad_get_st : lvalue { return $blah }
513
514 sub bad_id : lvalue { return ${\shift} }
515 sub bad_id1 : lvalue { return $_[0] }
516 sub bad_inc : lvalue { return ${\++$_[0]} }
517
518 $in = 5;
519 $blah = 3;
520
521 bad_get_st = 7;
522
523 is( $blah, 7 );
524
525 bad_get_lex = 7;
526
527 is($in, 7, "yada");
528
529 ++bad_get_st;
530
531 is($blah, 8, "yada");
07fd1c9c
FC
532
533 ++bad_get_lex;
534 cmp_ok($in, '==', 8);
535
536 bad_id(bad_get_st) = 10;
537 cmp_ok($blah, '==', 10);
538
539 bad_id(bad_get_lex) = 10;
540 cmp_ok($in, '==', 10);
541
542 ++bad_id(bad_get_st);
543 cmp_ok($blah, '==', 11);
544
545 ++bad_id(bad_get_lex);
546 cmp_ok($in, '==', 11);
547
548 bad_id1(bad_get_st) = 20;
549 cmp_ok($blah, '==', 20);
550
551 bad_id1(bad_get_lex) = 20;
552 cmp_ok($in, '==', 20);
553
554 ++bad_id1(bad_get_st);
555 cmp_ok($blah, '==', 21);
556
557 ++bad_id1(bad_get_lex);
558 cmp_ok($in, '==', 21);
559
560 bad_inc(bad_get_st);
561 cmp_ok($blah, '==', 22);
562
563 bad_inc(bad_get_lex);
564 cmp_ok($in, '==', 22);
565
566 bad_inc(bad_id(bad_get_st));
567 cmp_ok($blah, '==', 23);
568
569 bad_inc(bad_id(bad_get_lex));
570 cmp_ok($in, '==', 23);
571
572 ++bad_inc(bad_id1(bad_id(bad_get_st)));
573 cmp_ok($blah, '==', 25);
574
575 ++bad_inc(bad_id1(bad_id(bad_get_lex)));
576 cmp_ok($in, '==', 25);
1ffdc07c
FC
577
578 # Recursive
579 my $r;
580 my $to_modify;
581 $r = sub :lvalue {
582 my $depth = shift//0;
583 if ($depth == 2) { return $to_modify }
584 return &$r($depth+1);
585 };
586 &$r(0) = 7;
587 is $to_modify, 7, 'recursive lvalue sub';
f6a9f8a4
FC
588
589 # Recursive with substr [perl #72706]
590 my $val = '';
591 my $pie;
592 $pie = sub :lvalue {
593 my $depth = shift;
594 return &$pie($depth) if $depth--;
595 substr $val, 0;
596 };
597 for my $depth (0, 1, 2) {
598 my $value = "Good $depth";
599 eval {
600 &$pie($depth) = $value;
601 };
602 is($@, '', "recursive lvalue substr return depth $depth");
603 is($val, $value,
604 "value assigned to recursive lvalue substr (depth $depth)");
605 }
1c4274f4
MS
606}
607
91e34d82 608{ # bug #23790
4546bcba
RGS
609 my @arr = qw /one two three/;
610 my $line = "zero";
611 sub lval_array () : lvalue {@arr}
612
613 for (lval_array) {
614 $line .= $_;
615 }
616
617 is($line, "zeroonetwothree");
91e34d82
MP
618
619 sub trythislval { scalar(@_)."x".join "", @_ }
620 is(trythislval(lval_array()), "3xonetwothree");
621
622 sub changeme { $_[2] = "free" }
623 changeme(lval_array);
624 is("@arr", "one two free");
40c94d11
FC
625
626 # test again, with explicit return
627 sub rlval_array() : lvalue {return @arr}
628 @arr = qw /one two three/;
629 $line = "zero";
630 for (rlval_array) {
631 $line .= $_;
632 }
633 is($line, "zeroonetwothree");
634 is(trythislval(rlval_array()), "3xonetwothree");
635 changeme(rlval_array);
636 is("@arr", "one two free");
637
638 # Variations on the same theme, with multiple vars returned
639 my $scalar = 'half';
640 sub lval_scalar_array () : lvalue { $scalar, @arr }
641 @arr = qw /one two three/;
642 $line = "zero";
643 for (lval_scalar_array) {
644 $line .= $_;
645 }
646 is($line, "zerohalfonetwothree");
647 is(trythislval(lval_scalar_array()), "4xhalfonetwothree");
648 changeme(lval_scalar_array);
649 is("@arr", "one free three");
650
651 sub lval_array_scalar () : lvalue { @arr, $scalar }
652 @arr = qw /one two three/;
653 $line = "zero";
654 $scalar = 'four';
655 for (lval_array_scalar) {
656 $line .= $_;
657 }
658 is($line, "zeroonetwothreefour");
659 is(trythislval(lval_array_scalar()), "4xonetwothreefour");
660 changeme(lval_array_scalar);
661 is("@arr", "one two free");
662
663 # Tests for specific ops not tested above
664 # rv2av
665 @array2 = qw 'one two free';
666 is join(',', map $_, sub:lvalue{@array2}->()), 'one,two,free',
667 'rv2av in reference context';
668 is join(',', map $_, sub:lvalue{@{\@array2}}->()), 'one,two,free',
669 'rv2av-with-ref in reference context';
670 # padhv
671 my %hash = qw[a b c d];
672 like join(',', map $_, sub:lvalue{%hash}->()),
673 qr/^(?:a,b,c,d|c,d,a,b)\z/, 'padhv in reference context';
674 # rv2hv
675 %hash2 = qw[a b c d];
676 like join(',', map $_, sub:lvalue{%hash2}->()),
677 qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv in reference context';
678 like join(',', map $_, sub:lvalue{%{\%hash2}}->()),
679 qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv-with-ref in reference context';
4546bcba 680}
cb0d96b9
NC
681
682{
683 package Foo;
684 sub AUTOLOAD :lvalue { *{$AUTOLOAD} };
685 package main;
686 my $foo = bless {},"Foo";
687 my $result;
688 $foo->bar = sub { $result = "bar" };
689 $foo->bar;
690 is ($result, 'bar', "RT #41550");
691}
885ef6f5
GG
692
693fresh_perl_is(<<'----', <<'====', "lvalue can not be set after definition. [perl #68758]");
694use warnings;
695our $x;
696sub foo { $x }
697sub foo : lvalue;
698foo = 3;
699----
700lvalue attribute ignored after the subroutine has been defined at - line 4.
701Can't modify non-lvalue subroutine call in scalar assignment at - line 5, near "3;"
702Execution of - aborted due to compilation errors.
703====
eac910c8
GG
704
705{
706 my $x;
707 sub lval_decl : lvalue;
708 sub lval_decl { $x }
709 lval_decl = 5;
710 is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]");
711}
f71f472f
FC
712
713sub fleen : lvalue { $pnare }
714$pnare = __PACKAGE__;
715ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\
716is $pnare, 1, 'and returning CATTLE actually works';
a0aa6076
FC
717$pnare = __PACKAGE__;
718ok eval { (fleen) = 1 }, "lvalues can return COWs in list context";
719is $pnare, 1, 'and returning COWs in list context actually works';
a1302723
FC
720$pnare = __PACKAGE__;
721ok eval { $_ = 1 for(fleen); 1 }, "lvalues can return COWs in ref cx";
722is $pnare, 1, 'and returning COWs in reference context actually works';
145b2bbb
FC
723
724
725# Returning an arbitrary expression, not necessarily lvalue
726+sub :lvalue { return $ambaga || $ambaga }->() = 73;
727is $ambaga, 73, 'explicit return of arbitrary expression (scalar context)';
728(sub :lvalue { return $ambaga || $ambaga }->()) = 74;
729is $ambaga, 74, 'explicit return of arbitrary expression (list context)';
730+sub :lvalue { $ambaga || $ambaga }->() = 73;
731is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)';
732(sub :lvalue { $ambaga || $ambaga }->()) = 74;
733is $ambaga, 74, 'implicit return of arbitrary expression (list context)';
734{ local $::TODO = 'return needs to enforce the same rules as leavesublv';
735eval { +sub :lvalue { return 3 }->() = 4 };
736like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
737 'assignment to numeric constant explicitly returned from lv sub';
738eval { (sub :lvalue { return 3 }->()) = 4 };
739like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
740 'assignment to num constant explicitly returned (list cx)';
741}
742eval { +sub :lvalue { 3 }->() = 4 };
743like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
744 'assignment to numeric constant implicitly returned from lv sub';
745eval { (sub :lvalue { 3 }->()) = 4 };
746like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
747 'assignment to num constant implicitly returned (list cx)';
bf8fb5eb
FC
748
749# reference (potential lvalue) context
750$suffix = '';
751for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
752 &$sub()->${\sub { $_[0] = 37 }};
753 is $_, '37', 'lvalue->method'.$suffix;
754 ${\scalar &$sub()} = 38;
755 is $_, '38', 'scalar(lvalue)'.$suffix;
756 sub assign39_with_proto ($) { $_[0] = 39 }
757 assign39_with_proto(&$sub());
758 is $_, '39', 'func(lvalue) when func has $ proto'.$suffix;
759 $_ = 1;
760 ${\(&$sub()||undef)} = 40;
761 is $_, '40', 'lvalue||...'.$suffix;
762 ${\(${\undef}||&$sub())} = 41; # extra ${\...} to bypass const folding
763 is $_, '41', '...||lvalue'.$suffix;
764 $_ = 0;
765 ${\(&$sub()&&undef)} = 42;
766 is $_, '42', 'lvalue&&...'.$suffix;
767 ${\(${\1}&&&$sub())} = 43;
768 is $_, '43', '...&&lvalue'.$suffix;
769 ${\(&$sub())[0]} = 44;
770 is $_, '44', '(lvalue)[0]'.$suffix;
771}
772continue { $suffix = ' (explicit return)' }
767eda44
FC
773
774# autovivification
d507ecb9 775$suffix = '';
767eda44
FC
776for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
777 undef $_;
778 &$sub()->[3] = 4;
779 is $_->[3], 4, 'func->[...] autovivification'.$suffix;
780 undef $_;
781 &$sub()->{3} = 4;
782 is $_->{3}, 4, 'func->{...} autovivification'.$suffix;
783 undef $_;
784 ${&$sub()} = 4;
785 is $$_, 4, '${func()} autovivification' .$suffix;
786 undef $_;
787 @{&$sub()} = 4;
788 is "@$_", 4, '@{func()} autovivification' .$suffix;
789 undef $_;
790 %{&$sub()} = (4,5);
791 is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix;
792}
793continue { $suffix = ' (explicit return)' }
e08be60b
FC
794
795# [perl #92406] [perl #92290] Returning a pad var in rvalue context
796$suffix = '';
797for my $sub (
798 sub :lvalue { my $x = 72; $x },
799 sub :lvalue { my $x = 72; return $x }
800) {
801 is scalar(&$sub), 72, "sub returning pad var in scalar context$suffix";
802 is +(&$sub)[0], 72, "sub returning pad var in list context$suffix";
803}
804continue { $suffix = ' (explicit return)' }