Commit | Line | Data |
---|---|---|
ca237673 BF |
1 | #!./perl |
2 | ||
3 | # | |
4 | # various typeglob tests | |
5 | # | |
6 | ||
7 | BEGIN { | |
8 | chdir 't' if -d 't'; | |
ca237673 | 9 | require './test.pl'; |
43ece5b1 | 10 | set_up_inc('../lib'); |
2b08d1e2 | 11 | skip_all_without_unicode_tables(); |
ca237673 BF |
12 | } |
13 | ||
14 | use utf8; | |
15 | use open qw( :utf8 :std ); | |
16 | use warnings; | |
17 | ||
2eaf799e | 18 | plan( tests => 206 ); |
ca237673 BF |
19 | |
20 | # type coersion on assignment | |
21 | $ᕘ = 'ᕘ'; | |
22 | $ᴮᛅ = *main::ᕘ; | |
23 | $ᴮᛅ = $ᕘ; | |
24 | is(ref(\$ᴮᛅ), 'SCALAR'); | |
25 | $ᕘ = *main::ᴮᛅ; | |
26 | ||
27 | # type coersion (not) on misc ops | |
28 | ||
29 | ok($ᕘ); | |
30 | is(ref(\$ᕘ), 'GLOB'); | |
31 | ||
32 | unlike ($ᕘ, qr/abcd/); | |
33 | is(ref(\$ᕘ), 'GLOB'); | |
34 | ||
35 | is($ᕘ, '*main::ᴮᛅ'); | |
36 | is(ref(\$ᕘ), 'GLOB'); | |
37 | ||
38 | { | |
39 | no warnings; | |
40 | ${\*$ᕘ} = undef; | |
41 | is(ref(\$ᕘ), 'GLOB', 'no type coersion when assigning to *{} retval'); | |
42 | $::{ఫケ} = *ᴮᛅ; | |
43 | is( | |
44 | \$::{ఫケ}, \*{"ఫケ"}, | |
45 | 'symbolic *{} returns symtab entry when FAKE' | |
46 | ); | |
47 | ${\*{"ఫケ"}} = undef; | |
48 | is( | |
49 | ref(\$::{ఫケ}), 'GLOB', | |
50 | 'no type coersion when assigning to retval of symbolic *{}' | |
51 | ); | |
52 | $::{pɥአQuઍ} = *ᴮᛅ; | |
53 | eval ' | |
54 | is( | |
55 | \$::{pɥአQuઍ}, \*pɥአQuઍ, | |
56 | "compile-time *{} returns symtab entry when FAKE" | |
57 | ); | |
58 | ${\*pɥአQuઍ} = undef; | |
59 | '; | |
60 | is( | |
61 | ref(\$::{pɥአQuઍ}), 'GLOB', | |
62 | 'no type coersion when assigning to retval of compile-time *{}' | |
63 | ); | |
64 | } | |
65 | ||
66 | # type coersion on substitutions that match | |
67 | $a = *main::ᕘ; | |
68 | $b = $a; | |
69 | $a =~ s/^X//; | |
70 | is(ref(\$a), 'GLOB'); | |
71 | $a =~ s/^\*//; | |
72 | is($a, 'main::ᕘ'); | |
73 | is(ref(\$b), 'GLOB'); | |
74 | ||
75 | # typeglobs as lvalues | |
76 | substr($ᕘ, 0, 1) = "XXX"; | |
77 | is(ref(\$ᕘ), 'SCALAR'); | |
78 | is($ᕘ, 'XXXmain::ᴮᛅ'); | |
79 | ||
80 | # returning glob values | |
81 | sub ᕘ { | |
82 | local($ᴮᛅ) = *main::ᕘ; | |
83 | $ᕘ = *main::ᴮᛅ; | |
84 | return ($ᕘ, $ᴮᛅ); | |
85 | } | |
86 | ||
87 | ($ፉṶ, $ባ) = ᕘ(); | |
88 | ok(defined $ፉṶ); | |
89 | is(ref(\$ፉṶ), 'GLOB'); | |
90 | ||
91 | ||
92 | ok(defined $ባ); | |
93 | is(ref(\$ባ), 'GLOB'); | |
94 | ||
95 | # nested package globs | |
96 | # NOTE: It's probably OK if these semantics change, because the | |
97 | # fact that %X::Y:: is stored in %X:: isn't documented. | |
98 | # (I hope.) | |
99 | ||
100 | { package ฝ오::ʉ; no warnings 'once'; $test=1; } | |
101 | ok(exists $ฝ오::{'ʉ::'}); | |
102 | is($ฝ오::{'ʉ::'}, '*ฝ오::ʉ::'); | |
103 | ||
104 | ||
105 | # test undef operator clearing out entire glob | |
106 | $ᕘ = 'stuff'; | |
107 | @ᕘ = qw(more stuff); | |
108 | %ᕘ = qw(even more random stuff); | |
109 | undef *ᕘ; | |
110 | is ($ᕘ, undef); | |
111 | is (scalar @ᕘ, 0); | |
112 | is (scalar %ᕘ, 0); | |
113 | ||
472394e4 | 114 | { |
ca237673 BF |
115 | # test warnings from assignment of undef to glob |
116 | my $msg = ''; | |
117 | local $SIG{__WARN__} = sub { $msg = $_[0] }; | |
118 | use warnings; | |
119 | *ᕘ = 'ᴮᛅ'; | |
120 | is($msg, ''); | |
121 | *ᕘ = undef; | |
122 | like($msg, qr/Undefined value assigned to typeglob/); | |
123 | ||
d6945f70 KW |
124 | my $O_grave = utf8::unicode_to_native(0xd2); |
125 | my $E_grave = utf8::unicode_to_native(0xc8); | |
126 | my $pat = sprintf( | |
127 | # It took a lot of experimentation to get the backslashes right (khw) | |
92e8e650 KW |
128 | "Argument \"\\*main::(?:PW\\\\x\\{%x\\}MPF" |
129 | . "|SKR\\\\x\\{%x\\}\\\\x\\{%x\\}\\\\x\\{%x\\})\" " | |
d6945f70 KW |
130 | . "isn't numeric in sprintf", |
131 | $O_grave, $E_grave, $E_grave, $E_grave); | |
132 | $pat = qr/$pat/; | |
133 | ||
ca237673 BF |
134 | no warnings 'once'; |
135 | # test warnings for converting globs to other forms | |
136 | my $copy = *PWÒMPF; | |
137 | foreach ($copy, *SKRÈÈÈ) { | |
138 | $msg = ''; | |
139 | my $victim = sprintf "%d", $_; | |
d6945f70 | 140 | like($msg, $pat, "Warning on conversion to IV"); |
ca237673 BF |
141 | is($victim, 0); |
142 | ||
143 | $msg = ''; | |
144 | $victim = sprintf "%u", $_; | |
d6945f70 | 145 | like($msg, $pat, "Warning on conversion to UV"); |
ca237673 BF |
146 | is($victim, 0); |
147 | ||
148 | $msg = ''; | |
149 | $victim = sprintf "%e", $_; | |
d6945f70 | 150 | like($msg, $pat, "Warning on conversion to NV"); |
ca237673 BF |
151 | like($victim, qr/^0\.0+E\+?00/i, "Expect floating point zero"); |
152 | ||
153 | $msg = ''; | |
154 | $victim = sprintf "%s", $_; | |
155 | is($msg, '', "No warning on stringification"); | |
156 | is($victim, '' . $_); | |
157 | } | |
158 | } | |
159 | ||
160 | my $test = curr_test(); | |
161 | # test *glob{THING} syntax | |
162 | $Ẋ = "ok $test\n"; | |
163 | ++$test; | |
164 | @Ẋ = ("ok $test\n"); | |
165 | ++$test; | |
166 | %Ẋ = ("ok $test" => "\n"); | |
167 | ++$test; | |
168 | sub Ẋ { "ok $test\n" } | |
169 | print ${*Ẋ{SCALAR}}, @{*Ẋ{ARRAY}}, %{*Ẋ{HASH}}, &{*Ẋ{CODE}}; | |
170 | # This needs to go here, after the print, as sub Ẋ will return the current | |
171 | # value of test | |
172 | ++$test; | |
173 | format Ẋ = | |
174 | XXX This text isn't used. Should it be? | |
175 | . | |
176 | curr_test($test); | |
177 | ||
178 | is (ref *Ẋ{FORMAT}, "FORMAT"); | |
179 | *Ẋ = *STDOUT; | |
180 | is (*{*Ẋ{GLOB}}, "*main::STDOUT"); | |
181 | ||
182 | { | |
183 | my $test = curr_test(); | |
184 | ||
185 | print {*Ẋ{IO}} "ok $test\n"; | |
186 | ++$test; | |
187 | ||
188 | my $warn; | |
189 | local $SIG{__WARN__} = sub { | |
190 | $warn .= $_[0]; | |
191 | }; | |
192 | my $val = *Ẋ{FILEHANDLE}; | |
83677dc5 RS |
193 | |
194 | # deprecation warning removed in v5.23 -- rjbs, 2015-12-31 | |
195 | # https://rt.perl.org/Ticket/Display.html?id=127060 | |
196 | print {*Ẋ{IO}} (! defined $warn | |
ca237673 BF |
197 | ? "ok $test\n" : "not ok $test\n"); |
198 | curr_test(++$test); | |
199 | } | |
200 | ||
201 | ||
202 | { | |
203 | # test if defined() doesn't create any new symbols | |
204 | ||
205 | my $a = "Sʎm000"; | |
206 | ok(!defined *{$a}); | |
207 | ||
ca237673 BF |
208 | ok(!defined ${$a}); |
209 | ok(!defined *{$a}); | |
210 | ||
211 | ok(!defined &{$a}); | |
212 | ok(!defined *{$a}); | |
213 | ||
214 | my $state = "not"; | |
215 | *{$a} = sub { $state = "ok" }; | |
216 | ok(defined &{$a}); | |
217 | ok(defined *{$a}); | |
218 | &{$a}; | |
219 | is ($state, 'ok'); | |
220 | } | |
221 | ||
ee95e30c | 222 | # [ID 20010526.001 (#7038)] localized glob loses value when assigned to |
ca237673 BF |
223 | |
224 | $J=1; %J=(a=>1); @J=(1); local *J=*J; *J = sub{}; | |
225 | ||
226 | is($J, 1); | |
227 | is($J{a}, 1); | |
228 | is($J[0], 1); | |
229 | ||
230 | { | |
231 | # does pp_readline() handle glob-ness correctly? | |
232 | my $g = *ᕘ; | |
233 | $g = <DATA>; | |
234 | is ($g, "Perl\n"); | |
235 | } | |
236 | ||
237 | { | |
238 | my $w = ''; | |
239 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
240 | sub aʙȼ1 (); | |
241 | local *aʙȼ1 = sub { }; | |
242 | is ($w, ''); | |
243 | sub aʙȼ2 (); | |
244 | local *aʙȼ2; | |
245 | *aʙȼ2 = sub { }; | |
246 | is ($w, ''); | |
247 | sub aʙȼ3 (); | |
248 | *aʙȼ3 = sub { }; | |
249 | like ($w, qr/Prototype mismatch/); | |
250 | } | |
251 | ||
252 | { | |
253 | # [17375] rcatline to formerly-defined undef was broken. Fixed in | |
254 | # do_readline by checking SvOK. AMS, 20020918 | |
255 | my $x = "not "; | |
256 | $x = undef; | |
257 | $x .= <DATA>; | |
258 | is ($x, "Rules\n"); | |
259 | } | |
260 | ||
261 | { | |
262 | # test the assignment of a GLOB to an LVALUE | |
263 | my $e = ''; | |
264 | local $SIG{__DIE__} = sub { $e = $_[0] }; | |
265 | my %V; | |
266 | sub ƒ { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA } | |
267 | ƒ($V{V}); | |
268 | is ($V{V}, '*main::DATA'); | |
269 | is (ref\$V{V}, 'GLOB', 'lvalue assignment preserves globs'); | |
270 | my $x = readline $V{V}; | |
271 | is ($x, "perl\n"); | |
272 | is ($e, '', '__DIE__ handler never called'); | |
273 | } | |
4886938f BF |
274 | |
275 | { | |
276 | ||
ca237673 BF |
277 | my $e = ''; |
278 | # GLOB assignment to tied element | |
279 | local $SIG{__DIE__} = sub { $e = $_[0] }; | |
280 | sub Ʈ::TIEARRAY { bless [] => "Ʈ" } | |
281 | sub Ʈ::STORE { $_[0]->[ $_[1] ] = $_[2] } | |
282 | sub Ʈ::FETCH { $_[0]->[ $_[1] ] } | |
283 | sub Ʈ::FETCHSIZE { @{$_[0]} } | |
284 | tie my @ary => "Ʈ"; | |
285 | $ary[0] = *DATA; | |
286 | is ($ary[0], '*main::DATA'); | |
287 | is ( | |
288 | ref\tied(@ary)->[0], 'GLOB', | |
289 | 'tied elem assignment preserves globs' | |
290 | ); | |
291 | is ($e, '', '__DIE__ handler not called'); | |
292 | my $x = readline $ary[0]; | |
293 | is($x, "rocks\n"); | |
294 | is ($e, '', '__DIE__ handler never called'); | |
295 | } | |
4886938f BF |
296 | |
297 | { | |
ca237673 | 298 | SKIP: { |
8cb149dc | 299 | skip_if_miniperl('no dynamic loading on miniperl, no Encode', 2); |
ca237673 BF |
300 | # Need some sort of die or warn to get the global destruction text if the |
301 | # bug is still present | |
302 | my $prog = <<'EOPROG'; | |
303 | use utf8; | |
304 | use open qw( :utf8 :std ); | |
305 | package ᴹ; | |
306 | $| = 1; | |
307 | sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} | |
308 | package main; | |
309 | ||
310 | bless \$Ⱥ::ㄅ, q{ᴹ}; | |
311 | *Ⱥ:: = \*ㄅ::; | |
312 | EOPROG | |
313 | ||
314 | utf8::decode($prog); | |
315 | my $output = runperl(prog => $prog); | |
316 | ||
317 | require Encode; | |
318 | $output = Encode::decode("UTF-8", $output); | |
319 | like($output, qr/^Farewell ᴹ=SCALAR/, "DESTROY was called"); | |
320 | unlike($output, qr/global destruction/, | |
321 | "unreferenced symbol tables should be cleaned up immediately"); | |
322 | } | |
323 | } | |
324 | ||
e0260a5b | 325 | { |
ca237673 BF |
326 | # Possibly not the correct test file for these tests. |
327 | # There are certain space optimisations implemented via promotion rules to | |
328 | # GVs | |
329 | ||
330 | foreach (qw (оઓnḲ ga_ㄕƚo잎)) { | |
331 | ok(!exists $::{$_}, "no symbols of any sort to start with for $_"); | |
332 | } | |
333 | ||
334 | # A string in place of the typeglob is promoted to the function prototype | |
335 | $::{оઓnḲ} = "pìè"; | |
336 | my $proto = eval 'prototype \&оઓnḲ'; | |
337 | die if $@; | |
338 | is ($proto, "pìè", "String is promoted to prototype"); | |
339 | ||
340 | ||
341 | # A reference to a value is used to generate a constant subroutine | |
342 | foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2}, | |
343 | \*STDIN, \&ok, \undef, *STDOUT) { | |
344 | delete $::{оઓnḲ}; | |
345 | $::{оઓnḲ} = \$value; | |
346 | $proto = eval 'prototype \&оઓnḲ'; | |
347 | die if $@; | |
348 | is ($proto, '', "Prototype for a constant subroutine is empty"); | |
349 | ||
350 | my $got = eval 'оઓnḲ'; | |
351 | die if $@; | |
352 | is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")"); | |
353 | is ($got, $value, "Value is correctly set"); | |
354 | } | |
355 | } | |
356 | ||
357 | delete $::{оઓnḲ}; | |
358 | $::{оઓnḲ} = \"Value"; | |
359 | ||
360 | *{"ga_ㄕƚo잎"} = \&{"оઓnḲ"}; | |
361 | ||
362 | is (ref $::{ga_ㄕƚo잎}, 'SCALAR', "Export of proxy constant as is"); | |
363 | is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); | |
364 | is (eval 'ga_ㄕƚo잎', "Value", "Constant has correct value"); | |
365 | is (ref $::{ga_ㄕƚo잎}, 'SCALAR', | |
366 | "Inlining of constant doesn't change representation"); | |
367 | ||
368 | delete $::{ga_ㄕƚo잎}; | |
369 | ||
370 | eval 'sub ga_ㄕƚo잎 (); 1' or die $@; | |
371 | is ($::{ga_ㄕƚo잎}, '', "Prototype is stored as an empty string"); | |
372 | ||
373 | # Check that a prototype expands. | |
374 | *{"ga_ㄕƚo잎"} = \&{"оઓnḲ"}; | |
375 | ||
376 | is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); | |
377 | is (eval 'ga_ㄕƚo잎', "Value", "Constant has correct value"); | |
378 | is (ref \$::{ga_ㄕƚo잎}, 'GLOB', "Symbol table has full typeglob"); | |
379 | ||
380 | ||
381 | @::zᐓt = ('Zᐓt!'); | |
382 | ||
383 | # Check that assignment to an existing typeglob works | |
384 | { | |
385 | my $w = ''; | |
386 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
387 | *{"zᐓt"} = \&{"оઓnḲ"}; | |
388 | is($w, '', "Should be no warning"); | |
389 | } | |
390 | ||
391 | is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); | |
392 | is (eval 'zᐓt', "Value", "Constant has correct value"); | |
393 | is (ref \$::{zᐓt}, 'GLOB', "Symbol table has full typeglob"); | |
394 | is (join ('!', @::zᐓt), 'Zᐓt!', "Existing array still in typeglob"); | |
395 | ||
396 | sub Ṩp맅싵Ş () { | |
397 | "Traditional"; | |
398 | } | |
399 | ||
400 | # Check that assignment to an existing subroutine works | |
2e434a10 | 401 | { |
ca237673 BF |
402 | my $w = ''; |
403 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
404 | *{"Ṩp맅싵Ş"} = \&{"оઓnḲ"}; | |
405 | like($w, qr/^Constant subroutine main::Ṩp맅싵Ş redefined/, | |
406 | "Redefining a constant sub should warn"); | |
407 | } | |
408 | ||
409 | is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); | |
410 | is (eval 'Ṩp맅싵Ş', "Value", "Constant has correct value"); | |
411 | is (ref \$::{Ṩp맅싵Ş}, 'GLOB', "Symbol table has full typeglob"); | |
412 | ||
413 | # Check that assignment to an existing typeglob works | |
414 | { | |
415 | my $w = ''; | |
416 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
417 | *{"plუᒃ"} = []; | |
418 | *{"plუᒃ"} = \&{"оઓnḲ"}; | |
419 | is($w, '', "Should be no warning"); | |
420 | } | |
421 | ||
422 | is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); | |
423 | is (eval 'plუᒃ', "Value", "Constant has correct value"); | |
424 | is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob"); | |
425 | ||
426 | my $gr = eval '\*plუᒃ' or die; | |
427 | ||
428 | { | |
429 | my $w = ''; | |
430 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
431 | *{$gr} = \&{"оઓnḲ"}; | |
432 | is($w, '', "Redefining a constant sub to another constant sub with the same underlying value should not warn (It's just re-exporting, and that was always legal)"); | |
433 | } | |
434 | ||
435 | is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); | |
436 | is (eval 'plუᒃ', "Value", "Constant has correct value"); | |
437 | is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob"); | |
438 | ||
439 | # Non-void context should defeat the optimisation, and will cause the original | |
440 | # to be promoted (what change 26482 intended) | |
441 | my $result; | |
442 | { | |
443 | my $w = ''; | |
444 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
445 | $result = *{"aẈʞƙʞƙʞƙ"} = \&{"оઓnḲ"}; | |
446 | is($w, '', "Should be no warning"); | |
447 | } | |
448 | ||
449 | is (ref \$result, 'GLOB', | |
450 | "Non void assignment should still return a typeglob"); | |
451 | ||
452 | is (ref \$::{оઓnḲ}, 'GLOB', "This export does affect original"); | |
453 | is (eval 'plუᒃ', "Value", "Constant has correct value"); | |
454 | is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob"); | |
455 | ||
456 | delete $::{оઓnḲ}; | |
457 | $::{оઓnḲ} = \"Value"; | |
458 | ||
459 | sub non_dangling { | |
460 | my $w = ''; | |
461 | local $SIG{__WARN__} = sub { $w = $_[0] }; | |
462 | *{"z앞"} = \&{"оઓnḲ"}; | |
463 | is($w, '', "Should be no warning"); | |
464 | } | |
465 | ||
466 | non_dangling(); | |
467 | is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); | |
468 | is (eval 'z앞', "Value", "Constant has correct value"); | |
469 | is (ref $::{z앞}, 'SCALAR', "Exported target is also a PCS"); | |
470 | ||
471 | sub dangling { | |
472 | local $SIG{__WARN__} = sub { die $_[0] }; | |
473 | *{"ビfᶠ"} = \&{"оઓnḲ"}; | |
474 | } | |
475 | ||
476 | dangling(); | |
477 | is (ref \$::{оઓnḲ}, 'GLOB', "This export does affect original"); | |
478 | is (eval 'ビfᶠ', "Value", "Constant has correct value"); | |
479 | is (ref \$::{ビfᶠ}, 'GLOB', "Symbol table has full typeglob"); | |
480 | ||
481 | { | |
482 | use vars qw($gᓙʞ $sምḲ $ᕘf); | |
483 | # Check reference assignment isn't affected by the SV type (bug #38439) | |
484 | $gᓙʞ = 3; | |
485 | $sምḲ = 4; | |
486 | $ᕘf = "halt and cool down"; | |
487 | ||
488 | my $rv = \*sምḲ; | |
489 | is($gᓙʞ, 3); | |
490 | *gᓙʞ = $rv; | |
491 | is($gᓙʞ, 4); | |
492 | ||
493 | my $pv = ""; | |
494 | $pv = \*sምḲ; | |
495 | is($ᕘf, "halt and cool down"); | |
496 | *ᕘf = $pv; | |
497 | is($ᕘf, 4); | |
498 | } | |
499 | ||
e0260a5b | 500 | { |
ca237673 BF |
501 | no warnings 'once'; |
502 | format = | |
503 | . | |
504 | ||
2eaf799e | 505 | foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) { |
ca237673 BF |
506 | # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns |
507 | # IO::Handle, which isn't what we want. | |
508 | my $type = $value; | |
509 | $type =~ s/.*=//; | |
510 | $type =~ s/\(.*//; | |
511 | delete $::{оઓnḲ}; | |
512 | $::{оઓnḲ} = $value; | |
513 | $proto = eval 'prototype \&оઓnḲ'; | |
514 | like ($@, qr/^Cannot convert a reference to $type to typeglob/, | |
515 | "Cannot upgrade ref-to-$type to typeglob"); | |
516 | } | |
517 | } | |
518 | ||
519 | { | |
520 | no warnings qw(once uninitialized); | |
521 | my $g = \*ȼલᑧɹ; | |
522 | my $r = eval {no strict; ${*{$g}{SCALAR}}}; | |
523 | is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax"); | |
524 | ||
525 | $g = \*vȍwɯ; | |
526 | $r = eval {use strict; ${*{$g}{SCALAR}}}; | |
527 | is ($@, '', | |
528 | "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict"); | |
529 | } | |
530 | ||
531 | { | |
532 | # Bug reported by broquaint on IRC | |
533 | *ᔅᓗsḨ::{HASH}->{ISA}=[]; | |
534 | ᔅᓗsḨ->import; | |
535 | pass("gv_fetchmeth coped with the unexpected"); | |
536 | ||
537 | # An audit found these: | |
538 | { | |
539 | package ᔅᓗsḨ; | |
540 | sub 맆 { | |
541 | my $s = shift; | |
542 | $s->SUPER::맆; | |
543 | } | |
544 | } | |
545 | { | |
ca237673 BF |
546 | eval {ᔅᓗsḨ->맆;}; |
547 | like ($@, qr/^Can't locate object method "맆"/, "Even with SUPER"); | |
548 | } | |
549 | is(ᔅᓗsḨ->isa('swoosh'), ''); | |
550 | } | |
551 | ||
552 | { | |
553 | die if exists $::{본ㄎ}; | |
554 | $::{본ㄎ} = \"포ヰe"; | |
555 | *{"본ㄎ"} = \&{"본ㄎ"}; | |
556 | eval 'is(본ㄎ(), "포ヰe", | |
557 | "Assignment works when glob created midway (bug 45607)"); 1' | |
558 | or die $@; | |
559 | } | |
560 | ||
561 | ||
562 | # [perl #72740] - indirect object syntax, heuristically imputed due to | |
563 | # the non-existence of a function, should not cause a stash entry to be | |
564 | # created for the non-existent function. | |
4886938f | 565 | { |
ca237673 | 566 | { |
4886938f BF |
567 | package RƬ72740a; |
568 | my $f = bless({}, RƬ72740b); | |
ca237673 BF |
569 | sub s1 { s2 $f; } |
570 | our $s4; | |
571 | sub s3 { s4 $f; } | |
572 | } | |
573 | { | |
4886938f BF |
574 | package RƬ72740b; |
575 | sub s2 { "RƬ72740b::s2" } | |
576 | sub s4 { "RƬ72740b::s4" } | |
ca237673 | 577 | } |
4886938f BF |
578 | ok(exists($RƬ72740a::{s1}), "RƬ72740a::s1 exists"); |
579 | ok(!exists($RƬ72740a::{s2}), "RƬ72740a::s2 does not exist"); | |
580 | ok(exists($RƬ72740a::{s3}), "RƬ72740a::s3 exists"); | |
581 | ok(exists($RƬ72740a::{s4}), "RƬ72740a::s4 exists"); | |
582 | is(RƬ72740a::s1(), "RƬ72740b::s2", "RƬ72740::s1 parsed correctly"); | |
583 | is(RƬ72740a::s3(), "RƬ72740b::s4", "RƬ72740::s3 parsed correctly"); | |
ca237673 BF |
584 | } |
585 | ||
586 | # [perl #71686] Globs that are in symbol table can be un-globbed | |
587 | $ŚyṀ = undef; | |
588 | $::{Ḟ앜ɞ} = *ŚyṀ; | |
589 | is (eval 'local *::Ḟ앜ɞ = \"chuck"; $Ḟ앜ɞ', 'chuck', | |
590 | "Localized glob didn't coerce into a RV"); | |
591 | is ($@, '', "Can localize FAKE glob that's present in stash"); | |
e0260a5b | 592 | { |
ca237673 BF |
593 | is (scalar $::{Ḟ앜ɞ}, "*main::ŚyṀ", |
594 | "Localized FAKE glob's value was correctly restored"); | |
595 | } | |
596 | ||
597 | # [perl #1804] *$x assignment when $x is a copy of another glob | |
598 | # And [perl #77508] (same thing with list assignment) | |
119cacd0 | 599 | { |
ca237673 BF |
600 | no warnings 'once'; |
601 | my $x = *_ràndom::glob_that_is_not_used_elsewhere; | |
602 | *$x = sub{}; | |
603 | is( | |
604 | "$x", '*_ràndom::glob_that_is_not_used_elsewhere', | |
605 | '[perl #1804] *$x assignment when $x is FAKE', | |
606 | ); | |
607 | $x = *_ràndom::glob_that_is_not_used_elsewhere; | |
608 | (my $dummy, *$x) = (undef,[]); | |
609 | is( | |
610 | "$x", '*_ràndom::glob_that_is_not_used_elsewhere', | |
611 | '[perl #77508] *$x list assignment when $x is FAKE', | |
119cacd0 | 612 | ) or require Devel::Peek, Devel::Peek::Dump($x); |
ca237673 BF |
613 | } |
614 | ||
615 | # [perl #76540] | |
616 | # this caused panics or 'Attempt to free unreferenced scalar' | |
617 | # (its a compile-time issue, so the die lets us skip the prints) | |
618 | { | |
619 | my @warnings; | |
620 | local $SIG{__WARN__} = sub { push @warnings, @_ }; | |
621 | ||
622 | eval <<'EOF'; | |
623 | BEGIN { $::{FÒÒ} = \'ᴮᛅ' } | |
624 | die "made it"; | |
625 | print FÒÒ, "\n"; | |
626 | print FÒÒ, "\n"; | |
627 | EOF | |
628 | ||
629 | like($@, qr/made it/, "#76540 - no panic"); | |
630 | ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'"); | |
631 | } | |
632 | ||
633 | # [perl #77362] various bugs related to globs as PVLVs | |
2e434a10 | 634 | { |
ca237673 BF |
635 | no warnings qw 'once void'; |
636 | my %h; # We pass a key of this hash to the subroutine to get a PVLV. | |
637 | sub { for(shift) { | |
638 | # Set up our glob-as-PVLV | |
639 | $_ = *hòn; | |
640 | is $_, "*main::hòn"; | |
641 | ||
642 | # Bad symbol for array | |
643 | ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@; | |
644 | ||
2e434a10 | 645 | { |
ca237673 BF |
646 | # This should call TIEHANDLE, not TIESCALAR |
647 | *thèxt::TIEHANDLE = sub{}; | |
648 | ok eval{ tie *$_, 'thèxt'; 1 }, 'PVLV globs can be tied as handles' | |
649 | or diag $@; | |
650 | } | |
651 | # Assigning undef to the glob should not overwrite it... | |
652 | { | |
653 | my $w; | |
654 | local $SIG{__WARN__} = sub { $w = shift }; | |
655 | *$_ = undef; | |
656 | is $_, "*main::hòn", 'PVLV: assigning undef to the glob does nothing'; | |
657 | like $w, qr\Undefined value assigned to typeglob\, | |
658 | 'PVLV: assigning undef to the glob warns'; | |
659 | } | |
660 | ||
661 | # Neither should reference assignment. | |
662 | *$_ = []; | |
663 | is $_, "*main::hòn", "PVLV: arrayref assignment assigns to the AV slot"; | |
664 | ||
665 | # Concatenation should still work. | |
666 | ok eval { $_ .= 'thlèw' }, 'PVLV concatenation does not die' or diag $@; | |
667 | is $_, '*main::hònthlèw', 'PVLV concatenation works'; | |
668 | ||
669 | # And we should be able to overwrite it with a string, number, or refer- | |
670 | # ence, too, if we omit the *. | |
671 | $_ = *hòn; $_ = 'tzòr'; | |
672 | is $_, 'tzòr', 'PVLV: assigning a string over a glob'; | |
673 | $_ = *hòn; $_ = 23; | |
674 | is $_, 23, 'PVLV: assigning an integer over a glob'; | |
675 | $_ = *hòn; $_ = 23.23; | |
676 | is $_, 23.23, 'PVLV: assigning a float over a glob'; | |
677 | $_ = *hòn; $_ = \my $sthat; | |
678 | is $_, \$sthat, 'PVLV: assigning a reference over a glob'; | |
679 | ||
680 | # This bug was found by code inspection. Could this ever happen in | |
681 | # real life? :-) | |
682 | # This duplicates a file handle, accessing it through a PVLV glob, the | |
683 | # glob having been removed from the symbol table, so a stringified form | |
684 | # of it does not work. This checks that sv_2io does not stringify a PVLV. | |
685 | $_ = *quìn; | |
686 | open *quìn, "test.pl"; # test.pl is as good a file as any | |
687 | delete $::{quìn}; | |
688 | ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not' | |
689 | or diag $@; | |
690 | ||
691 | # Similar tests to make sure sv_2cv etc. do not stringify. | |
692 | *$_ = sub { 1 }; | |
693 | ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@; | |
694 | *flèlp = sub { 2 }; | |
695 | $_ = 'flèlp'; | |
696 | is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub' | |
697 | or diag $@; | |
698 | ||
699 | # Coderef-to-glob assignment when the glob is no longer accessible | |
700 | # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV | |
701 | # optimisation takes PVLVs into account, which is why the RHSs have to be | |
702 | # named subs. | |
703 | use constant ghèèn => 'quàrè'; | |
704 | $_ = *mìng; | |
705 | delete $::{mìng}; | |
706 | *$_ = \&ghèèn; | |
707 | is eval { &$_ }, 'quàrè', | |
708 | 'PVLV: constant assignment when the glob is detached from the symtab' | |
709 | or diag $@; | |
710 | $_ = *bèngth; | |
711 | delete $::{bèngth}; | |
712 | *ghèck = sub { 'lon' }; | |
713 | *$_ = \&ghèck; | |
714 | is eval { &$_ }, 'lon', | |
715 | 'PVLV: coderef assignment when the glob is detached from the symtab' | |
716 | or diag $@; | |
717 | ||
718 | SKIP: { | |
719 | skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1); | |
720 | # open should accept a PVLV as its first argument | |
721 | $_ = *hòn; | |
722 | ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open' | |
723 | or diag $@; | |
724 | } | |
725 | ||
726 | # -t should not stringify | |
727 | $_ = *thlìt; delete $::{thlìt}; | |
728 | *$_ = *STDOUT{IO}; | |
729 | ok defined -t $_, 'PVLV: -t does not stringify'; | |
730 | ||
731 | # neither should -T | |
732 | # but some systems donâ\80\99t support this on file handles | |
733 | my $pass; | |
734 | ok | |
735 | eval { | |
736 | open my $quìle, "<", 'test.pl'; | |
737 | $_ = *$quìle; | |
738 | $pass = -T $_; | |
739 | 1 | |
740 | } ? $pass : $@ =~ /not implemented on filehandles/, | |
741 | "PVLV: -T does not stringify"; | |
742 | # Unopened file handle | |
743 | { | |
744 | my $w; | |
745 | local $SIG{__WARN__} = sub { $w .= shift }; | |
746 | $_ = *vòr; | |
747 | close $_; | |
748 | like $w, qr\unopened filehandle vòr\, | |
749 | 'PVLV globs get their names reported in unopened error messages'; | |
750 | } | |
751 | ||
752 | }}->($h{k}); | |
753 | } | |
754 | ||
755 | *àieee = 4; | |
756 | pass('Can assign integers to typeglobs'); | |
757 | *àieee = 3.14; | |
758 | pass('Can assign floats to typeglobs'); | |
759 | *àieee = 'pi'; | |
760 | pass('Can assign strings to typeglobs'); | |
761 | ||
4886938f | 762 | |
ca237673 BF |
763 | { |
764 | package thrèxt; | |
765 | sub TIESCALAR{bless[]} | |
766 | sub STORE{ die "No!"} | |
767 | sub FETCH{ no warnings 'once'; *thrìt } | |
768 | tie my $a, "thrèxt"; | |
769 | () = "$a"; # do a fetch; now $a holds a glob | |
770 | eval { *$a = sub{} }; | |
771 | untie $a; | |
772 | eval { $a = "ᴮᛅ" }; | |
773 | ::is $a, "ᴮᛅ", | |
774 | "[perl #77812] Globs in tied scalars can be reified if STORE dies" | |
775 | } | |
ca237673 BF |
776 | |
777 | # These two crashed prior to 5.13.6. In 5.13.6 they were fatal errors. They | |
778 | # were fixed in 5.13.7. | |
779 | ok eval { | |
780 | my $glob = \*hèèn::ISA; | |
781 | delete $::{"hèèn::"}; | |
782 | *$glob = *ᴮᛅ; | |
783 | }, "glob-to-*ISA assignment works when *ISA has lost its stash"; | |
784 | ok eval { | |
785 | my $glob = \*slàre::ISA; | |
786 | delete $::{"slàre::"}; | |
787 | *$glob = []; | |
788 | }, "array-to-*ISA assignment works when *ISA has lost its stash"; | |
789 | # These two crashed in 5.13.6. They were likewise fixed in 5.13.7. | |
790 | ok eval { | |
791 | sub grèck; | |
792 | my $glob = do { no warnings "once"; \*phìng::ᕘ}; | |
793 | delete $::{"phìng::"}; | |
794 | *$glob = *grèck; | |
795 | }, "Assigning a glob-with-sub to a glob that has lost its stash warks"; | |
796 | ok eval { | |
797 | sub pòn::ᕘ; | |
798 | my $glob = \*pòn::ᕘ; | |
799 | delete $::{"pòn::"}; | |
800 | *$glob = *ᕘ; | |
801 | }, "Assigning a glob to a glob-with-sub that has lost its stash warks"; | |
802 | ||
803 | { | |
804 | package Tie::Alias; | |
805 | sub TIESCALAR{ bless \\pop } | |
806 | sub FETCH { $${$_[0]} } | |
807 | sub STORE { $${$_[0]} = $_[1] } | |
808 | package main; | |
809 | tie my $alias, 'Tie::Alias', my $var; | |
810 | no warnings 'once'; | |
811 | $var = *gàlobbe; | |
812 | { | |
813 | local *$alias = []; | |
814 | $var = 3; | |
815 | is $alias, 3, "[perl #77926] Glob reification during localisation"; | |
816 | } | |
817 | } | |
818 | ||
819 | # This code causes gp_free to call a destructor when a glob is being | |
820 | # restored on scope exit. The destructor used to see SVs with a refcount of | |
821 | # zero inside the glob, which could result in crashes (though not in this | |
822 | # test case, which just panics). | |
4886938f | 823 | { |
ca237673 BF |
824 | no warnings 'once'; |
825 | my $survived; | |
826 | *Trìt::DESTROY = sub { | |
827 | $thwèxt = 42; # panic | |
828 | $survived = 1; | |
829 | }; | |
830 | { | |
831 | local *thwèxt = bless [],'Trìt'; | |
832 | (); | |
833 | } | |
834 | ok $survived, | |
835 | 'no error when gp_free calls a destructor that assigns to the gv'; | |
836 | } | |
837 | ||
838 | __END__ | |
839 | Perl | |
840 | Rules | |
841 | perl | |
842 | rocks |