Commit | Line | Data |
---|---|---|
dbc6b789 | 1 | #!./perl |
045ac317 | 2 | |
dbc6b789 RGS |
3 | # Tests the scoping of $^H and %^H |
4 | ||
c06820fb JD |
5 | BEGIN { |
6 | @INC = qw(. ../lib); | |
1614bc67 | 7 | chdir 't'; |
c06820fb | 8 | } |
0f94e4a9 | 9 | |
3607ca02 | 10 | BEGIN { print "1..31\n"; } |
045ac317 RGS |
11 | BEGIN { |
12 | print "not " if exists $^H{foo}; | |
13 | print "ok 1 - \$^H{foo} doesn't exist initially\n"; | |
09337566 NC |
14 | if (${^OPEN}) { |
15 | print "not " unless $^H & 0x00020000; | |
16 | print "ok 2 - \$^H contains HINT_LOCALIZE_HH initially with ${^OPEN}\n"; | |
17 | } else { | |
18 | print "not " if $^H & 0x00020000; | |
19 | print "ok 2 - \$^H doesn't contain HINT_LOCALIZE_HH initially\n"; | |
20 | } | |
045ac317 RGS |
21 | } |
22 | { | |
7168684c | 23 | # simulate a pragma -- don't forget HINT_LOCALIZE_HH |
af796537 | 24 | BEGIN { $^H |= 0x04020000; $^H{foo} = "a"; } |
045ac317 RGS |
25 | BEGIN { |
26 | print "not " if $^H{foo} ne "a"; | |
dbc6b789 RGS |
27 | print "ok 3 - \$^H{foo} is now 'a'\n"; |
28 | print "not " unless $^H & 0x00020000; | |
29 | print "ok 4 - \$^H contains HINT_LOCALIZE_HH while compiling\n"; | |
045ac317 RGS |
30 | } |
31 | { | |
32 | BEGIN { $^H |= 0x00020000; $^H{foo} = "b"; } | |
33 | BEGIN { | |
34 | print "not " if $^H{foo} ne "b"; | |
7168684c | 35 | print "ok 5 - \$^H{foo} is now 'b'\n"; |
045ac317 RGS |
36 | } |
37 | } | |
38 | BEGIN { | |
39 | print "not " if $^H{foo} ne "a"; | |
f747ebd6 | 40 | print "ok 6 - \$^H{foo} restored to 'a'\n"; |
045ac317 | 41 | } |
dbc6b789 RGS |
42 | # The pragma settings disappear after compilation |
43 | # (test at CHECK-time and at run-time) | |
045ac317 RGS |
44 | CHECK { |
45 | print "not " if exists $^H{foo}; | |
7168684c | 46 | print "ok 9 - \$^H{foo} doesn't exist when compilation complete\n"; |
09337566 NC |
47 | if (${^OPEN}) { |
48 | print "not " unless $^H & 0x00020000; | |
49 | print "ok 10 - \$^H contains HINT_LOCALIZE_HH when compilation complete with ${^OPEN}\n"; | |
50 | } else { | |
51 | print "not " if $^H & 0x00020000; | |
52 | print "ok 10 - \$^H doesn't contain HINT_LOCALIZE_HH when compilation complete\n"; | |
53 | } | |
045ac317 RGS |
54 | } |
55 | print "not " if exists $^H{foo}; | |
7168684c | 56 | print "ok 11 - \$^H{foo} doesn't exist at runtime\n"; |
09337566 NC |
57 | if (${^OPEN}) { |
58 | print "not " unless $^H & 0x00020000; | |
59 | print "ok 12 - \$^H contains HINT_LOCALIZE_HH at run-time with ${^OPEN}\n"; | |
60 | } else { | |
61 | print "not " if $^H & 0x00020000; | |
62 | print "ok 12 - \$^H doesn't contain HINT_LOCALIZE_HH at run-time\n"; | |
63 | } | |
dbc6b789 RGS |
64 | # op_entereval should keep the pragmas it was compiled with |
65 | eval q* | |
f45b078d | 66 | BEGIN { |
dbc6b789 | 67 | print "not " if $^H{foo} ne "a"; |
7168684c | 68 | print "ok 13 - \$^H{foo} is 'a' at eval-\"\" time\n"; |
dbc6b789 | 69 | print "not " unless $^H & 0x00020000; |
7168684c | 70 | print "ok 14 - \$^H contains HINT_LOCALIZE_HH at eval\"\"-time\n"; |
f45b078d | 71 | } |
dbc6b789 | 72 | *; |
045ac317 RGS |
73 | } |
74 | BEGIN { | |
75 | print "not " if exists $^H{foo}; | |
7168684c | 76 | print "ok 7 - \$^H{foo} doesn't exist while finishing compilation\n"; |
09337566 NC |
77 | if (${^OPEN}) { |
78 | print "not " unless $^H & 0x00020000; | |
79 | print "ok 8 - \$^H contains HINT_LOCALIZE_HH while finishing compilation with ${^OPEN}\n"; | |
80 | } else { | |
81 | print "not " if $^H & 0x00020000; | |
82 | print "ok 8 - \$^H doesn't contain HINT_LOCALIZE_HH while finishing compilation\n"; | |
83 | } | |
045ac317 | 84 | } |
dfa41748 | 85 | |
0282be92 RGS |
86 | { |
87 | BEGIN{$^H{x}=1}; | |
bc8f2ddd | 88 | for my $tno (15..16) { |
0282be92 | 89 | eval q( |
f45b078d FC |
90 | BEGIN { |
91 | print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n"; | |
92 | } | |
0282be92 RGS |
93 | $^H{y} = 1; |
94 | ); | |
95 | if ($@) { | |
96 | (my $str = $@)=~s/^/# /gm; | |
f747ebd6 | 97 | print "not ok $tno\n$str\n"; |
0282be92 RGS |
98 | } |
99 | } | |
100 | } | |
f747ebd6 Z |
101 | |
102 | { | |
f747ebd6 Z |
103 | BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; } |
104 | ||
105 | our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; } | |
a026e652 NC |
106 | print +($ri0 & 0x04000000 ? "" : "not "), "ok 17 - \$^H correct before require\n"; |
107 | print +($rf0 eq "z" ? "" : "not "), "ok 18 - \$^H{foo} correct before require\n"; | |
f747ebd6 Z |
108 | |
109 | our($ra1, $ri1, $rf1, $rfe1); | |
110 | BEGIN { require "comp/hints.aux"; } | |
a026e652 NC |
111 | print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 19 - \$^H cleared for require\n"; |
112 | print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 20 - \$^H{foo} cleared for require\n"; | |
f747ebd6 Z |
113 | |
114 | our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; } | |
a026e652 NC |
115 | print +($ri2 & 0x04000000 ? "" : "not "), "ok 21 - \$^H correct after require\n"; |
116 | print +($rf2 eq "z" ? "" : "not "), "ok 22 - \$^H{foo} correct after require\n"; | |
f747ebd6 | 117 | } |
bc8f2ddd | 118 | |
ec34a119 DM |
119 | # [perl #73174] |
120 | ||
121 | { | |
122 | my $res; | |
123 | BEGIN { $^H{73174} = "foo" } | |
124 | BEGIN { $res = ($^H{73174} // "") } | |
125 | "" =~ /\x{100}/i; # forces loading of utf8.pm, which used to reset %^H | |
126 | BEGIN { $res .= '-' . ($^H{73174} // "")} | |
127 | $res .= '-' . ($^H{73174} // ""); | |
128 | print $res eq "foo-foo-" ? "" : "not ", | |
129 | "ok 23 - \$^H{foo} correct after /unicode/i (res=$res)\n"; | |
130 | } | |
131 | ||
95cf2368 | 132 | # [perl #106282] Crash when tying %^H |
cb1f05e8 FC |
133 | # Tying %^H should not result in a crash when the hint hash is cloned. |
134 | # Hints should also be copied properly to inner scopes. See also | |
135 | # [rt.cpan.org #73402]. | |
95cf2368 FC |
136 | eval q` |
137 | # Do something naughty enough, and you get your module mentioned in the | |
138 | # test suite. :-) | |
139 | package namespace::clean::_TieHintHash; | |
140 | ||
141 | sub TIEHASH { bless[] } | |
142 | sub STORE { $_[0][0]{$_[1]} = $_[2] } | |
143 | sub FETCH { $_[0][0]{$_[1]} } | |
144 | sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } | |
145 | sub NEXTKEY { each %{$_[0][0]} } | |
146 | ||
147 | package main; | |
148 | ||
149 | BEGIN { | |
150 | $^H{foo} = "bar"; # activate localisation magic | |
151 | tie( %^H, 'namespace::clean::_TieHintHash' ); # sabotage %^H | |
152 | $^H{foo} = "bar"; # create an element in the tied hash | |
153 | } | |
cb1f05e8 FC |
154 | { # clone the tied hint hash on scope entry |
155 | BEGIN { | |
156 | print "not " x ($^H{foo} ne 'bar'), | |
157 | "ok 24 - tied hint hash is copied to inner scope\n"; | |
158 | %^H = (); | |
159 | tie( %^H, 'namespace::clean::_TieHintHash' ); | |
160 | $^H{foo} = "bar"; | |
161 | } | |
162 | { | |
163 | BEGIN{ | |
164 | ||
165 | "not " x ($^H{foo} ne 'bar'), | |
166 | "ok 25 - tied empty hint hash is copied to inner scope\n" | |
167 | } | |
168 | } | |
169 | 1; | |
170 | } | |
171 | 1; | |
172 | ` or warn $@; | |
173 | print "ok 26 - no crash when cloning a tied hint hash\n"; | |
ec34a119 | 174 | |
52c7aca6 FC |
175 | { |
176 | my $w; | |
177 | local $SIG{__WARN__} = sub { $w = shift }; | |
178 | eval q` | |
179 | package namespace::clean::_TieHintHasi; | |
180 | ||
181 | sub TIEHASH { bless[] } | |
182 | sub STORE { $_[0][0]{$_[1]} = $_[2] } | |
183 | sub FETCH { $_[0][0]{$_[1]} } | |
184 | sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } | |
185 | # Intentionally commented out: | |
186 | # sub NEXTKEY { each %{$_[0][0]} } | |
187 | ||
188 | package main; | |
189 | ||
190 | BEGIN { | |
191 | $^H{foo} = "bar"; # activate localisation magic | |
192 | tie( %^H, 'namespace::clean::_TieHintHasi' ); # sabotage %^H | |
193 | $^H{foo} = "bar"; # create an element in the tied hash | |
194 | } | |
195 | { ; } # clone the tied hint hash | |
196 | `; | |
197 | print "not " if $w; | |
198 | print "ok 27 - double-freeing explosive tied hints hash\n"; | |
199 | print "# got: $w" if $w; | |
200 | } | |
201 | ||
7e4f0450 FC |
202 | # Setting ${^WARNING_HINTS} to its own value should not change things. |
203 | { | |
204 | my $w; | |
205 | local $SIG{__WARN__} = sub { $w++ }; | |
206 | BEGIN { | |
207 | # should have no effect: | |
208 | my $x = ${^WARNING_BITS}; | |
209 | ${^WARNING_BITS} = $x; | |
210 | } | |
211 | { | |
212 | local $^W = 1; | |
213 | () = 1 + undef; | |
214 | } | |
215 | print "# ", $w//'no', " warnings\nnot " unless $w == 1; | |
216 | print "ok 28 - ", | |
217 | "setting \${^WARNING_BITS} to its own value has no effect\n"; | |
218 | } | |
219 | ||
2653c1e3 DM |
220 | # [perl #112326] |
221 | # this code could cause a crash, due to PL_hints continuing to point to th | |
222 | # hints hash currently being freed | |
223 | ||
224 | { | |
225 | package Foo; | |
226 | my @h = qw(a 1 b 2); | |
227 | BEGIN { | |
228 | $^H{FOO} = bless {}; | |
229 | } | |
230 | sub DESTROY { | |
231 | @h = %^H; | |
232 | delete $INC{strict}; require strict; # boom! | |
233 | } | |
234 | my $h = join ':', %h; | |
235 | # this isn't the main point of the test; the main point is that | |
236 | # it doesn't crash! | |
237 | print "not " if $h ne ''; | |
238 | print "ok 29 - #112326\n"; | |
239 | } | |
240 | ||
ec34a119 | 241 | |
3607ca02 FC |
242 | # [perl #112444] |
243 | # A destructor called while %^H is freed should not be able to stop %^H | |
244 | # from being magical (due to *^H{HASH} being undef). | |
245 | { | |
246 | BEGIN { | |
247 | # Make sure %^H is clear and not localised, to begin with | |
248 | %^H = (); | |
249 | $^H = 0; | |
250 | } | |
251 | DESTROY { %^H } | |
252 | { | |
253 | { | |
254 | BEGIN { | |
255 | $^H{foom} = bless[]; | |
256 | } | |
257 | } # scope exit triggers destructor, which autovivifies a non- | |
258 | # magical %^H | |
259 | BEGIN { | |
260 | # Here we have the %^H created by DESTROY, which is | |
261 | # not localised | |
262 | $^H{112444} = 'baz'; | |
263 | } | |
264 | } # %^H leaks on scope exit | |
265 | BEGIN { @keez = keys %^H } | |
266 | } | |
267 | print "not " if @keez; | |
268 | print "ok 30 - %^H does not leak when autovivified in destructor\n"; | |
269 | print "# keys are: @keez\n" if @keez; | |
270 | ||
271 | ||
bc8f2ddd NC |
272 | # Add new tests above this require, in case it fails. |
273 | require './test.pl'; | |
274 | ||
275 | # bug #27040: hints hash was being double-freed | |
276 | my $result = runperl( | |
277 | prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}', | |
278 | stderr => 1 | |
279 | ); | |
280 | print "not " if length $result; | |
3607ca02 | 281 | print "ok 31 - double-freeing hints hash\n"; |
bc8f2ddd NC |
282 | print "# got: $result\n" if length $result; |
283 | ||
284 | __END__ | |
285 | # Add new tests above require 'test.pl' |