home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / pragma / sub_lval.t < prev    next >
Text File  |  1999-10-01  |  7KB  |  430 lines
  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";
  430.