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