t/op/sub_lval.t

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