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