t/op/sub_lval.t

   1 BEGIN {
   2     chdir 't' if -d 't';
   3     @INC = '../lib';
   4     require './test.pl';
   5 }
   6 plan tests=>179;
   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 is($_, undef, "returning a temp from an lvalue sub in scalar context");
 337
 338 $_ = undef;
 339 eval <<'EOE' or $_ = $@;
 340   (lv1tmp) = (2,3);
 341   1;
 342 EOE
 343
 344 is($_, undef, "returning a temp from an lvalue sub in list context");
 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 {
 426 my %hash; my @array;
 427 sub alv : lvalue { $array[1] }
 428 sub alv2 : lvalue { $array[$_[0]] }
 429 sub hlv : lvalue { $hash{"foo"} }
 430 sub hlv2 : lvalue { $hash{$_[0]} }
 431 $array[1] = "not ok 51\n";
 432 alv() = "ok 50\n";
 433 is(alv(), "ok 50\n");
 434
 435 alv2(20) = "ok 51\n";
 436 is($array[20], "ok 51\n");
 437
 438 $hash{"foo"} = "not ok 52\n";
 439 hlv() = "ok 52\n";
 440 is($hash{foo}, "ok 52\n");
 441
 442 $hash{bar} = "not ok 53\n";
 443 hlv("bar") = "ok 53\n";
 444 is(hlv("bar"), "ok 53\n");
 445
 446 sub array : lvalue  { @array  }
 447 sub array2 : lvalue { @array2 } # This is a global.
 448 sub hash : lvalue   { %hash   }
 449 sub hash2 : lvalue  { %hash2  } # So's this.
 450 @array2 = qw(foo bar);
 451 %hash2 = qw(foo bar);
 452
 453 (array()) = qw(ok 54);
 454 is("@array", "ok 54");
 455
 456 (array2()) = qw(ok 55);
 457 is("@array2", "ok 55");
 458
 459 (hash()) = qw(ok 56);
 460 cmp_ok($hash{ok}, '==', 56);
 461
 462 (hash2()) = qw(ok 57);
 463 cmp_ok($hash2{ok}, '==', 57);
 464
 465 @array = qw(a b c d);
 466 sub aslice1 : lvalue { @array[0,2] };
 467 (aslice1()) = ("ok", "already");
 468 is("@array", "ok b already d");
 469
 470 @array2 = qw(a B c d);
 471 sub aslice2 : lvalue { @array2[0,2] };
 472 (aslice2()) = ("ok", "already");
 473 is("@array2", "ok B already d");
 474
 475 %hash = qw(a Alpha b Beta c Gamma);
 476 sub hslice : lvalue { @hash{"c", "b"} }
 477 (hslice()) = ("CISC", "BogoMIPS");
 478 is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS");
 479 }
 480
 481 $str = "Hello, world!";
 482 sub sstr : lvalue { substr($str, 1, 4) }
 483 sstr() = "i";
 484 is($str, "Hi, world!");
 485
 486 $str = "Made w/ JavaScript";
 487 sub veclv : lvalue { vec($str, 2, 32) }
 488 if (ord('A') != 193) {
 489     veclv() = 0x5065726C;
 490 }
 491 else { # EBCDIC?
 492     veclv() = 0xD7859993;
 493 }
 494 is($str, "Made w/ PerlScript");
 495
 496 sub position : lvalue { pos }
 497 @p = ();
 498 $_ = "fee fi fo fum";
 499 while (/f/g) {
 500     push @p, position;
 501     position() += 6;
 502 }
 503 is("@p", "1 8");
 504
 505 sub keeze : lvalue { keys %__ }
 506 %__ = ("a","b");
 507 keeze = 64;
 508 is scalar %__, '1/64', 'keys assignment through lvalue sub';
 509
 510 # Bug 20001223.002: split thought that the list had only one element
 511 @ary = qw(4 5 6);
 512 sub lval1 : lvalue { $ary[0]; }
 513 sub lval2 : lvalue { $ary[1]; }
 514 (lval1(), lval2()) = split ' ', "1 2 3 4";
 515
 516 is(join(':', @ary), "1:2:6");
 517
 518 # check that an element of a tied hash/array can be assigned to via lvalueness
 519
 520 package Tie_Hash;
 521
 522 our ($key, $val);
 523 sub TIEHASH { bless \my $v => __PACKAGE__ }
 524 sub STORE   { ($key, $val) = @_[1,2] }
 525
 526 package main;
 527 sub lval_tie_hash : lvalue {
 528     tie my %t => 'Tie_Hash';
 529     $t{key};
 530 }
 531
 532 eval { lval_tie_hash() = "value"; };
 533
 534 is($@, "", "element of tied hash");
 535
 536 is("$Tie_Hash::key-$Tie_Hash::val", "key-value");
 537
 538
 539 package Tie_Array;
 540
 541 our @val;
 542 sub TIEARRAY { bless \my $v => __PACKAGE__ }
 543 sub STORE   { $val[ $_[1] ] = $_[2] }
 544
 545 package main;
 546 sub lval_tie_array : lvalue {
 547     tie my @t => 'Tie_Array';
 548     $t[0];
 549 }
 550
 551 eval { lval_tie_array() = "value"; };
 552
 553
 554 is($@, "", "element of tied array");
 555
 556 is ($Tie_Array::val[0], "value");
 557
 558
 559 # Check that tied pad vars that are returned can be assigned to
 560 sub TIESCALAR { bless [] }
 561 sub STORE {$wheel = $_[1]}
 562 sub FETCH {$wheel}
 563 sub tied_pad_var  :lvalue { tie my $tyre, ''; $tyre }
 564 sub tied_pad_varr :lvalue { tie my $tyre, ''; return $tyre }
 565 tied_pad_var = 1;
 566 is $wheel, 1, 'tied pad var returned in scalar lvalue context';
 567 tied_pad_var->${\sub{ $_[0] = 2 }};
 568 is $wheel, 2, 'tied pad var returned in scalar ref context';
 569 (tied_pad_var) = 3;
 570 is $wheel, 3, 'tied pad var returned in list lvalue context';
 571 $_ = 4 for tied_pad_var;
 572 is $wheel, 4, 'tied pad var returned in list ref context';
 573 tied_pad_varr = 5;
 574 is $wheel, 5, 'tied pad var explicitly returned in scalar lvalue context';
 575 tied_pad_varr->${\sub{ $_[0] = 6 }};
 576 is $wheel, 6, 'tied pad var explicitly returned in scalar ref context';
 577 (tied_pad_varr) = 7;
 578 is $wheel, 7, 'tied pad var explicitly returned in list lvalue context';
 579 $_ = 8 for tied_pad_varr;
 580 is $wheel, 8, 'tied pad var explicitly returned in list ref context';
 581
 582
 583 # Test explicit return of lvalue expression
 584 {
 585     # subs are copies from tests 1-~18 with an explicit return added.
 586     # They used not to work, which is why they are ‘badly’ named.
 587     sub bad_get_lex : lvalue { return $in };
 588     sub bad_get_st  : lvalue { return $blah }
 589
 590     sub bad_id  : lvalue { return ${\shift} }
 591     sub bad_id1 : lvalue { return $_[0] }
 592     sub bad_inc : lvalue { return ${\++$_[0]} }
 593
 594     $in = 5;
 595     $blah = 3;
 596
 597     bad_get_st = 7;
 598
 599     is( $blah, 7 );
 600
 601     bad_get_lex = 7;
 602
 603     is($in, 7, "yada");
 604
 605     ++bad_get_st;
 606
 607     is($blah, 8, "yada");
 608
 609     ++bad_get_lex;
 610     cmp_ok($in, '==', 8);
 611
 612     bad_id(bad_get_st) = 10;
 613     cmp_ok($blah, '==', 10);
 614
 615     bad_id(bad_get_lex) = 10;
 616     cmp_ok($in, '==', 10);
 617
 618     ++bad_id(bad_get_st);
 619     cmp_ok($blah, '==', 11);
 620
 621     ++bad_id(bad_get_lex);
 622     cmp_ok($in, '==', 11);
 623
 624     bad_id1(bad_get_st) = 20;
 625     cmp_ok($blah, '==', 20);
 626
 627     bad_id1(bad_get_lex) = 20;
 628     cmp_ok($in, '==', 20);
 629
 630     ++bad_id1(bad_get_st);
 631     cmp_ok($blah, '==', 21);
 632
 633     ++bad_id1(bad_get_lex);
 634     cmp_ok($in, '==', 21);
 635
 636     bad_inc(bad_get_st);
 637     cmp_ok($blah, '==', 22);
 638
 639     bad_inc(bad_get_lex);
 640     cmp_ok($in, '==', 22);
 641
 642     bad_inc(bad_id(bad_get_st));
 643     cmp_ok($blah, '==', 23);
 644
 645     bad_inc(bad_id(bad_get_lex));
 646     cmp_ok($in, '==', 23);
 647
 648     ++bad_inc(bad_id1(bad_id(bad_get_st)));
 649     cmp_ok($blah, '==', 25);
 650
 651     ++bad_inc(bad_id1(bad_id(bad_get_lex)));
 652     cmp_ok($in, '==', 25);
 653
 654     # Recursive
 655     my $r;
 656     my $to_modify;
 657     $r = sub :lvalue {
 658       my $depth = shift//0;
 659       if ($depth == 2) { return $to_modify }
 660       return &$r($depth+1);
 661     };
 662     &$r(0) = 7;
 663     is $to_modify, 7, 'recursive lvalue sub';
 664
 665     # Recursive with substr [perl #72706]
 666     my $val = '';
 667     my $pie;
 668     $pie = sub :lvalue {
 669         my $depth = shift;
 670         return &$pie($depth) if $depth--;
 671         substr $val, 0;
 672     };
 673     for my $depth (0, 1, 2) {
 674         my $value = "Good $depth";
 675         eval {
 676             &$pie($depth) = $value;
 677         };
 678         is($@, '', "recursive lvalue substr return depth $depth");
 679         is($val, $value,
 680            "value assigned to recursive lvalue substr (depth $depth)");
 681     }
 682 }
 683
 684 { # bug #23790
 685     my @arr  = qw /one two three/;
 686     my $line = "zero";
 687     sub lval_array () : lvalue {@arr}
 688
 689     for (lval_array) {
 690         $line .= $_;
 691     }
 692
 693     is($line, "zeroonetwothree");
 694
 695     sub trythislval { scalar(@_)."x".join "", @_ }
 696     is(trythislval(lval_array()), "3xonetwothree");
 697
 698     sub changeme { $_[2] = "free" }
 699     changeme(lval_array);
 700     is("@arr", "one two free");
 701
 702     # test again, with explicit return
 703     sub rlval_array() : lvalue {return @arr}
 704     @arr  = qw /one two three/;
 705     $line = "zero";
 706     for (rlval_array) {
 707         $line .= $_;
 708     }
 709     is($line, "zeroonetwothree");
 710     is(trythislval(rlval_array()), "3xonetwothree");
 711     changeme(rlval_array);
 712     is("@arr", "one two free");
 713
 714     # Variations on the same theme, with multiple vars returned
 715     my $scalar = 'half';
 716     sub lval_scalar_array () : lvalue { $scalar, @arr }
 717     @arr  = qw /one two three/;
 718     $line = "zero";
 719     for (lval_scalar_array) {
 720         $line .= $_;
 721     }
 722     is($line, "zerohalfonetwothree");
 723     is(trythislval(lval_scalar_array()), "4xhalfonetwothree");
 724     changeme(lval_scalar_array);
 725     is("@arr", "one free three");
 726
 727     sub lval_array_scalar () : lvalue { @arr, $scalar }
 728     @arr  = qw /one two three/;
 729     $line = "zero";
 730     $scalar = 'four';
 731     for (lval_array_scalar) {
 732         $line .= $_;
 733     }
 734     is($line, "zeroonetwothreefour");
 735     is(trythislval(lval_array_scalar()), "4xonetwothreefour");
 736     changeme(lval_array_scalar);
 737     is("@arr", "one two free");
 738
 739     # Tests for specific ops not tested above
 740     # rv2av
 741     @array2 = qw 'one two free';
 742     is join(',', map $_, sub:lvalue{@array2}->()), 'one,two,free',
 743       'rv2av in reference context';
 744     is join(',', map $_, sub:lvalue{@{\@array2}}->()), 'one,two,free',
 745       'rv2av-with-ref in reference context';
 746     # padhv
 747     my %hash = qw[a b c d];
 748     like join(',', map $_, sub:lvalue{%hash}->()),
 749          qr/^(?:a,b,c,d|c,d,a,b)\z/, 'padhv in reference context';
 750     # rv2hv
 751     %hash2 = qw[a b c d];
 752     like join(',', map $_, sub:lvalue{%hash2}->()),
 753          qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv in reference context';
 754     like join(',', map $_, sub:lvalue{%{\%hash2}}->()),
 755          qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv-with-ref in reference context';
 756 }
 757
 758 {
 759     package Foo;
 760     sub AUTOLOAD :lvalue { *{$AUTOLOAD} };
 761     package main;
 762     my $foo = bless {},"Foo";
 763     my $result;
 764     $foo->bar = sub { $result = "bar" };
 765     $foo->bar;
 766     is ($result, 'bar', "RT #41550");
 767 }
 768
 769 SKIP: { skip 'no attributes.pm', 1 unless eval 'require attributes';
 770 fresh_perl_is(<<'----', <<'====', "lvalue can not be set after definition. [perl #68758]");
 771 use warnings;
 772 our $x;
 773 sub foo { $x }
 774 sub foo : lvalue;
 775 sub MODIFY_CODE_ATTRIBUTES {}
 776 sub foo : lvalue : fr0g;
 777 foo = 3;
 778 ----
 779 lvalue attribute ignored after the subroutine has been defined at - line 4.
 780 lvalue attribute ignored after the subroutine has been defined at - line 6.
 781 Can't modify non-lvalue subroutine call in scalar assignment at - line 7, near "3;"
 782 Execution of - aborted due to compilation errors.
 783 ====
 784 }
 785
 786 {
 787     my $x;
 788     sub lval_decl : lvalue;
 789     sub lval_decl { $x }
 790     lval_decl = 5;
 791     is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]");
 792 }
 793
 794 SKIP: { skip "no attributes.pm", 2 unless eval { require attributes };
 795   sub utf8::valid :lvalue;
 796   require attributes;
 797   is "@{[ &attributes::get(\&utf8::valid) ]}", 'lvalue',
 798    'sub declaration with :lvalue applies it to XSUBs';
 799
 800   BEGIN { *wonky = \&marjibberous }
 801   sub wonky :lvalue;
 802   is "@{[ &attributes::get(\&wonky) ]}", 'lvalue',
 803    'sub declaration with :lvalue applies it to assigned stub';
 804 }
 805
 806 sub fleen : lvalue { $pnare }
 807 $pnare = __PACKAGE__;
 808 ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\
 809 is $pnare, 1, 'and returning CATTLE actually works';
 810 $pnare = __PACKAGE__;
 811 ok eval { (fleen) = 1 }, "lvalues can return COWs in list context";
 812 is $pnare, 1, 'and returning COWs in list context actually works';
 813 $pnare = __PACKAGE__;
 814 ok eval { $_ = 1 for(fleen); 1 }, "lvalues can return COWs in ref cx";
 815 is $pnare, 1, 'and returning COWs in reference context actually works';
 816
 817
 818 # Returning an arbitrary expression, not necessarily lvalue
 819 +sub :lvalue { return $ambaga || $ambaga }->() = 73;
 820 is $ambaga, 73, 'explicit return of arbitrary expression (scalar context)';
 821 (sub :lvalue { return $ambaga || $ambaga }->()) = 74;
 822 is $ambaga, 74, 'explicit return of arbitrary expression (list context)';
 823 +sub :lvalue { $ambaga || $ambaga }->() = 73;
 824 is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)';
 825 (sub :lvalue { $ambaga || $ambaga }->()) = 74;
 826 is $ambaga, 74, 'implicit return of arbitrary expression (list context)';
 827 eval { +sub :lvalue { return 3 }->() = 4 };
 828 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 829       'assignment to numeric constant explicitly returned from lv sub';
 830 eval { (sub :lvalue { return 3 }->()) = 4 };
 831 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 832       'assignment to num constant explicitly returned (list cx)';
 833 eval { +sub :lvalue { 3 }->() = 4 };
 834 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 835       'assignment to numeric constant implicitly returned from lv sub';
 836 eval { (sub :lvalue { 3 }->()) = 4 };
 837 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 838       'assignment to num constant implicitly returned (list cx)';
 839
 840 # reference (potential lvalue) context
 841 $suffix = '';
 842 for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
 843     &$sub()->${\sub { $_[0] = 37 }};
 844     is $_, '37', 'lvalue->method'.$suffix;
 845     ${\scalar &$sub()} = 38;
 846     is $_, '38', 'scalar(lvalue)'.$suffix;
 847     sub assign39_with_proto ($) { $_[0] = 39 }
 848     assign39_with_proto(&$sub());
 849     is $_, '39', 'func(lvalue) when func has $ proto'.$suffix;
 850     $_ = 1;
 851     ${\(&$sub()||undef)} = 40;
 852     is $_, '40', 'lvalue||...'.$suffix;
 853     ${\(${\undef}||&$sub())} = 41; # extra ${\...} to bypass const folding
 854     is $_, '41', '...||lvalue'.$suffix;
 855     $_ = 0;
 856     ${\(&$sub()&&undef)} = 42;
 857     is $_, '42', 'lvalue&&...'.$suffix;
 858     ${\(${\1}&&&$sub())} = 43;
 859     is $_, '43', '...&&lvalue'.$suffix;
 860     ${\(&$sub())[0]} = 44;
 861     is $_, '44', '(lvalue)[0]'.$suffix;
 862 }
 863 continue { $suffix = ' (explicit return)' }
 864
 865 # autovivification
 866 $suffix = '';
 867 for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
 868     undef $_;
 869     &$sub()->[3] = 4;
 870     is $_->[3], 4, 'func->[...] autovivification'.$suffix;
 871     undef $_;
 872     &$sub()->{3} = 4;
 873     is $_->{3}, 4, 'func->{...} autovivification'.$suffix;
 874     undef $_;
 875     ${&$sub()} = 4;
 876     is $$_, 4, '${func()} autovivification'      .$suffix;
 877     undef $_;
 878     @{&$sub()} = 4;
 879     is "@$_", 4, '@{func()} autovivification'    .$suffix;
 880     undef $_;
 881     %{&$sub()} = (4,5);
 882     is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix;
 883 }
 884 continue { $suffix = ' (explicit return)' }
 885
 886 # [perl #92406] [perl #92290] Returning a pad var in rvalue context
 887 $suffix = '';
 888 for my $sub (
 889          sub :lvalue { my $x = 72; $x },
 890          sub :lvalue { my $x = 72; return $x }
 891 ) {
 892     is scalar(&$sub), 72, "sub returning pad var in scalar context$suffix";
 893     is +(&$sub)[0], 72, "sub returning pad var in list context$suffix";
 894 }
 895 continue { $suffix = ' (explicit return)' }
 896
 897 # Returning read-only values in reference context
 898 $suffix = '';
 899 for (
 900          sub :lvalue { $] }->(),
 901          sub :lvalue { return $] }->()
 902 ) {
 903     is \$_, \$], 'read-only values are returned in reference context'
 904                  .$suffix             # (they used to be copied)
 905 }
 906 continue { $suffix = ' (explicit return)' }
 907
 908 # Returning unwritables from nested lvalue sub call in in rvalue context
 909 # First, ensure we are testing what we think we are:
 910 if (!Internals::SvREADONLY($])) { Internals::SvREADONLY($],1); }
 911 sub squibble : lvalue { return $] }
 912 sub squebble : lvalue {        squibble }
 913 sub squabble : lvalue { return squibble }
 914 is $x = squebble, $], 'returning ro from nested lv sub call in rv cx';
 915 is $x = squabble, $], 'explct. returning ro from nested lv sub in rv cx';
 916 is \squebble, \$], 'returning ro from nested lv sub call in ref cx';
 917 is \squabble, \$], 'explct. returning ro from nested lv sub in ref cx';