t/op/sub_lval.t

   1 print "1..68\n";
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   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 print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error.
  13 print "ok 1\n";
  14
  15 my @out = grep /main/, a(b()); # Check that temporaries are allowed.
  16 print "# `@out'\nnot " unless @out==1; # Not reached if error.
  17 print "ok 2\n";
  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 print "# `$in'\nnot " unless $in eq '-2';
  33 print "ok 3\n";
  34
  35 sub get_lex : lvalue { $in }
  36 sub get_st : lvalue { $blah }
  37 sub id : lvalue { ${\shift} }
  38 sub id1 : lvalue { $_[0] }
  39 sub inc : lvalue { ${\++$_[0]} }
  40
  41 $in = 5;
  42 $blah = 3;
  43
  44 get_st = 7;
  45
  46 print "# `$blah' ne 7\nnot " unless $blah == 7;
  47 print "ok 4\n";
  48
  49 get_lex = 7;
  50
  51 print "# `$in' ne 7\nnot " unless $in == 7;
  52 print "ok 5\n";
  53
  54 ++get_st;
  55
  56 print "# `$blah' ne 8\nnot " unless $blah == 8;
  57 print "ok 6\n";
  58
  59 ++get_lex;
  60
  61 print "# `$in' ne 8\nnot " unless $in == 8;
  62 print "ok 7\n";
  63
  64 id(get_st) = 10;
  65
  66 print "# `$blah' ne 10\nnot " unless $blah == 10;
  67 print "ok 8\n";
  68
  69 id(get_lex) = 10;
  70
  71 print "# `$in' ne 10\nnot " unless $in == 10;
  72 print "ok 9\n";
  73
  74 ++id(get_st);
  75
  76 print "# `$blah' ne 11\nnot " unless $blah == 11;
  77 print "ok 10\n";
  78
  79 ++id(get_lex);
  80
  81 print "# `$in' ne 11\nnot " unless $in == 11;
  82 print "ok 11\n";
  83
  84 id1(get_st) = 20;
  85
  86 print "# `$blah' ne 20\nnot " unless $blah == 20;
  87 print "ok 12\n";
  88
  89 id1(get_lex) = 20;
  90
  91 print "# `$in' ne 20\nnot " unless $in == 20;
  92 print "ok 13\n";
  93
  94 ++id1(get_st);
  95
  96 print "# `$blah' ne 21\nnot " unless $blah == 21;
  97 print "ok 14\n";
  98
  99 ++id1(get_lex);
 100
 101 print "# `$in' ne 21\nnot " unless $in == 21;
 102 print "ok 15\n";
 103
 104 inc(get_st);
 105
 106 print "# `$blah' ne 22\nnot " unless $blah == 22;
 107 print "ok 16\n";
 108
 109 inc(get_lex);
 110
 111 print "# `$in' ne 22\nnot " unless $in == 22;
 112 print "ok 17\n";
 113
 114 inc(id(get_st));
 115
 116 print "# `$blah' ne 23\nnot " unless $blah == 23;
 117 print "ok 18\n";
 118
 119 inc(id(get_lex));
 120
 121 print "# `$in' ne 23\nnot " unless $in == 23;
 122 print "ok 19\n";
 123
 124 ++inc(id1(id(get_st)));
 125
 126 print "# `$blah' ne 25\nnot " unless $blah == 25;
 127 print "ok 20\n";
 128
 129 ++inc(id1(id(get_lex)));
 130
 131 print "# `$in' ne 25\nnot " unless $in == 25;
 132 print "ok 21\n";
 133
 134 @a = (1) x 3;
 135 @b = (undef) x 2;
 136 $#c = 3;                        # These slots are not fillable.
 137
 138 # Explanation: empty slots contain &sv_undef.
 139
 140 =for disabled constructs
 141
 142 sub a3 :lvalue {@a}
 143 sub b2 : lvalue {@b}
 144 sub c4: lvalue {@c}
 145
 146 $_ = '';
 147
 148 eval <<'EOE' or $_ = $@;
 149   ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
 150   1;
 151 EOE
 152
 153 #@out = ($x, a3, $y, b2, $z, c4, $t);
 154 #@in = (34 .. 41, (undef) x 4, 46);
 155 #print "# `@out' ne `@in'\nnot " unless "@out" eq "@in";
 156
 157 print "# '$_'.\nnot "
 158   unless /Can\'t return an uninitialized value from lvalue subroutine/;
 159 =cut
 160
 161 print "ok 22\n";
 162
 163 my $var;
 164
 165 sub a::var : lvalue { $var }
 166
 167 "a"->var = 45;
 168
 169 print "# `$var' ne 45\nnot " unless $var == 45;
 170 print "ok 23\n";
 171
 172 my $oo;
 173 $o = bless \$oo, "a";
 174
 175 $o->var = 47;
 176
 177 print "# `$var' ne 47\nnot " unless $var == 47;
 178 print "ok 24\n";
 179
 180 sub o : lvalue { $o }
 181
 182 o->var = 49;
 183
 184 print "# `$var' ne 49\nnot " unless $var == 49;
 185 print "ok 25\n";
 186
 187 sub nolv () { $x0, $x1 } # Not lvalue
 188
 189 $_ = '';
 190
 191 eval <<'EOE' or $_ = $@;
 192   nolv = (2,3);
 193   1;
 194 EOE
 195
 196 print "not "
 197   unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
 198 print "ok 26\n";
 199
 200 $_ = '';
 201
 202 eval <<'EOE' or $_ = $@;
 203   nolv = (2,3) if $_;
 204   1;
 205 EOE
 206
 207 print "not "
 208   unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
 209 print "ok 27\n";
 210
 211 $_ = '';
 212
 213 eval <<'EOE' or $_ = $@;
 214   &nolv = (2,3) if $_;
 215   1;
 216 EOE
 217
 218 print "not "
 219   unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
 220 print "ok 28\n";
 221
 222 $x0 = $x1 = $_ = undef;
 223 $nolv = \&nolv;
 224
 225 eval <<'EOE' or $_ = $@;
 226   $nolv->() = (2,3) if $_;
 227   1;
 228 EOE
 229
 230 print "# '$_', '$x0', '$x1'.\nnot " if defined $_;
 231 print "ok 29\n";
 232
 233 $x0 = $x1 = $_ = undef;
 234 $nolv = \&nolv;
 235
 236 eval <<'EOE' or $_ = $@;
 237   $nolv->() = (2,3);
 238   1;
 239 EOE
 240
 241 print "# '$_', '$x0', '$x1'.\nnot "
 242   unless /Can\'t modify non-lvalue subroutine call/;
 243 print "ok 30\n";
 244
 245 sub lv0 : lvalue { }            # Converted to lv10 in scalar context
 246
 247 $_ = undef;
 248 eval <<'EOE' or $_ = $@;
 249   lv0 = (2,3);
 250   1;
 251 EOE
 252
 253 print "# '$_'.\nnot "
 254   unless /Can't return undef from lvalue subroutine/;
 255 print "ok 31\n";
 256
 257 sub lv10 : lvalue {}
 258
 259 $_ = undef;
 260 eval <<'EOE' or $_ = $@;
 261   (lv0) = (2,3);
 262   1;
 263 EOE
 264
 265 print "# '$_'.\nnot " if defined $_;
 266 print "ok 32\n";
 267
 268 sub lv1u :lvalue { undef }
 269
 270 $_ = undef;
 271 eval <<'EOE' or $_ = $@;
 272   lv1u = (2,3);
 273   1;
 274 EOE
 275
 276 print "# '$_'.\nnot "
 277   unless /Can't return undef from lvalue subroutine/;
 278 print "ok 33\n";
 279
 280 $_ = undef;
 281 eval <<'EOE' or $_ = $@;
 282   (lv1u) = (2,3);
 283   1;
 284 EOE
 285
 286 # Fixed by change @10777
 287 #print "# '$_'.\nnot "
 288 #  unless /Can\'t return an uninitialized value from lvalue subroutine/;
 289 print "ok 34 # Skip: removed test\n";
 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 print "# '$_'.\nnot "
 301   unless /Can\'t modify index in lvalue subroutine return/;
 302 print "ok 35\n";
 303
 304 $_ = undef;
 305 eval <<'EOE' or $_ = $@;
 306   sub lv2t : lvalue { shift }
 307   (lv2t) = (2,3);
 308   1;
 309 EOE
 310
 311 print "# '$_'.\nnot "
 312   unless /Can\'t modify shift in lvalue subroutine return/;
 313 print "ok 36\n";
 314
 315 $xxx = 'xxx';
 316 sub xxx () { $xxx }  # Not lvalue
 317
 318 $_ = undef;
 319 eval <<'EOE' or $_ = $@;
 320   sub lv1tmp : lvalue { xxx }                   # is it a TEMP?
 321   lv1tmp = (2,3);
 322   1;
 323 EOE
 324
 325 print "# '$_'.\nnot "
 326   unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/;
 327 print "ok 37\n";
 328
 329 $_ = undef;
 330 eval <<'EOE' or $_ = $@;
 331   (lv1tmp) = (2,3);
 332   1;
 333 EOE
 334
 335 print "# '$_'.\nnot "
 336   unless /Can\'t return a temporary from lvalue subroutine/;
 337 print "ok 38\n";
 338
 339 sub yyy () { 'yyy' } # Const, not lvalue
 340
 341 $_ = undef;
 342 eval <<'EOE' or $_ = $@;
 343   sub lv1tmpr : lvalue { yyy }                  # is it read-only?
 344   lv1tmpr = (2,3);
 345   1;
 346 EOE
 347
 348 print "# '$_'.\nnot "
 349   unless /Can\'t modify constant item in lvalue subroutine return/;
 350 print "ok 39\n";
 351
 352 $_ = undef;
 353 eval <<'EOE' or $_ = $@;
 354   (lv1tmpr) = (2,3);
 355   1;
 356 EOE
 357
 358 print "# '$_'.\nnot "
 359   unless /Can\'t return a readonly value from lvalue subroutine/;
 360 print "ok 40\n";
 361
 362 sub lva : lvalue {@a}
 363
 364 $_ = undef;
 365 @a = ();
 366 $a[1] = 12;
 367 eval <<'EOE' or $_ = $@;
 368   (lva) = (2,3);
 369   1;
 370 EOE
 371
 372 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 373 print "ok 41\n";
 374
 375 $_ = undef;
 376 @a = ();
 377 $a[0] = undef;
 378 $a[1] = 12;
 379 eval <<'EOE' or $_ = $@;
 380   (lva) = (2,3);
 381   1;
 382 EOE
 383
 384 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 385 print "ok 42\n";
 386
 387 $_ = undef;
 388 @a = ();
 389 $a[0] = undef;
 390 $a[1] = 12;
 391 eval <<'EOE' or $_ = $@;
 392   (lva) = (2,3);
 393   1;
 394 EOE
 395
 396 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 397 print "ok 43\n";
 398
 399 sub lv1n : lvalue { $newvar }
 400
 401 $_ = undef;
 402 eval <<'EOE' or $_ = $@;
 403   lv1n = (3,4);
 404   1;
 405 EOE
 406
 407 print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' ";
 408 print "ok 44\n";
 409
 410 sub lv1nn : lvalue { $nnewvar }
 411
 412 $_ = undef;
 413 eval <<'EOE' or $_ = $@;
 414   (lv1nn) = (3,4);
 415   1;
 416 EOE
 417
 418 print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' ";
 419 print "ok 45\n";
 420
 421 $a = \&lv1nn;
 422 $a->() = 8;
 423 print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
 424 print "ok 46\n";
 425
 426 eval 'sub AUTOLOAD : lvalue { $newvar }';
 427 foobar() = 12;
 428 print "# '$newvar'.\nnot " unless $newvar eq "12";
 429 print "ok 47\n";
 430
 431 print "ok 48 # Skip: removed test\n";
 432
 433 print "ok 49 # Skip: removed test\n";
 434
 435 {
 436 my %hash; my @array;
 437 sub alv : lvalue { $array[1] }
 438 sub alv2 : lvalue { $array[$_[0]] }
 439 sub hlv : lvalue { $hash{"foo"} }
 440 sub hlv2 : lvalue { $hash{$_[0]} }
 441 $array[1] = "not ok 51\n";
 442 alv() = "ok 50\n";
 443 print alv();
 444
 445 alv2(20) = "ok 51\n";
 446 print $array[20];
 447
 448 $hash{"foo"} = "not ok 52\n";
 449 hlv() = "ok 52\n";
 450 print $hash{foo};
 451
 452 $hash{bar} = "not ok 53\n";
 453 hlv("bar") = "ok 53\n";
 454 print hlv("bar");
 455
 456 sub array : lvalue  { @array  }
 457 sub array2 : lvalue { @array2 } # This is a global.
 458 sub hash : lvalue   { %hash   }
 459 sub hash2 : lvalue  { %hash2  } # So's this.
 460 @array2 = qw(foo bar);
 461 %hash2 = qw(foo bar);
 462
 463 (array()) = qw(ok 54);
 464 print "not " unless "@array" eq "ok 54";
 465 print "ok 54\n";
 466
 467 (array2()) = qw(ok 55);
 468 print "not " unless "@array2" eq "ok 55";
 469 print "ok 55\n";
 470
 471 (hash()) = qw(ok 56);
 472 print "not " unless $hash{ok} == 56;
 473 print "ok 56\n";
 474
 475 (hash2()) = qw(ok 57);
 476 print "not " unless $hash2{ok} == 57;
 477 print "ok 57\n";
 478
 479 @array = qw(a b c d);
 480 sub aslice1 : lvalue { @array[0,2] };
 481 (aslice1()) = ("ok", "already");
 482 print "# @array\nnot " unless "@array" eq "ok b already d";
 483 print "ok 58\n";
 484
 485 @array2 = qw(a B c d);
 486 sub aslice2 : lvalue { @array2[0,2] };
 487 (aslice2()) = ("ok", "already");
 488 print "not " unless "@array2" eq "ok B already d";
 489 print "ok 59\n";
 490
 491 %hash = qw(a Alpha b Beta c Gamma);
 492 sub hslice : lvalue { @hash{"c", "b"} }
 493 (hslice()) = ("CISC", "BogoMIPS");
 494 print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS";
 495 print "ok 60\n";
 496 }
 497
 498 $str = "Hello, world!";
 499 sub sstr : lvalue { substr($str, 1, 4) }
 500 sstr() = "i";
 501 print "not " unless $str eq "Hi, world!";
 502 print "ok 61\n";
 503
 504 $str = "Made w/ JavaScript";
 505 sub veclv : lvalue { vec($str, 2, 32) }
 506 if (ord('A') != 193) {
 507     veclv() = 0x5065726C;
 508 }
 509 else { # EBCDIC?
 510     veclv() = 0xD7859993;
 511 }
 512 print "# $str\nnot " unless $str eq "Made w/ PerlScript";
 513 print "ok 62\n";
 514
 515 sub position : lvalue { pos }
 516 @p = ();
 517 $_ = "fee fi fo fum";
 518 while (/f/g) {
 519     push @p, position;
 520     position() += 6;
 521 }
 522 print "# @p\nnot " unless "@p" eq "1 8";
 523 print "ok 63\n";
 524
 525 # Bug 20001223.002: split thought that the list had only one element
 526 @ary = qw(4 5 6);
 527 sub lval1 : lvalue { $ary[0]; }
 528 sub lval2 : lvalue { $ary[1]; }
 529 (lval1(), lval2()) = split ' ', "1 2 3 4";
 530 print "not " unless join(':', @ary) eq "1:2:6";
 531 print "ok 64\n";
 532
 533 require './test.pl';
 534 curr_test(65);
 535
 536 TODO: {
 537     local $TODO = 'test explicit return of lval expr';
 538
 539     # subs are corrupted copies from tests 1-~4
 540     sub bad_get_lex : lvalue { return $in };
 541     sub bad_get_st  : lvalue { return $blah }
 542
 543     sub bad_id  : lvalue { return ${\shift} }
 544     sub bad_id1 : lvalue { return $_[0] }
 545     sub bad_inc : lvalue { return ${\++$_[0]} }
 546
 547     $in = 5;
 548     $blah = 3;
 549
 550     bad_get_st = 7;
 551
 552     is( $blah, 7 );
 553
 554     bad_get_lex = 7;
 555
 556     is($in, 7, "yada");
 557
 558     ++bad_get_st;
 559
 560     is($blah, 8, "yada");
 561 }
 562
 563 TODO: {
 564     local $TODO = "bug #23790";
 565     my @arr  = qw /one two three/;
 566     my $line = "zero";
 567     sub lval_array () : lvalue {@arr}
 568
 569     for (lval_array) {
 570         $line .= $_;
 571     }
 572
 573     is($line, "zeroonetwothree");
 574 }