This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Correct test count in UCD.t
[perl5.git] / t / op / gv.t
CommitLineData
b9894134
PP
1#!./perl
2
3#
4# various typeglob tests
5#
6
9f1b1f2d
GS
7BEGIN {
8 chdir 't' if -d 't';
20822f61 9 @INC = '../lib';
13be902c 10 require './test.pl';
98e007d4 11}
9f1b1f2d
GS
12
13use warnings;
14
8d33f848 15plan( tests => 230 );
b9894134
PP
16
17# type coersion on assignment
18$foo = 'foo';
19$bar = *main::foo;
20$bar = $foo;
98e007d4 21is(ref(\$bar), 'SCALAR');
b9894134
PP
22$foo = *main::bar;
23
24# type coersion (not) on misc ops
25
98e007d4
NC
26ok($foo);
27is(ref(\$foo), 'GLOB');
b9894134 28
98e007d4
NC
29unlike ($foo, qr/abcd/);
30is(ref(\$foo), 'GLOB');
b9894134 31
98e007d4
NC
32is($foo, '*main::bar');
33is(ref(\$foo), 'GLOB');
b9894134 34
2acc3314
FC
35{
36 no warnings;
37 ${\*$foo} = undef;
38 is(ref(\$foo), 'GLOB', 'no type coersion when assigning to *{} retval');
39 $::{phake} = *bar;
40 is(
41 \$::{phake}, \*{"phake"},
42 'symbolic *{} returns symtab entry when FAKE'
43 );
44 ${\*{"phake"}} = undef;
45 is(
46 ref(\$::{phake}), 'GLOB',
47 'no type coersion when assigning to retval of symbolic *{}'
48 );
49 $::{phaque} = *bar;
50 eval '
51 is(
52 \$::{phaque}, \*phaque,
53 "compile-time *{} returns symtab entry when FAKE"
54 );
55 ${\*phaque} = undef;
56 ';
57 is(
58 ref(\$::{phaque}), 'GLOB',
59 'no type coersion when assigning to retval of compile-time *{}'
60 );
61}
62
b9894134
PP
63# type coersion on substitutions that match
64$a = *main::foo;
65$b = $a;
66$a =~ s/^X//;
98e007d4 67is(ref(\$a), 'GLOB');
b9894134 68$a =~ s/^\*//;
98e007d4
NC
69is($a, 'main::foo');
70is(ref(\$b), 'GLOB');
b9894134
PP
71
72# typeglobs as lvalues
73substr($foo, 0, 1) = "XXX";
98e007d4
NC
74is(ref(\$foo), 'SCALAR');
75is($foo, 'XXXmain::bar');
b9894134
PP
76
77# returning glob values
78sub foo {
79 local($bar) = *main::foo;
80 $foo = *main::bar;
81 return ($foo, $bar);
82}
83
84($fuu, $baa) = foo();
98e007d4
NC
85ok(defined $fuu);
86is(ref(\$fuu), 'GLOB');
b9894134 87
98e007d4
NC
88
89ok(defined $baa);
90is(ref(\$baa), 'GLOB');
b9894134 91
85aff577
CS
92# nested package globs
93# NOTE: It's probably OK if these semantics change, because the
94# fact that %X::Y:: is stored in %X:: isn't documented.
95# (I hope.)
96
9f1b1f2d 97{ package Foo::Bar; no warnings 'once'; $test=1; }
98e007d4
NC
98ok(exists $Foo::{'Bar::'});
99is($Foo::{'Bar::'}, '*Foo::Bar::');
100
20408e3c
GS
101
102# test undef operator clearing out entire glob
103$foo = 'stuff';
104@foo = qw(more stuff);
105%foo = qw(even more random stuff);
106undef *foo;
98e007d4
NC
107is ($foo, undef);
108is (scalar @foo, 0);
109is (scalar %foo, 0);
20408e3c 110
20408e3c 111{
98e007d4
NC
112 # test warnings from assignment of undef to glob
113 my $msg = '';
20408e3c 114 local $SIG{__WARN__} = sub { $msg = $_[0] };
9f1b1f2d 115 use warnings;
20408e3c 116 *foo = 'bar';
98e007d4 117 is($msg, '');
20408e3c 118 *foo = undef;
98e007d4 119 like($msg, qr/Undefined value assigned to typeglob/);
e36cc0fb
NC
120
121 no warnings 'once';
122 # test warnings for converting globs to other forms
123 my $copy = *PWOMPF;
124 foreach ($copy, *SKREEE) {
125 $msg = '';
126 my $victim = sprintf "%d", $_;
127 like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
128 "Warning on conversion to IV");
129 is($victim, 0);
130
131 $msg = '';
132 $victim = sprintf "%u", $_;
133 like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
134 "Warning on conversion to UV");
135 is($victim, 0);
136
137 $msg = '';
138 $victim = sprintf "%e", $_;
139 like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
140 "Warning on conversion to NV");
141 like($victim, qr/^0\.0+E\+?00/i, "Expect floating point zero");
142
143 $msg = '';
144 $victim = sprintf "%s", $_;
145 is($msg, '', "No warning on stringification");
146 is($victim, '' . $_);
147 }
20408e3c 148}
640b9ef6 149
98e007d4 150my $test = curr_test();
640b9ef6 151# test *glob{THING} syntax
98e007d4
NC
152$x = "ok $test\n";
153++$test;
154@x = ("ok $test\n");
155++$test;
156%x = ("ok $test" => "\n");
157++$test;
158sub x { "ok $test\n" }
640b9ef6 159print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
98e007d4
NC
160# This needs to go here, after the print, as sub x will return the current
161# value of test
162++$test;
f4d13ee9 163format x =
98e007d4 164XXX This text isn't used. Should it be?
f4d13ee9 165.
98e007d4
NC
166curr_test($test);
167
168is (ref *x{FORMAT}, "FORMAT");
640b9ef6 169*x = *STDOUT;
98e007d4 170is (*{*x{GLOB}}, "*main::STDOUT");
39b99f21 171
29a56bd6 172{
98e007d4
NC
173 my $test = curr_test();
174
175 print {*x{IO}} "ok $test\n";
176 ++$test;
177
178 my $warn;
179 local $SIG{__WARN__} = sub {
180 $warn .= $_[0];
181 };
182 my $val = *x{FILEHANDLE};
183 print {*x{IO}} ($warn =~ /is deprecated/
184 ? "ok $test\n" : "not ok $test\n");
185 curr_test(++$test);
29a56bd6
JH
186}
187
35cd451c
GS
188
189{
98e007d4 190 # test if defined() doesn't create any new symbols
35cd451c
GS
191
192 my $a = "SYM000";
98e007d4 193 ok(!defined *{$a});
35cd451c 194
98e007d4
NC
195 ok(!defined @{$a});
196 ok(!defined *{$a});
35cd451c 197
d47e1c27
NC
198 {
199 no warnings 'deprecated';
200 ok(!defined %{$a});
201 }
98e007d4 202 ok(!defined *{$a});
35cd451c 203
98e007d4
NC
204 ok(!defined ${$a});
205 ok(!defined *{$a});
35cd451c 206
98e007d4
NC
207 ok(!defined &{$a});
208 ok(!defined *{$a});
35cd451c 209
98e007d4
NC
210 my $state = "not";
211 *{$a} = sub { $state = "ok" };
212 ok(defined &{$a});
213 ok(defined *{$a});
214 &{$a};
215 is ($state, 'ok');
35cd451c 216}
640b9ef6 217
c9d5ac95 218{
98e007d4 219 # although it *should* if you're talking about magicals
c9d5ac95
GS
220
221 my $a = "]";
98e007d4
NC
222 ok(defined ${$a});
223 ok(defined *{$a});
c9d5ac95
GS
224
225 $a = "1";
226 "o" =~ /(o)/;
98e007d4
NC
227 ok(${$a});
228 ok(defined *{$a});
c9d5ac95 229 $a = "2";
98e007d4
NC
230 ok(!${$a});
231 ok(defined *{$a});
c9d5ac95 232 $a = "1x";
98e007d4
NC
233 ok(!defined ${$a});
234 ok(!defined *{$a});
c9d5ac95
GS
235 $a = "11";
236 "o" =~ /(((((((((((o)))))))))))/;
98e007d4
NC
237 ok(${$a});
238 ok(defined *{$a});
c9d5ac95
GS
239}
240
bd2155e9
JH
241# [ID 20010526.001] localized glob loses value when assigned to
242
243$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
244
98e007d4
NC
245is($j, 1);
246is($j{a}, 1);
247is($j[0], 1);
99491443
GS
248
249{
98e007d4 250 # does pp_readline() handle glob-ness correctly?
99491443
GS
251 my $g = *foo;
252 $g = <DATA>;
98e007d4 253 is ($g, "Perl\n");
99491443
GS
254}
255
fb24441d
RGS
256{
257 my $w = '';
bb112e5a 258 local $SIG{__WARN__} = sub { $w = $_[0] };
fb24441d
RGS
259 sub abc1 ();
260 local *abc1 = sub { };
98e007d4 261 is ($w, '');
fb24441d
RGS
262 sub abc2 ();
263 local *abc2;
264 *abc2 = sub { };
98e007d4 265 is ($w, '');
fb24441d
RGS
266 sub abc3 ();
267 *abc3 = sub { };
98e007d4 268 like ($w, qr/Prototype mismatch/);
fb24441d
RGS
269}
270
2b5e58c4
AMS
271{
272 # [17375] rcatline to formerly-defined undef was broken. Fixed in
273 # do_readline by checking SvOK. AMS, 20020918
274 my $x = "not ";
275 $x = undef;
276 $x .= <DATA>;
98e007d4 277 is ($x, "Rules\n");
2b5e58c4
AMS
278}
279
4ce457a6
TP
280{
281 # test the assignment of a GLOB to an LVALUE
282 my $e = '';
283 local $SIG{__DIE__} = sub { $e = $_[0] };
13be902c 284 my %v;
4ce457a6 285 sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
13be902c
FC
286 f($v{v});
287 is ($v{v}, '*main::DATA');
288 is (ref\$v{v}, 'GLOB', 'lvalue assignment preserves globs');
289 my $x = readline $v{v};
98e007d4 290 is ($x, "perl\n");
4ce457a6
TP
291}
292
98e007d4
NC
293{
294 $e = '';
4ce457a6
TP
295 # GLOB assignment to tied element
296 local $SIG{__DIE__} = sub { $e = $_[0] };
98e007d4
NC
297 sub T::TIEARRAY { bless [] => "T" }
298 sub T::STORE { $_[0]->[ $_[1] ] = $_[2] }
299 sub T::FETCH { $_[0]->[ $_[1] ] }
300 sub T::FETCHSIZE { @{$_[0]} }
4ce457a6
TP
301 tie my @ary => "T";
302 $ary[0] = *DATA;
98e007d4 303 is ($ary[0], '*main::DATA');
13be902c
FC
304 is (
305 ref\tied(@ary)->[0], 'GLOB',
306 'tied elem assignment preserves globs'
307 );
98e007d4 308 is ($e, '');
4ce457a6 309 my $x = readline $ary[0];
98e007d4 310 is($x, "rocks\n");
4ce457a6
TP
311}
312
e15faf7d 313{
4184c77b
NC
314 # Need some sort of die or warn to get the global destruction text if the
315 # bug is still present
5c2a9b31 316 my $output = runperl(prog => <<'EOPROG');
e15faf7d 317package M;
5c2a9b31 318$| = 1;
4184c77b 319sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
e15faf7d
NC
320package main;
321
3d7a9343 322bless \$A::B, q{M};
e15faf7d
NC
323*A:: = \*B::;
324EOPROG
325 like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
326 unlike($output, qr/global destruction/,
327 "unreferenced symbol tables should be cleaned up immediately");
328}
63fa9adc
NC
329
330# Possibly not the correct test file for these tests.
331# There are certain space optimisations implemented via promotion rules to
332# GVs
333
bb112e5a
NC
334foreach (qw (oonk ga_shloip)) {
335 ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
336}
63fa9adc
NC
337
338# A string in place of the typeglob is promoted to the function prototype
339$::{oonk} = "pie";
340my $proto = eval 'prototype \&oonk';
341die if $@;
342is ($proto, "pie", "String is promoted to prototype");
343
344
345# A reference to a value is used to generate a constant subroutine
346foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
5c1f4d79 347 \*STDIN, \&ok, \undef, *STDOUT) {
63fa9adc
NC
348 delete $::{oonk};
349 $::{oonk} = \$value;
350 $proto = eval 'prototype \&oonk';
351 die if $@;
352 is ($proto, '', "Prototype for a constant subroutine is empty");
353
354 my $got = eval 'oonk';
355 die if $@;
5c1f4d79 356 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
63fa9adc
NC
357 is ($got, $value, "Value is correctly set");
358}
5c1f4d79 359
bb112e5a
NC
360delete $::{oonk};
361$::{oonk} = \"Value";
362
363*{"ga_shloip"} = \&{"oonk"};
364
365is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
366is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
367is (eval 'ga_shloip', "Value", "Constant has correct value");
368is (ref $::{ga_shloip}, 'SCALAR',
369 "Inlining of constant doesn't change represenatation");
370
371delete $::{ga_shloip};
372
373eval 'sub ga_shloip (); 1' or die $@;
374is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
375
376# Check that a prototype expands.
377*{"ga_shloip"} = \&{"oonk"};
378
379is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
380is (eval 'ga_shloip', "Value", "Constant has correct value");
381is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
382
383
384@::zwot = ('Zwot!');
385
386# Check that assignment to an existing typeglob works
387{
388 my $w = '';
389 local $SIG{__WARN__} = sub { $w = $_[0] };
390 *{"zwot"} = \&{"oonk"};
391 is($w, '', "Should be no warning");
392}
393
394is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
395is (eval 'zwot', "Value", "Constant has correct value");
396is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
397is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
398
399sub spritsits () {
400 "Traditional";
401}
402
403# Check that assignment to an existing subroutine works
404{
405 my $w = '';
406 local $SIG{__WARN__} = sub { $w = $_[0] };
407 *{"spritsits"} = \&{"oonk"};
408 like($w, qr/^Constant subroutine main::spritsits redefined/,
409 "Redefining a constant sub should warn");
410}
411
412is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
413is (eval 'spritsits', "Value", "Constant has correct value");
414is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
415
bb112e5a
NC
416# Check that assignment to an existing typeglob works
417{
418 my $w = '';
419 local $SIG{__WARN__} = sub { $w = $_[0] };
50baa5ea
VP
420 *{"plunk"} = [];
421 *{"plunk"} = \&{"oonk"};
bb112e5a
NC
422 is($w, '', "Should be no warning");
423}
424
bb112e5a
NC
425is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
426is (eval 'plunk', "Value", "Constant has correct value");
427is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
428
429my $gr = eval '\*plunk' or die;
430
431{
432 my $w = '';
433 local $SIG{__WARN__} = sub { $w = $_[0] };
50baa5ea 434 *{$gr} = \&{"oonk"};
2111d928 435 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)");
bb112e5a
NC
436}
437
438is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
439is (eval 'plunk', "Value", "Constant has correct value");
440is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
441
50baa5ea
VP
442# Non-void context should defeat the optimisation, and will cause the original
443# to be promoted (what change 26482 intended)
444my $result;
445{
446 my $w = '';
447 local $SIG{__WARN__} = sub { $w = $_[0] };
448 $result = *{"awkkkkkk"} = \&{"oonk"};
449 is($w, '', "Should be no warning");
450}
451
452is (ref \$result, 'GLOB',
453 "Non void assignment should still return a typeglob");
454
455is (ref \$::{oonk}, 'GLOB', "This export does affect original");
456is (eval 'plunk', "Value", "Constant has correct value");
457is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
458
459delete $::{oonk};
460$::{oonk} = \"Value";
461
462sub non_dangling {
463 my $w = '';
464 local $SIG{__WARN__} = sub { $w = $_[0] };
465 *{"zap"} = \&{"oonk"};
466 is($w, '', "Should be no warning");
467}
468
469non_dangling();
470is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
471is (eval 'zap', "Value", "Constant has correct value");
472is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
473
474sub dangling {
475 local $SIG{__WARN__} = sub { die $_[0] };
476 *{"biff"} = \&{"oonk"};
477}
478
479dangling();
480is (ref \$::{oonk}, 'GLOB', "This export does affect original");
481is (eval 'biff', "Value", "Constant has correct value");
482is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
483
acaa9288
NC
484{
485 use vars qw($glook $smek $foof);
486 # Check reference assignment isn't affected by the SV type (bug #38439)
487 $glook = 3;
488 $smek = 4;
489 $foof = "halt and cool down";
490
491 my $rv = \*smek;
492 is($glook, 3);
493 *glook = $rv;
494 is($glook, 4);
495
496 my $pv = "";
497 $pv = \*smek;
498 is($foof, "halt and cool down");
499 *foof = $pv;
500 is($foof, 4);
501}
502
5c1f4d79
NC
503format =
504.
505
506foreach 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 $::{oonk};
513 $::{oonk} = $value;
514 $proto = eval 'prototype \&oonk';
515 like ($@, qr/^Cannot convert a reference to $type to typeglob/,
516 "Cannot upgrade ref-to-$type to typeglob");
517}
f9d52e31
NC
518
519{
520 no warnings qw(once uninitialized);
521 my $g = \*clatter;
522 my $r = eval {no strict; ${*{$g}{SCALAR}}};
523 is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
524
525 $g = \*vowm;
526 $r = eval {use strict; ${*{$g}{SCALAR}}};
527 is ($@, '',
528 "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
529}
530
06be3b40
NC
531{
532 # Bug reported by broquaint on IRC
533 *slosh::{HASH}->{ISA}=[];
534 slosh->import;
535 pass("gv_fetchmeth coped with the unexpected");
9e0d86f8
NC
536
537 # An audit found these:
538 {
539 package slosh;
540 sub rip {
541 my $s = shift;
542 $s->SUPER::rip;
543 }
544 }
545 eval {slosh->rip;};
546 like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
547
548 is(slosh->isa('swoosh'), '');
549
550 $CORE::GLOBAL::{"lock"}=[];
551 eval "no warnings; lock";
552 like($@, qr/^Not enough arguments for lock/,
553 "Can't trip up general keyword overloading");
554
555 $CORE::GLOBAL::{"readline"}=[];
b3c9268e 556 eval "<STDOUT> if 0";
9e0d86f8 557 is($@, '', "Can't trip up readline overloading");
d5e716f5
NC
558
559 $CORE::GLOBAL::{"readpipe"}=[];
560 eval "`` if 0";
561 is($@, '', "Can't trip up readpipe overloading");
06be3b40 562}
53a42478
NC
563
564{
565 die if exists $::{BONK};
566 $::{BONK} = \"powie";
567 *{"BONK"} = \&{"BONK"};
568 eval 'is(BONK(), "powie",
569 "Assigment works when glob created midway (bug 45607)"); 1'
570 or die $@;
571}
1f257c95
NC
572
573# For now these tests are here, but they would probably be better in a file for
574# tests for croaks. (And in turn, that probably deserves to be in a different
575# directory. Gerard Goossen has a point about the layout being unclear
576
577sub coerce_integer {
578 no warnings 'numeric';
579 $_[0] |= 0;
580}
581sub coerce_number {
582 no warnings 'numeric';
583 $_[0] += 0;
584}
585sub coerce_string {
586 $_[0] .= '';
587}
588
589foreach my $type (qw(integer number string)) {
590 my $prog = "coerce_$type(*STDERR)";
591 is (scalar eval "$prog; 1", undef, "$prog failed...");
592 like ($@, qr/Can't coerce GLOB to $type in/,
593 "with the correct error message");
594}
595
1809c940
DM
596# RT #60954 anonymous glob should be defined, and not coredump when
597# stringified. The behaviours are:
598#
599# defined($glob) "$glob"
600# 5.8.8 false "" with uninit warning
601# 5.10.0 true (coredump)
602# 5.12.0 true ""
603
604{
605 my $io_ref = *STDOUT{IO};
606 my $glob = *$io_ref;
607 ok(defined $glob, "RT #60954 anon glob should be defined");
608
609 my $warn = '';
610 local $SIG{__WARN__} = sub { $warn = $_[0] };
611 use warnings;
612 my $str = "$glob";
613 is($warn, '', "RT #60954 anon glob stringification shouln't warn");
614 is($str, '', "RT #60954 anon glob stringification should be empty");
615}
616
1f730e6c
FC
617# [perl #71254] - Assigning a glob to a variable that has a current
618# match position. (We are testing that Perl_magic_setmglob respects globs'
619# special used of SvSCREAM.)
620{
621 $m = 2; $m=~s/./0/gems; $m= *STDERR;
622 is(
623 "$m", "*main::STDERR",
624 '[perl #71254] assignment of globs to vars with pos'
625 );
626}
627
2867cdbc
Z
628# [perl #72740] - indirect object syntax, heuristically imputed due to
629# the non-existence of a function, should not cause a stash entry to be
630# created for the non-existent function.
631{
632 package RT72740a;
633 my $f = bless({}, RT72740b);
634 sub s1 { s2 $f; }
635 our $s4;
636 sub s3 { s4 $f; }
637}
638{
639 package RT72740b;
640 sub s2 { "RT72740b::s2" }
641 sub s4 { "RT72740b::s4" }
642}
643ok(exists($RT72740a::{s1}), "RT72740a::s1 exists");
644ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist");
645ok(exists($RT72740a::{s3}), "RT72740a::s3 exists");
646ok(exists($RT72740a::{s4}), "RT72740a::s4 exists");
647is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly");
648is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly");
649
b9e00b79
LRG
650# [perl #71686] Globs that are in symbol table can be un-globbed
651$sym = undef;
652$::{fake} = *sym;
653is (eval 'local *::fake = \"chuck"; $fake', 'chuck',
654 "Localized glob didn't coerce into a RV");
655is ($@, '', "Can localize FAKE glob that's present in stash");
656is (scalar $::{fake}, "*main::sym",
657 "Localized FAKE glob's value was correctly restored");
658
0fe688f5 659# [perl #1804] *$x assignment when $x is a copy of another glob
0095ccd4 660# And [perl #77508] (same thing with list assignment)
0fe688f5
FC
661{
662 no warnings 'once';
663 my $x = *_random::glob_that_is_not_used_elsewhere;
664 *$x = sub{};
665 is(
666 "$x", '*_random::glob_that_is_not_used_elsewhere',
667 '[perl #1804] *$x assignment when $x is FAKE',
668 );
0095ccd4
FC
669 $x = *_random::glob_that_is_not_used_elsewhere;
670 (my $dummy, *$x) = (undef,[]);
671 is(
672 "$x", '*_random::glob_that_is_not_used_elsewhere',
673 '[perl #77508] *$x list assignment when $x is FAKE',
674 ) or require Devel::Peek, Devel::Peek::Dump($x);
0fe688f5
FC
675}
676
cf203c62
FR
677# [perl #76540]
678# this caused panics or 'Attempt to free unreferenced scalar'
679# (its a compile-time issue, so the die lets us skip the prints)
680{
681 my @warnings;
682 local $SIG{__WARN__} = sub { push @warnings, @_ };
683
684 eval <<'EOF';
685BEGIN { $::{FOO} = \'bar' }
686die "made it";
687print FOO, "\n";
688print FOO, "\n";
689EOF
690
691 like($@, qr/made it/, "#76540 - no panic");
692 ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'");
693}
694
13be902c
FC
695# [perl #77362] various bugs related to globs as PVLVs
696{
697 no warnings qw 'once void';
698 my %h; # We pass a key of this hash to the subroutine to get a PVLV.
699 sub { for(shift) {
700 # Set up our glob-as-PVLV
701 $_ = *hon;
702
703 # Bad symbol for array
704 ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@;
705
706 # This should call TIEHANDLE, not TIESCALAR
707 *thext::TIEHANDLE = sub{};
708 ok eval{ tie *$_, 'thext'; 1 }, 'PVLV globs can be tied as handles'
709 or diag $@;
710
711 # Assigning undef to the glob should not overwrite it...
712 {
713 my $w;
714 local $SIG{__WARN__} = sub { $w = shift };
715 *$_ = undef;
716 is $_, "*main::hon", 'PVLV: assigning undef to the glob does nothing';
717 like $w, qr\Undefined value assigned to typeglob\,
718 'PVLV: assigning undef to the glob warns';
719 }
720
2acc3314 721 # Neither should reference assignment.
13be902c 722 *$_ = [];
2acc3314 723 is $_, "*main::hon", "PVLV: arrayref assignment assigns to the AV slot";
13be902c
FC
724
725 # Concatenation should still work.
726 ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@;
2acc3314 727 is $_, '*main::honthlew', 'PVLV concatenation works';
13be902c
FC
728
729 # And we should be able to overwrite it with a string, number, or refer-
730 # ence, too, if we omit the *.
731 $_ = *hon; $_ = 'tzor';
732 is $_, 'tzor', 'PVLV: assigning a string over a glob';
733 $_ = *hon; $_ = 23;
734 is $_, 23, 'PVLV: assigning an integer over a glob';
735 $_ = *hon; $_ = 23.23;
736 is $_, 23.23, 'PVLV: assigning a float over a glob';
737 $_ = *hon; $_ = \my $sthat;
738 is $_, \$sthat, 'PVLV: assigning a reference over a glob';
739
740 # This bug was found by code inspection. Could this ever happen in
741 # real life? :-)
742 # This duplicates a file handle, accessing it through a PVLV glob, the
743 # glob having been removed from the symbol table, so a stringified form
744 # of it does not work. This checks that sv_2io does not stringify a PVLV.
745 $_ = *quin;
746 open *quin, "test.pl"; # test.pl is as good a file as any
747 delete $::{quin};
748 ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not'
749 or diag $@;
750
751 # Similar tests to make sure sv_2cv etc. do not stringify.
752 *$_ = sub { 1 };
753 ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@;
754 *flelp = sub { 2 };
755 $_ = 'flelp';
756 is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub'
757 or diag $@;
758
759 # Coderef-to-glob assignment when the glob is no longer accessible
760 # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV
761 # optimisation takes PVLVs into account, which is why the RHSs have to be
762 # named subs.
763 use constant gheen => 'quare';
764 $_ = *ming;
765 delete $::{ming};
766 *$_ = \&gheen;
767 is eval { &$_ }, 'quare',
768 'PVLV: constant assignment when the glob is detached from the symtab'
769 or diag $@;
770 $_ = *bength;
771 delete $::{bength};
772 *gheck = sub { 'lon' };
773 *$_ = \&gheck;
774 is eval { &$_ }, 'lon',
775 'PVLV: coderef assignment when the glob is detached from the symtab'
776 or diag $@;
777
778 # open should accept a PVLV as its first argument
779 $_ = *hon;
780 ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open'
781 or diag $@;
782
783 # -t should not stringify
784 $_ = *thlit; delete $::{thlit};
785 *$_ = *STDOUT{IO};
786 ok defined -t $_, 'PVLV: -t does not stringify';
787
788 # neither should -T
804401ea
FC
789 # but some systems don’t support this on file handles
790 my $pass;
791 ok
792 eval {
793 open my $quile, "<", 'test.pl';
794 $_ = *$quile;
795 $pass = -T $_;
796 1
797 } ? $pass : $@ =~ /not implemented on filehandles/,
798 "PVLV: -T does not stringify";
13be902c
FC
799
800 # Unopened file handle
801 {
802 my $w;
803 local $SIG{__WARN__} = sub { $w .= shift };
804 $_ = *vor;
805 close $_;
806 like $w, qr\unopened filehandle vor\,
807 'PVLV globs get their names reported in unopened error messages';
808 }
809
810 }}->($h{k});
811}
812
251c9b20
NC
813*aieee = 4;
814pass('Can assign integers to typeglobs');
815*aieee = 3.14;
816pass('Can assign floats to typeglobs');
817*aieee = 'pi';
818pass('Can assign strings to typeglobs');
819
0936ef8b
FC
820{
821 package thrext;
822 sub TIESCALAR{bless[]}
823 sub STORE{ die "No!"}
824 sub FETCH{ no warnings 'once'; *thrit }
825 tie my $a, "thrext";
826 () = "$a"; # do a fetch; now $a holds a glob
827 eval { *$a = sub{} };
828 untie $a;
829 eval { $a = "bar" };
830 ::is $a, "bar",
831 "[perl #77812] Globs in tied scalars can be reified if STORE dies"
832}
833
8d33f848
FC
834# These two crashed prior to 5.13.6. In 5.13.6 they were fatal errors. They
835# were fixed in 5.13.7.
836ok eval {
837 my $glob = \*heen::ISA;
838 delete $::{"heen::"};
839 *$glob = *bar;
840}, "glob-to-*ISA assignment works when *ISA has lost its stash";
841ok eval {
842 my $glob = \*slare::ISA;
843 delete $::{"slare::"};
844 *$glob = [];
845}, "array-to-*ISA assignment works when *ISA has lost its stash";
846# These two crashed in 5.13.6. They were likewise fixed in 5.13.7.
847ok eval {
848 sub greck;
4a68a320 849 my $glob = do { no warnings "once"; \*phing::foo};
8d33f848
FC
850 delete $::{"phing::"};
851 *$glob = *greck;
852}, "Assigning a glob-with-sub to a glob that has lost its stash warks";
853ok eval {
854 sub pon::foo;
855 my $glob = \*pon::foo;
856 delete $::{"pon::"};
857 *$glob = *foo;
858}, "Assigning a glob to a glob-with-sub that has lost its stash warks";
859
860
99491443 861__END__
98e007d4
NC
862Perl
863Rules
864perl
865rocks