Commit | Line | Data |
a687059c |
1 | #!./perl |
2 | |
d441d3db |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | require './test.pl'; |
6 | } |
658aef79 |
7 | plan tests => 114; |
a687059c |
8 | |
13414bd5 |
9 | my $list_assignment_supported = 1; |
10 | |
11 | #mg.c says list assignment not supported on VMS, EPOC, and SYMBIAN. |
12 | $list_assignment_supported = 0 if ($^O eq 'VMS'); |
13 | |
14 | |
a687059c |
15 | sub foo { |
16 | local($a, $b) = @_; |
17 | local($c, $d); |
d441d3db |
18 | $c = "c 3"; |
19 | $d = "d 4"; |
20 | { local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); } |
21 | is($a, "a 1"); |
22 | is($b, "b 2"); |
23 | $c, $d; |
a687059c |
24 | } |
25 | |
d441d3db |
26 | $a = "a 5"; |
27 | $b = "b 6"; |
28 | $c = "c 7"; |
29 | $d = "d 8"; |
a687059c |
30 | |
d441d3db |
31 | my @res; |
32 | @res = &foo("a 1","b 2"); |
33 | is($res[0], "c 3"); |
34 | is($res[1], "d 4"); |
a687059c |
35 | |
d441d3db |
36 | is($a, "a 5"); |
37 | is($b, "b 6"); |
38 | is($c, "c 7"); |
39 | is($d, "d 8"); |
40 | is($x, "a 9"); |
41 | is($y, "c 10"); |
a687059c |
42 | |
43 | # same thing, only with arrays and associative arrays |
44 | |
45 | sub foo2 { |
46 | local($a, @b) = @_; |
47 | local(@c, %d); |
d441d3db |
48 | @c = "c 3"; |
49 | $d{''} = "d 4"; |
50 | { local($a,@c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); } |
51 | is($a, "a 1"); |
52 | is("@b", "b 2"); |
53 | $c[0], $d{''}; |
a687059c |
54 | } |
55 | |
d441d3db |
56 | $a = "a 5"; |
57 | @b = "b 6"; |
58 | @c = "c 7"; |
59 | $d{''} = "d 8"; |
60 | |
61 | @res = &foo2("a 1","b 2"); |
62 | is($res[0], "c 3"); |
63 | is($res[1], "d 4"); |
a687059c |
64 | |
d441d3db |
65 | is($a, "a 5"); |
66 | is("@b", "b 6"); |
67 | is($c[0], "c 7"); |
68 | is($d{''}, "d 8"); |
69 | is($x, "a 19"); |
70 | is($y, "c 20"); |
a687059c |
71 | |
706a304b |
72 | |
73 | eval 'local($$e)'; |
d441d3db |
74 | like($@, qr/Can't localize through a reference/); |
706a304b |
75 | |
82d03984 |
76 | eval '$e = []; local(@$e)'; |
d441d3db |
77 | like($@, qr/Can't localize through a reference/); |
706a304b |
78 | |
82d03984 |
79 | eval '$e = {}; local(%$e)'; |
d441d3db |
80 | like($@, qr/Can't localize through a reference/); |
85aff577 |
81 | |
161b7d16 |
82 | # Array and hash elements |
83 | |
84 | @a = ('a', 'b', 'c'); |
85 | { |
86 | local($a[1]) = 'foo'; |
87 | local($a[2]) = $a[2]; |
d441d3db |
88 | is($a[1], 'foo'); |
89 | is($a[2], 'c'); |
161b7d16 |
90 | undef @a; |
91 | } |
d441d3db |
92 | is($a[1], 'b'); |
93 | is($a[2], 'c'); |
94 | ok(!defined $a[0]); |
161b7d16 |
95 | |
96 | @a = ('a', 'b', 'c'); |
97 | { |
98 | local($a[1]) = "X"; |
99 | shift @a; |
100 | } |
d441d3db |
101 | is($a[0].$a[1], "Xb"); |
d60c5a05 |
102 | { |
103 | my $d = "@a"; |
104 | local @a = @a; |
105 | is("@a", $d); |
106 | } |
161b7d16 |
107 | |
108 | %h = ('a' => 1, 'b' => 2, 'c' => 3); |
109 | { |
110 | local($h{'a'}) = 'foo'; |
111 | local($h{'b'}) = $h{'b'}; |
d441d3db |
112 | is($h{'a'}, 'foo'); |
113 | is($h{'b'}, 2); |
161b7d16 |
114 | local($h{'c'}); |
115 | delete $h{'c'}; |
116 | } |
d441d3db |
117 | is($h{'a'}, 1); |
118 | is($h{'b'}, 2); |
d60c5a05 |
119 | { |
120 | my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); |
121 | local %h = %h; |
122 | is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); |
123 | } |
d441d3db |
124 | is($h{'c'}, 3); |
2bb40b7f |
125 | |
126 | # check for scope leakage |
127 | $a = 'outer'; |
128 | if (1) { local $a = 'inner' } |
d441d3db |
129 | is($a, 'outer'); |
2bb40b7f |
130 | |
131 | # see if localization works when scope unwinds |
132 | local $m = 5; |
133 | eval { |
134 | for $m (6) { |
135 | local $m = 7; |
136 | die "bye"; |
137 | } |
138 | }; |
d441d3db |
139 | is($m, 5); |
4e4c362e |
140 | |
141 | # see if localization works on tied arrays |
142 | { |
143 | package TA; |
144 | sub TIEARRAY { bless [], $_[0] } |
145 | sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } |
146 | sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } |
147 | sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } |
148 | sub FETCHSIZE { scalar(@{$_[0]}) } |
149 | sub SHIFT { shift (@{$_[0]}) } |
150 | sub EXTEND {} |
151 | } |
152 | |
153 | tie @a, 'TA'; |
154 | @a = ('a', 'b', 'c'); |
155 | { |
156 | local($a[1]) = 'foo'; |
be6c24e0 |
157 | local($a[2]) = $a[2]; |
d441d3db |
158 | is($a[1], 'foo'); |
159 | is($a[2], 'c'); |
4e4c362e |
160 | @a = (); |
161 | } |
d441d3db |
162 | is($a[1], 'b'); |
163 | is($a[2], 'c'); |
164 | ok(!defined $a[0]); |
d60c5a05 |
165 | { |
166 | my $d = "@a"; |
167 | local @a = @a; |
168 | is("@a", $d); |
169 | } |
4e4c362e |
170 | |
171 | { |
172 | package TH; |
173 | sub TIEHASH { bless {}, $_[0] } |
174 | sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } |
175 | sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } |
c39e6ab0 |
176 | sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; } |
4e4c362e |
177 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } |
178 | sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } |
d60c5a05 |
179 | sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} } |
180 | sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} } |
4e4c362e |
181 | } |
182 | |
183 | # see if localization works on tied hashes |
184 | tie %h, 'TH'; |
185 | %h = ('a' => 1, 'b' => 2, 'c' => 3); |
186 | |
187 | { |
188 | local($h{'a'}) = 'foo'; |
be6c24e0 |
189 | local($h{'b'}) = $h{'b'}; |
159ad915 |
190 | local($h{'y'}); |
191 | local($h{'z'}) = 33; |
d441d3db |
192 | is($h{'a'}, 'foo'); |
193 | is($h{'b'}, 2); |
4e4c362e |
194 | local($h{'c'}); |
195 | delete $h{'c'}; |
196 | } |
d441d3db |
197 | is($h{'a'}, 1); |
198 | is($h{'b'}, 2); |
199 | is($h{'c'}, 3); |
200 | # local() should preserve the existenceness of tied hash elements |
201 | ok(! exists $h{'y'}); |
202 | ok(! exists $h{'z'}); |
d60c5a05 |
203 | TODO: { |
204 | todo_skip("Localize entire tied hash"); |
205 | my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); |
206 | local %h = %h; |
207 | is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); |
208 | } |
4e4c362e |
209 | |
210 | @a = ('a', 'b', 'c'); |
211 | { |
212 | local($a[1]) = "X"; |
213 | shift @a; |
214 | } |
d441d3db |
215 | is($a[0].$a[1], "Xb"); |
4e4c362e |
216 | |
be6c24e0 |
217 | # now try the same for %SIG |
218 | |
219 | $SIG{TERM} = 'foo'; |
220 | $SIG{INT} = \&foo; |
221 | $SIG{__WARN__} = $SIG{INT}; |
222 | { |
223 | local($SIG{TERM}) = $SIG{TERM}; |
224 | local($SIG{INT}) = $SIG{INT}; |
225 | local($SIG{__WARN__}) = $SIG{__WARN__}; |
d441d3db |
226 | is($SIG{TERM}, 'main::foo'); |
227 | is($SIG{INT}, \&foo); |
228 | is($SIG{__WARN__}, \&foo); |
be6c24e0 |
229 | local($SIG{INT}); |
230 | delete $SIG{__WARN__}; |
231 | } |
d441d3db |
232 | is($SIG{TERM}, 'main::foo'); |
233 | is($SIG{INT}, \&foo); |
234 | is($SIG{__WARN__}, \&foo); |
d60c5a05 |
235 | { |
236 | my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG); |
237 | local %SIG = %SIG; |
238 | is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d); |
239 | } |
be6c24e0 |
240 | |
241 | # and for %ENV |
242 | |
243 | $ENV{_X_} = 'a'; |
244 | $ENV{_Y_} = 'b'; |
245 | $ENV{_Z_} = 'c'; |
246 | { |
159ad915 |
247 | local($ENV{_A_}); |
248 | local($ENV{_B_}) = 'foo'; |
be6c24e0 |
249 | local($ENV{_X_}) = 'foo'; |
250 | local($ENV{_Y_}) = $ENV{_Y_}; |
d441d3db |
251 | is($ENV{_X_}, 'foo'); |
252 | is($ENV{_Y_}, 'b'); |
be6c24e0 |
253 | local($ENV{_Z_}); |
254 | delete $ENV{_Z_}; |
255 | } |
d441d3db |
256 | is($ENV{_X_}, 'a'); |
257 | is($ENV{_Y_}, 'b'); |
258 | is($ENV{_Z_}, 'c'); |
259 | # local() should preserve the existenceness of %ENV elements |
260 | ok(! exists $ENV{_A_}); |
261 | ok(! exists $ENV{_B_}); |
13414bd5 |
262 | |
263 | SKIP: { |
264 | skip("Can't make list assignment to \%ENV on this system") |
265 | unless $list_assignment_supported; |
d60c5a05 |
266 | my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV); |
267 | local %ENV = %ENV; |
268 | is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d); |
269 | } |
be6c24e0 |
270 | |
0214ae40 |
271 | # does implicit localization in foreach skip magic? |
272 | |
d441d3db |
273 | $_ = "o 0,o 1,"; |
0214ae40 |
274 | my $iter = 0; |
275 | while (/(o.+?),/gc) { |
d441d3db |
276 | is($1, "o $iter"); |
0214ae40 |
277 | foreach (1..1) { $iter++ } |
d441d3db |
278 | if ($iter > 2) { fail("endless loop"); last; } |
0214ae40 |
279 | } |
280 | |
281 | { |
282 | package UnderScore; |
283 | sub TIESCALAR { bless \my $self, shift } |
284 | sub FETCH { die "read \$_ forbidden" } |
285 | sub STORE { die "write \$_ forbidden" } |
286 | tie $_, __PACKAGE__; |
0214ae40 |
287 | my @tests = ( |
288 | "Nesting" => sub { print '#'; for (1..3) { print } |
289 | print "\n" }, 1, |
290 | "Reading" => sub { print }, 0, |
291 | "Matching" => sub { $x = /badness/ }, 0, |
292 | "Concat" => sub { $_ .= "a" }, 0, |
293 | "Chop" => sub { chop }, 0, |
294 | "Filetest" => sub { -x }, 0, |
295 | "Assignment" => sub { $_ = "Bad" }, 0, |
296 | # XXX whether next one should fail is debatable |
297 | "Local \$_" => sub { local $_ = 'ok?'; print }, 0, |
298 | "for local" => sub { for("#ok?\n"){ print } }, 1, |
299 | ); |
300 | while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { |
0214ae40 |
301 | eval { &$code }; |
d441d3db |
302 | main::ok(($ok xor $@), "Underscore '$name'"); |
0214ae40 |
303 | } |
304 | untie $_; |
305 | } |
306 | |
1f5346dc |
307 | { |
308 | # BUG 20001205.22 |
309 | my %x; |
310 | $x{a} = 1; |
311 | { local $x{b} = 1; } |
d441d3db |
312 | ok(! exists $x{b}); |
1f5346dc |
313 | { local @x{c,d,e}; } |
d441d3db |
314 | ok(! exists $x{c}); |
1f5346dc |
315 | } |
159ad915 |
316 | |
33f3c7b8 |
317 | # local() and readonly magic variables |
318 | |
319 | eval { local $1 = 1 }; |
d441d3db |
320 | like($@, qr/Modification of a read-only value attempted/); |
33f3c7b8 |
321 | |
322 | eval { for ($1) { local $_ = 1 } }; |
d441d3db |
323 | like($@, qr/Modification of a read-only value attempted/); |
33f3c7b8 |
324 | |
0cbee0a4 |
325 | # make sure $1 is still read-only |
33f3c7b8 |
326 | eval { for ($1) { local $_ = 1 } }; |
d441d3db |
327 | like($@, qr/Modification of a read-only value attempted/); |
ac117f44 |
328 | |
329 | # The s/// adds 'g' magic to $_, but it should remain non-readonly |
330 | eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } }; |
d441d3db |
331 | is($@, ""); |
4cb09e0a |
332 | |
333 | # Special local() behavior for $[ |
334 | # (see RT #38207 - Useless localization of constant ($[) in getopts.pl} |
335 | { |
336 | local $[ = 1; |
337 | local $TODO = "local() not currently working correctly with \$["; |
338 | ok(1 == $[); |
339 | undef $TODO; |
340 | f(); |
341 | } |
342 | |
343 | sub f { ok(0 == $[); } |
344 | |
985d6f61 |
345 | # sub localisation |
346 | { |
347 | package Other; |
348 | |
349 | sub f1 { "f1" } |
350 | sub f2 { "f2" } |
351 | |
352 | no warnings "redefine"; |
353 | { |
354 | local *f1 = sub { "g1" }; |
355 | ::ok(f1() eq "g1", "localised sub via glob"); |
356 | } |
357 | ::ok(f1() eq "f1", "localised sub restored"); |
358 | { |
359 | local $Other::{"f1"} = sub { "h1" }; |
360 | ::ok(f1() eq "h1", "localised sub via stash"); |
361 | } |
362 | ::ok(f1() eq "f1", "localised sub restored"); |
363 | { |
364 | local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" }); |
985d6f61 |
365 | ::ok(f1() eq "j1", "localised sub via stash slice"); |
366 | ::ok(f2() eq "j2", "localised sub via stash slice"); |
985d6f61 |
367 | } |
368 | ::ok(f1() eq "f1", "localised sub restored"); |
369 | ::ok(f2() eq "f2", "localised sub restored"); |
370 | } |
7d654f43 |
371 | |
372 | # Localising unicode keys (bug #38815) |
373 | { |
374 | my %h; |
375 | $h{"\243"} = "pound"; |
376 | $h{"\302\240"} = "octects"; |
377 | is(scalar keys %h, 2); |
378 | { |
379 | my $unicode = chr 256; |
380 | my $ambigous = "\240" . $unicode; |
381 | chop $ambigous; |
382 | local $h{$unicode} = 256; |
383 | local $h{$ambigous} = 160; |
384 | |
385 | is(scalar keys %h, 4); |
386 | is($h{"\243"}, "pound"); |
387 | is($h{$unicode}, 256); |
388 | is($h{$ambigous}, 160); |
389 | is($h{"\302\240"}, "octects"); |
390 | } |
391 | is(scalar keys %h, 2); |
392 | is($h{"\243"}, "pound"); |
393 | is($h{"\302\240"}, "octects"); |
394 | } |
919acde0 |
395 | |
396 | # And with slices |
397 | { |
398 | my %h; |
399 | $h{"\243"} = "pound"; |
400 | $h{"\302\240"} = "octects"; |
401 | is(scalar keys %h, 2); |
402 | { |
403 | my $unicode = chr 256; |
404 | my $ambigous = "\240" . $unicode; |
405 | chop $ambigous; |
406 | local @h{$unicode, $ambigous} = (256, 160); |
407 | |
408 | is(scalar keys %h, 4); |
409 | is($h{"\243"}, "pound"); |
410 | is($h{$unicode}, 256); |
411 | is($h{$ambigous}, 160); |
412 | is($h{"\302\240"}, "octects"); |
413 | } |
414 | is(scalar keys %h, 2); |
415 | is($h{"\243"}, "pound"); |
416 | is($h{"\302\240"}, "octects"); |
417 | } |
658aef79 |
418 | |
419 | # [perl #39012] localizing @_ element then shifting frees element too # soon |
420 | |
421 | { |
422 | my $x; |
423 | my $y = bless [], 'X39012'; |
424 | sub X39012::DESTROY { $x++ } |
425 | sub { local $_[0]; shift }->($y); |
426 | ok(!$x, '[perl #39012]'); |
427 | |
428 | } |
429 | |