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