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