Commit | Line | Data |
a687059c |
1 | #!./perl |
2 | |
d441d3db |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | require './test.pl'; |
6 | } |
7 | plan tests => 79; |
a687059c |
8 | |
9 | sub foo { |
10 | local($a, $b) = @_; |
11 | local($c, $d); |
d441d3db |
12 | $c = "c 3"; |
13 | $d = "d 4"; |
14 | { local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); } |
15 | is($a, "a 1"); |
16 | is($b, "b 2"); |
17 | $c, $d; |
a687059c |
18 | } |
19 | |
d441d3db |
20 | $a = "a 5"; |
21 | $b = "b 6"; |
22 | $c = "c 7"; |
23 | $d = "d 8"; |
a687059c |
24 | |
d441d3db |
25 | my @res; |
26 | @res = &foo("a 1","b 2"); |
27 | is($res[0], "c 3"); |
28 | is($res[1], "d 4"); |
a687059c |
29 | |
d441d3db |
30 | is($a, "a 5"); |
31 | is($b, "b 6"); |
32 | is($c, "c 7"); |
33 | is($d, "d 8"); |
34 | is($x, "a 9"); |
35 | is($y, "c 10"); |
a687059c |
36 | |
37 | # same thing, only with arrays and associative arrays |
38 | |
39 | sub foo2 { |
40 | local($a, @b) = @_; |
41 | local(@c, %d); |
d441d3db |
42 | @c = "c 3"; |
43 | $d{''} = "d 4"; |
44 | { local($a,@c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); } |
45 | is($a, "a 1"); |
46 | is("@b", "b 2"); |
47 | $c[0], $d{''}; |
a687059c |
48 | } |
49 | |
d441d3db |
50 | $a = "a 5"; |
51 | @b = "b 6"; |
52 | @c = "c 7"; |
53 | $d{''} = "d 8"; |
54 | |
55 | @res = &foo2("a 1","b 2"); |
56 | is($res[0], "c 3"); |
57 | is($res[1], "d 4"); |
a687059c |
58 | |
d441d3db |
59 | is($a, "a 5"); |
60 | is("@b", "b 6"); |
61 | is($c[0], "c 7"); |
62 | is($d{''}, "d 8"); |
63 | is($x, "a 19"); |
64 | is($y, "c 20"); |
a687059c |
65 | |
706a304b |
66 | |
67 | eval 'local($$e)'; |
d441d3db |
68 | like($@, qr/Can't localize through a reference/); |
706a304b |
69 | |
82d03984 |
70 | eval '$e = []; local(@$e)'; |
d441d3db |
71 | like($@, qr/Can't localize through a reference/); |
706a304b |
72 | |
82d03984 |
73 | eval '$e = {}; local(%$e)'; |
d441d3db |
74 | like($@, qr/Can't localize through a reference/); |
85aff577 |
75 | |
161b7d16 |
76 | # Array and hash elements |
77 | |
78 | @a = ('a', 'b', 'c'); |
79 | { |
80 | local($a[1]) = 'foo'; |
81 | local($a[2]) = $a[2]; |
d441d3db |
82 | is($a[1], 'foo'); |
83 | is($a[2], 'c'); |
161b7d16 |
84 | undef @a; |
85 | } |
d441d3db |
86 | is($a[1], 'b'); |
87 | is($a[2], 'c'); |
88 | ok(!defined $a[0]); |
161b7d16 |
89 | |
90 | @a = ('a', 'b', 'c'); |
91 | { |
92 | local($a[1]) = "X"; |
93 | shift @a; |
94 | } |
d441d3db |
95 | is($a[0].$a[1], "Xb"); |
161b7d16 |
96 | |
97 | %h = ('a' => 1, 'b' => 2, 'c' => 3); |
98 | { |
99 | local($h{'a'}) = 'foo'; |
100 | local($h{'b'}) = $h{'b'}; |
d441d3db |
101 | is($h{'a'}, 'foo'); |
102 | is($h{'b'}, 2); |
161b7d16 |
103 | local($h{'c'}); |
104 | delete $h{'c'}; |
105 | } |
d441d3db |
106 | is($h{'a'}, 1); |
107 | is($h{'b'}, 2); |
108 | is($h{'c'}, 3); |
2bb40b7f |
109 | |
110 | # check for scope leakage |
111 | $a = 'outer'; |
112 | if (1) { local $a = 'inner' } |
d441d3db |
113 | is($a, 'outer'); |
2bb40b7f |
114 | |
115 | # see if localization works when scope unwinds |
116 | local $m = 5; |
117 | eval { |
118 | for $m (6) { |
119 | local $m = 7; |
120 | die "bye"; |
121 | } |
122 | }; |
d441d3db |
123 | is($m, 5); |
4e4c362e |
124 | |
125 | # see if localization works on tied arrays |
126 | { |
127 | package TA; |
128 | sub TIEARRAY { bless [], $_[0] } |
129 | sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } |
130 | sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } |
131 | sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } |
132 | sub FETCHSIZE { scalar(@{$_[0]}) } |
133 | sub SHIFT { shift (@{$_[0]}) } |
134 | sub EXTEND {} |
135 | } |
136 | |
137 | tie @a, 'TA'; |
138 | @a = ('a', 'b', 'c'); |
139 | { |
140 | local($a[1]) = 'foo'; |
be6c24e0 |
141 | local($a[2]) = $a[2]; |
d441d3db |
142 | is($a[1], 'foo'); |
143 | is($a[2], 'c'); |
4e4c362e |
144 | @a = (); |
145 | } |
d441d3db |
146 | is($a[1], 'b'); |
147 | is($a[2], 'c'); |
148 | ok(!defined $a[0]); |
4e4c362e |
149 | |
150 | { |
151 | package TH; |
152 | sub TIEHASH { bless {}, $_[0] } |
153 | sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } |
154 | sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } |
c39e6ab0 |
155 | sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; } |
4e4c362e |
156 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } |
157 | sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } |
158 | } |
159 | |
160 | # see if localization works on tied hashes |
161 | tie %h, 'TH'; |
162 | %h = ('a' => 1, 'b' => 2, 'c' => 3); |
163 | |
164 | { |
165 | local($h{'a'}) = 'foo'; |
be6c24e0 |
166 | local($h{'b'}) = $h{'b'}; |
159ad915 |
167 | local($h{'y'}); |
168 | local($h{'z'}) = 33; |
d441d3db |
169 | is($h{'a'}, 'foo'); |
170 | is($h{'b'}, 2); |
4e4c362e |
171 | local($h{'c'}); |
172 | delete $h{'c'}; |
173 | } |
d441d3db |
174 | is($h{'a'}, 1); |
175 | is($h{'b'}, 2); |
176 | is($h{'c'}, 3); |
177 | # local() should preserve the existenceness of tied hash elements |
178 | ok(! exists $h{'y'}); |
179 | ok(! exists $h{'z'}); |
4e4c362e |
180 | |
181 | @a = ('a', 'b', 'c'); |
182 | { |
183 | local($a[1]) = "X"; |
184 | shift @a; |
185 | } |
d441d3db |
186 | is($a[0].$a[1], "Xb"); |
4e4c362e |
187 | |
be6c24e0 |
188 | # now try the same for %SIG |
189 | |
190 | $SIG{TERM} = 'foo'; |
191 | $SIG{INT} = \&foo; |
192 | $SIG{__WARN__} = $SIG{INT}; |
193 | { |
194 | local($SIG{TERM}) = $SIG{TERM}; |
195 | local($SIG{INT}) = $SIG{INT}; |
196 | local($SIG{__WARN__}) = $SIG{__WARN__}; |
d441d3db |
197 | is($SIG{TERM}, 'main::foo'); |
198 | is($SIG{INT}, \&foo); |
199 | is($SIG{__WARN__}, \&foo); |
be6c24e0 |
200 | local($SIG{INT}); |
201 | delete $SIG{__WARN__}; |
202 | } |
d441d3db |
203 | is($SIG{TERM}, 'main::foo'); |
204 | is($SIG{INT}, \&foo); |
205 | is($SIG{__WARN__}, \&foo); |
be6c24e0 |
206 | |
207 | # and for %ENV |
208 | |
209 | $ENV{_X_} = 'a'; |
210 | $ENV{_Y_} = 'b'; |
211 | $ENV{_Z_} = 'c'; |
212 | { |
159ad915 |
213 | local($ENV{_A_}); |
214 | local($ENV{_B_}) = 'foo'; |
be6c24e0 |
215 | local($ENV{_X_}) = 'foo'; |
216 | local($ENV{_Y_}) = $ENV{_Y_}; |
d441d3db |
217 | is($ENV{_X_}, 'foo'); |
218 | is($ENV{_Y_}, 'b'); |
be6c24e0 |
219 | local($ENV{_Z_}); |
220 | delete $ENV{_Z_}; |
221 | } |
d441d3db |
222 | is($ENV{_X_}, 'a'); |
223 | is($ENV{_Y_}, 'b'); |
224 | is($ENV{_Z_}, 'c'); |
225 | # local() should preserve the existenceness of %ENV elements |
226 | ok(! exists $ENV{_A_}); |
227 | ok(! exists $ENV{_B_}); |
be6c24e0 |
228 | |
0214ae40 |
229 | # does implicit localization in foreach skip magic? |
230 | |
d441d3db |
231 | $_ = "o 0,o 1,"; |
0214ae40 |
232 | my $iter = 0; |
233 | while (/(o.+?),/gc) { |
d441d3db |
234 | is($1, "o $iter"); |
0214ae40 |
235 | foreach (1..1) { $iter++ } |
d441d3db |
236 | if ($iter > 2) { fail("endless loop"); last; } |
0214ae40 |
237 | } |
238 | |
239 | { |
240 | package UnderScore; |
241 | sub TIESCALAR { bless \my $self, shift } |
242 | sub FETCH { die "read \$_ forbidden" } |
243 | sub STORE { die "write \$_ forbidden" } |
244 | tie $_, __PACKAGE__; |
0214ae40 |
245 | my @tests = ( |
246 | "Nesting" => sub { print '#'; for (1..3) { print } |
247 | print "\n" }, 1, |
248 | "Reading" => sub { print }, 0, |
249 | "Matching" => sub { $x = /badness/ }, 0, |
250 | "Concat" => sub { $_ .= "a" }, 0, |
251 | "Chop" => sub { chop }, 0, |
252 | "Filetest" => sub { -x }, 0, |
253 | "Assignment" => sub { $_ = "Bad" }, 0, |
254 | # XXX whether next one should fail is debatable |
255 | "Local \$_" => sub { local $_ = 'ok?'; print }, 0, |
256 | "for local" => sub { for("#ok?\n"){ print } }, 1, |
257 | ); |
258 | while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { |
0214ae40 |
259 | eval { &$code }; |
d441d3db |
260 | main::ok(($ok xor $@), "Underscore '$name'"); |
0214ae40 |
261 | } |
262 | untie $_; |
263 | } |
264 | |
1f5346dc |
265 | { |
266 | # BUG 20001205.22 |
267 | my %x; |
268 | $x{a} = 1; |
269 | { local $x{b} = 1; } |
d441d3db |
270 | ok(! exists $x{b}); |
1f5346dc |
271 | { local @x{c,d,e}; } |
d441d3db |
272 | ok(! exists $x{c}); |
1f5346dc |
273 | } |
159ad915 |
274 | |
33f3c7b8 |
275 | # local() and readonly magic variables |
276 | |
277 | eval { local $1 = 1 }; |
d441d3db |
278 | like($@, qr/Modification of a read-only value attempted/); |
33f3c7b8 |
279 | |
280 | eval { for ($1) { local $_ = 1 } }; |
d441d3db |
281 | like($@, qr/Modification of a read-only value attempted/); |
33f3c7b8 |
282 | |
0cbee0a4 |
283 | # make sure $1 is still read-only |
33f3c7b8 |
284 | eval { for ($1) { local $_ = 1 } }; |
d441d3db |
285 | like($@, qr/Modification of a read-only value attempted/); |
ac117f44 |
286 | |
287 | # The s/// adds 'g' magic to $_, but it should remain non-readonly |
288 | eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } }; |
d441d3db |
289 | is($@, ""); |