t/op/sub_lval.t

   1 BEGIN {
   2     chdir 't' if -d 't';
   3     @INC = '../lib';
   4     require './test.pl';
   5 }
   6 plan tests=>207;
   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 eval <<'EOF';
 391   sub lv2tmpr : lvalue { my $x = *foo; Internals::SvREADONLY $x, 1; $x }
 392   lv2tmpr = (2,3);
 393 EOF
 394
 395 like($@, qr/Can\'t return a readonly value from lvalue subroutine at/);
 396
 397 eval <<'EOG';
 398   (lv2tmpr) = (2,3);
 399 EOG
 400
 401 like($@, qr/Can\'t return a readonly value from lvalue subroutine/);
 402
 403 sub lva : lvalue {@a}
 404
 405 $_ = undef;
 406 @a = ();
 407 $a[1] = 12;
 408 eval <<'EOE' or $_ = $@;
 409   (lva) = (2,3);
 410   1;
 411 EOE
 412
 413 is("'@a' $_", "'2 3' ");
 414
 415 $_ = undef;
 416 @a = ();
 417 $a[0] = undef;
 418 $a[1] = 12;
 419 eval <<'EOE' or $_ = $@;
 420   (lva) = (2,3);
 421   1;
 422 EOE
 423
 424 is("'@a' $_", "'2 3' ");
 425
 426 is lva->${\sub { return $_[0] }}, 2,
 427   'lvalue->$thing when lvalue returns array';
 428
 429 my @my = qw/ a b c /;
 430 sub lvmya : lvalue { @my }
 431
 432 is lvmya->${\sub { return $_[0] }}, 3,
 433   'lvalue->$thing when lvalue returns lexical array';
 434
 435 sub lv1n : lvalue { $newvar }
 436
 437 $_ = undef;
 438 eval <<'EOE' or $_ = $@;
 439   lv1n = (3,4);
 440   1;
 441 EOE
 442
 443 is("'$newvar' $_", "'4' ");
 444
 445 sub lv1nn : lvalue { $nnewvar }
 446
 447 $_ = undef;
 448 eval <<'EOE' or $_ = $@;
 449   (lv1nn) = (3,4);
 450   1;
 451 EOE
 452
 453 is("'$nnewvar' $_", "'3' ");
 454
 455 $a = \&lv1nn;
 456 $a->() = 8;
 457 is($nnewvar, '8');
 458
 459 eval 'sub AUTOLOAD : lvalue { $newvar }';
 460 foobar() = 12;
 461 is($newvar, "12");
 462
 463 # But autoloading should only be triggered by a call to an undefined
 464 # subroutine.
 465 &{"lv1nn"} = 14;
 466 is $newvar, 12, 'AUTOLOAD does not take precedence over lvalue sub';
 467 eval { &{"xxx"} = 14 };
 468 is $newvar, 12, 'AUTOLOAD does not take precedence over non-lvalue sub';
 469
 470 {
 471 my %hash; my @array;
 472 sub alv : lvalue { $array[1] }
 473 sub alv2 : lvalue { $array[$_[0]] }
 474 sub hlv : lvalue { $hash{"foo"} }
 475 sub hlv2 : lvalue { $hash{$_[0]} }
 476 $array[1] = "not ok 51\n";
 477 alv() = "ok 50\n";
 478 is(alv(), "ok 50\n");
 479
 480 alv2(20) = "ok 51\n";
 481 is($array[20], "ok 51\n");
 482
 483 $hash{"foo"} = "not ok 52\n";
 484 hlv() = "ok 52\n";
 485 is($hash{foo}, "ok 52\n");
 486
 487 $hash{bar} = "not ok 53\n";
 488 hlv("bar") = "ok 53\n";
 489 is(hlv("bar"), "ok 53\n");
 490
 491 sub array : lvalue  { @array  }
 492 sub array2 : lvalue { @array2 } # This is a global.
 493 sub hash : lvalue   { %hash   }
 494 sub hash2 : lvalue  { %hash2  } # So's this.
 495 @array2 = qw(foo bar);
 496 %hash2 = qw(foo bar);
 497
 498 (array()) = qw(ok 54);
 499 is("@array", "ok 54");
 500
 501 (array2()) = qw(ok 55);
 502 is("@array2", "ok 55");
 503
 504 (hash()) = qw(ok 56);
 505 cmp_ok($hash{ok}, '==', 56);
 506
 507 (hash2()) = qw(ok 57);
 508 cmp_ok($hash2{ok}, '==', 57);
 509
 510 @array = qw(a b c d);
 511 sub aslice1 : lvalue { @array[0,2] };
 512 (aslice1()) = ("ok", "already");
 513 is("@array", "ok b already d");
 514
 515 @array2 = qw(a B c d);
 516 sub aslice2 : lvalue { @array2[0,2] };
 517 (aslice2()) = ("ok", "already");
 518 is("@array2", "ok B already d");
 519
 520 %hash = qw(a Alpha b Beta c Gamma);
 521 sub hslice : lvalue { @hash{"c", "b"} }
 522 (hslice()) = ("CISC", "BogoMIPS");
 523 is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS");
 524 }
 525
 526 $str = "Hello, world!";
 527 sub sstr : lvalue { substr($str, 1, 4) }
 528 sstr() = "i";
 529 is($str, "Hi, world!");
 530
 531 $str = "Made w/ JavaScript";
 532 sub veclv : lvalue { vec($str, 2, 32) }
 533 if (ord('A') != 193) {
 534     veclv() = 0x5065726C;
 535 }
 536 else { # EBCDIC?
 537     veclv() = 0xD7859993;
 538 }
 539 is($str, "Made w/ PerlScript");
 540
 541 sub position : lvalue { pos }
 542 @p = ();
 543 $_ = "fee fi fo fum";
 544 while (/f/g) {
 545     push @p, position;
 546     position() += 6;
 547 }
 548 is("@p", "1 8");
 549
 550 sub keeze : lvalue { keys %__ }
 551 %__ = ("a","b");
 552 keeze = 64;
 553 is scalar %__, '1/64', 'keys assignment through lvalue sub';
 554
 555 # Bug 20001223.002: split thought that the list had only one element
 556 @ary = qw(4 5 6);
 557 sub lval1 : lvalue { $ary[0]; }
 558 sub lval2 : lvalue { $ary[1]; }
 559 (lval1(), lval2()) = split ' ', "1 2 3 4";
 560
 561 is(join(':', @ary), "1:2:6");
 562
 563 # check that an element of a tied hash/array can be assigned to via lvalueness
 564
 565 package Tie_Hash;
 566
 567 our ($key, $val);
 568 sub TIEHASH { bless \my $v => __PACKAGE__ }
 569 sub STORE   { ($key, $val) = @_[1,2] }
 570
 571 package main;
 572 sub lval_tie_hash : lvalue {
 573     tie my %t => 'Tie_Hash';
 574     $t{key};
 575 }
 576
 577 eval { lval_tie_hash() = "value"; };
 578
 579 is($@, "", "element of tied hash");
 580
 581 is("$Tie_Hash::key-$Tie_Hash::val", "key-value");
 582
 583
 584 package Tie_Array;
 585
 586 our @val;
 587 sub TIEARRAY { bless \my $v => __PACKAGE__ }
 588 sub STORE   { $val[ $_[1] ] = $_[2] }
 589
 590 package main;
 591 sub lval_tie_array : lvalue {
 592     tie my @t => 'Tie_Array';
 593     $t[0];
 594 }
 595
 596 eval { lval_tie_array() = "value"; };
 597
 598
 599 is($@, "", "element of tied array");
 600
 601 is ($Tie_Array::val[0], "value");
 602
 603
 604 # Check that tied pad vars that are returned can be assigned to
 605 sub TIESCALAR { bless [] }
 606 sub STORE {$wheel = $_[1]}
 607 sub FETCH {$wheel}
 608 sub tied_pad_var  :lvalue { tie my $tyre, ''; $tyre }
 609 sub tied_pad_varr :lvalue { tie my $tyre, ''; return $tyre }
 610 tied_pad_var = 1;
 611 is $wheel, 1, 'tied pad var returned in scalar lvalue context';
 612 tied_pad_var->${\sub{ $_[0] = 2 }};
 613 is $wheel, 2, 'tied pad var returned in scalar ref context';
 614 (tied_pad_var) = 3;
 615 is $wheel, 3, 'tied pad var returned in list lvalue context';
 616 $_ = 4 for tied_pad_var;
 617 is $wheel, 4, 'tied pad var returned in list ref context';
 618 tied_pad_varr = 5;
 619 is $wheel, 5, 'tied pad var explicitly returned in scalar lvalue context';
 620 tied_pad_varr->${\sub{ $_[0] = 6 }};
 621 is $wheel, 6, 'tied pad var explicitly returned in scalar ref context';
 622 (tied_pad_varr) = 7;
 623 is $wheel, 7, 'tied pad var explicitly returned in list lvalue context';
 624 $_ = 8 for tied_pad_varr;
 625 is $wheel, 8, 'tied pad var explicitly returned in list ref context';
 626
 627
 628 # Test explicit return of lvalue expression
 629 {
 630     # subs are copies from tests 1-~18 with an explicit return added.
 631     # They used not to work, which is why they are ‘badly’ named.
 632     sub bad_get_lex : lvalue { return $in };
 633     sub bad_get_st  : lvalue { return $blah }
 634
 635     sub bad_id  : lvalue { return ${\shift} }
 636     sub bad_id1 : lvalue { return $_[0] }
 637     sub bad_inc : lvalue { return ${\++$_[0]} }
 638
 639     $in = 5;
 640     $blah = 3;
 641
 642     bad_get_st = 7;
 643
 644     is( $blah, 7 );
 645
 646     bad_get_lex = 7;
 647
 648     is($in, 7, "yada");
 649
 650     ++bad_get_st;
 651
 652     is($blah, 8, "yada");
 653
 654     ++bad_get_lex;
 655     cmp_ok($in, '==', 8);
 656
 657     bad_id(bad_get_st) = 10;
 658     cmp_ok($blah, '==', 10);
 659
 660     bad_id(bad_get_lex) = 10;
 661     cmp_ok($in, '==', 10);
 662
 663     ++bad_id(bad_get_st);
 664     cmp_ok($blah, '==', 11);
 665
 666     ++bad_id(bad_get_lex);
 667     cmp_ok($in, '==', 11);
 668
 669     bad_id1(bad_get_st) = 20;
 670     cmp_ok($blah, '==', 20);
 671
 672     bad_id1(bad_get_lex) = 20;
 673     cmp_ok($in, '==', 20);
 674
 675     ++bad_id1(bad_get_st);
 676     cmp_ok($blah, '==', 21);
 677
 678     ++bad_id1(bad_get_lex);
 679     cmp_ok($in, '==', 21);
 680
 681     bad_inc(bad_get_st);
 682     cmp_ok($blah, '==', 22);
 683
 684     bad_inc(bad_get_lex);
 685     cmp_ok($in, '==', 22);
 686
 687     bad_inc(bad_id(bad_get_st));
 688     cmp_ok($blah, '==', 23);
 689
 690     bad_inc(bad_id(bad_get_lex));
 691     cmp_ok($in, '==', 23);
 692
 693     ++bad_inc(bad_id1(bad_id(bad_get_st)));
 694     cmp_ok($blah, '==', 25);
 695
 696     ++bad_inc(bad_id1(bad_id(bad_get_lex)));
 697     cmp_ok($in, '==', 25);
 698
 699     # Recursive
 700     my $r;
 701     my $to_modify;
 702     $r = sub :lvalue {
 703       my $depth = shift//0;
 704       if ($depth == 2) { return $to_modify }
 705       return &$r($depth+1);
 706     };
 707     &$r(0) = 7;
 708     is $to_modify, 7, 'recursive lvalue sub';
 709
 710     # Recursive with substr [perl #72706]
 711     my $val = '';
 712     my $pie;
 713     $pie = sub :lvalue {
 714         my $depth = shift;
 715         return &$pie($depth) if $depth--;
 716         substr $val, 0;
 717     };
 718     for my $depth (0, 1, 2) {
 719         my $value = "Good $depth";
 720         eval {
 721             &$pie($depth) = $value;
 722         };
 723         is($@, '', "recursive lvalue substr return depth $depth");
 724         is($val, $value,
 725            "value assigned to recursive lvalue substr (depth $depth)");
 726     }
 727 }
 728
 729 { # bug #23790
 730     my @arr  = qw /one two three/;
 731     my $line = "zero";
 732     sub lval_array () : lvalue {@arr}
 733
 734     for (lval_array) {
 735         $line .= $_;
 736     }
 737
 738     is($line, "zeroonetwothree");
 739
 740     sub trythislval { scalar(@_)."x".join "", @_ }
 741     is(trythislval(lval_array()), "3xonetwothree");
 742
 743     sub changeme { $_[2] = "free" }
 744     changeme(lval_array);
 745     is("@arr", "one two free");
 746
 747     # test again, with explicit return
 748     sub rlval_array() : lvalue {return @arr}
 749     @arr  = qw /one two three/;
 750     $line = "zero";
 751     for (rlval_array) {
 752         $line .= $_;
 753     }
 754     is($line, "zeroonetwothree");
 755     is(trythislval(rlval_array()), "3xonetwothree");
 756     changeme(rlval_array);
 757     is("@arr", "one two free");
 758
 759     # Variations on the same theme, with multiple vars returned
 760     my $scalar = 'half';
 761     sub lval_scalar_array () : lvalue { $scalar, @arr }
 762     @arr  = qw /one two three/;
 763     $line = "zero";
 764     for (lval_scalar_array) {
 765         $line .= $_;
 766     }
 767     is($line, "zerohalfonetwothree");
 768     is(trythislval(lval_scalar_array()), "4xhalfonetwothree");
 769     changeme(lval_scalar_array);
 770     is("@arr", "one free three");
 771
 772     sub lval_array_scalar () : lvalue { @arr, $scalar }
 773     @arr  = qw /one two three/;
 774     $line = "zero";
 775     $scalar = 'four';
 776     for (lval_array_scalar) {
 777         $line .= $_;
 778     }
 779     is($line, "zeroonetwothreefour");
 780     is(trythislval(lval_array_scalar()), "4xonetwothreefour");
 781     changeme(lval_array_scalar);
 782     is("@arr", "one two free");
 783
 784     # Tests for specific ops not tested above
 785     # rv2av
 786     @array2 = qw 'one two free';
 787     is join(',', map $_, sub:lvalue{@array2}->()), 'one,two,free',
 788       'rv2av in reference context';
 789     is join(',', map $_, sub:lvalue{@{\@array2}}->()), 'one,two,free',
 790       'rv2av-with-ref in reference context';
 791     # padhv
 792     my %hash = qw[a b c d];
 793     like join(',', map $_, sub:lvalue{%hash}->()),
 794          qr/^(?:a,b,c,d|c,d,a,b)\z/, 'padhv in reference context';
 795     # rv2hv
 796     %hash2 = qw[a b c d];
 797     like join(',', map $_, sub:lvalue{%hash2}->()),
 798          qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv in reference context';
 799     like join(',', map $_, sub:lvalue{%{\%hash2}}->()),
 800          qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv-with-ref in reference context';
 801 }
 802
 803 {
 804     package Foo;
 805     sub AUTOLOAD :lvalue { *{$AUTOLOAD} };
 806     package main;
 807     my $foo = bless {},"Foo";
 808     my $result;
 809     $foo->bar = sub { $result = "bar" };
 810     $foo->bar;
 811     is ($result, 'bar', "RT #41550");
 812 }
 813
 814 SKIP: { skip 'no attributes.pm', 1 unless eval 'require attributes';
 815 fresh_perl_is(<<'----', <<'====', {}, "lvalue can not be set after definition. [perl #68758]");
 816 use warnings;
 817 our $x;
 818 sub foo { $x }
 819 sub foo : lvalue;
 820 sub MODIFY_CODE_ATTRIBUTES {}
 821 sub foo : lvalue : fr0g;
 822 foo = 3;
 823 ----
 824 lvalue attribute ignored after the subroutine has been defined at - line 4.
 825 lvalue attribute ignored after the subroutine has been defined at - line 6.
 826 Can't modify non-lvalue subroutine call in scalar assignment at - line 7, near "3;"
 827 Execution of - aborted due to compilation errors.
 828 ====
 829 }
 830
 831 {
 832     my $x;
 833     sub lval_decl : lvalue;
 834     sub lval_decl { $x }
 835     lval_decl = 5;
 836     is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]");
 837 }
 838
 839 SKIP: { skip "no attributes.pm", 2 unless eval { require attributes };
 840   sub utf8::valid :lvalue;
 841   require attributes;
 842   is "@{[ &attributes::get(\&utf8::valid) ]}", 'lvalue',
 843    'sub declaration with :lvalue applies it to XSUBs';
 844
 845   BEGIN { *wonky = \&marjibberous }
 846   sub wonky :lvalue;
 847   is "@{[ &attributes::get(\&wonky) ]}", 'lvalue',
 848    'sub declaration with :lvalue applies it to assigned stub';
 849 }
 850
 851 sub fleen : lvalue { $pnare }
 852 $pnare = __PACKAGE__;
 853 ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\
 854 is $pnare, 1, 'and returning CATTLE actually works';
 855 $pnare = __PACKAGE__;
 856 ok eval { (fleen) = 1 }, "lvalues can return COWs in list context";
 857 is $pnare, 1, 'and returning COWs in list context actually works';
 858 $pnare = __PACKAGE__;
 859 ok eval { $_ = 1 for(fleen); 1 }, "lvalues can return COWs in ref cx";
 860 is $pnare, 1, 'and returning COWs in reference context actually works';
 861
 862
 863 # Returning an arbitrary expression, not necessarily lvalue
 864 +sub :lvalue { return $ambaga || $ambaga }->() = 73;
 865 is $ambaga, 73, 'explicit return of arbitrary expression (scalar context)';
 866 (sub :lvalue { return $ambaga || $ambaga }->()) = 74;
 867 is $ambaga, 74, 'explicit return of arbitrary expression (list context)';
 868 +sub :lvalue { $ambaga || $ambaga }->() = 73;
 869 is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)';
 870 (sub :lvalue { $ambaga || $ambaga }->()) = 74;
 871 is $ambaga, 74, 'implicit return of arbitrary expression (list context)';
 872 eval { +sub :lvalue { return 3 }->() = 4 };
 873 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 874       'assignment to numeric constant explicitly returned from lv sub';
 875 eval { (sub :lvalue { return 3 }->()) = 4 };
 876 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 877       'assignment to num constant explicitly returned (list cx)';
 878 eval { +sub :lvalue { 3 }->() = 4 };
 879 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 880       'assignment to numeric constant implicitly returned from lv sub';
 881 eval { (sub :lvalue { 3 }->()) = 4 };
 882 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 883       'assignment to num constant implicitly returned (list cx)';
 884
 885 # reference (potential lvalue) context
 886 $suffix = '';
 887 for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
 888     &$sub()->${\sub { $_[0] = 37 }};
 889     is $_, '37', 'lvalue->method'.$suffix;
 890     ${\scalar &$sub()} = 38;
 891     is $_, '38', 'scalar(lvalue)'.$suffix;
 892     sub assign39_with_proto ($) { $_[0] = 39 }
 893     assign39_with_proto(&$sub());
 894     is $_, '39', 'func(lvalue) when func has $ proto'.$suffix;
 895     $_ = 1;
 896     ${\(&$sub()||undef)} = 40;
 897     is $_, '40', 'lvalue||...'.$suffix;
 898     ${\(${\undef}||&$sub())} = 41; # extra ${\...} to bypass const folding
 899     is $_, '41', '...||lvalue'.$suffix;
 900     $_ = 0;
 901     ${\(&$sub()&&undef)} = 42;
 902     is $_, '42', 'lvalue&&...'.$suffix;
 903     ${\(${\1}&&&$sub())} = 43;
 904     is $_, '43', '...&&lvalue'.$suffix;
 905     ${\(&$sub())[0]} = 44;
 906     is $_, '44', '(lvalue)[0]'.$suffix;
 907 }
 908 continue { $suffix = ' (explicit return)' }
 909
 910 # autovivification
 911 $suffix = '';
 912 for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
 913     undef $_;
 914     &$sub()->[3] = 4;
 915     is $_->[3], 4, 'func->[...] autovivification'.$suffix;
 916     undef $_;
 917     &$sub()->{3} = 4;
 918     is $_->{3}, 4, 'func->{...} autovivification'.$suffix;
 919     undef $_;
 920     ${&$sub()} = 4;
 921     is $$_, 4, '${func()} autovivification'      .$suffix;
 922     undef $_;
 923     @{&$sub()} = 4;
 924     is "@$_", 4, '@{func()} autovivification'    .$suffix;
 925     undef $_;
 926     %{&$sub()} = (4,5);
 927     is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix;
 928     undef $_;
 929     ${ (), &$sub()} = 4;
 930     is $$_, 4, '${ (), func()} autovivification'      .$suffix;
 931 }
 932 continue { $suffix = ' (explicit return)' }
 933
 934 # [perl #92406] [perl #92290] Returning a pad var in rvalue context
 935 $suffix = '';
 936 for my $sub (
 937          sub :lvalue { my $x = 72; $x },
 938          sub :lvalue { my $x = 72; return $x }
 939 ) {
 940     is scalar(&$sub), 72, "sub returning pad var in scalar context$suffix";
 941     is +(&$sub)[0], 72, "sub returning pad var in list context$suffix";
 942 }
 943 continue { $suffix = ' (explicit return)' }
 944
 945 # Returning read-only values in reference context
 946 $suffix = '';
 947 for (
 948          sub :lvalue { $] }->(),
 949          sub :lvalue { return $] }->()
 950 ) {
 951     is \$_, \$], 'read-only values are returned in reference context'
 952                  .$suffix             # (they used to be copied)
 953 }
 954 continue { $suffix = ' (explicit return)' }
 955
 956 # Returning unwritables from nested lvalue sub call in in rvalue context
 957 # First, ensure we are testing what we think we are:
 958 if (!Internals::SvREADONLY($])) { Internals::SvREADONLY($],1); }
 959 sub squibble : lvalue { return $] }
 960 sub squebble : lvalue {        squibble }
 961 sub squabble : lvalue { return squibble }
 962 is $x = squebble, $], 'returning ro from nested lv sub call in rv cx';
 963 is $x = squabble, $], 'explct. returning ro from nested lv sub in rv cx';
 964 is \squebble, \$], 'returning ro from nested lv sub call in ref cx';
 965 is \squabble, \$], 'explct. returning ro from nested lv sub in ref cx';
 966
 967 # [perl #102486] Sub calls as the last statement of an lvalue sub
 968 package _102486 {
 969   my $called;
 970   my $x = 'nonlv';
 971   sub strictlv :lvalue { use strict 'refs'; &$x }
 972   sub lv :lvalue { &$x }
 973   sub nonlv { ++$called }
 974   eval { strictlv };
 975   ::like $@, qr/^Can't use string \("nonlv"\) as a subroutine ref while/,
 976         'strict mode applies to sub:lvalue{ &$string }';
 977   $called = 0;
 978   ::ok eval { lv },
 979       'sub:lvalue{&$x}->() does not die for non-lvalue inner sub call';
 980   ::is $called, 1, 'The &$x actually called the sub';
 981   eval { +sub :lvalue { &$x }->() = 3 };
 982   ::like $@, qr/^Can't modify non-lvalue subroutine call at /,
 983         'sub:lvalue{&$x}->() dies in true lvalue context';
 984 }
 985
 986 # TARG should be copied in rvalue context
 987 sub ucf :lvalue { ucfirst $_[0] }
 988 is ucf("just another ") . ucf("perl hacker,\n"),
 989    "Just another Perl hacker,\n", 'TARG is copied in rvalue scalar cx';
 990 is join('',ucf("just another "), ucf "perl hacker,\n"),
 991    "Just another Perl hacker,\n", 'TARG is copied in rvalue list cx';
 992 sub ucfr : lvalue {
 993     @_ ? ucfirst $_[0] : do {
 994         is ucfr("just another ") . ucfr("perl hacker,\n"),
 995            "Just another Perl hacker,\n",
 996            'TARG is copied in recursive rvalue scalar cx';
 997         is join('',ucfr("just another "), ucfr("perl hacker,\n")),
 998            "Just another Perl hacker,\n",
 999            'TARG is copied in recursive rvalue list cx';
1000     }
1001 }
1002 ucfr();
1003
1004 # Test TARG with potential lvalue context, too
1005 for (sub : lvalue { "$x" }->()) {
1006     is \$_, \$_, '\$_ == \$_ in for(sub :lvalue{"$x"}->()){...}'
1007 }
1008
1009 # [perl #117947] XSUBs should not be treated as lvalues at run time
1010 eval { &{\&utf8::is_utf8}("") = 3 };
1011 like $@, qr/^Can't modify non-lvalue subroutine call at /,
1012         'XSUB not seen at compile time dies in lvalue context';
1013
1014 # [perl #119797] else implicitly returning value
1015 # This used to cause Bizarre copy of ARRAY in pp_leave
1016 sub else119797 : lvalue {
1017     if ($_[0]) {
1018         1; # two statements force a leave op
1019         @119797
1020     }
1021     else {
1022         @119797
1023     }
1024 }
1025 eval { (else119797(0)) = 1..3 };
1026 is $@, "", '$@ after writing to array returned by else';
1027 is "@119797", "1 2 3", 'writing to array returned by else';
1028 eval { (else119797(1)) = 4..6 };
1029 is $@, "", '$@ after writing to array returned by if (with else)';
1030 is "@119797", "4 5 6", 'writing to array returned by if (with else)';
1031 sub if119797 : lvalue {
1032     if ($_[0]) {
1033         @119797
1034     }
1035 }
1036 @119797 = ();
1037 eval { (if119797(1)) = 4..6 };
1038 is $@, "", '$@ after writing to array returned by if';
1039 is "@119797", "4 5 6", 'writing to array returned by if';
1040 sub unless119797 : lvalue {
1041     unless ($_[0]) {
1042         @119797
1043     }
1044 }
1045 @119797 = ();
1046 eval { (unless119797(0)) = 4..6 };
1047 is $@, "", '$@ after writing to array returned by unless';
1048 is "@119797", "4 5 6", 'writing to array returned by unless';
1049 sub bare119797 : lvalue {
1050     {;
1051         @119797
1052     }
1053 }
1054 @119797 = ();
1055 eval { (bare119797(0)) = 4..6 };
1056 is $@, "", '$@ after writing to array returned by bare block';
1057 is "@119797", "4 5 6", 'writing to array returned by bare block';