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