xref: /openbsd/gnu/usr.bin/perl/t/uni/gv.t (revision 5af055cd) 
1#!./perl
2
3#
4# various typeglob tests
5#
6
7BEGIN {
8    chdir 't' if -d 't';
9    @INC = '../lib';
10    require './test.pl';
11}
12
13use utf8;
14use open qw( :utf8 :std );
15use warnings;
16
17plan( tests => 211 );
18
19# type coersion on assignment
20$ᕘ = 'ᕘ';
21$ᴮᛅ = *main::ᕘ;
22$ᴮᛅ = $ᕘ;
23is(ref(\$ᴮᛅ), 'SCALAR');
24$ᕘ = *main::ᴮᛅ;
25
26# type coersion (not) on misc ops
27
28ok($ᕘ);
29is(ref(\$ᕘ), 'GLOB');
30
31unlike ($ᕘ, qr/abcd/);
32is(ref(\$ᕘ), 'GLOB');
33
34is($ᕘ, '*main::ᴮᛅ');
35is(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ɥአＱuઍ} = *ᴮᛅ;
52 eval '
53   is(
54     \$::{pɥአＱuઍ}, \*pɥአＱuઍ,
55     "compile-time *{} returns symtab entry when FAKE"
56   );
57   ${\*pɥአＱuઍ} = undef;
58 ';
59 is(
60   ref(\$::{pɥአＱuઍ}), '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//;
69is(ref(\$a), 'GLOB');
70$a =~ s/^\*//;
71is($a, 'main::ᕘ');
72is(ref(\$b), 'GLOB');
73
74# typeglobs as lvalues
75substr($ᕘ, 0, 1) = "XXX";
76is(ref(\$ᕘ), 'SCALAR');
77is($ᕘ, 'XXXmain::ᴮᛅ');
78
79# returning glob values
80sub ᕘ {
81  local($ᴮᛅ) = *main::ᕘ;
82  $ᕘ = *main::ᴮᛅ;
83  return ($ᕘ, $ᴮᛅ);
84}
85
86($ፉṶ, $ባ) = ᕘ();
87ok(defined $ፉṶ);
88is(ref(\$ፉṶ), 'GLOB');
89
90
91ok(defined $ባ);
92is(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; }
100ok(exists $ฝ오::{'ʉ::'});
101is($ฝ오::{'ʉ::'}, '*ฝ오::ʉ::');
102
103
104# test undef operator clearing out entire glob
105$ᕘ = 'stuff';
106@ᕘ = qw(more stuff);
107%ᕘ = qw(even more random stuff);
108undef *ᕘ;
109is ($ᕘ, undef);
110is (scalar @ᕘ, 0);
111is (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
152my $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;
160sub Ẋ { "ok $test\n" }
161print ${*Ẋ{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;
165format Ẋ =
166XXX This text isn't used. Should it be?
167.
168curr_test($test);
169
170is (ref *Ẋ{FORMAT}, "FORMAT");
171*Ẋ = *STDOUT;
172is (*{*Ẋ{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ʎｍ000";
195    ok(!defined *{$a});
196
197    {
198	no warnings 'deprecated';
199	ok(!defined @{$a});
200    }
201    ok(!defined *{$a});
202
203    {
204	no warnings 'deprecated';
205	ok(!defined %{$a});
206    }
207    ok(!defined *{$a});
208
209    ok(!defined ${$a});
210    ok(!defined *{$a});
211
212    ok(!defined &{$a});
213    ok(!defined *{$a});
214
215    my $state = "not";
216    *{$a} = sub { $state = "ok" };
217    ok(defined &{$a});
218    ok(defined *{$a});
219    &{$a};
220    is ($state, 'ok');
221}
222
223# [ID 20010526.001] localized glob loses value when assigned to
224
225$Ｊ=1; %Ｊ=(a=>1); @Ｊ=(1); local *Ｊ=*Ｊ; *Ｊ = sub{};
226
227is($Ｊ, 1);
228is($Ｊ{a}, 1);
229is($Ｊ[0], 1);
230
231{
232    # does pp_readline() handle glob-ness correctly?
233    my $g = *ᕘ;
234    $g = <DATA>;
235    is ($g, "Perl\n");
236}
237
238{
239    my $w = '';
240    local $SIG{__WARN__} = sub { $w = $_[0] };
241    sub aʙȼ1 ();
242    local *aʙȼ1 = sub { };
243    is ($w, '');
244    sub aʙȼ2 ();
245    local *aʙȼ2;
246    *aʙȼ2 = sub { };
247    is ($w, '');
248    sub aʙȼ3 ();
249    *aʙȼ3 = sub { };
250    like ($w, qr/Prototype mismatch/);
251}
252
253{
254    # [17375] rcatline to formerly-defined undef was broken. Fixed in
255    # do_readline by checking SvOK. AMS, 20020918
256    my $x = "not ";
257    $x  = undef;
258    $x .= <DATA>;
259    is ($x, "Rules\n");
260}
261
262{
263    # test the assignment of a GLOB to an LVALUE
264    my $e = '';
265    local $SIG{__DIE__} = sub { $e = $_[0] };
266    my %Ｖ;
267    sub ƒ { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
268    ƒ($Ｖ{Ｖ});
269    is ($Ｖ{Ｖ}, '*main::DATA');
270    is (ref\$Ｖ{Ｖ}, 'GLOB', 'lvalue assignment preserves globs');
271    my $x = readline $Ｖ{Ｖ};
272    is ($x, "perl\n");
273    is ($e, '', '__DIE__ handler never called');
274}
275
276{
277
278    my $e = '';
279    # GLOB assignment to tied element
280    local $SIG{__DIE__} = sub { $e = $_[0] };
281    sub Ʈ::TIEARRAY  { bless [] => "Ʈ" }
282    sub Ʈ::STORE     { $_[0]->[ $_[1] ] = $_[2] }
283    sub Ʈ::FETCH     { $_[0]->[ $_[1] ] }
284    sub Ʈ::FETCHSIZE { @{$_[0]} }
285    tie my @ary => "Ʈ";
286    $ary[0] = *DATA;
287    is ($ary[0], '*main::DATA');
288    is (
289      ref\tied(@ary)->[0], 'GLOB',
290     'tied elem assignment preserves globs'
291    );
292    is ($e, '', '__DIE__ handler not called');
293    my $x = readline $ary[0];
294    is($x, "rocks\n");
295    is ($e, '', '__DIE__ handler never called');
296}
297
298{
299    SKIP: {
300        skip_if_miniperl('no dynamic loading on miniperl, no Encode', 2);
301        # Need some sort of die or warn to get the global destruction text if the
302        # bug is still present
303        my $prog = <<'EOPROG';
304            use utf8;
305            use open qw( :utf8 :std );
306            package ᴹ;
307            $| = 1;
308            sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
309            package main;
310
311            bless \$Ⱥ::ㄅ, q{ᴹ};
312            *Ⱥ:: = \*ㄅ::;
313EOPROG
314
315        utf8::decode($prog);
316        my $output = runperl(prog => $prog);
317
318        require Encode;
319        $output = Encode::decode("UTF-8", $output);
320        like($output, qr/^Farewell ᴹ=SCALAR/, "DESTROY was called");
321        unlike($output, qr/global destruction/,
322            "unreferenced symbol tables should be cleaned up immediately");
323    }
324}
325
326{
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
358delete $::{оઓnḲ};
359$::{оઓnḲ} = \"Value";
360
361*{"ga_ㄕƚo잎"} = \&{"оઓnḲ"};
362
363is (ref $::{ga_ㄕƚo잎}, 'SCALAR', "Export of proxy constant as is");
364is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
365is (eval 'ga_ㄕƚo잎', "Value", "Constant has correct value");
366is (ref $::{ga_ㄕƚo잎}, 'SCALAR',
367    "Inlining of constant doesn't change representation");
368
369delete $::{ga_ㄕƚo잎};
370
371eval 'sub ga_ㄕƚo잎 (); 1' or die $@;
372is ($::{ga_ㄕƚo잎}, '', "Prototype is stored as an empty string");
373
374# Check that a prototype expands.
375*{"ga_ㄕƚo잎"} = \&{"оઓnḲ"};
376
377is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
378is (eval 'ga_ㄕƚo잎', "Value", "Constant has correct value");
379is (ref \$::{ga_ㄕƚo잎}, 'GLOB', "Symbol table has full typeglob");
380
381
382@::zᐓｔ = ('Zᐓｔ!');
383
384# Check that assignment to an existing typeglob works
385{
386  my $w = '';
387  local $SIG{__WARN__} = sub { $w = $_[0] };
388  *{"zᐓｔ"} = \&{"оઓnḲ"};
389  is($w, '', "Should be no warning");
390}
391
392is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
393is (eval 'zᐓｔ', "Value", "Constant has correct value");
394is (ref \$::{zᐓｔ}, 'GLOB', "Symbol table has full typeglob");
395is (join ('!', @::zᐓｔ), 'Zᐓｔ!', "Existing array still in typeglob");
396
397sub Ṩp맅싵Ş () {
398    "Traditional";
399}
400
401# Check that assignment to an existing subroutine works
402{
403  my $w = '';
404  local $SIG{__WARN__} = sub { $w = $_[0] };
405  *{"Ṩp맅싵Ş"} = \&{"оઓnḲ"};
406  like($w, qr/^Constant subroutine main::Ṩp맅싵Ş redefined/,
407       "Redefining a constant sub should warn");
408}
409
410is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
411is (eval 'Ṩp맅싵Ş', "Value", "Constant has correct value");
412is (ref \$::{Ṩp맅싵Ş}, 'GLOB', "Symbol table has full typeglob");
413
414# Check that assignment to an existing typeglob works
415{
416  my $w = '';
417  local $SIG{__WARN__} = sub { $w = $_[0] };
418  *{"plუᒃ"} = [];
419  *{"plუᒃ"} = \&{"оઓnḲ"};
420  is($w, '', "Should be no warning");
421}
422
423is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
424is (eval 'plუᒃ', "Value", "Constant has correct value");
425is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob");
426
427my $gr = eval '\*plუᒃ' or die;
428
429{
430  my $w = '';
431  local $SIG{__WARN__} = sub { $w = $_[0] };
432  *{$gr} = \&{"оઓnḲ"};
433  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)");
434}
435
436is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
437is (eval 'plუᒃ', "Value", "Constant has correct value");
438is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob");
439
440# Non-void context should defeat the optimisation, and will cause the original
441# to be promoted (what change 26482 intended)
442my $result;
443{
444  my $w = '';
445  local $SIG{__WARN__} = sub { $w = $_[0] };
446  $result = *{"aẈʞƙʞƙʞƙ"} = \&{"оઓnḲ"};
447  is($w, '', "Should be no warning");
448}
449
450is (ref \$result, 'GLOB',
451    "Non void assignment should still return a typeglob");
452
453is (ref \$::{оઓnḲ}, 'GLOB', "This export does affect original");
454is (eval 'plუᒃ', "Value", "Constant has correct value");
455is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob");
456
457delete $::{оઓnḲ};
458$::{оઓnḲ} = \"Value";
459
460sub non_dangling {
461  my $w = '';
462  local $SIG{__WARN__} = sub { $w = $_[0] };
463  *{"z앞"} = \&{"оઓnḲ"};
464  is($w, '', "Should be no warning");
465}
466
467non_dangling();
468is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
469is (eval 'z앞', "Value", "Constant has correct value");
470is (ref $::{z앞}, 'SCALAR', "Exported target is also a PCS");
471
472sub dangling {
473  local $SIG{__WARN__} = sub { die $_[0] };
474  *{"ビfᶠ"} = \&{"оઓnḲ"};
475}
476
477dangling();
478is (ref \$::{оઓnḲ}, 'GLOB', "This export does affect original");
479is (eval 'ビfᶠ', "Value", "Constant has correct value");
480is (ref \$::{ビfᶠ}, 'GLOB', "Symbol table has full typeglob");
481
482{
483    use vars qw($gᓙʞ $sምḲ $ᕘf);
484    # Check reference assignment isn't affected by the SV type (bug #38439)
485    $gᓙʞ = 3;
486    $sምḲ = 4;
487    $ᕘf = "halt and cool down";
488
489    my $rv = \*sምḲ;
490    is($gᓙʞ, 3);
491    *gᓙʞ = $rv;
492    is($gᓙʞ, 4);
493
494    my $pv = "";
495    $pv = \*sምḲ;
496    is($ᕘf, "halt and cool down");
497    *ᕘf = $pv;
498    is($ᕘf, 4);
499}
500
501{
502no warnings 'once';
503format =
504.
505
506    foreach my $value ({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    $::{본ㄎ} = \"포ヰｅ";
556    *{"본ㄎ"} = \&{"본ㄎ"};
557    eval 'is(본ㄎ(), "포ヰｅ",
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Ṁ;
590is (eval 'local *::Ḟ앜ɞ = \"chuck"; $Ḟ앜ɞ', 'chuck',
591	"Localized glob didn't coerce into a RV");
592is ($@, '', "Can localize FAKE glob that's present in stash");
593{
594    is (scalar $::{Ḟ앜ɞ}, "*main::ŚyṀ",
595            "Localized FAKE glob's value was correctly restored");
596}
597
598# [perl #1804] *$x assignment when $x is a copy of another glob
599# And [perl #77508] (same thing with list assignment)
600 {
601    no warnings 'once';
602    my $x = *_ràndom::glob_that_is_not_used_elsewhere;
603    *$x = sub{};
604    is(
605      "$x", '*_ràndom::glob_that_is_not_used_elsewhere',
606      '[perl #1804] *$x assignment when $x is FAKE',
607    );
608    $x = *_ràndom::glob_that_is_not_used_elsewhere;
609    (my $dummy, *$x) = (undef,[]);
610    is(
611      "$x", '*_ràndom::glob_that_is_not_used_elsewhere',
612      '[perl #77508] *$x list assignment when $x is FAKE',
613    ) or require Devel::Peek, Devel::Peek::Dump($x);
614}
615
616# [perl #76540]
617# this caused panics or 'Attempt to free unreferenced scalar'
618# (its a compile-time issue, so the die lets us skip the prints)
619{
620    my @warnings;
621    local $SIG{__WARN__} = sub { push @warnings, @_ };
622
623    eval <<'EOF';
624BEGIN { $::{FÒÒ} = \'ᴮᛅ' }
625die "made it";
626print FÒÒ, "\n";
627print FÒÒ, "\n";
628EOF
629
630    like($@, qr/made it/, "#76540 - no panic");
631    ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'");
632}
633
634# [perl #77362] various bugs related to globs as PVLVs
635{
636 no warnings qw 'once void';
637 my %h; # We pass a key of this hash to the subroutine to get a PVLV.
638 sub { for(shift) {
639  # Set up our glob-as-PVLV
640  $_ = *hòn;
641  is $_, "*main::hòn";
642
643  # Bad symbol for array
644  ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@;
645
646    {
647        # This should call TIEHANDLE, not TIESCALAR
648        *thèxt::TIEHANDLE = sub{};
649        ok eval{ tie *$_, 'thèxt'; 1 }, 'PVLV globs can be tied as handles'
650            or diag $@;
651    }
652  # Assigning undef to the glob should not overwrite it...
653  {
654   my $w;
655   local $SIG{__WARN__} = sub { $w = shift };
656   *$_ = undef;
657   is $_, "*main::hòn", 'PVLV: assigning undef to the glob does nothing';
658   like $w, qr\Undefined value assigned to typeglob\,
659    'PVLV: assigning undef to the glob warns';
660  }
661
662  # Neither should reference assignment.
663  *$_ = [];
664  is $_, "*main::hòn", "PVLV: arrayref assignment assigns to the AV slot";
665
666  # Concatenation should still work.
667  ok eval { $_ .= 'thlèw' }, 'PVLV concatenation does not die' or diag $@;
668  is $_, '*main::hònthlèw', 'PVLV concatenation works';
669
670  # And we should be able to overwrite it with a string, number, or refer-
671  # ence, too, if we omit the *.
672  $_ = *hòn; $_ = 'tzòr';
673  is $_, 'tzòr', 'PVLV: assigning a string over a glob';
674  $_ = *hòn; $_ = 23;
675  is $_, 23, 'PVLV: assigning an integer over a glob';
676  $_ = *hòn; $_ = 23.23;
677  is $_, 23.23, 'PVLV: assigning a float over a glob';
678  $_ = *hòn; $_ = \my $sthat;
679  is $_, \$sthat, 'PVLV: assigning a reference over a glob';
680
681  # This bug was found by code inspection. Could this ever happen in
682  # real life? :-)
683  # This duplicates a file handle, accessing it through a PVLV glob, the
684  # glob having been removed from the symbol table, so a stringified form
685  # of it does not work. This checks that sv_2io does not stringify a PVLV.
686  $_ = *quìn;
687  open *quìn, "test.pl"; # test.pl is as good a file as any
688  delete $::{quìn};
689  ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not'
690   or diag $@;
691
692  # Similar tests to make sure sv_2cv etc. do not stringify.
693  *$_ = sub { 1 };
694  ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@;
695  *flèlp = sub { 2 };
696  $_ = 'flèlp';
697  is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub'
698   or diag $@;
699
700  # Coderef-to-glob assignment when the glob is no longer accessible
701  # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV
702  # optimisation takes PVLVs into account, which is why the RHSs have to be
703  # named subs.
704  use constant ghèèn => 'quàrè';
705  $_ = *mìng;
706  delete $::{mìng};
707  *$_ = \&ghèèn;
708  is eval { &$_ }, 'quàrè',
709   'PVLV: constant assignment when the glob is detached from the symtab'
710    or diag $@;
711  $_ = *bèngth;
712  delete $::{bèngth};
713  *ghèck = sub { 'lon' };
714  *$_ = \&ghèck;
715  is eval { &$_ }, 'lon',
716   'PVLV: coderef assignment when the glob is detached from the symtab'
717    or diag $@;
718
719SKIP: {
720    skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
721    # open should accept a PVLV as its first argument
722    $_ = *hòn;
723    ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open'
724	or diag $@;
725  }
726
727  # -t should not stringify
728  $_ = *thlìt; delete $::{thlìt};
729  *$_ = *STDOUT{IO};
730  ok defined -t $_, 'PVLV: -t does not stringify';
731
732  # neither should -T
733  # but some systems don’t support this on file handles
734  my $pass;
735  ok
736    eval {
737     open my $quìle, "<", 'test.pl';
738     $_ = *$quìle;
739     $pass = -T $_;
740     1
741    } ? $pass : $@ =~ /not implemented on filehandles/,
742   "PVLV: -T does not stringify";
743  # Unopened file handle
744  {
745   my $w;
746   local $SIG{__WARN__} = sub { $w .= shift };
747   $_ = *vòr;
748   close $_;
749   like $w, qr\unopened filehandle vòr\,
750    'PVLV globs get their names reported in unopened error messages';
751  }
752
753 }}->($h{k});
754}
755
756*àieee = 4;
757pass('Can assign integers to typeglobs');
758*àieee = 3.14;
759pass('Can assign floats to typeglobs');
760*àieee = 'pi';
761pass('Can assign strings to typeglobs');
762
763
764{
765  package thrèxt;
766  sub TIESCALAR{bless[]}
767  sub STORE{ die "No!"}
768  sub FETCH{ no warnings 'once'; *thrìt }
769  tie my $a, "thrèxt";
770  () = "$a"; # do a fetch; now $a holds a glob
771  eval { *$a = sub{} };
772  untie $a;
773  eval { $a = "ᴮᛅ" };
774  ::is $a, "ᴮᛅ",
775    "[perl #77812] Globs in tied scalars can be reified if STORE dies"
776}
777
778# These two crashed prior to 5.13.6. In 5.13.6 they were fatal errors. They
779# were fixed in 5.13.7.
780ok eval {
781  my $glob = \*hèèn::ISA;
782  delete $::{"hèèn::"};
783  *$glob = *ᴮᛅ;
784}, "glob-to-*ISA assignment works when *ISA has lost its stash";
785ok eval {
786  my $glob = \*slàre::ISA;
787  delete $::{"slàre::"};
788  *$glob = [];
789}, "array-to-*ISA assignment works when *ISA has lost its stash";
790# These two crashed in 5.13.6. They were likewise fixed in 5.13.7.
791ok eval {
792  sub grèck;
793  my $glob = do { no warnings "once"; \*phìng::ᕘ};
794  delete $::{"phìng::"};
795  *$glob = *grèck;
796}, "Assigning a glob-with-sub to a glob that has lost its stash warks";
797ok eval {
798  sub pòn::ᕘ;
799  my $glob = \*pòn::ᕘ;
800  delete $::{"pòn::"};
801  *$glob = *ᕘ;
802}, "Assigning a glob to a glob-with-sub that has lost its stash warks";
803
804{
805  package Tie::Alias;
806  sub TIESCALAR{ bless \\pop }
807  sub FETCH { $${$_[0]} }
808  sub STORE { $${$_[0]} = $_[1] }
809  package main;
810  tie my $alias, 'Tie::Alias', my $var;
811  no warnings 'once';
812  $var = *gàlobbe;
813  {
814    local *$alias = [];
815    $var = 3;
816    is $alias, 3, "[perl #77926] Glob reification during localisation";
817  }
818}
819
820# This code causes gp_free to call a destructor when a glob is being
821# restored on scope exit. The destructor used to see SVs with a refcount of
822# zero inside the glob, which could result in crashes (though not in this
823# test case, which just panics).
824{
825 no warnings 'once';
826 my $survived;
827 *Trìt::DESTROY = sub {
828   $thwèxt = 42;  # panic
829   $survived = 1;
830 };
831 {
832  local *thwèxt = bless [],'Trìt';
833  ();
834 }
835 ok $survived,
836  'no error when gp_free calls a destructor that assigns to the gv';
837}
838
839__END__
840Perl
841Rules
842perl
843rocks
844