t/op/sub_lval.t

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