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