This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5db: add tests for v command
[perl5.git] / t / uni / gv.t
CommitLineData
ca237673
BF
1#!./perl
2
3#
4# various typeglob tests
5#
6
7BEGIN {
8 chdir 't' if -d 't';
ca237673 9 require './test.pl';
43ece5b1 10 set_up_inc('../lib');
2b08d1e2 11 skip_all_without_unicode_tables();
ca237673
BF
12}
13
14use utf8;
15use open qw( :utf8 :std );
16use warnings;
17
2eaf799e 18plan( tests => 206 );
ca237673
BF
19
20# type coersion on assignment
21$ᕘ = 'ᕘ';
22$ᴮᛅ = *main::ᕘ;
23$ᴮᛅ = $ᕘ;
24is(ref(\$ᴮᛅ), 'SCALAR');
25$ᕘ = *main::ᴮᛅ;
26
27# type coersion (not) on misc ops
28
29ok($ᕘ);
30is(ref(\$ᕘ), 'GLOB');
31
32unlike ($ᕘ, qr/abcd/);
33is(ref(\$ᕘ), 'GLOB');
34
35is($ᕘ, '*main::ᴮᛅ');
36is(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//;
70is(ref(\$a), 'GLOB');
71$a =~ s/^\*//;
72is($a, 'main::ᕘ');
73is(ref(\$b), 'GLOB');
74
75# typeglobs as lvalues
76substr($ᕘ, 0, 1) = "XXX";
77is(ref(\$ᕘ), 'SCALAR');
78is($ᕘ, 'XXXmain::ᴮᛅ');
79
80# returning glob values
81sub ᕘ {
82 local($ᴮᛅ) = *main::ᕘ;
83 $ᕘ = *main::ᴮᛅ;
84 return ($ᕘ, $ᴮᛅ);
85}
86
87($ፉṶ, $ባ) = ᕘ();
88ok(defined $ፉṶ);
89is(ref(\$ፉṶ), 'GLOB');
90
91
92ok(defined $ባ);
93is(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; }
101ok(exists $ฝ오::{'ʉ::'});
102is($ฝ오::{'ʉ::'}, '*ฝ오::ʉ::');
103
104
105# test undef operator clearing out entire glob
106$ᕘ = 'stuff';
107@ᕘ = qw(more stuff);
108%ᕘ = qw(even more random stuff);
109undef *ᕘ;
110is ($ᕘ, undef);
111is (scalar @ᕘ, 0);
112is (scalar %ᕘ, 0);
113
472394e4 114{
ca237673
BF
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
d6945f70
KW
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)
92e8e650
KW
128 "Argument \"\\*main::(?:PW\\\\x\\{%x\\}MPF"
129 . "|SKR\\\\x\\{%x\\}\\\\x\\{%x\\}\\\\x\\{%x\\})\" "
d6945f70
KW
130 . "isn't numeric in sprintf",
131 $O_grave, $E_grave, $E_grave, $E_grave);
132 $pat = qr/$pat/;
133
ca237673
BF
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", $_;
d6945f70 140 like($msg, $pat, "Warning on conversion to IV");
ca237673
BF
141 is($victim, 0);
142
143 $msg = '';
144 $victim = sprintf "%u", $_;
d6945f70 145 like($msg, $pat, "Warning on conversion to UV");
ca237673
BF
146 is($victim, 0);
147
148 $msg = '';
149 $victim = sprintf "%e", $_;
d6945f70 150 like($msg, $pat, "Warning on conversion to NV");
ca237673
BF
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
160my $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;
168sub Ẋ { "ok $test\n" }
169print ${*Ẋ{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;
173format Ẋ =
174XXX This text isn't used. Should it be?
175.
176curr_test($test);
177
178is (ref *Ẋ{FORMAT}, "FORMAT");
179*Ẋ = *STDOUT;
180is (*{*Ẋ{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};
83677dc5
RS
193
194 # deprecation warning removed in v5.23 -- rjbs, 2015-12-31
8034715d 195 # https://github.com/Perl/perl5/issues/15105
83677dc5 196 print {*Ẋ{IO}} (! defined $warn
ca237673
BF
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
ca237673
BF
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
ee95e30c 222# [ID 20010526.001 (#7038)] localized glob loses value when assigned to
ca237673
BF
223
224$J=1; %J=(a=>1); @J=(1); local *J=*J; *J = sub{};
225
226is($J, 1);
227is($J{a}, 1);
228is($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}
4886938f
BF
274
275{
276
ca237673
BF
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}
4886938f
BF
296
297{
ca237673 298 SKIP: {
8cb149dc 299 skip_if_miniperl('no dynamic loading on miniperl, no Encode', 2);
ca237673
BF
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 *Ⱥ:: = \*ㄅ::;
312EOPROG
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
e0260a5b 325{
ca237673
BF
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
357delete $::{оઓnḲ};
358$::{оઓnḲ} = \"Value";
359
360*{"ga_ㄕƚo잎"} = \&{"оઓnḲ"};
361
362is (ref $::{ga_ㄕƚo잎}, 'SCALAR', "Export of proxy constant as is");
363is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
364is (eval 'ga_ㄕƚo잎', "Value", "Constant has correct value");
365is (ref $::{ga_ㄕƚo잎}, 'SCALAR',
366 "Inlining of constant doesn't change representation");
367
368delete $::{ga_ㄕƚo잎};
369
370eval 'sub ga_ㄕƚo잎 (); 1' or die $@;
371is ($::{ga_ㄕƚo잎}, '', "Prototype is stored as an empty string");
372
373# Check that a prototype expands.
374*{"ga_ㄕƚo잎"} = \&{"оઓnḲ"};
375
376is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
377is (eval 'ga_ㄕƚo잎', "Value", "Constant has correct value");
378is (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
391is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
392is (eval 'zᐓt', "Value", "Constant has correct value");
393is (ref \$::{zᐓt}, 'GLOB', "Symbol table has full typeglob");
394is (join ('!', @::zᐓt), 'Zᐓt!', "Existing array still in typeglob");
395
396sub Ṩp맅싵Ş () {
397 "Traditional";
398}
399
400# Check that assignment to an existing subroutine works
2e434a10 401{
ca237673
BF
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
409is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
410is (eval 'Ṩp맅싵Ş', "Value", "Constant has correct value");
411is (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
422is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
423is (eval 'plუᒃ', "Value", "Constant has correct value");
424is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob");
425
426my $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
435is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
436is (eval 'plუᒃ', "Value", "Constant has correct value");
437is (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)
441my $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
449is (ref \$result, 'GLOB',
450 "Non void assignment should still return a typeglob");
451
452is (ref \$::{оઓnḲ}, 'GLOB', "This export does affect original");
453is (eval 'plუᒃ', "Value", "Constant has correct value");
454is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob");
455
456delete $::{оઓnḲ};
457$::{оઓnḲ} = \"Value";
458
459sub non_dangling {
460 my $w = '';
461 local $SIG{__WARN__} = sub { $w = $_[0] };
462 *{"z앞"} = \&{"оઓnḲ"};
463 is($w, '', "Should be no warning");
464}
465
466non_dangling();
467is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original");
468is (eval 'z앞', "Value", "Constant has correct value");
469is (ref $::{z앞}, 'SCALAR', "Exported target is also a PCS");
470
471sub dangling {
472 local $SIG{__WARN__} = sub { die $_[0] };
473 *{"ビfᶠ"} = \&{"оઓnḲ"};
474}
475
476dangling();
477is (ref \$::{оઓnḲ}, 'GLOB', "This export does affect original");
478is (eval 'ビfᶠ', "Value", "Constant has correct value");
479is (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
e0260a5b 500{
ca237673
BF
501no warnings 'once';
502format =
503.
504
2eaf799e 505 foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) {
ca237673
BF
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 {
ca237673
BF
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.
4886938f 565{
ca237673 566 {
4886938f
BF
567 package RƬ72740a;
568 my $f = bless({}, RƬ72740b);
ca237673
BF
569 sub s1 { s2 $f; }
570 our $s4;
571 sub s3 { s4 $f; }
572 }
573 {
4886938f
BF
574 package RƬ72740b;
575 sub s2 { "RƬ72740b::s2" }
576 sub s4 { "RƬ72740b::s4" }
ca237673 577 }
4886938f
BF
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");
ca237673
BF
584}
585
586# [perl #71686] Globs that are in symbol table can be un-globbed
587$ŚyṀ = undef;
588$::{Ḟ앜ɞ} = *ŚyṀ;
589is (eval 'local *::Ḟ앜ɞ = \"chuck"; $Ḟ앜ɞ', 'chuck',
590 "Localized glob didn't coerce into a RV");
591is ($@, '', "Can localize FAKE glob that's present in stash");
e0260a5b 592{
ca237673
BF
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)
119cacd0 599 {
ca237673
BF
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',
119cacd0 612 ) or require Devel::Peek, Devel::Peek::Dump($x);
ca237673
BF
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';
623BEGIN { $::{FÒÒ} = \'ᴮᛅ' }
624die "made it";
625print FÒÒ, "\n";
626print FÒÒ, "\n";
627EOF
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
2e434a10 634{
ca237673
BF
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
2e434a10 645 {
ca237673
BF
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
718SKIP: {
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;
756pass('Can assign integers to typeglobs');
757*àieee = 3.14;
758pass('Can assign floats to typeglobs');
759*àieee = 'pi';
760pass('Can assign strings to typeglobs');
761
4886938f 762
ca237673
BF
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}
ca237673
BF
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.
779ok 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";
784ok 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.
790ok 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";
796ok 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).
4886938f 823{
ca237673
BF
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__
839Perl
840Rules
841perl
842rocks