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