t/op/sub_lval.t

   1 BEGIN {
   2     chdir 't' if -d 't';
   3     @INC = '../lib';
   4     require './test.pl';
   5 }
   6 plan tests=>71;
   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 { }            # Converted to lv10 in scalar context
 214
 215 $_ = undef;
 216 eval <<'EOE' or $_ = $@;
 217   lv0 = (2,3);
 218   1;
 219 EOE
 220
 221 like($_, qr/Can't return undef from lvalue subroutine/);
 222
 223 sub lv10 : lvalue {}
 224
 225 $_ = undef;
 226 eval <<'EOE' or $_ = $@;
 227   (lv0) = (2,3);
 228   1;
 229 EOE
 230
 231 ok(!defined $_) or diag $_;
 232
 233 sub lv1u :lvalue { undef }
 234
 235 $_ = undef;
 236 eval <<'EOE' or $_ = $@;
 237   lv1u = (2,3);
 238   1;
 239 EOE
 240
 241 like($_, qr/Can't return undef from lvalue subroutine/);
 242
 243 $_ = undef;
 244 eval <<'EOE' or $_ = $@;
 245   (lv1u) = (2,3);
 246   1;
 247 EOE
 248
 249 # Fixed by change @10777
 250 #print "# '$_'.\nnot "
 251 #  unless /Can\'t return an uninitialized value from lvalue subroutine/;
 252 # print "ok 34 # Skip: removed test\n";
 253
 254 $x = '1234567';
 255
 256 $_ = undef;
 257 eval <<'EOE' or $_ = $@;
 258   sub lv1t : lvalue { index $x, 2 }
 259   lv1t = (2,3);
 260   1;
 261 EOE
 262
 263 like($_, qr/Can\'t modify index in lvalue subroutine return/);
 264
 265 $_ = undef;
 266 eval <<'EOE' or $_ = $@;
 267   sub lv2t : lvalue { shift }
 268   (lv2t) = (2,3);
 269   1;
 270 EOE
 271
 272 like($_, qr/Can\'t modify shift in lvalue subroutine return/);
 273
 274 $xxx = 'xxx';
 275 sub xxx () { $xxx }  # Not lvalue
 276
 277 $_ = undef;
 278 eval <<'EOE' or $_ = $@;
 279   sub lv1tmp : lvalue { xxx }                   # is it a TEMP?
 280   lv1tmp = (2,3);
 281   1;
 282 EOE
 283
 284 like($_, qr/Can\'t modify non-lvalue subroutine call in lvalue subroutine return/);
 285
 286 $_ = undef;
 287 eval <<'EOE' or $_ = $@;
 288   (lv1tmp) = (2,3);
 289   1;
 290 EOE
 291
 292 like($_, qr/Can\'t return a temporary from lvalue subroutine/);
 293
 294 sub yyy () { 'yyy' } # Const, not lvalue
 295
 296 $_ = undef;
 297 eval <<'EOE' or $_ = $@;
 298   sub lv1tmpr : lvalue { yyy }                  # is it read-only?
 299   lv1tmpr = (2,3);
 300   1;
 301 EOE
 302
 303 like($_, qr/Can\'t modify constant item in lvalue subroutine return/);
 304
 305 $_ = undef;
 306 eval <<'EOE' or $_ = $@;
 307   (lv1tmpr) = (2,3);
 308   1;
 309 EOE
 310
 311 like($_, qr/Can\'t return a readonly value from lvalue subroutine/);
 312
 313 sub lva : lvalue {@a}
 314
 315 $_ = undef;
 316 @a = ();
 317 $a[1] = 12;
 318 eval <<'EOE' or $_ = $@;
 319   (lva) = (2,3);
 320   1;
 321 EOE
 322
 323 is("'@a' $_", "'2 3' ");
 324
 325 $_ = undef;
 326 @a = ();
 327 $a[0] = undef;
 328 $a[1] = 12;
 329 eval <<'EOE' or $_ = $@;
 330   (lva) = (2,3);
 331   1;
 332 EOE
 333
 334 is("'@a' $_", "'2 3' ");
 335
 336 $_ = undef;
 337 @a = ();
 338 $a[0] = undef;
 339 $a[1] = 12;
 340 eval <<'EOE' or $_ = $@;
 341   (lva) = (2,3);
 342   1;
 343 EOE
 344
 345 is("'@a' $_", "'2 3' ");
 346
 347 sub lv1n : lvalue { $newvar }
 348
 349 $_ = undef;
 350 eval <<'EOE' or $_ = $@;
 351   lv1n = (3,4);
 352   1;
 353 EOE
 354
 355 is("'$newvar' $_", "'4' ");
 356
 357 sub lv1nn : lvalue { $nnewvar }
 358
 359 $_ = undef;
 360 eval <<'EOE' or $_ = $@;
 361   (lv1nn) = (3,4);
 362   1;
 363 EOE
 364
 365 is("'$nnewvar' $_", "'3' ");
 366
 367 $a = \&lv1nn;
 368 $a->() = 8;
 369 is($nnewvar, '8');
 370
 371 eval 'sub AUTOLOAD : lvalue { $newvar }';
 372 foobar() = 12;
 373 is($newvar, "12");
 374
 375 {
 376 my %hash; my @array;
 377 sub alv : lvalue { $array[1] }
 378 sub alv2 : lvalue { $array[$_[0]] }
 379 sub hlv : lvalue { $hash{"foo"} }
 380 sub hlv2 : lvalue { $hash{$_[0]} }
 381 $array[1] = "not ok 51\n";
 382 alv() = "ok 50\n";
 383 is(alv(), "ok 50\n");
 384
 385 alv2(20) = "ok 51\n";
 386 is($array[20], "ok 51\n");
 387
 388 $hash{"foo"} = "not ok 52\n";
 389 hlv() = "ok 52\n";
 390 is($hash{foo}, "ok 52\n");
 391
 392 $hash{bar} = "not ok 53\n";
 393 hlv("bar") = "ok 53\n";
 394 is(hlv("bar"), "ok 53\n");
 395
 396 sub array : lvalue  { @array  }
 397 sub array2 : lvalue { @array2 } # This is a global.
 398 sub hash : lvalue   { %hash   }
 399 sub hash2 : lvalue  { %hash2  } # So's this.
 400 @array2 = qw(foo bar);
 401 %hash2 = qw(foo bar);
 402
 403 (array()) = qw(ok 54);
 404 is("@array", "ok 54");
 405
 406 (array2()) = qw(ok 55);
 407 is("@array2", "ok 55");
 408
 409 (hash()) = qw(ok 56);
 410 cmp_ok($hash{ok}, '==', 56);
 411
 412 (hash2()) = qw(ok 57);
 413 cmp_ok($hash2{ok}, '==', 57);
 414
 415 @array = qw(a b c d);
 416 sub aslice1 : lvalue { @array[0,2] };
 417 (aslice1()) = ("ok", "already");
 418 is("@array", "ok b already d");
 419
 420 @array2 = qw(a B c d);
 421 sub aslice2 : lvalue { @array2[0,2] };
 422 (aslice2()) = ("ok", "already");
 423 is("@array2", "ok B already d");
 424
 425 %hash = qw(a Alpha b Beta c Gamma);
 426 sub hslice : lvalue { @hash{"c", "b"} }
 427 (hslice()) = ("CISC", "BogoMIPS");
 428 is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS");
 429 }
 430
 431 $str = "Hello, world!";
 432 sub sstr : lvalue { substr($str, 1, 4) }
 433 sstr() = "i";
 434 is($str, "Hi, world!");
 435
 436 $str = "Made w/ JavaScript";
 437 sub veclv : lvalue { vec($str, 2, 32) }
 438 if (ord('A') != 193) {
 439     veclv() = 0x5065726C;
 440 }
 441 else { # EBCDIC?
 442     veclv() = 0xD7859993;
 443 }
 444 is($str, "Made w/ PerlScript");
 445
 446 sub position : lvalue { pos }
 447 @p = ();
 448 $_ = "fee fi fo fum";
 449 while (/f/g) {
 450     push @p, position;
 451     position() += 6;
 452 }
 453 is("@p", "1 8");
 454
 455 # Bug 20001223.002: split thought that the list had only one element
 456 @ary = qw(4 5 6);
 457 sub lval1 : lvalue { $ary[0]; }
 458 sub lval2 : lvalue { $ary[1]; }
 459 (lval1(), lval2()) = split ' ', "1 2 3 4";
 460
 461 is(join(':', @ary), "1:2:6");
 462
 463 # check that an element of a tied hash/array can be assigned to via lvalueness
 464
 465 package Tie_Hash;
 466
 467 our ($key, $val);
 468 sub TIEHASH { bless \my $v => __PACKAGE__ }
 469 sub STORE   { ($key, $val) = @_[1,2] }
 470
 471 package main;
 472 sub lval_tie_hash : lvalue {
 473     tie my %t => 'Tie_Hash';
 474     $t{key};
 475 }
 476
 477 eval { lval_tie_hash() = "value"; };
 478
 479 is($@, "", "element of tied hash");
 480
 481 is("$Tie_Hash::key-$Tie_Hash::val", "key-value");
 482
 483
 484 package Tie_Array;
 485
 486 our @val;
 487 sub TIEARRAY { bless \my $v => __PACKAGE__ }
 488 sub STORE   { $val[ $_[1] ] = $_[2] }
 489
 490 package main;
 491 sub lval_tie_array : lvalue {
 492     tie my @t => 'Tie_Array';
 493     $t[0];
 494 }
 495
 496 eval { lval_tie_array() = "value"; };
 497
 498
 499 is($@, "", "element of tied array");
 500
 501 is ($Tie_Array::val[0], "value");
 502
 503 TODO: {
 504     local $TODO = 'test explicit return of lval expr';
 505
 506     # subs are corrupted copies from tests 1-~4
 507     sub bad_get_lex : lvalue { return $in };
 508     sub bad_get_st  : lvalue { return $blah }
 509
 510     sub bad_id  : lvalue { return ${\shift} }
 511     sub bad_id1 : lvalue { return $_[0] }
 512     sub bad_inc : lvalue { return ${\++$_[0]} }
 513
 514     $in = 5;
 515     $blah = 3;
 516
 517     bad_get_st = 7;
 518
 519     is( $blah, 7 );
 520
 521     bad_get_lex = 7;
 522
 523     is($in, 7, "yada");
 524
 525     ++bad_get_st;
 526
 527     is($blah, 8, "yada");
 528 }
 529
 530 TODO: {
 531     local $TODO = "bug #23790";
 532     my @arr  = qw /one two three/;
 533     my $line = "zero";
 534     sub lval_array () : lvalue {@arr}
 535
 536     for (lval_array) {
 537         $line .= $_;
 538     }
 539
 540     is($line, "zeroonetwothree");
 541 }
 542
 543 {
 544     package Foo;
 545     sub AUTOLOAD :lvalue { *{$AUTOLOAD} };
 546     package main;
 547     my $foo = bless {},"Foo";
 548     my $result;
 549     $foo->bar = sub { $result = "bar" };
 550     $foo->bar;
 551     is ($result, 'bar', "RT #41550");
 552 }
 553
 554 fresh_perl_is(<<'----', <<'====', "lvalue can not be set after definition. [perl #68758]");
 555 use warnings;
 556 our $x;
 557 sub foo { $x }
 558 sub foo : lvalue;
 559 foo = 3;
 560 ----
 561 lvalue attribute ignored after the subroutine has been defined at - line 4.
 562 Can't modify non-lvalue subroutine call in scalar assignment at - line 5, near "3;"
 563 Execution of - aborted due to compilation errors.
 564 ====
 565
 566 {
 567     my $x;
 568     sub lval_decl : lvalue;
 569     sub lval_decl { $x }
 570     lval_decl = 5;
 571     is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]");
 572 }