t/op/sub_lval.t

   1 BEGIN {
   2     chdir 't' if -d 't';
   3     @INC = '../lib';
   4     require './test.pl';
   5 }
   6 plan tests=>205;
   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 # These next two tests are not necessarily normative.  But this way we will
 322 # know if this discrepancy changes.
 323
 324 $_ = undef;
 325 eval <<'EOE' or $_ = $@;
 326   sub scalarray : lvalue { @a || $b }
 327   @a = 1;
 328   (scalarray) = (2,3);
 329   1;
 330 EOE
 331
 332 like($_, qr/Can\'t return a temporary from lvalue subroutine/,
 333     'returning a scalar-context array via ||');
 334
 335 $_ = undef;
 336 eval <<'EOE' or $_ = $@;
 337   use warnings "FATAL" => "all";
 338   sub myscalarray : lvalue { my @a = 1; @a || $b }
 339   (myscalarray) = (2,3);
 340   1;
 341 EOE
 342
 343 like($_, qr/Useless assignment to a temporary/,
 344     'returning a scalar-context lexical array via ||');
 345
 346 $_ = undef;
 347 sub lv2t : lvalue { shift }
 348 (lv2t($_)) = (2,3);
 349 is($_, 2);
 350
 351 $xxx = 'xxx';
 352 sub xxx () { $xxx }  # Not lvalue
 353
 354 $_ = undef;
 355 eval <<'EOE' or $_ = $@;
 356   sub lv1tmp : lvalue { xxx }                   # is it a TEMP?
 357   lv1tmp = (2,3);
 358   1;
 359 EOE
 360
 361 like($_, qr/Can\'t modify non-lvalue subroutine call at /);
 362
 363 $_ = undef;
 364 eval <<'EOE' or $_ = $@;
 365   (lv1tmp) = (2,3);
 366   1;
 367 EOE
 368
 369 like($_, qr/Can\'t modify non-lvalue subroutine call at /);
 370
 371 sub yyy () { 'yyy' } # Const, not lvalue
 372
 373 $_ = undef;
 374 eval <<'EOE' or $_ = $@;
 375   sub lv1tmpr : lvalue { yyy }                  # is it read-only?
 376   lv1tmpr = (2,3);
 377   1;
 378 EOE
 379
 380 like($_, qr/Can\'t return a readonly value from lvalue subroutine at/);
 381
 382 $_ = undef;
 383 eval <<'EOE' or $_ = $@;
 384   (lv1tmpr) = (2,3);
 385   1;
 386 EOE
 387
 388 like($_, qr/Can\'t return a readonly value from lvalue subroutine/);
 389
 390 sub lva : lvalue {@a}
 391
 392 $_ = undef;
 393 @a = ();
 394 $a[1] = 12;
 395 eval <<'EOE' or $_ = $@;
 396   (lva) = (2,3);
 397   1;
 398 EOE
 399
 400 is("'@a' $_", "'2 3' ");
 401
 402 $_ = undef;
 403 @a = ();
 404 $a[0] = undef;
 405 $a[1] = 12;
 406 eval <<'EOE' or $_ = $@;
 407   (lva) = (2,3);
 408   1;
 409 EOE
 410
 411 is("'@a' $_", "'2 3' ");
 412
 413 is lva->${\sub { return $_[0] }}, 2,
 414   'lvalue->$thing when lvalue returns array';
 415
 416 my @my = qw/ a b c /;
 417 sub lvmya : lvalue { @my }
 418
 419 is lvmya->${\sub { return $_[0] }}, 3,
 420   'lvalue->$thing when lvalue returns lexical array';
 421
 422 sub lv1n : lvalue { $newvar }
 423
 424 $_ = undef;
 425 eval <<'EOE' or $_ = $@;
 426   lv1n = (3,4);
 427   1;
 428 EOE
 429
 430 is("'$newvar' $_", "'4' ");
 431
 432 sub lv1nn : lvalue { $nnewvar }
 433
 434 $_ = undef;
 435 eval <<'EOE' or $_ = $@;
 436   (lv1nn) = (3,4);
 437   1;
 438 EOE
 439
 440 is("'$nnewvar' $_", "'3' ");
 441
 442 $a = \&lv1nn;
 443 $a->() = 8;
 444 is($nnewvar, '8');
 445
 446 eval 'sub AUTOLOAD : lvalue { $newvar }';
 447 foobar() = 12;
 448 is($newvar, "12");
 449
 450 # But autoloading should only be triggered by a call to an undefined
 451 # subroutine.
 452 &{"lv1nn"} = 14;
 453 is $newvar, 12, 'AUTOLOAD does not take precedence over lvalue sub';
 454 eval { &{"xxx"} = 14 };
 455 is $newvar, 12, 'AUTOLOAD does not take precedence over non-lvalue sub';
 456
 457 {
 458 my %hash; my @array;
 459 sub alv : lvalue { $array[1] }
 460 sub alv2 : lvalue { $array[$_[0]] }
 461 sub hlv : lvalue { $hash{"foo"} }
 462 sub hlv2 : lvalue { $hash{$_[0]} }
 463 $array[1] = "not ok 51\n";
 464 alv() = "ok 50\n";
 465 is(alv(), "ok 50\n");
 466
 467 alv2(20) = "ok 51\n";
 468 is($array[20], "ok 51\n");
 469
 470 $hash{"foo"} = "not ok 52\n";
 471 hlv() = "ok 52\n";
 472 is($hash{foo}, "ok 52\n");
 473
 474 $hash{bar} = "not ok 53\n";
 475 hlv("bar") = "ok 53\n";
 476 is(hlv("bar"), "ok 53\n");
 477
 478 sub array : lvalue  { @array  }
 479 sub array2 : lvalue { @array2 } # This is a global.
 480 sub hash : lvalue   { %hash   }
 481 sub hash2 : lvalue  { %hash2  } # So's this.
 482 @array2 = qw(foo bar);
 483 %hash2 = qw(foo bar);
 484
 485 (array()) = qw(ok 54);
 486 is("@array", "ok 54");
 487
 488 (array2()) = qw(ok 55);
 489 is("@array2", "ok 55");
 490
 491 (hash()) = qw(ok 56);
 492 cmp_ok($hash{ok}, '==', 56);
 493
 494 (hash2()) = qw(ok 57);
 495 cmp_ok($hash2{ok}, '==', 57);
 496
 497 @array = qw(a b c d);
 498 sub aslice1 : lvalue { @array[0,2] };
 499 (aslice1()) = ("ok", "already");
 500 is("@array", "ok b already d");
 501
 502 @array2 = qw(a B c d);
 503 sub aslice2 : lvalue { @array2[0,2] };
 504 (aslice2()) = ("ok", "already");
 505 is("@array2", "ok B already d");
 506
 507 %hash = qw(a Alpha b Beta c Gamma);
 508 sub hslice : lvalue { @hash{"c", "b"} }
 509 (hslice()) = ("CISC", "BogoMIPS");
 510 is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS");
 511 }
 512
 513 $str = "Hello, world!";
 514 sub sstr : lvalue { substr($str, 1, 4) }
 515 sstr() = "i";
 516 is($str, "Hi, world!");
 517
 518 $str = "Made w/ JavaScript";
 519 sub veclv : lvalue { vec($str, 2, 32) }
 520 if (ord('A') != 193) {
 521     veclv() = 0x5065726C;
 522 }
 523 else { # EBCDIC?
 524     veclv() = 0xD7859993;
 525 }
 526 is($str, "Made w/ PerlScript");
 527
 528 sub position : lvalue { pos }
 529 @p = ();
 530 $_ = "fee fi fo fum";
 531 while (/f/g) {
 532     push @p, position;
 533     position() += 6;
 534 }
 535 is("@p", "1 8");
 536
 537 sub keeze : lvalue { keys %__ }
 538 %__ = ("a","b");
 539 keeze = 64;
 540 is 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);
 544 sub lval1 : lvalue { $ary[0]; }
 545 sub lval2 : lvalue { $ary[1]; }
 546 (lval1(), lval2()) = split ' ', "1 2 3 4";
 547
 548 is(join(':', @ary), "1:2:6");
 549
 550 # check that an element of a tied hash/array can be assigned to via lvalueness
 551
 552 package Tie_Hash;
 553
 554 our ($key, $val);
 555 sub TIEHASH { bless \my $v => __PACKAGE__ }
 556 sub STORE   { ($key, $val) = @_[1,2] }
 557
 558 package main;
 559 sub lval_tie_hash : lvalue {
 560     tie my %t => 'Tie_Hash';
 561     $t{key};
 562 }
 563
 564 eval { lval_tie_hash() = "value"; };
 565
 566 is($@, "", "element of tied hash");
 567
 568 is("$Tie_Hash::key-$Tie_Hash::val", "key-value");
 569
 570
 571 package Tie_Array;
 572
 573 our @val;
 574 sub TIEARRAY { bless \my $v => __PACKAGE__ }
 575 sub STORE   { $val[ $_[1] ] = $_[2] }
 576
 577 package main;
 578 sub lval_tie_array : lvalue {
 579     tie my @t => 'Tie_Array';
 580     $t[0];
 581 }
 582
 583 eval { lval_tie_array() = "value"; };
 584
 585
 586 is($@, "", "element of tied array");
 587
 588 is ($Tie_Array::val[0], "value");
 589
 590
 591 # Check that tied pad vars that are returned can be assigned to
 592 sub TIESCALAR { bless [] }
 593 sub STORE {$wheel = $_[1]}
 594 sub FETCH {$wheel}
 595 sub tied_pad_var  :lvalue { tie my $tyre, ''; $tyre }
 596 sub tied_pad_varr :lvalue { tie my $tyre, ''; return $tyre }
 597 tied_pad_var = 1;
 598 is $wheel, 1, 'tied pad var returned in scalar lvalue context';
 599 tied_pad_var->${\sub{ $_[0] = 2 }};
 600 is $wheel, 2, 'tied pad var returned in scalar ref context';
 601 (tied_pad_var) = 3;
 602 is $wheel, 3, 'tied pad var returned in list lvalue context';
 603 $_ = 4 for tied_pad_var;
 604 is $wheel, 4, 'tied pad var returned in list ref context';
 605 tied_pad_varr = 5;
 606 is $wheel, 5, 'tied pad var explicitly returned in scalar lvalue context';
 607 tied_pad_varr->${\sub{ $_[0] = 6 }};
 608 is $wheel, 6, 'tied pad var explicitly returned in scalar ref context';
 609 (tied_pad_varr) = 7;
 610 is $wheel, 7, 'tied pad var explicitly returned in list lvalue context';
 611 $_ = 8 for tied_pad_varr;
 612 is $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
 801 SKIP: { skip 'no attributes.pm', 1 unless eval 'require attributes';
 802 fresh_perl_is(<<'----', <<'====', {}, "lvalue can not be set after definition. [perl #68758]");
 803 use warnings;
 804 our $x;
 805 sub foo { $x }
 806 sub foo : lvalue;
 807 sub MODIFY_CODE_ATTRIBUTES {}
 808 sub foo : lvalue : fr0g;
 809 foo = 3;
 810 ----
 811 lvalue attribute ignored after the subroutine has been defined at - line 4.
 812 lvalue attribute ignored after the subroutine has been defined at - line 6.
 813 Can't modify non-lvalue subroutine call in scalar assignment at - line 7, near "3;"
 814 Execution 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
 826 SKIP: { 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
 838 sub fleen : lvalue { $pnare }
 839 $pnare = __PACKAGE__;
 840 ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\
 841 is $pnare, 1, 'and returning CATTLE actually works';
 842 $pnare = __PACKAGE__;
 843 ok eval { (fleen) = 1 }, "lvalues can return COWs in list context";
 844 is $pnare, 1, 'and returning COWs in list context actually works';
 845 $pnare = __PACKAGE__;
 846 ok eval { $_ = 1 for(fleen); 1 }, "lvalues can return COWs in ref cx";
 847 is $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;
 852 is $ambaga, 73, 'explicit return of arbitrary expression (scalar context)';
 853 (sub :lvalue { return $ambaga || $ambaga }->()) = 74;
 854 is $ambaga, 74, 'explicit return of arbitrary expression (list context)';
 855 +sub :lvalue { $ambaga || $ambaga }->() = 73;
 856 is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)';
 857 (sub :lvalue { $ambaga || $ambaga }->()) = 74;
 858 is $ambaga, 74, 'implicit return of arbitrary expression (list context)';
 859 eval { +sub :lvalue { return 3 }->() = 4 };
 860 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 861       'assignment to numeric constant explicitly returned from lv sub';
 862 eval { (sub :lvalue { return 3 }->()) = 4 };
 863 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 864       'assignment to num constant explicitly returned (list cx)';
 865 eval { +sub :lvalue { 3 }->() = 4 };
 866 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 867       'assignment to numeric constant implicitly returned from lv sub';
 868 eval { (sub :lvalue { 3 }->()) = 4 };
 869 like $@, 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 = '';
 874 for 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 }
 895 continue { $suffix = ' (explicit return)' }
 896
 897 # autovivification
 898 $suffix = '';
 899 for 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 }
 919 continue { $suffix = ' (explicit return)' }
 920
 921 # [perl #92406] [perl #92290] Returning a pad var in rvalue context
 922 $suffix = '';
 923 for 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 }
 930 continue { $suffix = ' (explicit return)' }
 931
 932 # Returning read-only values in reference context
 933 $suffix = '';
 934 for (
 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 }
 941 continue { $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:
 945 if (!Internals::SvREADONLY($])) { Internals::SvREADONLY($],1); }
 946 sub squibble : lvalue { return $] }
 947 sub squebble : lvalue {        squibble }
 948 sub squabble : lvalue { return squibble }
 949 is $x = squebble, $], 'returning ro from nested lv sub call in rv cx';
 950 is $x = squabble, $], 'explct. returning ro from nested lv sub in rv cx';
 951 is \squebble, \$], 'returning ro from nested lv sub call in ref cx';
 952 is \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
 955 package _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
 974 sub ucf :lvalue { ucfirst $_[0] }
 975 is ucf("just another ") . ucf("perl hacker,\n"),
 976    "Just another Perl hacker,\n", 'TARG is copied in rvalue scalar cx';
 977 is join('',ucf("just another "), ucf "perl hacker,\n"),
 978    "Just another Perl hacker,\n", 'TARG is copied in rvalue list cx';
 979 sub 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 }
 989 ucfr();
 990
 991 # Test TARG with potential lvalue context, too
 992 for (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
 997 eval { &{\&utf8::is_utf8}("") = 3 };
 998 like $@, 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
1003 sub else119797 : lvalue {
1004     if ($_[0]) {
1005         1; # two statements force a leave op
1006         @119797
1007     }
1008     else {
1009         @119797
1010     }
1011 }
1012 eval { (else119797(0)) = 1..3 };
1013 is $@, "", '$@ after writing to array returned by else';
1014 is "@119797", "1 2 3", 'writing to array returned by else';
1015 eval { (else119797(1)) = 4..6 };
1016 is $@, "", '$@ after writing to array returned by if (with else)';
1017 is "@119797", "4 5 6", 'writing to array returned by if (with else)';
1018 sub if119797 : lvalue {
1019     if ($_[0]) {
1020         @119797
1021     }
1022 }
1023 @119797 = ();
1024 eval { (if119797(1)) = 4..6 };
1025 is $@, "", '$@ after writing to array returned by if';
1026 is "@119797", "4 5 6", 'writing to array returned by if';
1027 sub unless119797 : lvalue {
1028     unless ($_[0]) {
1029         @119797
1030     }
1031 }
1032 @119797 = ();
1033 eval { (unless119797(0)) = 4..6 };
1034 is $@, "", '$@ after writing to array returned by unless';
1035 is "@119797", "4 5 6", 'writing to array returned by unless';
1036 sub bare119797 : lvalue {
1037     {;
1038         @119797
1039     }
1040 }
1041 @119797 = ();
1042 eval { (bare119797(0)) = 4..6 };
1043 is $@, "", '$@ after writing to array returned by bare block';
1044 is "@119797", "4 5 6", 'writing to array returned by bare block';