1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6}
7plan tests => 81;
8
9my $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
15sub foo {
16    local($a, $b) = @_;
17    local($c, $d);
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;
24}
25
26$a = "a 5";
27$b = "b 6";
28$c = "c 7";
29$d = "d 8";
30
31my @res;
32@res =  &foo("a 1","b 2");
33is($res[0], "c 3");
34is($res[1], "d 4");
35
36is($a, "a 5");
37is($b, "b 6");
38is($c, "c 7");
39is($d, "d 8");
40is($x, "a 9");
41is($y, "c 10");
42
43# same thing, only with arrays and associative arrays
44
45sub foo2 {
46    local($a, @b) = @_;
47    local(@c, %d);
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{''};
54}
55
56$a = "a 5";
57@b = "b 6";
58@c = "c 7";
59$d{''} = "d 8";
60
61@res = &foo2("a 1","b 2");
62is($res[0], "c 3");
63is($res[1], "d 4");
64
65is($a, "a 5");
66is("@b", "b 6");
67is($c[0], "c 7");
68is($d{''}, "d 8");
69is($x, "a 19");
70is($y, "c 20");
71
72
73eval 'local($$e)';
74like($@, qr/Can't localize through a reference/);
75
76eval '$e = []; local(@$e)';
77like($@, qr/Can't localize through a reference/);
78
79eval '$e = {}; local(%$e)';
80like($@, qr/Can't localize through a reference/);
81
82# Array and hash elements
83
84@a = ('a', 'b', 'c');
85{
86    local($a[1]) = 'foo';
87    local($a[2]) = $a[2];
88    is($a[1], 'foo');
89    is($a[2], 'c');
90    undef @a;
91}
92is($a[1], 'b');
93is($a[2], 'c');
94ok(!defined $a[0]);
95
96@a = ('a', 'b', 'c');
97{
98    local($a[1]) = "X";
99    shift @a;
100}
101is($a[0].$a[1], "Xb");
102{
103    my $d = "@a";
104    local @a = @a;
105    is("@a", $d);
106}
107
108%h = ('a' => 1, 'b' => 2, 'c' => 3);
109{
110    local($h{'a'}) = 'foo';
111    local($h{'b'}) = $h{'b'};
112    is($h{'a'}, 'foo');
113    is($h{'b'}, 2);
114    local($h{'c'});
115    delete $h{'c'};
116}
117is($h{'a'}, 1);
118is($h{'b'}, 2);
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}
124is($h{'c'}, 3);
125
126# check for scope leakage
127$a = 'outer';
128if (1) { local $a = 'inner' }
129is($a, 'outer');
130
131# see if localization works when scope unwinds
132local $m = 5;
133eval {
134    for $m (6) {
135	local $m = 7;
136	die "bye";
137    }
138};
139is($m, 5);
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
153tie @a, 'TA';
154@a = ('a', 'b', 'c');
155{
156    local($a[1]) = 'foo';
157    local($a[2]) = $a[2];
158    is($a[1], 'foo');
159    is($a[2], 'c');
160    @a = ();
161}
162is($a[1], 'b');
163is($a[2], 'c');
164ok(!defined $a[0]);
165{
166    my $d = "@a";
167    local @a = @a;
168    is("@a", $d);
169}
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 }
176    sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; }
177    sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; }
178    sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); }
179    sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} }
180    sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} }
181}
182
183# see if localization works on tied hashes
184tie %h, 'TH';
185%h = ('a' => 1, 'b' => 2, 'c' => 3);
186
187{
188    local($h{'a'}) = 'foo';
189    local($h{'b'}) = $h{'b'};
190    local($h{'y'});
191    local($h{'z'}) = 33;
192    is($h{'a'}, 'foo');
193    is($h{'b'}, 2);
194    local($h{'c'});
195    delete $h{'c'};
196}
197is($h{'a'}, 1);
198is($h{'b'}, 2);
199is($h{'c'}, 3);
200# local() should preserve the existenceness of tied hash elements
201ok(! exists $h{'y'});
202ok(! exists $h{'z'});
203TODO: {
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}
209
210@a = ('a', 'b', 'c');
211{
212    local($a[1]) = "X";
213    shift @a;
214}
215is($a[0].$a[1], "Xb");
216
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__};
226    is($SIG{TERM}, 'main::foo');
227    is($SIG{INT}, \&foo);
228    is($SIG{__WARN__}, \&foo);
229    local($SIG{INT});
230    delete $SIG{__WARN__};
231}
232is($SIG{TERM}, 'main::foo');
233is($SIG{INT}, \&foo);
234is($SIG{__WARN__}, \&foo);
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}
240
241# and for %ENV
242
243$ENV{_X_} = 'a';
244$ENV{_Y_} = 'b';
245$ENV{_Z_} = 'c';
246{
247    local($ENV{_A_});
248    local($ENV{_B_}) = 'foo';
249    local($ENV{_X_}) = 'foo';
250    local($ENV{_Y_}) = $ENV{_Y_};
251    is($ENV{_X_}, 'foo');
252    is($ENV{_Y_}, 'b');
253    local($ENV{_Z_});
254    delete $ENV{_Z_};
255}
256is($ENV{_X_}, 'a');
257is($ENV{_Y_}, 'b');
258is($ENV{_Z_}, 'c');
259# local() should preserve the existenceness of %ENV elements
260ok(! exists $ENV{_A_});
261ok(! exists $ENV{_B_});
262
263SKIP: {
264    skip("Can't make list assignment to \%ENV on this system")
265	unless $list_assignment_supported;
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}
270
271# does implicit localization in foreach skip magic?
272
273$_ = "o 0,o 1,";
274my $iter = 0;
275while (/(o.+?),/gc) {
276    is($1, "o $iter");
277    foreach (1..1) { $iter++ }
278    if ($iter > 2) { fail("endless loop"); last; }
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__;
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) ) {
301	eval { &$code };
302        main::ok(($ok xor $@), "Underscore '$name'");
303    }
304    untie $_;
305}
306
307{
308    # BUG 20001205.22
309    my %x;
310    $x{a} = 1;
311    { local $x{b} = 1; }
312    ok(! exists $x{b});
313    { local @x{c,d,e}; }
314    ok(! exists $x{c});
315}
316