Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
159ad915 | 3 | print "1..75\n"; |
a687059c LW |
4 | |
5 | sub foo { | |
6 | local($a, $b) = @_; | |
7 | local($c, $d); | |
8 | $c = "ok 3\n"; | |
9 | $d = "ok 4\n"; | |
10 | { local($a,$c) = ("ok 9\n", "ok 10\n"); ($x, $y) = ($a, $c); } | |
11 | print $a, $b; | |
12 | $c . $d; | |
13 | } | |
14 | ||
15 | $a = "ok 5\n"; | |
16 | $b = "ok 6\n"; | |
17 | $c = "ok 7\n"; | |
18 | $d = "ok 8\n"; | |
19 | ||
93a17b20 | 20 | print &foo("ok 1\n","ok 2\n"); |
a687059c LW |
21 | |
22 | print $a,$b,$c,$d,$x,$y; | |
23 | ||
24 | # same thing, only with arrays and associative arrays | |
25 | ||
26 | sub foo2 { | |
27 | local($a, @b) = @_; | |
28 | local(@c, %d); | |
29 | @c = "ok 13\n"; | |
30 | $d{''} = "ok 14\n"; | |
31 | { local($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); } | |
32 | print $a, @b; | |
33 | $c[0] . $d{''}; | |
34 | } | |
35 | ||
36 | $a = "ok 15\n"; | |
37 | @b = "ok 16\n"; | |
38 | @c = "ok 17\n"; | |
39 | $d{''} = "ok 18\n"; | |
40 | ||
93a17b20 | 41 | print &foo2("ok 11\n","ok 12\n"); |
a687059c LW |
42 | |
43 | print $a,@b,@c,%d,$x,$y; | |
706a304b SM |
44 | |
45 | eval 'local($$e)'; | |
46 | print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 21\n"; | |
47 | ||
82d03984 | 48 | eval '$e = []; local(@$e)'; |
706a304b SM |
49 | print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n"; |
50 | ||
82d03984 | 51 | eval '$e = {}; local(%$e)'; |
706a304b | 52 | print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n"; |
85aff577 | 53 | |
161b7d16 SM |
54 | # Array and hash elements |
55 | ||
56 | @a = ('a', 'b', 'c'); | |
57 | { | |
58 | local($a[1]) = 'foo'; | |
59 | local($a[2]) = $a[2]; | |
2bb40b7f GS |
60 | print +($a[1] eq 'foo') ? "" : "not ", "ok 24\n"; |
61 | print +($a[2] eq 'c') ? "" : "not ", "ok 25\n"; | |
161b7d16 SM |
62 | undef @a; |
63 | } | |
2bb40b7f GS |
64 | print +($a[1] eq 'b') ? "" : "not ", "ok 26\n"; |
65 | print +($a[2] eq 'c') ? "" : "not ", "ok 27\n"; | |
66 | print +(!defined $a[0]) ? "" : "not ", "ok 28\n"; | |
161b7d16 SM |
67 | |
68 | @a = ('a', 'b', 'c'); | |
69 | { | |
70 | local($a[1]) = "X"; | |
71 | shift @a; | |
72 | } | |
2bb40b7f | 73 | print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 29\n"; |
161b7d16 SM |
74 | |
75 | %h = ('a' => 1, 'b' => 2, 'c' => 3); | |
76 | { | |
77 | local($h{'a'}) = 'foo'; | |
78 | local($h{'b'}) = $h{'b'}; | |
2bb40b7f GS |
79 | print +($h{'a'} eq 'foo') ? "" : "not ", "ok 30\n"; |
80 | print +($h{'b'} == 2) ? "" : "not ", "ok 31\n"; | |
161b7d16 SM |
81 | local($h{'c'}); |
82 | delete $h{'c'}; | |
83 | } | |
2bb40b7f GS |
84 | print +($h{'a'} == 1) ? "" : "not ", "ok 32\n"; |
85 | print +($h{'b'} == 2) ? "" : "not ", "ok 33\n"; | |
86 | print +($h{'c'} == 3) ? "" : "not ", "ok 34\n"; | |
87 | ||
88 | # check for scope leakage | |
89 | $a = 'outer'; | |
90 | if (1) { local $a = 'inner' } | |
91 | print +($a eq 'outer') ? "" : "not ", "ok 35\n"; | |
92 | ||
93 | # see if localization works when scope unwinds | |
94 | local $m = 5; | |
95 | eval { | |
96 | for $m (6) { | |
97 | local $m = 7; | |
98 | die "bye"; | |
99 | } | |
100 | }; | |
101 | print $m == 5 ? "" : "not ", "ok 36\n"; | |
4e4c362e GS |
102 | |
103 | # see if localization works on tied arrays | |
104 | { | |
105 | package TA; | |
106 | sub TIEARRAY { bless [], $_[0] } | |
107 | sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } | |
108 | sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } | |
109 | sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } | |
110 | sub FETCHSIZE { scalar(@{$_[0]}) } | |
111 | sub SHIFT { shift (@{$_[0]}) } | |
112 | sub EXTEND {} | |
113 | } | |
114 | ||
115 | tie @a, 'TA'; | |
116 | @a = ('a', 'b', 'c'); | |
117 | { | |
118 | local($a[1]) = 'foo'; | |
be6c24e0 | 119 | local($a[2]) = $a[2]; |
4e4c362e | 120 | print +($a[1] eq 'foo') ? "" : "not ", "ok 37\n"; |
be6c24e0 | 121 | print +($a[2] eq 'c') ? "" : "not ", "ok 38\n"; |
4e4c362e GS |
122 | @a = (); |
123 | } | |
124 | print +($a[1] eq 'b') ? "" : "not ", "ok 39\n"; | |
125 | print +($a[2] eq 'c') ? "" : "not ", "ok 40\n"; | |
126 | print +(!defined $a[0]) ? "" : "not ", "ok 41\n"; | |
127 | ||
128 | { | |
129 | package TH; | |
130 | sub TIEHASH { bless {}, $_[0] } | |
131 | sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } | |
132 | sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } | |
c39e6ab0 | 133 | sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; } |
4e4c362e GS |
134 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } |
135 | sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } | |
136 | } | |
137 | ||
138 | # see if localization works on tied hashes | |
139 | tie %h, 'TH'; | |
140 | %h = ('a' => 1, 'b' => 2, 'c' => 3); | |
141 | ||
142 | { | |
143 | local($h{'a'}) = 'foo'; | |
be6c24e0 | 144 | local($h{'b'}) = $h{'b'}; |
159ad915 DM |
145 | local($h{'y'}); |
146 | local($h{'z'}) = 33; | |
4e4c362e | 147 | print +($h{'a'} eq 'foo') ? "" : "not ", "ok 42\n"; |
be6c24e0 | 148 | print +($h{'b'} == 2) ? "" : "not ", "ok 43\n"; |
4e4c362e GS |
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 | ||
be6c24e0 GS |
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 | { | |
159ad915 DM |
188 | local($ENV{_A_}); |
189 | local($ENV{_B_}) = 'foo'; | |
be6c24e0 GS |
190 | local($ENV{_X_}) = 'foo'; |
191 | local($ENV{_Y_}) = $ENV{_Y_}; | |
192 | print +($ENV{_X_} eq 'foo') ? "" : "not ", "ok 54\n"; | |
193 | print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 55\n"; | |
194 | local($ENV{_Z_}); | |
195 | delete $ENV{_Z_}; | |
196 | } | |
197 | print +($ENV{_X_} eq 'a') ? "" : "not ", "ok 56\n"; | |
198 | print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 57\n"; | |
199 | print +($ENV{_Z_} eq 'c') ? "" : "not ", "ok 58\n"; | |
200 | ||
0214ae40 GS |
201 | # does implicit localization in foreach skip magic? |
202 | ||
203 | $_ = "ok 59,ok 60,"; | |
204 | my $iter = 0; | |
205 | while (/(o.+?),/gc) { | |
206 | print "$1\n"; | |
207 | foreach (1..1) { $iter++ } | |
208 | if ($iter > 2) { print "not ok 60\n"; last; } | |
209 | } | |
210 | ||
211 | { | |
212 | package UnderScore; | |
213 | sub TIESCALAR { bless \my $self, shift } | |
214 | sub FETCH { die "read \$_ forbidden" } | |
215 | sub STORE { die "write \$_ forbidden" } | |
216 | tie $_, __PACKAGE__; | |
217 | my $t = 61; | |
218 | my @tests = ( | |
219 | "Nesting" => sub { print '#'; for (1..3) { print } | |
220 | print "\n" }, 1, | |
221 | "Reading" => sub { print }, 0, | |
222 | "Matching" => sub { $x = /badness/ }, 0, | |
223 | "Concat" => sub { $_ .= "a" }, 0, | |
224 | "Chop" => sub { chop }, 0, | |
225 | "Filetest" => sub { -x }, 0, | |
226 | "Assignment" => sub { $_ = "Bad" }, 0, | |
227 | # XXX whether next one should fail is debatable | |
228 | "Local \$_" => sub { local $_ = 'ok?'; print }, 0, | |
229 | "for local" => sub { for("#ok?\n"){ print } }, 1, | |
230 | ); | |
231 | while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { | |
232 | print "# Testing $name\n"; | |
233 | eval { &$code }; | |
234 | print(($ok xor $@) ? "ok $t\n" : "not ok $t\n"); | |
235 | ++$t; | |
236 | } | |
237 | untie $_; | |
238 | } | |
239 | ||
1f5346dc SC |
240 | { |
241 | # BUG 20001205.22 | |
242 | my %x; | |
243 | $x{a} = 1; | |
244 | { local $x{b} = 1; } | |
245 | print "not " if exists $x{b}; | |
246 | print "ok 70\n"; | |
247 | { local @x{c,d,e}; } | |
248 | print "not " if exists $x{c}; | |
249 | print "ok 71\n"; | |
250 | } | |
159ad915 DM |
251 | |
252 | # these tests should be physically located after tests 46 and 58, | |
253 | # but are here instead to avoid renumbering everything. | |
254 | ||
255 | # local() should preserve the existenceness of tied hashes and %ENV | |
256 | print "not " if exists $h{'y'}; print "ok 72\n"; | |
257 | print "not " if exists $h{'z'}; print "ok 73\n"; | |
258 | print "not " if exists $ENV{_A_}; print "ok 74\n"; | |
259 | print "not " if exists $ENV{_B_}; print "ok 75\n"; |