This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
[perl5.git] / t / op / local.t
CommitLineData
a687059c
LW
1#!./perl
2
360eb788 3print "1..71\n";
a687059c 4
9c63abab
GS
5# XXX known to leak scalars
6$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
eec2d3df 7
a687059c
LW
8sub 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
93a17b20 23print &foo("ok 1\n","ok 2\n");
a687059c
LW
24
25print $a,$b,$c,$d,$x,$y;
26
27# same thing, only with arrays and associative arrays
28
29sub 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
93a17b20 44print &foo2("ok 11\n","ok 12\n");
a687059c
LW
45
46print $a,@b,@c,%d,$x,$y;
706a304b
SM
47
48eval 'local($$e)';
49print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 21\n";
50
51eval 'local(@$e)';
52print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n";
53
54eval 'local(%$e)';
55print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n";
85aff577 56
161b7d16
SM
57# Array and hash elements
58
59@a = ('a', 'b', 'c');
60{
61 local($a[1]) = 'foo';
62 local($a[2]) = $a[2];
2bb40b7f
GS
63 print +($a[1] eq 'foo') ? "" : "not ", "ok 24\n";
64 print +($a[2] eq 'c') ? "" : "not ", "ok 25\n";
161b7d16
SM
65 undef @a;
66}
2bb40b7f
GS
67print +($a[1] eq 'b') ? "" : "not ", "ok 26\n";
68print +($a[2] eq 'c') ? "" : "not ", "ok 27\n";
69print +(!defined $a[0]) ? "" : "not ", "ok 28\n";
161b7d16
SM
70
71@a = ('a', 'b', 'c');
72{
73 local($a[1]) = "X";
74 shift @a;
75}
2bb40b7f 76print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 29\n";
161b7d16
SM
77
78%h = ('a' => 1, 'b' => 2, 'c' => 3);
79{
80 local($h{'a'}) = 'foo';
81 local($h{'b'}) = $h{'b'};
2bb40b7f
GS
82 print +($h{'a'} eq 'foo') ? "" : "not ", "ok 30\n";
83 print +($h{'b'} == 2) ? "" : "not ", "ok 31\n";
161b7d16
SM
84 local($h{'c'});
85 delete $h{'c'};
86}
2bb40b7f
GS
87print +($h{'a'} == 1) ? "" : "not ", "ok 32\n";
88print +($h{'b'} == 2) ? "" : "not ", "ok 33\n";
89print +($h{'c'} == 3) ? "" : "not ", "ok 34\n";
90
91# check for scope leakage
92$a = 'outer';
93if (1) { local $a = 'inner' }
94print +($a eq 'outer') ? "" : "not ", "ok 35\n";
95
96# see if localization works when scope unwinds
97local $m = 5;
98eval {
99 for $m (6) {
100 local $m = 7;
101 die "bye";
102 }
103};
104print $m == 5 ? "" : "not ", "ok 36\n";
4e4c362e
GS
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
118tie @a, 'TA';
119@a = ('a', 'b', 'c');
120{
121 local($a[1]) = 'foo';
be6c24e0 122 local($a[2]) = $a[2];
4e4c362e 123 print +($a[1] eq 'foo') ? "" : "not ", "ok 37\n";
be6c24e0 124 print +($a[2] eq 'c') ? "" : "not ", "ok 38\n";
4e4c362e
GS
125 @a = ();
126}
127print +($a[1] eq 'b') ? "" : "not ", "ok 39\n";
128print +($a[2] eq 'c') ? "" : "not ", "ok 40\n";
129print +(!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
141tie %h, 'TH';
142%h = ('a' => 1, 'b' => 2, 'c' => 3);
143
144{
145 local($h{'a'}) = 'foo';
be6c24e0 146 local($h{'b'}) = $h{'b'};
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}
152print +($h{'a'} == 1) ? "" : "not ", "ok 44\n";
153print +($h{'b'} == 2) ? "" : "not ", "ok 45\n";
154print +($h{'c'} == 3) ? "" : "not ", "ok 46\n";
155
156@a = ('a', 'b', 'c');
157{
158 local($a[1]) = "X";
159 shift @a;
160}
161print +($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}
178print +($SIG{TERM} eq 'main::foo') ? "" : "not ", "ok 51\n";
179print +($SIG{INT} eq \&foo) ? "" : "not ", "ok 52\n";
180print +($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}
195print +($ENV{_X_} eq 'a') ? "" : "not ", "ok 56\n";
196print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 57\n";
197print +($ENV{_Z_} eq 'c') ? "" : "not ", "ok 58\n";
198
0214ae40
GS
199# does implicit localization in foreach skip magic?
200
201$_ = "ok 59,ok 60,";
202my $iter = 0;
203while (/(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
360eb788
NIS
238{
239 # BUG 20001205.22
240 my %x;
241 $x{a} = 1;
242 { local $x{b} = 1; }
243 print "not " if exists $x{b};
244 print "ok 70\n";
245 { local @x{c,d,e}; }
246 print "not " if exists $x{c};
247 print "ok 71\n";
248}