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