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