8 sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary
9 sub b : lvalue { ${\shift} }
11 my $out = a(b()); # Check that temporaries are allowed.
12 is(ref $out, 'main'); # Not reached if error.
14 my @out = grep /main/, a(b()); # Check that temporaries are allowed.
15 cmp_ok(scalar @out, '==', 1); # Not reached if error.
19 # Check that we can return localized values from subroutines:
21 sub in : lvalue { $in = shift; }
22 sub neg : lvalue { #(num_str) return num_str
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]} }
43 cmp_ok($blah, '==', 7);
51 cmp_ok($blah, '==', 8);
59 cmp_ok($blah, '==', 10);
63 cmp_ok($in, '==', 10);
67 cmp_ok($blah, '==', 11);
71 cmp_ok($in, '==', 11);
75 cmp_ok($blah, '==', 20);
79 cmp_ok($in, '==', 20);
83 cmp_ok($blah, '==', 21);
87 cmp_ok($in, '==', 21);
91 cmp_ok($blah, '==', 22);
95 cmp_ok($in, '==', 22);
99 cmp_ok($blah, '==', 23);
103 cmp_ok($in, '==', 23);
105 ++inc(id1(id(get_st)));
107 cmp_ok($blah, '==', 25);
109 ++inc(id1(id(get_lex)));
111 cmp_ok($in, '==', 25);
115 $#c = 3; # These slots are not fillable.
117 # Explanation: empty slots contain &sv_undef.
119 =for disabled constructs
127 eval <<'EOE' or $_ = $@;
128 ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
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";
136 like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/);
144 sub a::var : lvalue { $var }
148 cmp_ok($var, '==', 45);
151 $o = bless \$oo, "a";
155 cmp_ok($var, '==', 47);
157 sub o : lvalue { $o }
161 cmp_ok($var, '==', 49);
163 sub nolv () { $x0, $x1 } # Not lvalue
167 eval <<'EOE' or $_ = $@;
172 like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
176 eval <<'EOE' or $_ = $@;
181 like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
185 eval <<'EOE' or $_ = $@;
190 like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/);
192 $x0 = $x1 = $_ = undef;
195 eval <<'EOE' or $_ = $@;
196 $nolv->() = (2,3) if $_;
200 ok(!defined $_) or diag "'$_', '$x0', '$x1'";
202 $x0 = $x1 = $_ = undef;
205 eval <<'EOE' or $_ = $@;
210 like($_, qr/Can\'t modify non-lvalue subroutine call/)
211 or diag "'$_', '$x0', '$x1'";
216 eval <<'EOE' or $_ = $@;
221 like($_, qr/Can't return undef from lvalue subroutine/);
224 eval <<'EOE' or $_ = $@;
229 ok(!defined $_) or diag $_;
232 (lv0($a,$b)) = (3,4);
233 is +($a//'undef') . ($b//'undef'), 'undefundef',
234 'list assignment to empty lvalue sub';
237 sub lv1u :lvalue { undef }
240 eval <<'EOE' or $_ = $@;
245 like($_, qr/Can't return undef from lvalue subroutine/);
248 eval <<'EOE' or $_ = $@;
253 # Fixed by change @10777
254 #print "# '$_'.\nnot "
255 # unless /Can\'t return an uninitialized value from lvalue subroutine/;
256 # print "ok 34 # Skip: removed test\n";
261 eval <<'EOE' or $_ = $@;
262 sub lv1t : lvalue { index $x, 2 }
267 like($_, qr/Can\'t return a temporary from lvalue subroutine/);
270 sub lv2t : lvalue { shift }
275 sub xxx () { $xxx } # Not lvalue
278 eval <<'EOE' or $_ = $@;
279 sub lv1tmp : lvalue { xxx } # is it a TEMP?
284 is($_, undef, "returning a temp from an lvalue sub in scalar context");
287 eval <<'EOE' or $_ = $@;
292 is($_, undef, "returning a temp from an lvalue sub in list context");
294 sub yyy () { 'yyy' } # Const, not lvalue
297 eval <<'EOE' or $_ = $@;
298 sub lv1tmpr : lvalue { yyy } # is it read-only?
303 like($_, qr/Can\'t return a readonly value from lvalue subroutine at/);
306 eval <<'EOE' or $_ = $@;
311 like($_, qr/Can\'t return a readonly value from lvalue subroutine/);
313 sub lva : lvalue {@a}
318 eval <<'EOE' or $_ = $@;
323 is("'@a' $_", "'2 3' ");
329 eval <<'EOE' or $_ = $@;
334 is("'@a' $_", "'2 3' ");
336 is lva->${\sub { return $_[0] }}, 2,
337 'lvalue->$thing when lvalue returns array';
339 my @my = qw/ a b c /;
340 sub lvmya : lvalue { @my }
342 is lvmya->${\sub { return $_[0] }}, 3,
343 'lvalue->$thing when lvalue returns lexical array';
345 sub lv1n : lvalue { $newvar }
348 eval <<'EOE' or $_ = $@;
353 is("'$newvar' $_", "'4' ");
355 sub lv1nn : lvalue { $nnewvar }
358 eval <<'EOE' or $_ = $@;
363 is("'$nnewvar' $_", "'3' ");
369 eval 'sub AUTOLOAD : lvalue { $newvar }';
375 sub alv : lvalue { $array[1] }
376 sub alv2 : lvalue { $array[$_[0]] }
377 sub hlv : lvalue { $hash{"foo"} }
378 sub hlv2 : lvalue { $hash{$_[0]} }
379 $array[1] = "not ok 51\n";
381 is(alv(), "ok 50\n");
383 alv2(20) = "ok 51\n";
384 is($array[20], "ok 51\n");
386 $hash{"foo"} = "not ok 52\n";
388 is($hash{foo}, "ok 52\n");
390 $hash{bar} = "not ok 53\n";
391 hlv("bar") = "ok 53\n";
392 is(hlv("bar"), "ok 53\n");
394 sub array : lvalue { @array }
395 sub array2 : lvalue { @array2 } # This is a global.
396 sub hash : lvalue { %hash }
397 sub hash2 : lvalue { %hash2 } # So's this.
398 @array2 = qw(foo bar);
399 %hash2 = qw(foo bar);
401 (array()) = qw(ok 54);
402 is("@array", "ok 54");
404 (array2()) = qw(ok 55);
405 is("@array2", "ok 55");
407 (hash()) = qw(ok 56);
408 cmp_ok($hash{ok}, '==', 56);
410 (hash2()) = qw(ok 57);
411 cmp_ok($hash2{ok}, '==', 57);
413 @array = qw(a b c d);
414 sub aslice1 : lvalue { @array[0,2] };
415 (aslice1()) = ("ok", "already");
416 is("@array", "ok b already d");
418 @array2 = qw(a B c d);
419 sub aslice2 : lvalue { @array2[0,2] };
420 (aslice2()) = ("ok", "already");
421 is("@array2", "ok B already d");
423 %hash = qw(a Alpha b Beta c Gamma);
424 sub hslice : lvalue { @hash{"c", "b"} }
425 (hslice()) = ("CISC", "BogoMIPS");
426 is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS");
429 $str = "Hello, world!";
430 sub sstr : lvalue { substr($str, 1, 4) }
432 is($str, "Hi, world!");
434 $str = "Made w/ JavaScript";
435 sub veclv : lvalue { vec($str, 2, 32) }
436 if (ord('A') != 193) {
437 veclv() = 0x5065726C;
440 veclv() = 0xD7859993;
442 is($str, "Made w/ PerlScript");
444 sub position : lvalue { pos }
446 $_ = "fee fi fo fum";
453 sub keeze : lvalue { keys %__ }
456 is scalar %__, '1/64', 'keys assignment through lvalue sub';
458 # Bug 20001223.002: split thought that the list had only one element
460 sub lval1 : lvalue { $ary[0]; }
461 sub lval2 : lvalue { $ary[1]; }
462 (lval1(), lval2()) = split ' ', "1 2 3 4";
464 is(join(':', @ary), "1:2:6");
466 # check that an element of a tied hash/array can be assigned to via lvalueness
471 sub TIEHASH { bless \my $v => __PACKAGE__ }
472 sub STORE { ($key, $val) = @_[1,2] }
475 sub lval_tie_hash : lvalue {
476 tie my %t => 'Tie_Hash';
480 eval { lval_tie_hash() = "value"; };
482 is($@, "", "element of tied hash");
484 is("$Tie_Hash::key-$Tie_Hash::val", "key-value");
490 sub TIEARRAY { bless \my $v => __PACKAGE__ }
491 sub STORE { $val[ $_[1] ] = $_[2] }
494 sub lval_tie_array : lvalue {
495 tie my @t => 'Tie_Array';
499 eval { lval_tie_array() = "value"; };
502 is($@, "", "element of tied array");
504 is ($Tie_Array::val[0], "value");
507 # Test explicit return of lvalue expression
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.
511 sub bad_get_lex : lvalue { return $in };
512 sub bad_get_st : lvalue { return $blah }
514 sub bad_id : lvalue { return ${\shift} }
515 sub bad_id1 : lvalue { return $_[0] }
516 sub bad_inc : lvalue { return ${\++$_[0]} }
531 is($blah, 8, "yada");
534 cmp_ok($in, '==', 8);
536 bad_id(bad_get_st) = 10;
537 cmp_ok($blah, '==', 10);
539 bad_id(bad_get_lex) = 10;
540 cmp_ok($in, '==', 10);
542 ++bad_id(bad_get_st);
543 cmp_ok($blah, '==', 11);
545 ++bad_id(bad_get_lex);
546 cmp_ok($in, '==', 11);
548 bad_id1(bad_get_st) = 20;
549 cmp_ok($blah, '==', 20);
551 bad_id1(bad_get_lex) = 20;
552 cmp_ok($in, '==', 20);
554 ++bad_id1(bad_get_st);
555 cmp_ok($blah, '==', 21);
557 ++bad_id1(bad_get_lex);
558 cmp_ok($in, '==', 21);
561 cmp_ok($blah, '==', 22);
563 bad_inc(bad_get_lex);
564 cmp_ok($in, '==', 22);
566 bad_inc(bad_id(bad_get_st));
567 cmp_ok($blah, '==', 23);
569 bad_inc(bad_id(bad_get_lex));
570 cmp_ok($in, '==', 23);
572 ++bad_inc(bad_id1(bad_id(bad_get_st)));
573 cmp_ok($blah, '==', 25);
575 ++bad_inc(bad_id1(bad_id(bad_get_lex)));
576 cmp_ok($in, '==', 25);
582 my $depth = shift//0;
583 if ($depth == 2) { return $to_modify }
584 return &$r($depth+1);
587 is $to_modify, 7, 'recursive lvalue sub';
589 # Recursive with substr [perl #72706]
594 return &$pie($depth) if $depth--;
597 for my $depth (0, 1, 2) {
598 my $value = "Good $depth";
600 &$pie($depth) = $value;
602 is($@, '', "recursive lvalue substr return depth $depth");
604 "value assigned to recursive lvalue substr (depth $depth)");
609 my @arr = qw /one two three/;
611 sub lval_array () : lvalue {@arr}
617 is($line, "zeroonetwothree");
619 sub trythislval { scalar(@_)."x".join "", @_ }
620 is(trythislval(lval_array()), "3xonetwothree");
622 sub changeme { $_[2] = "free" }
623 changeme(lval_array);
624 is("@arr", "one two free");
626 # test again, with explicit return
627 sub rlval_array() : lvalue {return @arr}
628 @arr = qw /one two three/;
633 is($line, "zeroonetwothree");
634 is(trythislval(rlval_array()), "3xonetwothree");
635 changeme(rlval_array);
636 is("@arr", "one two free");
638 # Variations on the same theme, with multiple vars returned
640 sub lval_scalar_array () : lvalue { $scalar, @arr }
641 @arr = qw /one two three/;
643 for (lval_scalar_array) {
646 is($line, "zerohalfonetwothree");
647 is(trythislval(lval_scalar_array()), "4xhalfonetwothree");
648 changeme(lval_scalar_array);
649 is("@arr", "one free three");
651 sub lval_array_scalar () : lvalue { @arr, $scalar }
652 @arr = qw /one two three/;
655 for (lval_array_scalar) {
658 is($line, "zeroonetwothreefour");
659 is(trythislval(lval_array_scalar()), "4xonetwothreefour");
660 changeme(lval_array_scalar);
661 is("@arr", "one two free");
663 # Tests for specific ops not tested above
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';
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';
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';
684 sub AUTOLOAD :lvalue { *{$AUTOLOAD} };
686 my $foo = bless {},"Foo";
688 $foo->bar = sub { $result = "bar" };
690 is ($result, 'bar', "RT #41550");
693 fresh_perl_is(<<'----', <<'====', "lvalue can not be set after definition. [perl #68758]");
698 sub MODIFY_CODE_ATTRIBUTES {}
699 sub foo : lvalue : fr0g;
702 lvalue attribute ignored after the subroutine has been defined at - line 4.
703 lvalue attribute ignored after the subroutine has been defined at - line 6.
704 Can't modify non-lvalue subroutine call in scalar assignment at - line 7, near "3;"
705 Execution of - aborted due to compilation errors.
710 sub lval_decl : lvalue;
713 is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]");
716 sub utf8::valid :lvalue;
718 is "@{[ &attributes::get(\&utf8::valid) ]}", 'lvalue',
719 'sub declaration with :lvalue applies it to XSUBs';
721 BEGIN { *wonky = \&marjibberous }
723 is "@{[ &attributes::get(\&wonky) ]}", 'lvalue',
724 'sub declaration with :lvalue applies it to assigned stub';
726 sub fleen : lvalue { $pnare }
727 $pnare = __PACKAGE__;
728 ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\
729 is $pnare, 1, 'and returning CATTLE actually works';
730 $pnare = __PACKAGE__;
731 ok eval { (fleen) = 1 }, "lvalues can return COWs in list context";
732 is $pnare, 1, 'and returning COWs in list context actually works';
733 $pnare = __PACKAGE__;
734 ok eval { $_ = 1 for(fleen); 1 }, "lvalues can return COWs in ref cx";
735 is $pnare, 1, 'and returning COWs in reference context actually works';
738 # Returning an arbitrary expression, not necessarily lvalue
739 +sub :lvalue { return $ambaga || $ambaga }->() = 73;
740 is $ambaga, 73, 'explicit return of arbitrary expression (scalar context)';
741 (sub :lvalue { return $ambaga || $ambaga }->()) = 74;
742 is $ambaga, 74, 'explicit return of arbitrary expression (list context)';
743 +sub :lvalue { $ambaga || $ambaga }->() = 73;
744 is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)';
745 (sub :lvalue { $ambaga || $ambaga }->()) = 74;
746 is $ambaga, 74, 'implicit return of arbitrary expression (list context)';
747 { local $::TODO = 'return needs to enforce the same rules as leavesublv';
748 eval { +sub :lvalue { return 3 }->() = 4 };
749 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
750 'assignment to numeric constant explicitly returned from lv sub';
751 eval { (sub :lvalue { return 3 }->()) = 4 };
752 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
753 'assignment to num constant explicitly returned (list cx)';
755 eval { +sub :lvalue { 3 }->() = 4 };
756 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
757 'assignment to numeric constant implicitly returned from lv sub';
758 eval { (sub :lvalue { 3 }->()) = 4 };
759 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
760 'assignment to num constant implicitly returned (list cx)';
762 # reference (potential lvalue) context
764 for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
765 &$sub()->${\sub { $_[0] = 37 }};
766 is $_, '37', 'lvalue->method'.$suffix;
767 ${\scalar &$sub()} = 38;
768 is $_, '38', 'scalar(lvalue)'.$suffix;
769 sub assign39_with_proto ($) { $_[0] = 39 }
770 assign39_with_proto(&$sub());
771 is $_, '39', 'func(lvalue) when func has $ proto'.$suffix;
773 ${\(&$sub()||undef)} = 40;
774 is $_, '40', 'lvalue||...'.$suffix;
775 ${\(${\undef}||&$sub())} = 41; # extra ${\...} to bypass const folding
776 is $_, '41', '...||lvalue'.$suffix;
778 ${\(&$sub()&&undef)} = 42;
779 is $_, '42', 'lvalue&&...'.$suffix;
780 ${\(${\1}&&&$sub())} = 43;
781 is $_, '43', '...&&lvalue'.$suffix;
782 ${\(&$sub())[0]} = 44;
783 is $_, '44', '(lvalue)[0]'.$suffix;
785 continue { $suffix = ' (explicit return)' }
789 for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
792 is $_->[3], 4, 'func->[...] autovivification'.$suffix;
795 is $_->{3}, 4, 'func->{...} autovivification'.$suffix;
798 is $$_, 4, '${func()} autovivification' .$suffix;
801 is "@$_", 4, '@{func()} autovivification' .$suffix;
804 is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix;
806 continue { $suffix = ' (explicit return)' }
808 # [perl #92406] [perl #92290] Returning a pad var in rvalue context
811 sub :lvalue { my $x = 72; $x },
812 sub :lvalue { my $x = 72; return $x }
814 is scalar(&$sub), 72, "sub returning pad var in scalar context$suffix";
815 is +(&$sub)[0], 72, "sub returning pad var in list context$suffix";
817 continue { $suffix = ' (explicit return)' }
819 # Returning read-only values in reference context
822 sub :lvalue { $] }->(),
823 sub :lvalue { return $] }->()
825 is \$_, \$], 'read-only values are returned in reference context'
826 .$suffix # (they used to be copied)
828 continue { $suffix = ' (explicit return)' }