9b0ad06090ad60b16c619b02dd3f4f12d0ffd6ef
[perl.git] / t / op / sub_lval.t
1 BEGIN {
2     chdir 't' if -d 't';
3     @INC = '../lib';
4     require './test.pl';
5 }
6 plan tests=>207;
7
8 sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
9 sub b : lvalue { ${\shift} }
10
11 my $out = a(b());               # Check that temporaries are allowed.
12 is(ref $out, 'main'); # Not reached if error.
13
14 my @out = grep /main/, a(b()); # Check that temporaries are allowed.
15 cmp_ok(scalar @out, '==', 1); # Not reached if error.
16
17 my $in;
18
19 # Check that we can return localized values from subroutines:
20
21 sub in : lvalue { $in = shift; }
22 sub neg : lvalue {  #(num_str) return num_str
23     local $_ = shift;
24     s/^\+/-/;
25     $_;
26 }
27 in(neg("+2"));
28
29
30 is($in, '-2');
31
32 sub get_lex : lvalue { $in }
33 sub get_st : lvalue { $blah }
34 sub id : lvalue { ${\shift} }
35 sub id1 : lvalue { $_[0] }
36 sub inc : lvalue { ${\++$_[0]} }
37
38 $in = 5;
39 $blah = 3;
40
41 get_st = 7;
42
43 cmp_ok($blah, '==', 7);
44
45 get_lex = 7;
46
47 cmp_ok($in, '==', 7);
48
49 ++get_st;
50
51 cmp_ok($blah, '==', 8);
52
53 ++get_lex;
54
55 cmp_ok($in, '==', 8);
56
57 id(get_st) = 10;
58
59 cmp_ok($blah, '==', 10);
60
61 id(get_lex) = 10;
62
63 cmp_ok($in, '==', 10);
64
65 ++id(get_st);
66
67 cmp_ok($blah, '==', 11);
68
69 ++id(get_lex);
70
71 cmp_ok($in, '==', 11);
72
73 id1(get_st) = 20;
74
75 cmp_ok($blah, '==', 20);
76
77 id1(get_lex) = 20;
78
79 cmp_ok($in, '==', 20);
80
81 ++id1(get_st);
82
83 cmp_ok($blah, '==', 21);
84
85 ++id1(get_lex);
86
87 cmp_ok($in, '==', 21);
88
89 inc(get_st);
90
91 cmp_ok($blah, '==', 22);
92
93 inc(get_lex);
94
95 cmp_ok($in, '==', 22);
96
97 inc(id(get_st));
98
99 cmp_ok($blah, '==', 23);
100
101 inc(id(get_lex));
102
103 cmp_ok($in, '==', 23);
104
105 ++inc(id1(id(get_st)));
106
107 cmp_ok($blah, '==', 25);
108
109 ++inc(id1(id(get_lex)));
110
111 cmp_ok($in, '==', 25);
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
121 sub a3 :lvalue {@a}
122 sub b2 : lvalue {@b}
123 sub c4: lvalue {@c}
124
125 $_ = '';
126
127 eval <<'EOE' or $_ = $@;
128   ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
129   1;
130 EOE
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
136 like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/);
137 print "ok 22\n";
138
139 =cut
140
141
142 my $var;
143
144 sub a::var : lvalue { $var }
145
146 "a"->var = 45;
147
148 cmp_ok($var, '==', 45);
149
150 my $oo;
151 $o = bless \$oo, "a";
152
153 $o->var = 47;
154
155 cmp_ok($var, '==', 47);
156
157 sub o : lvalue { $o }
158
159 o->var = 49;
160
161 cmp_ok($var, '==', 49);
162
163 sub nolv () { $x0, $x1 } # Not lvalue
164
165 $_ = '';
166
167 eval <<'EOE' or $_ = $@;
168   nolv = (2,3);
169   1;
170 EOE
171
172 like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
173
174 $_ = '';
175
176 eval <<'EOE' or $_ = $@;
177   nolv = (2,3) if $_;
178   1;
179 EOE
180
181 like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
182
183 $_ = '';
184
185 eval <<'EOE' or $_ = $@;
186   &nolv = (2,3) if $_;
187   1;
188 EOE
189
190 like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
191
192 $x0 = $x1 = $_ = undef;
193 $nolv = \&nolv;
194
195 eval <<'EOE' or $_ = $@;
196   $nolv->() = (2,3) if $_;
197   1;
198 EOE
199
200 ok(!defined $_) or diag "'$_', '$x0', '$x1'";
201
202 $x0 = $x1 = $_ = undef;
203 $nolv = \&nolv;
204
205 eval <<'EOE' or $_ = $@;
206   $nolv->() = (2,3);
207   1;
208 EOE
209
210 like($_, qr/Can\'t modify non-lvalue subroutine call/)
211   or diag "'$_', '$x0', '$x1'";
212
213 sub lv0 : lvalue { }
214 sub rlv0 : lvalue { return }
215
216 $_ = undef;
217 eval <<'EOE' or $_ = $@;
218   lv0 = (2,3);
219   1;
220 EOE
221
222 like($_, qr/Can't return undef from lvalue subroutine/);
223
224 $_ = undef;
225 eval <<'EOE' or $_ = $@;
226   rlv0 = (2,3);
227   1;
228 EOE
229
230 like($_, qr/Can't return undef from lvalue subroutine/,
231     'explicit return of nothing in scalar context');
232
233 $_ = undef;
234 eval <<'EOE' or $_ = $@;
235   (lv0) = (2,3);
236   1;
237 EOE
238
239 ok(!defined $_) or diag $_;
240
241 $_ = undef;
242 eval <<'EOE' or $_ = $@;
243   (rlv0) = (2,3);
244   1;
245 EOE
246
247 ok(!defined $_, 'explicit return of nothing in list context') or diag $_;
248
249 ($a,$b)=();
250 (lv0($a,$b)) = (3,4);
251 is +($a//'undef') . ($b//'undef'), 'undefundef',
252    'list assignment to empty lvalue sub';
253
254
255 sub lv1u :lvalue { undef }
256 sub rlv1u :lvalue { undef }
257
258 $_ = undef;
259 eval <<'EOE' or $_ = $@;
260   lv1u = (2,3);
261   1;
262 EOE
263
264 like($_, qr/Can't return undef from lvalue subroutine/);
265
266 $_ = undef;
267 eval <<'EOE' or $_ = $@;
268   rlv1u = (2,3);
269   1;
270 EOE
271
272 like($_, qr/Can't return undef from lvalue subroutine/,
273      'explicitly returning undef in scalar context');
274
275 $_ = undef;
276 eval <<'EOE' or $_ = $@;
277   (lv1u) = (2,3);
278   1;
279 EOE
280
281 ok(!defined, 'implicitly returning undef in list context');
282
283 $_ = undef;
284 eval <<'EOE' or $_ = $@;
285   (rlv1u) = (2,3);
286   1;
287 EOE
288
289 ok(!defined, 'explicitly returning undef in list context');
290
291 $x = '1234567';
292
293 $_ = undef;
294 eval <<'EOE' or $_ = $@;
295   sub lv1t : lvalue { index $x, 2 }
296   lv1t = (2,3);
297   1;
298 EOE
299
300 like($_, qr/Can\'t return a temporary from lvalue subroutine/);
301
302 $_ = undef;
303 eval <<'EOE' or $_ = $@;
304   sub rlv1t : lvalue { index $x, 2 }
305   rlv1t = (2,3);
306   1;
307 EOE
308
309 like($_, qr/Can\'t return a temporary from lvalue subroutine/,
310     'returning a PADTMP explicitly');
311
312 $_ = undef;
313 eval <<'EOE' or $_ = $@;
314   (rlv1t) = (2,3);
315   1;
316 EOE
317
318 like($_, qr/Can\'t return a temporary from lvalue subroutine/,
319     'returning a PADTMP explicitly (list context)');
320
321 # These next two tests are not necessarily normative.  But this way we will
322 # know if this discrepancy changes.
323
324 $_ = undef;
325 eval <<'EOE' or $_ = $@;
326   sub scalarray : lvalue { @a || $b }
327   @a = 1;
328   (scalarray) = (2,3);
329   1;
330 EOE
331
332 like($_, qr/Can\'t return a temporary from lvalue subroutine/,
333     'returning a scalar-context array via ||');
334
335 $_ = undef;
336 eval <<'EOE' or $_ = $@;
337   use warnings "FATAL" => "all";
338   sub myscalarray : lvalue { my @a = 1; @a || $b }
339   (myscalarray) = (2,3);
340   1;
341 EOE
342
343 like($_, qr/Useless assignment to a temporary/,
344     'returning a scalar-context lexical array via ||');
345
346 $_ = undef;
347 sub lv2t : lvalue { shift }
348 (lv2t($_)) = (2,3);
349 is($_, 2);
350
351 $xxx = 'xxx';
352 sub xxx () { $xxx }  # Not lvalue
353
354 $_ = undef;
355 eval <<'EOE' or $_ = $@;
356   sub lv1tmp : lvalue { xxx }                   # is it a TEMP?
357   lv1tmp = (2,3);
358   1;
359 EOE
360
361 like($_, qr/Can\'t modify non-lvalue subroutine call at /);
362
363 $_ = undef;
364 eval <<'EOE' or $_ = $@;
365   (lv1tmp) = (2,3);
366   1;
367 EOE
368
369 like($_, qr/Can\'t modify non-lvalue subroutine call at /);
370
371 sub yyy () { 'yyy' } # Const, not lvalue
372
373 $_ = undef;
374 eval <<'EOE' or $_ = $@;
375   sub lv1tmpr : lvalue { yyy }                  # is it read-only?
376   lv1tmpr = (2,3);
377   1;
378 EOE
379
380 like($_, qr/Can\'t return a readonly value from lvalue subroutine at/);
381
382 $_ = undef;
383 eval <<'EOE' or $_ = $@;
384   (lv1tmpr) = (2,3);
385   1;
386 EOE
387
388 like($_, qr/Can\'t return a readonly value from lvalue subroutine/);
389
390 eval <<'EOF';
391   sub lv2tmpr : lvalue { my $x = *foo; Internals::SvREADONLY $x, 1; $x }
392   lv2tmpr = (2,3);
393 EOF
394
395 like($@, qr/Can\'t return a readonly value from lvalue subroutine at/);
396
397 eval <<'EOG';
398   (lv2tmpr) = (2,3);
399 EOG
400
401 like($@, qr/Can\'t return a readonly value from lvalue subroutine/);
402
403 sub lva : lvalue {@a}
404
405 $_ = undef;
406 @a = ();
407 $a[1] = 12;
408 eval <<'EOE' or $_ = $@;
409   (lva) = (2,3);
410   1;
411 EOE
412
413 is("'@a' $_", "'2 3' ");
414
415 $_ = undef;
416 @a = ();
417 $a[0] = undef;
418 $a[1] = 12;
419 eval <<'EOE' or $_ = $@;
420   (lva) = (2,3);
421   1;
422 EOE
423
424 is("'@a' $_", "'2 3' ");
425
426 is lva->${\sub { return $_[0] }}, 2,
427   'lvalue->$thing when lvalue returns array';
428
429 my @my = qw/ a b c /;
430 sub lvmya : lvalue { @my }
431
432 is lvmya->${\sub { return $_[0] }}, 3,
433   'lvalue->$thing when lvalue returns lexical array';
434
435 sub lv1n : lvalue { $newvar }
436
437 $_ = undef;
438 eval <<'EOE' or $_ = $@;
439   lv1n = (3,4);
440   1;
441 EOE
442
443 is("'$newvar' $_", "'4' ");
444
445 sub lv1nn : lvalue { $nnewvar }
446
447 $_ = undef;
448 eval <<'EOE' or $_ = $@;
449   (lv1nn) = (3,4);
450   1;
451 EOE
452
453 is("'$nnewvar' $_", "'3' ");
454
455 $a = \&lv1nn;
456 $a->() = 8;
457 is($nnewvar, '8');
458
459 eval 'sub AUTOLOAD : lvalue { $newvar }';
460 foobar() = 12;
461 is($newvar, "12");
462
463 # But autoloading should only be triggered by a call to an undefined
464 # subroutine.
465 &{"lv1nn"} = 14;
466 is $newvar, 12, 'AUTOLOAD does not take precedence over lvalue sub';
467 eval { &{"xxx"} = 14 };
468 is $newvar, 12, 'AUTOLOAD does not take precedence over non-lvalue sub';
469
470 {
471 my %hash; my @array;
472 sub alv : lvalue { $array[1] }
473 sub alv2 : lvalue { $array[$_[0]] }
474 sub hlv : lvalue { $hash{"foo"} }
475 sub hlv2 : lvalue { $hash{$_[0]} }
476 $array[1] = "not ok 51\n";
477 alv() = "ok 50\n";
478 is(alv(), "ok 50\n");
479
480 alv2(20) = "ok 51\n";
481 is($array[20], "ok 51\n");
482
483 $hash{"foo"} = "not ok 52\n";
484 hlv() = "ok 52\n";
485 is($hash{foo}, "ok 52\n");
486
487 $hash{bar} = "not ok 53\n";
488 hlv("bar") = "ok 53\n";
489 is(hlv("bar"), "ok 53\n");
490
491 sub array : lvalue  { @array  }
492 sub array2 : lvalue { @array2 } # This is a global.
493 sub hash : lvalue   { %hash   }
494 sub hash2 : lvalue  { %hash2  } # So's this.
495 @array2 = qw(foo bar);
496 %hash2 = qw(foo bar);
497
498 (array()) = qw(ok 54);
499 is("@array", "ok 54");
500
501 (array2()) = qw(ok 55);
502 is("@array2", "ok 55");
503
504 (hash()) = qw(ok 56);
505 cmp_ok($hash{ok}, '==', 56);
506
507 (hash2()) = qw(ok 57);
508 cmp_ok($hash2{ok}, '==', 57);
509
510 @array = qw(a b c d);
511 sub aslice1 : lvalue { @array[0,2] };
512 (aslice1()) = ("ok", "already");
513 is("@array", "ok b already d");
514
515 @array2 = qw(a B c d);
516 sub aslice2 : lvalue { @array2[0,2] };
517 (aslice2()) = ("ok", "already");
518 is("@array2", "ok B already d");
519
520 %hash = qw(a Alpha b Beta c Gamma);
521 sub hslice : lvalue { @hash{"c", "b"} }
522 (hslice()) = ("CISC", "BogoMIPS");
523 is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS");
524 }
525
526 $str = "Hello, world!";
527 sub sstr : lvalue { substr($str, 1, 4) }
528 sstr() = "i";
529 is($str, "Hi, world!");
530
531 $str = "Made w/ JavaScript";
532 sub veclv : lvalue { vec($str, 2, 32) }
533 if (ord('A') != 193) {
534     veclv() = 0x5065726C;
535 }
536 else { # EBCDIC?
537     veclv() = 0xD7859993;
538 }
539 is($str, "Made w/ PerlScript");
540
541 sub position : lvalue { pos }
542 @p = ();
543 $_ = "fee fi fo fum";
544 while (/f/g) {
545     push @p, position;
546     position() += 6;
547 }
548 is("@p", "1 8");
549
550 sub keeze : lvalue { keys %__ }
551 %__ = ("a","b");
552 keeze = 64;
553 is scalar %__, '1/64', 'keys assignment through lvalue sub';
554
555 # Bug 20001223.002: split thought that the list had only one element
556 @ary = qw(4 5 6);
557 sub lval1 : lvalue { $ary[0]; }
558 sub lval2 : lvalue { $ary[1]; }
559 (lval1(), lval2()) = split ' ', "1 2 3 4";
560
561 is(join(':', @ary), "1:2:6");
562
563 # check that an element of a tied hash/array can be assigned to via lvalueness
564
565 package Tie_Hash;
566
567 our ($key, $val);
568 sub TIEHASH { bless \my $v => __PACKAGE__ }
569 sub STORE   { ($key, $val) = @_[1,2] }
570
571 package main;
572 sub lval_tie_hash : lvalue {
573     tie my %t => 'Tie_Hash';
574     $t{key};
575 }
576
577 eval { lval_tie_hash() = "value"; };
578
579 is($@, "", "element of tied hash");
580
581 is("$Tie_Hash::key-$Tie_Hash::val", "key-value");
582
583
584 package Tie_Array;
585
586 our @val;
587 sub TIEARRAY { bless \my $v => __PACKAGE__ }
588 sub STORE   { $val[ $_[1] ] = $_[2] }
589
590 package main;
591 sub lval_tie_array : lvalue {
592     tie my @t => 'Tie_Array';
593     $t[0];
594 }
595
596 eval { lval_tie_array() = "value"; };
597
598
599 is($@, "", "element of tied array");
600
601 is ($Tie_Array::val[0], "value");
602
603
604 # Check that tied pad vars that are returned can be assigned to
605 sub TIESCALAR { bless [] }
606 sub STORE {$wheel = $_[1]}
607 sub FETCH {$wheel}
608 sub tied_pad_var  :lvalue { tie my $tyre, ''; $tyre }
609 sub tied_pad_varr :lvalue { tie my $tyre, ''; return $tyre }
610 tied_pad_var = 1;
611 is $wheel, 1, 'tied pad var returned in scalar lvalue context';
612 tied_pad_var->${\sub{ $_[0] = 2 }};
613 is $wheel, 2, 'tied pad var returned in scalar ref context';
614 (tied_pad_var) = 3;
615 is $wheel, 3, 'tied pad var returned in list lvalue context';
616 $_ = 4 for tied_pad_var;
617 is $wheel, 4, 'tied pad var returned in list ref context';
618 tied_pad_varr = 5;
619 is $wheel, 5, 'tied pad var explicitly returned in scalar lvalue context';
620 tied_pad_varr->${\sub{ $_[0] = 6 }};
621 is $wheel, 6, 'tied pad var explicitly returned in scalar ref context';
622 (tied_pad_varr) = 7;
623 is $wheel, 7, 'tied pad var explicitly returned in list lvalue context';
624 $_ = 8 for tied_pad_varr;
625 is $wheel, 8, 'tied pad var explicitly returned in list ref context';
626
627
628 # Test explicit return of lvalue expression
629 {
630     # subs are copies from tests 1-~18 with an explicit return added.
631     # They used not to work, which is why they are ‘badly’ named.
632     sub bad_get_lex : lvalue { return $in };
633     sub bad_get_st  : lvalue { return $blah }
634
635     sub bad_id  : lvalue { return ${\shift} }
636     sub bad_id1 : lvalue { return $_[0] }
637     sub bad_inc : lvalue { return ${\++$_[0]} }
638
639     $in = 5;
640     $blah = 3;
641
642     bad_get_st = 7;
643
644     is( $blah, 7 );
645
646     bad_get_lex = 7;
647
648     is($in, 7, "yada");
649
650     ++bad_get_st;
651
652     is($blah, 8, "yada");
653
654     ++bad_get_lex;
655     cmp_ok($in, '==', 8);
656
657     bad_id(bad_get_st) = 10;
658     cmp_ok($blah, '==', 10);
659
660     bad_id(bad_get_lex) = 10;
661     cmp_ok($in, '==', 10);
662
663     ++bad_id(bad_get_st);
664     cmp_ok($blah, '==', 11);
665
666     ++bad_id(bad_get_lex);
667     cmp_ok($in, '==', 11);
668
669     bad_id1(bad_get_st) = 20;
670     cmp_ok($blah, '==', 20);
671
672     bad_id1(bad_get_lex) = 20;
673     cmp_ok($in, '==', 20);
674
675     ++bad_id1(bad_get_st);
676     cmp_ok($blah, '==', 21);
677
678     ++bad_id1(bad_get_lex);
679     cmp_ok($in, '==', 21);
680
681     bad_inc(bad_get_st);
682     cmp_ok($blah, '==', 22);
683
684     bad_inc(bad_get_lex);
685     cmp_ok($in, '==', 22);
686
687     bad_inc(bad_id(bad_get_st));
688     cmp_ok($blah, '==', 23);
689
690     bad_inc(bad_id(bad_get_lex));
691     cmp_ok($in, '==', 23);
692
693     ++bad_inc(bad_id1(bad_id(bad_get_st)));
694     cmp_ok($blah, '==', 25);
695
696     ++bad_inc(bad_id1(bad_id(bad_get_lex)));
697     cmp_ok($in, '==', 25);
698
699     # Recursive
700     my $r;
701     my $to_modify;
702     $r = sub :lvalue {
703       my $depth = shift//0;
704       if ($depth == 2) { return $to_modify }
705       return &$r($depth+1);
706     };
707     &$r(0) = 7;
708     is $to_modify, 7, 'recursive lvalue sub';
709
710     # Recursive with substr [perl #72706]
711     my $val = '';
712     my $pie;
713     $pie = sub :lvalue {
714         my $depth = shift;
715         return &$pie($depth) if $depth--;
716         substr $val, 0;
717     };
718     for my $depth (0, 1, 2) {
719         my $value = "Good $depth";
720         eval {
721             &$pie($depth) = $value;
722         };
723         is($@, '', "recursive lvalue substr return depth $depth");
724         is($val, $value,
725            "value assigned to recursive lvalue substr (depth $depth)");
726     }
727 }
728
729 { # bug #23790
730     my @arr  = qw /one two three/;
731     my $line = "zero";
732     sub lval_array () : lvalue {@arr}
733
734     for (lval_array) {
735         $line .= $_;
736     }
737
738     is($line, "zeroonetwothree");
739
740     sub trythislval { scalar(@_)."x".join "", @_ }
741     is(trythislval(lval_array()), "3xonetwothree");
742
743     sub changeme { $_[2] = "free" }
744     changeme(lval_array);
745     is("@arr", "one two free");
746
747     # test again, with explicit return
748     sub rlval_array() : lvalue {return @arr}
749     @arr  = qw /one two three/;
750     $line = "zero";
751     for (rlval_array) {
752         $line .= $_;
753     }
754     is($line, "zeroonetwothree");
755     is(trythislval(rlval_array()), "3xonetwothree");
756     changeme(rlval_array);
757     is("@arr", "one two free");
758
759     # Variations on the same theme, with multiple vars returned
760     my $scalar = 'half';
761     sub lval_scalar_array () : lvalue { $scalar, @arr }
762     @arr  = qw /one two three/;
763     $line = "zero";
764     for (lval_scalar_array) {
765         $line .= $_;
766     }
767     is($line, "zerohalfonetwothree");
768     is(trythislval(lval_scalar_array()), "4xhalfonetwothree");
769     changeme(lval_scalar_array);
770     is("@arr", "one free three");
771
772     sub lval_array_scalar () : lvalue { @arr, $scalar }
773     @arr  = qw /one two three/;
774     $line = "zero";
775     $scalar = 'four';
776     for (lval_array_scalar) {
777         $line .= $_;
778     }
779     is($line, "zeroonetwothreefour");
780     is(trythislval(lval_array_scalar()), "4xonetwothreefour");
781     changeme(lval_array_scalar);
782     is("@arr", "one two free");
783
784     # Tests for specific ops not tested above
785     # rv2av
786     @array2 = qw 'one two free';
787     is join(',', map $_, sub:lvalue{@array2}->()), 'one,two,free',
788       'rv2av in reference context';
789     is join(',', map $_, sub:lvalue{@{\@array2}}->()), 'one,two,free',
790       'rv2av-with-ref in reference context';
791     # padhv
792     my %hash = qw[a b c d];
793     like join(',', map $_, sub:lvalue{%hash}->()),
794          qr/^(?:a,b,c,d|c,d,a,b)\z/, 'padhv in reference context';
795     # rv2hv
796     %hash2 = qw[a b c d];
797     like join(',', map $_, sub:lvalue{%hash2}->()),
798          qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv in reference context';
799     like join(',', map $_, sub:lvalue{%{\%hash2}}->()),
800          qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv-with-ref in reference context';
801 }
802
803 {
804     package Foo;
805     sub AUTOLOAD :lvalue { *{$AUTOLOAD} };
806     package main;
807     my $foo = bless {},"Foo";
808     my $result;
809     $foo->bar = sub { $result = "bar" };
810     $foo->bar;
811     is ($result, 'bar', "RT #41550");
812 }
813
814 SKIP: { skip 'no attributes.pm', 1 unless eval 'require attributes';
815 fresh_perl_is(<<'----', <<'====', {}, "lvalue can not be set after definition. [perl #68758]");
816 use warnings;
817 our $x;
818 sub foo { $x }
819 sub foo : lvalue;
820 sub MODIFY_CODE_ATTRIBUTES {}
821 sub foo : lvalue : fr0g;
822 foo = 3;
823 ----
824 lvalue attribute ignored after the subroutine has been defined at - line 4.
825 lvalue attribute ignored after the subroutine has been defined at - line 6.
826 Can't modify non-lvalue subroutine call in scalar assignment at - line 7, near "3;"
827 Execution of - aborted due to compilation errors.
828 ====
829 }
830
831 {
832     my $x;
833     sub lval_decl : lvalue;
834     sub lval_decl { $x }
835     lval_decl = 5;
836     is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]");
837 }
838
839 SKIP: { skip "no attributes.pm", 2 unless eval { require attributes };
840   sub utf8::valid :lvalue;
841   require attributes;
842   is "@{[ &attributes::get(\&utf8::valid) ]}", 'lvalue',
843    'sub declaration with :lvalue applies it to XSUBs';
844
845   BEGIN { *wonky = \&marjibberous }
846   sub wonky :lvalue;
847   is "@{[ &attributes::get(\&wonky) ]}", 'lvalue',
848    'sub declaration with :lvalue applies it to assigned stub';
849 }
850
851 sub fleen : lvalue { $pnare }
852 $pnare = __PACKAGE__;
853 ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\
854 is $pnare, 1, 'and returning CATTLE actually works';
855 $pnare = __PACKAGE__;
856 ok eval { (fleen) = 1 }, "lvalues can return COWs in list context";
857 is $pnare, 1, 'and returning COWs in list context actually works';
858 $pnare = __PACKAGE__;
859 ok eval { $_ = 1 for(fleen); 1 }, "lvalues can return COWs in ref cx";
860 is $pnare, 1, 'and returning COWs in reference context actually works';
861
862
863 # Returning an arbitrary expression, not necessarily lvalue
864 +sub :lvalue { return $ambaga || $ambaga }->() = 73;
865 is $ambaga, 73, 'explicit return of arbitrary expression (scalar context)';
866 (sub :lvalue { return $ambaga || $ambaga }->()) = 74;
867 is $ambaga, 74, 'explicit return of arbitrary expression (list context)';
868 +sub :lvalue { $ambaga || $ambaga }->() = 73;
869 is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)';
870 (sub :lvalue { $ambaga || $ambaga }->()) = 74;
871 is $ambaga, 74, 'implicit return of arbitrary expression (list context)';
872 eval { +sub :lvalue { return 3 }->() = 4 };
873 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
874       'assignment to numeric constant explicitly returned from lv sub';
875 eval { (sub :lvalue { return 3 }->()) = 4 };
876 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
877       'assignment to num constant explicitly returned (list cx)';
878 eval { +sub :lvalue { 3 }->() = 4 };
879 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
880       'assignment to numeric constant implicitly returned from lv sub';
881 eval { (sub :lvalue { 3 }->()) = 4 };
882 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
883       'assignment to num constant implicitly returned (list cx)';
884
885 # reference (potential lvalue) context
886 $suffix = '';
887 for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
888     &$sub()->${\sub { $_[0] = 37 }};
889     is $_, '37', 'lvalue->method'.$suffix;
890     ${\scalar &$sub()} = 38;
891     is $_, '38', 'scalar(lvalue)'.$suffix;
892     sub assign39_with_proto ($) { $_[0] = 39 }
893     assign39_with_proto(&$sub());
894     is $_, '39', 'func(lvalue) when func has $ proto'.$suffix;
895     $_ = 1;
896     ${\(&$sub()||undef)} = 40;
897     is $_, '40', 'lvalue||...'.$suffix;
898     ${\(${\undef}||&$sub())} = 41; # extra ${\...} to bypass const folding
899     is $_, '41', '...||lvalue'.$suffix;
900     $_ = 0;
901     ${\(&$sub()&&undef)} = 42;
902     is $_, '42', 'lvalue&&...'.$suffix;
903     ${\(${\1}&&&$sub())} = 43;
904     is $_, '43', '...&&lvalue'.$suffix;
905     ${\(&$sub())[0]} = 44;
906     is $_, '44', '(lvalue)[0]'.$suffix;
907 }
908 continue { $suffix = ' (explicit return)' }
909
910 # autovivification
911 $suffix = '';
912 for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
913     undef $_;
914     &$sub()->[3] = 4;
915     is $_->[3], 4, 'func->[...] autovivification'.$suffix;
916     undef $_;
917     &$sub()->{3} = 4;
918     is $_->{3}, 4, 'func->{...} autovivification'.$suffix;
919     undef $_;
920     ${&$sub()} = 4;
921     is $$_, 4, '${func()} autovivification'      .$suffix;
922     undef $_;
923     @{&$sub()} = 4;
924     is "@$_", 4, '@{func()} autovivification'    .$suffix;
925     undef $_;
926     %{&$sub()} = (4,5);
927     is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix;
928     undef $_;
929     ${ (), &$sub()} = 4;
930     is $$_, 4, '${ (), func()} autovivification'      .$suffix;
931 }
932 continue { $suffix = ' (explicit return)' }
933
934 # [perl #92406] [perl #92290] Returning a pad var in rvalue context
935 $suffix = '';
936 for my $sub (
937          sub :lvalue { my $x = 72; $x },
938          sub :lvalue { my $x = 72; return $x }
939 ) {
940     is scalar(&$sub), 72, "sub returning pad var in scalar context$suffix";
941     is +(&$sub)[0], 72, "sub returning pad var in list context$suffix";
942 }
943 continue { $suffix = ' (explicit return)' }
944
945 # Returning read-only values in reference context
946 $suffix = '';
947 for (
948          sub :lvalue { $] }->(),
949          sub :lvalue { return $] }->()
950 ) {
951     is \$_, \$], 'read-only values are returned in reference context'
952                  .$suffix             # (they used to be copied)
953 }
954 continue { $suffix = ' (explicit return)' }
955
956 # Returning unwritables from nested lvalue sub call in in rvalue context
957 # First, ensure we are testing what we think we are:
958 if (!Internals::SvREADONLY($])) { Internals::SvREADONLY($],1); }
959 sub squibble : lvalue { return $] }
960 sub squebble : lvalue {        squibble }
961 sub squabble : lvalue { return squibble }
962 is $x = squebble, $], 'returning ro from nested lv sub call in rv cx';
963 is $x = squabble, $], 'explct. returning ro from nested lv sub in rv cx';
964 is \squebble, \$], 'returning ro from nested lv sub call in ref cx';
965 is \squabble, \$], 'explct. returning ro from nested lv sub in ref cx';
966
967 # [perl #102486] Sub calls as the last statement of an lvalue sub
968 package _102486 {
969   my $called;
970   my $x = 'nonlv';
971   sub strictlv :lvalue { use strict 'refs'; &$x }
972   sub lv :lvalue { &$x }
973   sub nonlv { ++$called }
974   eval { strictlv };
975   ::like $@, qr/^Can't use string \("nonlv"\) as a subroutine ref while/,
976         'strict mode applies to sub:lvalue{ &$string }';
977   $called = 0;
978   ::ok eval { lv },
979       'sub:lvalue{&$x}->() does not die for non-lvalue inner sub call';
980   ::is $called, 1, 'The &$x actually called the sub';
981   eval { +sub :lvalue { &$x }->() = 3 };
982   ::like $@, qr/^Can't modify non-lvalue subroutine call at /,
983         'sub:lvalue{&$x}->() dies in true lvalue context';
984 }
985
986 # TARG should be copied in rvalue context
987 sub ucf :lvalue { ucfirst $_[0] }
988 is ucf("just another ") . ucf("perl hacker,\n"),
989    "Just another Perl hacker,\n", 'TARG is copied in rvalue scalar cx';
990 is join('',ucf("just another "), ucf "perl hacker,\n"),
991    "Just another Perl hacker,\n", 'TARG is copied in rvalue list cx';
992 sub ucfr : lvalue {
993     @_ ? ucfirst $_[0] : do {
994         is ucfr("just another ") . ucfr("perl hacker,\n"),
995            "Just another Perl hacker,\n",
996            'TARG is copied in recursive rvalue scalar cx';
997         is join('',ucfr("just another "), ucfr("perl hacker,\n")),
998            "Just another Perl hacker,\n",
999            'TARG is copied in recursive rvalue list cx';
1000     }
1001 }
1002 ucfr();
1003
1004 # Test TARG with potential lvalue context, too
1005 for (sub : lvalue { "$x" }->()) {
1006     is \$_, \$_, '\$_ == \$_ in for(sub :lvalue{"$x"}->()){...}'
1007 }
1008
1009 # [perl #117947] XSUBs should not be treated as lvalues at run time
1010 eval { &{\&utf8::is_utf8}("") = 3 };
1011 like $@, qr/^Can't modify non-lvalue subroutine call at /,
1012         'XSUB not seen at compile time dies in lvalue context';
1013
1014 # [perl #119797] else implicitly returning value
1015 # This used to cause Bizarre copy of ARRAY in pp_leave
1016 sub else119797 : lvalue {
1017     if ($_[0]) {
1018         1; # two statements force a leave op
1019         @119797
1020     }
1021     else {
1022         @119797
1023     }
1024 }
1025 eval { (else119797(0)) = 1..3 };
1026 is $@, "", '$@ after writing to array returned by else';
1027 is "@119797", "1 2 3", 'writing to array returned by else';
1028 eval { (else119797(1)) = 4..6 };
1029 is $@, "", '$@ after writing to array returned by if (with else)';
1030 is "@119797", "4 5 6", 'writing to array returned by if (with else)';
1031 sub if119797 : lvalue {
1032     if ($_[0]) {
1033         @119797
1034     }
1035 }
1036 @119797 = ();
1037 eval { (if119797(1)) = 4..6 };
1038 is $@, "", '$@ after writing to array returned by if';
1039 is "@119797", "4 5 6", 'writing to array returned by if';
1040 sub unless119797 : lvalue {
1041     unless ($_[0]) {
1042         @119797
1043     }
1044 }
1045 @119797 = ();
1046 eval { (unless119797(0)) = 4..6 };
1047 is $@, "", '$@ after writing to array returned by unless';
1048 is "@119797", "4 5 6", 'writing to array returned by unless';
1049 sub bare119797 : lvalue {
1050     {;
1051         @119797
1052     }
1053 }
1054 @119797 = ();
1055 eval { (bare119797(0)) = 4..6 };
1056 is $@, "", '$@ after writing to array returned by bare block';
1057 is "@119797", "4 5 6", 'writing to array returned by bare block';