t/pragma/sub_lval.t

   1 print "1..46\n";
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     unshift @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 sub lv1t : lvalue { index $x, 2 }
 292
 293 $_ = undef;
 294 eval <<'EOE' or $_ = $@;
 295   lv1t = (2,3);
 296   1;
 297 EOE
 298
 299 print "# '$_'.\nnot "
 300   unless /Can\'t return a temporary from lvalue subroutine/;
 301 print "ok 35\n";
 302
 303 $_ = undef;
 304 eval <<'EOE' or $_ = $@;
 305   (lv1t) = (2,3);
 306   1;
 307 EOE
 308
 309 print "# '$_'.\nnot "
 310   unless /Can\'t return a temporary from lvalue subroutine/;
 311 print "ok 36\n";
 312
 313 $xxx = 'xxx';
 314 sub xxx () { $xxx }  # Not lvalue
 315 sub lv1tmp : lvalue { xxx }                     # is it a TEMP?
 316
 317 $_ = undef;
 318 eval <<'EOE' or $_ = $@;
 319   lv1tmp = (2,3);
 320   1;
 321 EOE
 322
 323 print "# '$_'.\nnot "
 324   unless /Can\'t return a temporary from lvalue subroutine/;
 325 print "ok 37\n";
 326
 327 $_ = undef;
 328 eval <<'EOE' or $_ = $@;
 329   (lv1tmp) = (2,3);
 330   1;
 331 EOE
 332
 333 print "# '$_'.\nnot "
 334   unless /Can\'t return a temporary from lvalue subroutine/;
 335 print "ok 38\n";
 336
 337 sub xxx () { 'xxx' } # Not lvalue
 338 sub lv1tmpr : lvalue { xxx }                    # is it a TEMP?
 339
 340 $_ = undef;
 341 eval <<'EOE' or $_ = $@;
 342   lv1tmpr = (2,3);
 343   1;
 344 EOE
 345
 346 print "# '$_'.\nnot "
 347   unless /Can\'t return a readonly value from lvalue subroutine/;
 348 print "ok 39\n";
 349
 350 $_ = undef;
 351 eval <<'EOE' or $_ = $@;
 352   (lv1tmpr) = (2,3);
 353   1;
 354 EOE
 355
 356 print "# '$_'.\nnot "
 357   unless /Can\'t return a readonly value from lvalue subroutine/;
 358 print "ok 40\n";
 359
 360 =for disabled constructs
 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 "
 373   unless /Can\'t return an uninitialized value from lvalue subroutine/;
 374 print "ok 41\n";
 375
 376 $_ = undef;
 377 @a = ();
 378 $a[0] = undef;
 379 $a[1] = 12;
 380 eval <<'EOE' or $_ = $@;
 381   (lva) = (2,3);
 382   1;
 383 EOE
 384
 385 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 386 print "ok 42\n";
 387
 388 $_ = undef;
 389 @a = ();
 390 $a[0] = undef;
 391 $a[1] = 12;
 392 eval <<'EOE' or $_ = $@;
 393   (lva) = (2,3);
 394   1;
 395 EOE
 396
 397 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 398 print "ok 43\n";
 399
 400 =cut
 401
 402 print "ok $_\n" for 41..43;
 403
 404 sub lv1n : lvalue { $newvar }
 405
 406 $_ = undef;
 407 eval <<'EOE' or $_ = $@;
 408   lv1n = (3,4);
 409   1;
 410 EOE
 411
 412 print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' ";
 413 print "ok 44\n";
 414
 415 sub lv1nn : lvalue { $nnewvar }
 416
 417 $_ = undef;
 418 eval <<'EOE' or $_ = $@;
 419   (lv1nn) = (3,4);
 420   1;
 421 EOE
 422
 423 print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' ";
 424 print "ok 45\n";
 425
 426 $a = \&lv1nn;
 427 $a->() = 8;
 428 print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
 429 print "ok 46\n";