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