*glob{FILEHANDLE} is no longer deprecated
[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
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
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
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
222 # [ID 20010526.001] localized glob loses value when assigned to
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 }
274
275 {
276
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 }
296
297 {
298     SKIP: {
299         skip_if_miniperl('no dynamic loading on miniperl, no Encode', 2);
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
325 {
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
401 {
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
500 {
501 no warnings 'once';
502 format =
503 .
504     
505     foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) {
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     {
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.
565 {
566     {
567             package RƬ72740a;
568             my $f = bless({}, RƬ72740b);
569             sub s1 { s2 $f; }
570             our $s4;
571             sub s3 { s4 $f; }
572     }
573     {
574             package RƬ72740b;
575             sub s2 { "RƬ72740b::s2" }
576             sub s4 { "RƬ72740b::s4" }
577     }
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");
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");
592 {
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)
599  {
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',
612     ) or require Devel::Peek, Devel::Peek::Dump($x);
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
634 {
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
645     {
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
762
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 }
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).
823 {
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