t/pragma/sub_lval.t

   1 print "1..64\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 eq 7;
  47 print "ok 4\n";
  48
  49 get_lex = 7;
  50
  51 print "# `$in' ne 7\nnot " unless $in eq 7;
  52 print "ok 5\n";
  53
  54 ++get_st;
  55
  56 print "# `$blah' ne 8\nnot " unless $blah eq 8;
  57 print "ok 6\n";
  58
  59 ++get_lex;
  60
  61 print "# `$in' ne 8\nnot " unless $in eq 8;
  62 print "ok 7\n";
  63
  64 id(get_st) = 10;
  65
  66 print "# `$blah' ne 10\nnot " unless $blah eq 10;
  67 print "ok 8\n";
  68
  69 id(get_lex) = 10;
  70
  71 print "# `$in' ne 10\nnot " unless $in eq 10;
  72 print "ok 9\n";
  73
  74 ++id(get_st);
  75
  76 print "# `$blah' ne 11\nnot " unless $blah eq 11;
  77 print "ok 10\n";
  78
  79 ++id(get_lex);
  80
  81 print "# `$in' ne 11\nnot " unless $in eq 11;
  82 print "ok 11\n";
  83
  84 id1(get_st) = 20;
  85
  86 print "# `$blah' ne 20\nnot " unless $blah eq 20;
  87 print "ok 12\n";
  88
  89 id1(get_lex) = 20;
  90
  91 print "# `$in' ne 20\nnot " unless $in eq 20;
  92 print "ok 13\n";
  93
  94 ++id1(get_st);
  95
  96 print "# `$blah' ne 21\nnot " unless $blah eq 21;
  97 print "ok 14\n";
  98
  99 ++id1(get_lex);
 100
 101 print "# `$in' ne 21\nnot " unless $in eq 21;
 102 print "ok 15\n";
 103
 104 inc(get_st);
 105
 106 print "# `$blah' ne 22\nnot " unless $blah eq 22;
 107 print "ok 16\n";
 108
 109 inc(get_lex);
 110
 111 print "# `$in' ne 22\nnot " unless $in eq 22;
 112 print "ok 17\n";
 113
 114 inc(id(get_st));
 115
 116 print "# `$blah' ne 23\nnot " unless $blah eq 23;
 117 print "ok 18\n";
 118
 119 inc(id(get_lex));
 120
 121 print "# `$in' ne 23\nnot " unless $in eq 23;
 122 print "ok 19\n";
 123
 124 ++inc(id1(id(get_st)));
 125
 126 print "# `$blah' ne 25\nnot " unless $blah eq 25;
 127 print "ok 20\n";
 128
 129 ++inc(id1(id(get_lex)));
 130
 131 print "# `$in' ne 25\nnot " unless $in eq 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 eq 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 eq 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 eq 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 a readonly value 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 a readonly value 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 print "# '$_'.\nnot "
 287   unless /Can\'t return an uninitialized value from lvalue subroutine/;
 288 print "ok 34\n";
 289
 290 $x = '1234567';
 291
 292 $_ = undef;
 293 eval <<'EOE' or $_ = $@;
 294   sub lv1t : lvalue { index $x, 2 }
 295   lv1t = (2,3);
 296   1;
 297 EOE
 298
 299 print "# '$_'.\nnot "
 300   unless /Can\'t modify index in lvalue subroutine return/;
 301 print "ok 35\n";
 302
 303 $_ = undef;
 304 eval <<'EOE' or $_ = $@;
 305   sub lv2t : lvalue { shift }
 306   (lv2t) = (2,3);
 307   1;
 308 EOE
 309
 310 print "# '$_'.\nnot "
 311   unless /Can\'t modify shift in lvalue subroutine return/;
 312 print "ok 36\n";
 313
 314 $xxx = 'xxx';
 315 sub xxx () { $xxx }  # Not lvalue
 316
 317 $_ = undef;
 318 eval <<'EOE' or $_ = $@;
 319   sub lv1tmp : lvalue { xxx }                   # is it a TEMP?
 320   lv1tmp = (2,3);
 321   1;
 322 EOE
 323
 324 print "# '$_'.\nnot "
 325   unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/;
 326 print "ok 37\n";
 327
 328 $_ = undef;
 329 eval <<'EOE' or $_ = $@;
 330   (lv1tmp) = (2,3);
 331   1;
 332 EOE
 333
 334 print "# '$_'.\nnot "
 335   unless /Can\'t return a temporary from lvalue subroutine/;
 336 print "ok 38\n";
 337
 338 sub yyy () { 'yyy' } # Const, not lvalue
 339
 340 $_ = undef;
 341 eval <<'EOE' or $_ = $@;
 342   sub lv1tmpr : lvalue { yyy }                  # is it read-only?
 343   lv1tmpr = (2,3);
 344   1;
 345 EOE
 346
 347 print "# '$_'.\nnot "
 348   unless /Can\'t modify constant item in lvalue subroutine return/;
 349 print "ok 39\n";
 350
 351 $_ = undef;
 352 eval <<'EOE' or $_ = $@;
 353   (lv1tmpr) = (2,3);
 354   1;
 355 EOE
 356
 357 print "# '$_'.\nnot "
 358   unless /Can\'t return a readonly value from lvalue subroutine/;
 359 print "ok 40\n";
 360
 361 sub lva : lvalue {@a}
 362
 363 $_ = undef;
 364 @a = ();
 365 $a[1] = 12;
 366 eval <<'EOE' or $_ = $@;
 367   (lva) = (2,3);
 368   1;
 369 EOE
 370
 371 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 372 print "ok 41\n";
 373
 374 $_ = undef;
 375 @a = ();
 376 $a[0] = undef;
 377 $a[1] = 12;
 378 eval <<'EOE' or $_ = $@;
 379   (lva) = (2,3);
 380   1;
 381 EOE
 382
 383 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 384 print "ok 42\n";
 385
 386 $_ = undef;
 387 @a = ();
 388 $a[0] = undef;
 389 $a[1] = 12;
 390 eval <<'EOE' or $_ = $@;
 391   (lva) = (2,3);
 392   1;
 393 EOE
 394
 395 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 396 print "ok 43\n";
 397
 398 sub lv1n : lvalue { $newvar }
 399
 400 $_ = undef;
 401 eval <<'EOE' or $_ = $@;
 402   lv1n = (3,4);
 403   1;
 404 EOE
 405
 406 print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' ";
 407 print "ok 44\n";
 408
 409 sub lv1nn : lvalue { $nnewvar }
 410
 411 $_ = undef;
 412 eval <<'EOE' or $_ = $@;
 413   (lv1nn) = (3,4);
 414   1;
 415 EOE
 416
 417 print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' ";
 418 print "ok 45\n";
 419
 420 $a = \&lv1nn;
 421 $a->() = 8;
 422 print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
 423 print "ok 46\n";
 424
 425 # This must happen at run time
 426 eval {
 427     sub AUTOLOAD : lvalue { $newvar };
 428 };
 429 foobar() = 12;
 430 print "# '$newvar'.\nnot " unless $newvar eq "12";
 431 print "ok 47\n";
 432
 433 print "ok 48 # Skip: removed test\n";
 434
 435 print "ok 49 # Skip: removed test\n";
 436
 437 {
 438 my %hash; my @array;
 439 sub alv : lvalue { $array[1] }
 440 sub alv2 : lvalue { $array[$_[0]] }
 441 sub hlv : lvalue { $hash{"foo"} }
 442 sub hlv2 : lvalue { $hash{$_[0]} }
 443 $array[1] = "not ok 51\n";
 444 alv() = "ok 50\n";
 445 print alv();
 446
 447 alv2(20) = "ok 51\n";
 448 print $array[20];
 449
 450 $hash{"foo"} = "not ok 52\n";
 451 hlv() = "ok 52\n";
 452 print $hash{foo};
 453
 454 $hash{bar} = "not ok 53\n";
 455 hlv("bar") = "ok 53\n";
 456 print hlv("bar");
 457
 458 sub array : lvalue  { @array  }
 459 sub array2 : lvalue { @array2 } # This is a global.
 460 sub hash : lvalue   { %hash   }
 461 sub hash2 : lvalue  { %hash2  } # So's this.
 462 @array2 = qw(foo bar);
 463 %hash2 = qw(foo bar);
 464
 465 (array()) = qw(ok 54);
 466 print "not " unless "@array" eq "ok 54";
 467 print "ok 54\n";
 468
 469 (array2()) = qw(ok 55);
 470 print "not " unless "@array2" eq "ok 55";
 471 print "ok 55\n";
 472
 473 (hash()) = qw(ok 56);
 474 print "not " unless $hash{ok} == 56;
 475 print "ok 56\n";
 476
 477 (hash2()) = qw(ok 57);
 478 print "not " unless $hash2{ok} == 57;
 479 print "ok 57\n";
 480
 481 @array = qw(a b c d);
 482 sub aslice1 : lvalue { @array[0,2] };
 483 (aslice1()) = ("ok", "already");
 484 print "# @array\nnot " unless "@array" eq "ok b already d";
 485 print "ok 58\n";
 486
 487 @array2 = qw(a B c d);
 488 sub aslice2 : lvalue { @array2[0,2] };
 489 (aslice2()) = ("ok", "already");
 490 print "not " unless "@array2" eq "ok B already d";
 491 print "ok 59\n";
 492
 493 %hash = qw(a Alpha b Beta c Gamma);
 494 sub hslice : lvalue { @hash{"c", "b"} }
 495 (hslice()) = ("CISC", "BogoMIPS");
 496 print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS";
 497 print "ok 60\n";
 498 }
 499
 500 $str = "Hello, world!";
 501 sub sstr : lvalue { substr($str, 1, 4) }
 502 sstr() = "i";
 503 print "not " unless $str eq "Hi, world!";
 504 print "ok 61\n";
 505
 506 $str = "Made w/ JavaScript";
 507 sub veclv : lvalue { vec($str, 2, 32) }
 508 if (ord('A') != 193) {
 509     veclv() = 0x5065726C;
 510 }
 511 else { # EBCDIC?
 512     veclv() = 0xD7859993;
 513 }
 514 print "# $str\nnot " unless $str eq "Made w/ PerlScript";
 515 print "ok 62\n";
 516
 517 sub position : lvalue { pos }
 518 @p = ();
 519 $_ = "fee fi fo fum";
 520 while (/f/g) {
 521     push @p, position;
 522     position() += 6;
 523 }
 524 print "# @p\nnot " unless "@p" eq "1 8";
 525 print "ok 63\n";
 526
 527 # Bug 20001223.002: split thought that the list had only one element
 528 @ary = qw(4 5 6);
 529 sub lval1 : lvalue { $ary[0]; }
 530 sub lval2 : lvalue { $ary[1]; }
 531 (lval1(), lval2()) = split ' ', "1 2 3 4";
 532 print "not " unless join(':', @ary) eq "1:2:6";
 533 print "ok 64\n";