home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / local.t < prev    next >
Text File  |  1999-07-20  |  6KB  |  238 lines
  1. #!./perl
  2.  
  3. print "1..69\n";
  4.  
  5. # XXX known to leak scalars
  6. $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
  7.  
  8. sub foo {
  9.     local($a, $b) = @_;
  10.     local($c, $d);
  11.     $c = "ok 3\n";
  12.     $d = "ok 4\n";
  13.     { local($a,$c) = ("ok 9\n", "ok 10\n"); ($x, $y) = ($a, $c); }
  14.     print $a, $b;
  15.     $c . $d;
  16. }
  17.  
  18. $a = "ok 5\n";
  19. $b = "ok 6\n";
  20. $c = "ok 7\n";
  21. $d = "ok 8\n";
  22.  
  23. print &foo("ok 1\n","ok 2\n");
  24.  
  25. print $a,$b,$c,$d,$x,$y;
  26.  
  27. # same thing, only with arrays and associative arrays
  28.  
  29. sub foo2 {
  30.     local($a, @b) = @_;
  31.     local(@c, %d);
  32.     @c = "ok 13\n";
  33.     $d{''} = "ok 14\n";
  34.     { local($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); }
  35.     print $a, @b;
  36.     $c[0] . $d{''};
  37. }
  38.  
  39. $a = "ok 15\n";
  40. @b = "ok 16\n";
  41. @c = "ok 17\n";
  42. $d{''} = "ok 18\n";
  43.  
  44. print &foo2("ok 11\n","ok 12\n");
  45.  
  46. print $a,@b,@c,%d,$x,$y;
  47.  
  48. eval 'local($$e)';
  49. print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 21\n";
  50.  
  51. eval 'local(@$e)';
  52. print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n";
  53.  
  54. eval 'local(%$e)';
  55. print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n";
  56.  
  57. # Array and hash elements
  58.  
  59. @a = ('a', 'b', 'c');
  60. {
  61.     local($a[1]) = 'foo';
  62.     local($a[2]) = $a[2];
  63.     print +($a[1] eq 'foo') ? "" : "not ", "ok 24\n";
  64.     print +($a[2] eq 'c') ? "" : "not ", "ok 25\n";
  65.     undef @a;
  66. }
  67. print +($a[1] eq 'b') ? "" : "not ", "ok 26\n";
  68. print +($a[2] eq 'c') ? "" : "not ", "ok 27\n";
  69. print +(!defined $a[0]) ? "" : "not ", "ok 28\n";
  70.  
  71. @a = ('a', 'b', 'c');
  72. {
  73.     local($a[1]) = "X";
  74.     shift @a;
  75. }
  76. print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 29\n";
  77.  
  78. %h = ('a' => 1, 'b' => 2, 'c' => 3);
  79. {
  80.     local($h{'a'}) = 'foo';
  81.     local($h{'b'}) = $h{'b'};
  82.     print +($h{'a'} eq 'foo') ? "" : "not ", "ok 30\n";
  83.     print +($h{'b'} == 2) ? "" : "not ", "ok 31\n";
  84.     local($h{'c'});
  85.     delete $h{'c'};
  86. }
  87. print +($h{'a'} == 1) ? "" : "not ", "ok 32\n";
  88. print +($h{'b'} == 2) ? "" : "not ", "ok 33\n";
  89. print +($h{'c'} == 3) ? "" : "not ", "ok 34\n";
  90.  
  91. # check for scope leakage
  92. $a = 'outer';
  93. if (1) { local $a = 'inner' }
  94. print +($a eq 'outer') ? "" : "not ", "ok 35\n";
  95.  
  96. # see if localization works when scope unwinds
  97. local $m = 5;
  98. eval {
  99.     for $m (6) {
  100.     local $m = 7;
  101.     die "bye";
  102.     }
  103. };
  104. print $m == 5 ? "" : "not ", "ok 36\n";
  105.  
  106. # see if localization works on tied arrays
  107. {
  108.     package TA;
  109.     sub TIEARRAY { bless [], $_[0] }
  110.     sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] }
  111.     sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v }
  112.     sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); }
  113.     sub FETCHSIZE { scalar(@{$_[0]}) }
  114.     sub SHIFT { shift (@{$_[0]}) }
  115.     sub EXTEND {}
  116. }
  117.  
  118. tie @a, 'TA';
  119. @a = ('a', 'b', 'c');
  120. {
  121.     local($a[1]) = 'foo';
  122.     local($a[2]) = $a[2];
  123.     print +($a[1] eq 'foo') ? "" : "not ", "ok 37\n";
  124.     print +($a[2] eq 'c') ? "" : "not ", "ok 38\n";
  125.     @a = ();
  126. }
  127. print +($a[1] eq 'b') ? "" : "not ", "ok 39\n";
  128. print +($a[2] eq 'c') ? "" : "not ", "ok 40\n";
  129. print +(!defined $a[0]) ? "" : "not ", "ok 41\n";
  130.  
  131. {
  132.     package TH;
  133.     sub TIEHASH { bless {}, $_[0] }
  134.     sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] }
  135.     sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v }
  136.     sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; }
  137.     sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); }
  138. }
  139.  
  140. # see if localization works on tied hashes
  141. tie %h, 'TH';
  142. %h = ('a' => 1, 'b' => 2, 'c' => 3);
  143.  
  144. {
  145.     local($h{'a'}) = 'foo';
  146.     local($h{'b'}) = $h{'b'};
  147.     print +($h{'a'} eq 'foo') ? "" : "not ", "ok 42\n";
  148.     print +($h{'b'} == 2) ? "" : "not ", "ok 43\n";
  149.     local($h{'c'});
  150.     delete $h{'c'};
  151. }
  152. print +($h{'a'} == 1) ? "" : "not ", "ok 44\n";
  153. print +($h{'b'} == 2) ? "" : "not ", "ok 45\n";
  154. print +($h{'c'} == 3) ? "" : "not ", "ok 46\n";
  155.  
  156. @a = ('a', 'b', 'c');
  157. {
  158.     local($a[1]) = "X";
  159.     shift @a;
  160. }
  161. print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 47\n";
  162.  
  163. # now try the same for %SIG
  164.  
  165. $SIG{TERM} = 'foo';
  166. $SIG{INT} = \&foo;
  167. $SIG{__WARN__} = $SIG{INT};
  168. {
  169.     local($SIG{TERM}) = $SIG{TERM};
  170.     local($SIG{INT}) = $SIG{INT};
  171.     local($SIG{__WARN__}) = $SIG{__WARN__};
  172.     print +($SIG{TERM}        eq 'main::foo') ? "" : "not ", "ok 48\n";
  173.     print +($SIG{INT}        eq \&foo) ? "" : "not ", "ok 49\n";
  174.     print +($SIG{__WARN__}    eq \&foo) ? "" : "not ", "ok 50\n";
  175.     local($SIG{INT});
  176.     delete $SIG{__WARN__};
  177. }
  178. print +($SIG{TERM}    eq 'main::foo') ? "" : "not ", "ok 51\n";
  179. print +($SIG{INT}    eq \&foo) ? "" : "not ", "ok 52\n";
  180. print +($SIG{__WARN__}    eq \&foo) ? "" : "not ", "ok 53\n";
  181.  
  182. # and for %ENV
  183.  
  184. $ENV{_X_} = 'a';
  185. $ENV{_Y_} = 'b';
  186. $ENV{_Z_} = 'c';
  187. {
  188.     local($ENV{_X_}) = 'foo';
  189.     local($ENV{_Y_}) = $ENV{_Y_};
  190.     print +($ENV{_X_} eq 'foo') ? "" : "not ", "ok 54\n";
  191.     print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 55\n";
  192.     local($ENV{_Z_});
  193.     delete $ENV{_Z_};
  194. }
  195. print +($ENV{_X_} eq 'a') ? "" : "not ", "ok 56\n";
  196. print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 57\n";
  197. print +($ENV{_Z_} eq 'c') ? "" : "not ", "ok 58\n";
  198.  
  199. # does implicit localization in foreach skip magic?
  200.  
  201. $_ = "ok 59,ok 60,";
  202. my $iter = 0;
  203. while (/(o.+?),/gc) {
  204.     print "$1\n";
  205.     foreach (1..1) { $iter++ }
  206.     if ($iter > 2) { print "not ok 60\n"; last; }
  207. }
  208.  
  209. {
  210.     package UnderScore;
  211.     sub TIESCALAR { bless \my $self, shift }
  212.     sub FETCH { die "read  \$_ forbidden" }
  213.     sub STORE { die "write \$_ forbidden" }
  214.     tie $_, __PACKAGE__;
  215.     my $t = 61;
  216.     my @tests = (
  217.     "Nesting"     => sub { print '#'; for (1..3) { print }
  218.                    print "\n" },            1,
  219.     "Reading"     => sub { print },                0,
  220.     "Matching"    => sub { $x = /badness/ },        0,
  221.     "Concat"      => sub { $_ .= "a" },            0,
  222.     "Chop"        => sub { chop },                0,
  223.     "Filetest"    => sub { -x },                0,
  224.     "Assignment"  => sub { $_ = "Bad" },            0,
  225.     # XXX whether next one should fail is debatable
  226.     "Local \$_"   => sub { local $_  = 'ok?'; print },    0,
  227.     "for local"   => sub { for("#ok?\n"){ print } },    1,
  228.     );
  229.     while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) {
  230.     print "# Testing $name\n";
  231.     eval { &$code };
  232.     print(($ok xor $@) ? "ok $t\n" : "not ok $t\n");
  233.     ++$t;
  234.     }
  235.     untie $_;
  236. }
  237.  
  238.