This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In Perl_gp_free() use PL_tmps_stack to avoid freeing glob entries immediately.
[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';
13be902c 9 require './test.pl';
43ece5b1 10 set_up_inc('../lib');
98e007d4 11}
9f1b1f2d
GS
12
13use warnings;
14
cfffe6dc 15# type coercion on assignment
b9894134
PP
16$foo = 'foo';
17$bar = *main::foo;
18$bar = $foo;
98e007d4 19is(ref(\$bar), 'SCALAR');
b9894134
PP
20$foo = *main::bar;
21
cfffe6dc 22# type coercion (not) on misc ops
b9894134 23
98e007d4
NC
24ok($foo);
25is(ref(\$foo), 'GLOB');
b9894134 26
98e007d4
NC
27unlike ($foo, qr/abcd/);
28is(ref(\$foo), 'GLOB');
b9894134 29
98e007d4
NC
30is($foo, '*main::bar');
31is(ref(\$foo), 'GLOB');
b9894134 32
2acc3314
FC
33{
34 no warnings;
35 ${\*$foo} = undef;
cfffe6dc 36 is(ref(\$foo), 'GLOB', 'no type coercion when assigning to *{} retval');
2acc3314
FC
37 $::{phake} = *bar;
38 is(
39 \$::{phake}, \*{"phake"},
40 'symbolic *{} returns symtab entry when FAKE'
41 );
42 ${\*{"phake"}} = undef;
43 is(
44 ref(\$::{phake}), 'GLOB',
cfffe6dc 45 'no type coercion when assigning to retval of symbolic *{}'
2acc3314
FC
46 );
47 $::{phaque} = *bar;
48 eval '
49 is(
50 \$::{phaque}, \*phaque,
51 "compile-time *{} returns symtab entry when FAKE"
52 );
53 ${\*phaque} = undef;
54 ';
55 is(
56 ref(\$::{phaque}), 'GLOB',
cfffe6dc 57 'no type coercion when assigning to retval of compile-time *{}'
2acc3314
FC
58 );
59}
60
cfffe6dc 61# type coercion on substitutions that match
b9894134
PP
62$a = *main::foo;
63$b = $a;
64$a =~ s/^X//;
98e007d4 65is(ref(\$a), 'GLOB');
b9894134 66$a =~ s/^\*//;
98e007d4
NC
67is($a, 'main::foo');
68is(ref(\$b), 'GLOB');
b9894134
PP
69
70# typeglobs as lvalues
71substr($foo, 0, 1) = "XXX";
98e007d4
NC
72is(ref(\$foo), 'SCALAR');
73is($foo, 'XXXmain::bar');
b9894134
PP
74
75# returning glob values
76sub foo {
77 local($bar) = *main::foo;
78 $foo = *main::bar;
79 return ($foo, $bar);
80}
81
82($fuu, $baa) = foo();
98e007d4
NC
83ok(defined $fuu);
84is(ref(\$fuu), 'GLOB');
b9894134 85
98e007d4
NC
86
87ok(defined $baa);
88is(ref(\$baa), 'GLOB');
b9894134 89
85aff577
CS
90# nested package globs
91# NOTE: It's probably OK if these semantics change, because the
92# fact that %X::Y:: is stored in %X:: isn't documented.
93# (I hope.)
94
9f1b1f2d 95{ package Foo::Bar; no warnings 'once'; $test=1; }
98e007d4
NC
96ok(exists $Foo::{'Bar::'});
97is($Foo::{'Bar::'}, '*Foo::Bar::');
98
20408e3c
GS
99
100# test undef operator clearing out entire glob
101$foo = 'stuff';
102@foo = qw(more stuff);
103%foo = qw(even more random stuff);
104undef *foo;
98e007d4
NC
105is ($foo, undef);
106is (scalar @foo, 0);
107is (scalar %foo, 0);
20408e3c 108
20408e3c 109{
98e007d4
NC
110 # test warnings from assignment of undef to glob
111 my $msg = '';
20408e3c 112 local $SIG{__WARN__} = sub { $msg = $_[0] };
9f1b1f2d 113 use warnings;
20408e3c 114 *foo = 'bar';
98e007d4 115 is($msg, '');
20408e3c 116 *foo = undef;
98e007d4 117 like($msg, qr/Undefined value assigned to typeglob/);
e36cc0fb
NC
118
119 no warnings 'once';
120 # test warnings for converting globs to other forms
121 my $copy = *PWOMPF;
122 foreach ($copy, *SKREEE) {
123 $msg = '';
124 my $victim = sprintf "%d", $_;
125 like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
126 "Warning on conversion to IV");
127 is($victim, 0);
128
129 $msg = '';
130 $victim = sprintf "%u", $_;
131 like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
132 "Warning on conversion to UV");
133 is($victim, 0);
134
135 $msg = '';
136 $victim = sprintf "%e", $_;
137 like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
138 "Warning on conversion to NV");
139 like($victim, qr/^0\.0+E\+?00/i, "Expect floating point zero");
140
141 $msg = '';
142 $victim = sprintf "%s", $_;
143 is($msg, '', "No warning on stringification");
144 is($victim, '' . $_);
145 }
20408e3c 146}
640b9ef6 147
98e007d4 148my $test = curr_test();
640b9ef6 149# test *glob{THING} syntax
98e007d4
NC
150$x = "ok $test\n";
151++$test;
152@x = ("ok $test\n");
153++$test;
154%x = ("ok $test" => "\n");
155++$test;
156sub x { "ok $test\n" }
640b9ef6 157print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
98e007d4
NC
158# This needs to go here, after the print, as sub x will return the current
159# value of test
160++$test;
f4d13ee9 161format x =
98e007d4 162XXX This text isn't used. Should it be?
f4d13ee9 163.
98e007d4
NC
164curr_test($test);
165
166is (ref *x{FORMAT}, "FORMAT");
e14698d8
FC
167is ("@{sub { *_{ARRAY} }->(1..3)}", "1 2 3",
168 'returning *_{ARRAY} from sub');
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};
83677dc5
RS
183
184 # deprecation warning removed in v5.23 -- rjbs, 2015-12-31
8034715d 185 # https://github.com/Perl/perl5/issues/15105
83677dc5 186 print {*x{IO}} (! defined $warn
98e007d4
NC
187 ? "ok $test\n" : "not ok $test\n");
188 curr_test(++$test);
29a56bd6
JH
189}
190
171e2879
FC
191is *x{NAME}, 'x', '*foo{NAME}';
192is *x{PACKAGE}, 'main', '*foo{PACKAGE}';
0787e289 193{ no warnings 'once'; *x = *Foo::y; }
4fbc7258
FC
194is *x, '*Foo::y', 'glob stringifies as assignee after glob-to-glob assign';
195is *x{NAME}, 'x', 'but *foo{NAME} still returns the original name';
196is *x{PACKAGE}, 'main', 'and *foo{PACKAGE} the original package';
35cd451c
GS
197
198{
98e007d4 199 # test if defined() doesn't create any new symbols
35cd451c
GS
200
201 my $a = "SYM000";
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 222 ok(defined *{$a});
82587197 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
ee95e30c 241# [ID 20010526.001 (#7038)] localized glob loses value when assigned to
bd2155e9
JH
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");
34770c8c 291 is ($e, '', '__DIE__ handler never called');
4ce457a6
TP
292}
293
98e007d4 294{
34770c8c 295 my $e = '';
4ce457a6
TP
296 # GLOB assignment to tied element
297 local $SIG{__DIE__} = sub { $e = $_[0] };
98e007d4
NC
298 sub T::TIEARRAY { bless [] => "T" }
299 sub T::STORE { $_[0]->[ $_[1] ] = $_[2] }
300 sub T::FETCH { $_[0]->[ $_[1] ] }
301 sub T::FETCHSIZE { @{$_[0]} }
4ce457a6
TP
302 tie my @ary => "T";
303 $ary[0] = *DATA;
98e007d4 304 is ($ary[0], '*main::DATA');
13be902c
FC
305 is (
306 ref\tied(@ary)->[0], 'GLOB',
307 'tied elem assignment preserves globs'
308 );
34770c8c 309 is ($e, '', '__DIE__ handler not called');
4ce457a6 310 my $x = readline $ary[0];
98e007d4 311 is($x, "rocks\n");
34770c8c 312 is ($e, '', '__DIE__ handler never called');
4ce457a6
TP
313}
314
e15faf7d 315{
4184c77b
NC
316 # Need some sort of die or warn to get the global destruction text if the
317 # bug is still present
2c205b54
NC
318 # This test is "interesting" because the cleanup is triggered by the call
319 # op_free(PL_main_root) in perl_destruct, which is *just* before this:
320 # PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
5c2a9b31 321 my $output = runperl(prog => <<'EOPROG');
e15faf7d 322package M;
5c2a9b31 323$| = 1;
4184c77b 324sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
e15faf7d
NC
325package main;
326
3d7a9343 327bless \$A::B, q{M};
e15faf7d
NC
328*A:: = \*B::;
329EOPROG
330 like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
331 unlike($output, qr/global destruction/,
332 "unreferenced symbol tables should be cleaned up immediately");
333}
63fa9adc
NC
334
335# Possibly not the correct test file for these tests.
336# There are certain space optimisations implemented via promotion rules to
337# GVs
338
bb112e5a
NC
339foreach (qw (oonk ga_shloip)) {
340 ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
341}
63fa9adc
NC
342
343# A string in place of the typeglob is promoted to the function prototype
344$::{oonk} = "pie";
345my $proto = eval 'prototype \&oonk';
346die if $@;
347is ($proto, "pie", "String is promoted to prototype");
348
349
350# A reference to a value is used to generate a constant subroutine
351foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
5c1f4d79 352 \*STDIN, \&ok, \undef, *STDOUT) {
63fa9adc
NC
353 delete $::{oonk};
354 $::{oonk} = \$value;
355 $proto = eval 'prototype \&oonk';
356 die if $@;
357 is ($proto, '', "Prototype for a constant subroutine is empty");
358
359 my $got = eval 'oonk';
360 die if $@;
5c1f4d79 361 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
63fa9adc
NC
362 is ($got, $value, "Value is correctly set");
363}
5c1f4d79 364
bb112e5a
NC
365delete $::{oonk};
366$::{oonk} = \"Value";
367
368*{"ga_shloip"} = \&{"oonk"};
369
370is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
371is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
372is (eval 'ga_shloip', "Value", "Constant has correct value");
373is (ref $::{ga_shloip}, 'SCALAR',
93f09d7b 374 "Inlining of constant doesn't change representation");
bb112e5a
NC
375
376delete $::{ga_shloip};
377
378eval 'sub ga_shloip (); 1' or die $@;
379is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
380
381# Check that a prototype expands.
382*{"ga_shloip"} = \&{"oonk"};
383
384is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
385is (eval 'ga_shloip', "Value", "Constant has correct value");
386is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
387
388
389@::zwot = ('Zwot!');
390
391# Check that assignment to an existing typeglob works
392{
393 my $w = '';
394 local $SIG{__WARN__} = sub { $w = $_[0] };
395 *{"zwot"} = \&{"oonk"};
396 is($w, '', "Should be no warning");
397}
398
399is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
400is (eval 'zwot', "Value", "Constant has correct value");
401is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
402is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
403
404sub spritsits () {
405 "Traditional";
406}
407
408# Check that assignment to an existing subroutine works
409{
410 my $w = '';
411 local $SIG{__WARN__} = sub { $w = $_[0] };
412 *{"spritsits"} = \&{"oonk"};
413 like($w, qr/^Constant subroutine main::spritsits redefined/,
414 "Redefining a constant sub should warn");
415}
416
417is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
418is (eval 'spritsits', "Value", "Constant has correct value");
419is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
420
bb112e5a
NC
421# Check that assignment to an existing typeglob works
422{
423 my $w = '';
424 local $SIG{__WARN__} = sub { $w = $_[0] };
50baa5ea
VP
425 *{"plunk"} = [];
426 *{"plunk"} = \&{"oonk"};
bb112e5a
NC
427 is($w, '', "Should be no warning");
428}
429
bb112e5a
NC
430is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
431is (eval 'plunk', "Value", "Constant has correct value");
432is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
433
434my $gr = eval '\*plunk' or die;
435
436{
437 my $w = '';
438 local $SIG{__WARN__} = sub { $w = $_[0] };
50baa5ea 439 *{$gr} = \&{"oonk"};
2111d928 440 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
441}
442
443is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
444is (eval 'plunk', "Value", "Constant has correct value");
445is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
446
50baa5ea
VP
447# Non-void context should defeat the optimisation, and will cause the original
448# to be promoted (what change 26482 intended)
449my $result;
450{
451 my $w = '';
452 local $SIG{__WARN__} = sub { $w = $_[0] };
453 $result = *{"awkkkkkk"} = \&{"oonk"};
454 is($w, '', "Should be no warning");
455}
456
457is (ref \$result, 'GLOB',
458 "Non void assignment should still return a typeglob");
459
460is (ref \$::{oonk}, 'GLOB', "This export does affect original");
461is (eval 'plunk', "Value", "Constant has correct value");
462is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
463
464delete $::{oonk};
465$::{oonk} = \"Value";
466
467sub non_dangling {
468 my $w = '';
469 local $SIG{__WARN__} = sub { $w = $_[0] };
470 *{"zap"} = \&{"oonk"};
471 is($w, '', "Should be no warning");
472}
473
474non_dangling();
475is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
476is (eval 'zap', "Value", "Constant has correct value");
477is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
478
479sub dangling {
480 local $SIG{__WARN__} = sub { die $_[0] };
481 *{"biff"} = \&{"oonk"};
482}
483
484dangling();
485is (ref \$::{oonk}, 'GLOB', "This export does affect original");
486is (eval 'biff', "Value", "Constant has correct value");
487is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
488
6f1b3ab0
FC
489$::{yarrow} = [4,5,6];
490is join("-", eval "yarrow()"), '4-5-6', 'array ref as stash elem';
491is ref $::{yarrow}, "ARRAY", 'stash elem is still array ref after use';
492is join("-", eval "&yarrow"), '4-5-6', 'calling const list with &';
493is join("-", eval "&yarrow(1..10)"), '4-5-6', 'const list ignores & args';
494is prototype "yarrow", "", 'const list has "" prototype';
495is eval "yarrow", 3, 'const list in scalar cx returns length';
496
2eaf799e
FC
497$::{borage} = \&ok;
498eval 'borage("sub ref in stash")' or fail "sub ref in stash";
499
acaa9288 500{
83461ff8 501 our ($glook, $smek, $foof);
acaa9288
NC
502 # Check reference assignment isn't affected by the SV type (bug #38439)
503 $glook = 3;
504 $smek = 4;
505 $foof = "halt and cool down";
506
507 my $rv = \*smek;
508 is($glook, 3);
509 *glook = $rv;
510 is($glook, 4);
511
512 my $pv = "";
513 $pv = \*smek;
514 is($foof, "halt and cool down");
515 *foof = $pv;
516 is($foof, 4);
517}
518
5c1f4d79
NC
519format =
520.
521
2eaf799e 522foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) {
5c1f4d79
NC
523 # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
524 # IO::Handle, which isn't what we want.
525 my $type = $value;
526 $type =~ s/.*=//;
527 $type =~ s/\(.*//;
528 delete $::{oonk};
529 $::{oonk} = $value;
530 $proto = eval 'prototype \&oonk';
531 like ($@, qr/^Cannot convert a reference to $type to typeglob/,
532 "Cannot upgrade ref-to-$type to typeglob");
533}
f9d52e31
NC
534
535{
536 no warnings qw(once uninitialized);
537 my $g = \*clatter;
538 my $r = eval {no strict; ${*{$g}{SCALAR}}};
539 is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
540
541 $g = \*vowm;
542 $r = eval {use strict; ${*{$g}{SCALAR}}};
543 is ($@, '',
544 "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
545}
546
06be3b40
NC
547{
548 # Bug reported by broquaint on IRC
549 *slosh::{HASH}->{ISA}=[];
550 slosh->import;
551 pass("gv_fetchmeth coped with the unexpected");
9e0d86f8
NC
552
553 # An audit found these:
554 {
555 package slosh;
556 sub rip {
557 my $s = shift;
558 $s->SUPER::rip;
559 }
560 }
561 eval {slosh->rip;};
562 like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
563
564 is(slosh->isa('swoosh'), '');
565
566 $CORE::GLOBAL::{"lock"}=[];
567 eval "no warnings; lock";
568 like($@, qr/^Not enough arguments for lock/,
569 "Can't trip up general keyword overloading");
570
571 $CORE::GLOBAL::{"readline"}=[];
b3c9268e 572 eval "<STDOUT> if 0";
9e0d86f8 573 is($@, '', "Can't trip up readline overloading");
d5e716f5
NC
574
575 $CORE::GLOBAL::{"readpipe"}=[];
576 eval "`` if 0";
577 is($@, '', "Can't trip up readpipe overloading");
06be3b40 578}
53a42478
NC
579
580{
581 die if exists $::{BONK};
582 $::{BONK} = \"powie";
583 *{"BONK"} = \&{"BONK"};
584 eval 'is(BONK(), "powie",
93f09d7b 585 "Assignment works when glob created midway (bug 45607)"); 1'
53a42478
NC
586 or die $@;
587}
1f257c95
NC
588
589# For now these tests are here, but they would probably be better in a file for
590# tests for croaks. (And in turn, that probably deserves to be in a different
591# directory. Gerard Goossen has a point about the layout being unclear
592
593sub coerce_integer {
594 no warnings 'numeric';
595 $_[0] |= 0;
596}
597sub coerce_number {
598 no warnings 'numeric';
599 $_[0] += 0;
600}
601sub coerce_string {
602 $_[0] .= '';
603}
604
605foreach my $type (qw(integer number string)) {
606 my $prog = "coerce_$type(*STDERR)";
607 is (scalar eval "$prog; 1", undef, "$prog failed...");
608 like ($@, qr/Can't coerce GLOB to $type in/,
609 "with the correct error message");
610}
611
e8986967 612# RT #65582 anonymous glob should be defined, and not coredump when
1809c940
DM
613# stringified. The behaviours are:
614#
52a6327b
FC
615# defined($glob) "$glob" $glob .= ...
616# 5.8.8 false "" with uninit warning "" with uninit warning
617# 5.10.0 true (coredump) (coredump)
618# 5.1[24] true "" "" with uninit warning
619# 5.16 true "*__ANON__::..." "*__ANON__::..."
1809c940
DM
620
621{
622 my $io_ref = *STDOUT{IO};
623 my $glob = *$io_ref;
e8986967 624 ok(defined $glob, "RT #65582 anon glob should be defined");
1809c940
DM
625
626 my $warn = '';
627 local $SIG{__WARN__} = sub { $warn = $_[0] };
628 use warnings;
629 my $str = "$glob";
e8986967 630 is($warn, '', "RT #65582 anon glob stringification shouldn't warn");
885f468a 631 is($str, '*__ANON__::__ANONIO__',
e8986967 632 "RT #65582/#96326 anon glob stringification");
1809c940
DM
633}
634
25451cef
FC
635# Another stringification bug: Test that recursion does not cause lexical
636# handles to lose their names.
637sub r {
638 my @output;
639 @output = r($_[0]-1) if $_[0];
640 open my $fh, "TEST";
641 push @output, $$fh;
642 close $fh;
643 @output;
644}
645is join(' ', r(4)),
646 '*main::$fh *main::$fh *main::$fh *main::$fh *main::$fh',
647 'recursion does not cause lex handles to lose their names';
648
3a6ce63a
FC
649# And sub cloning, too; not just recursion
650my $close_over_me;
651is join(' ', sub {
652 () = $close_over_me;
653 my @output;
654 @output = CORE::__SUB__->($_[0]-1) if $_[0];
655 open my $fh, "TEST";
656 push @output, $$fh;
657 close $fh;
658 @output;
659 }->(4)),
660 '*main::$fh *main::$fh *main::$fh *main::$fh *main::$fh',
661 'sub cloning does not cause lex handles to lose their names';
662
1f730e6c
FC
663# [perl #71254] - Assigning a glob to a variable that has a current
664# match position. (We are testing that Perl_magic_setmglob respects globs'
665# special used of SvSCREAM.)
666{
667 $m = 2; $m=~s/./0/gems; $m= *STDERR;
668 is(
669 "$m", "*main::STDERR",
670 '[perl #71254] assignment of globs to vars with pos'
671 );
672}
673
2867cdbc
Z
674# [perl #72740] - indirect object syntax, heuristically imputed due to
675# the non-existence of a function, should not cause a stash entry to be
676# created for the non-existent function.
677{
678 package RT72740a;
679 my $f = bless({}, RT72740b);
680 sub s1 { s2 $f; }
681 our $s4;
682 sub s3 { s4 $f; }
683}
684{
685 package RT72740b;
686 sub s2 { "RT72740b::s2" }
687 sub s4 { "RT72740b::s4" }
688}
689ok(exists($RT72740a::{s1}), "RT72740a::s1 exists");
690ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist");
691ok(exists($RT72740a::{s3}), "RT72740a::s3 exists");
692ok(exists($RT72740a::{s4}), "RT72740a::s4 exists");
693is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly");
694is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly");
695
b9e00b79
LRG
696# [perl #71686] Globs that are in symbol table can be un-globbed
697$sym = undef;
698$::{fake} = *sym;
699is (eval 'local *::fake = \"chuck"; $fake', 'chuck',
700 "Localized glob didn't coerce into a RV");
701is ($@, '', "Can localize FAKE glob that's present in stash");
702is (scalar $::{fake}, "*main::sym",
703 "Localized FAKE glob's value was correctly restored");
704
0fe688f5 705# [perl #1804] *$x assignment when $x is a copy of another glob
0095ccd4 706# And [perl #77508] (same thing with list assignment)
0fe688f5
FC
707{
708 no warnings 'once';
709 my $x = *_random::glob_that_is_not_used_elsewhere;
710 *$x = sub{};
711 is(
712 "$x", '*_random::glob_that_is_not_used_elsewhere',
713 '[perl #1804] *$x assignment when $x is FAKE',
714 );
0095ccd4
FC
715 $x = *_random::glob_that_is_not_used_elsewhere;
716 (my $dummy, *$x) = (undef,[]);
717 is(
718 "$x", '*_random::glob_that_is_not_used_elsewhere',
719 '[perl #77508] *$x list assignment when $x is FAKE',
720 ) or require Devel::Peek, Devel::Peek::Dump($x);
0fe688f5
FC
721}
722
cf203c62
FR
723# [perl #76540]
724# this caused panics or 'Attempt to free unreferenced scalar'
725# (its a compile-time issue, so the die lets us skip the prints)
726{
727 my @warnings;
728 local $SIG{__WARN__} = sub { push @warnings, @_ };
729
730 eval <<'EOF';
731BEGIN { $::{FOO} = \'bar' }
732die "made it";
733print FOO, "\n";
734print FOO, "\n";
735EOF
736
737 like($@, qr/made it/, "#76540 - no panic");
738 ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'");
739}
740
13be902c
FC
741# [perl #77362] various bugs related to globs as PVLVs
742{
743 no warnings qw 'once void';
744 my %h; # We pass a key of this hash to the subroutine to get a PVLV.
745 sub { for(shift) {
746 # Set up our glob-as-PVLV
747 $_ = *hon;
748
749 # Bad symbol for array
750 ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@;
751
752 # This should call TIEHANDLE, not TIESCALAR
753 *thext::TIEHANDLE = sub{};
754 ok eval{ tie *$_, 'thext'; 1 }, 'PVLV globs can be tied as handles'
755 or diag $@;
756
757 # Assigning undef to the glob should not overwrite it...
758 {
759 my $w;
760 local $SIG{__WARN__} = sub { $w = shift };
761 *$_ = undef;
762 is $_, "*main::hon", 'PVLV: assigning undef to the glob does nothing';
763 like $w, qr\Undefined value assigned to typeglob\,
764 'PVLV: assigning undef to the glob warns';
765 }
766
2acc3314 767 # Neither should reference assignment.
13be902c 768 *$_ = [];
2acc3314 769 is $_, "*main::hon", "PVLV: arrayref assignment assigns to the AV slot";
13be902c
FC
770
771 # Concatenation should still work.
772 ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@;
2acc3314 773 is $_, '*main::honthlew', 'PVLV concatenation works';
13be902c
FC
774
775 # And we should be able to overwrite it with a string, number, or refer-
776 # ence, too, if we omit the *.
777 $_ = *hon; $_ = 'tzor';
778 is $_, 'tzor', 'PVLV: assigning a string over a glob';
779 $_ = *hon; $_ = 23;
780 is $_, 23, 'PVLV: assigning an integer over a glob';
781 $_ = *hon; $_ = 23.23;
782 is $_, 23.23, 'PVLV: assigning a float over a glob';
783 $_ = *hon; $_ = \my $sthat;
784 is $_, \$sthat, 'PVLV: assigning a reference over a glob';
785
786 # This bug was found by code inspection. Could this ever happen in
787 # real life? :-)
788 # This duplicates a file handle, accessing it through a PVLV glob, the
789 # glob having been removed from the symbol table, so a stringified form
790 # of it does not work. This checks that sv_2io does not stringify a PVLV.
791 $_ = *quin;
792 open *quin, "test.pl"; # test.pl is as good a file as any
793 delete $::{quin};
794 ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not'
795 or diag $@;
796
797 # Similar tests to make sure sv_2cv etc. do not stringify.
798 *$_ = sub { 1 };
799 ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@;
800 *flelp = sub { 2 };
801 $_ = 'flelp';
802 is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub'
803 or diag $@;
804
805 # Coderef-to-glob assignment when the glob is no longer accessible
806 # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV
807 # optimisation takes PVLVs into account, which is why the RHSs have to be
808 # named subs.
809 use constant gheen => 'quare';
810 $_ = *ming;
811 delete $::{ming};
812 *$_ = \&gheen;
813 is eval { &$_ }, 'quare',
814 'PVLV: constant assignment when the glob is detached from the symtab'
815 or diag $@;
816 $_ = *bength;
817 delete $::{bength};
818 *gheck = sub { 'lon' };
819 *$_ = \&gheck;
820 is eval { &$_ }, 'lon',
821 'PVLV: coderef assignment when the glob is detached from the symtab'
822 or diag $@;
823
e77ae825
NC
824SKIP: {
825 skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
826 # open should accept a PVLV as its first argument
827 $_ = *hon;
828 ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open'
829 or diag $@;
830 }
13be902c
FC
831
832 # -t should not stringify
833 $_ = *thlit; delete $::{thlit};
834 *$_ = *STDOUT{IO};
835 ok defined -t $_, 'PVLV: -t does not stringify';
836
837 # neither should -T
804401ea
FC
838 # but some systems don’t support this on file handles
839 my $pass;
840 ok
841 eval {
842 open my $quile, "<", 'test.pl';
843 $_ = *$quile;
844 $pass = -T $_;
845 1
846 } ? $pass : $@ =~ /not implemented on filehandles/,
847 "PVLV: -T does not stringify";
13be902c
FC
848
849 # Unopened file handle
850 {
851 my $w;
852 local $SIG{__WARN__} = sub { $w .= shift };
853 $_ = *vor;
854 close $_;
855 like $w, qr\unopened filehandle vor\,
856 'PVLV globs get their names reported in unopened error messages';
857 }
858
859 }}->($h{k});
860}
861
251c9b20
NC
862*aieee = 4;
863pass('Can assign integers to typeglobs');
864*aieee = 3.14;
865pass('Can assign floats to typeglobs');
866*aieee = 'pi';
867pass('Can assign strings to typeglobs');
868
0936ef8b
FC
869{
870 package thrext;
871 sub TIESCALAR{bless[]}
872 sub STORE{ die "No!"}
873 sub FETCH{ no warnings 'once'; *thrit }
874 tie my $a, "thrext";
875 () = "$a"; # do a fetch; now $a holds a glob
876 eval { *$a = sub{} };
877 untie $a;
878 eval { $a = "bar" };
879 ::is $a, "bar",
880 "[perl #77812] Globs in tied scalars can be reified if STORE dies"
881}
882
8d33f848
FC
883# These two crashed prior to 5.13.6. In 5.13.6 they were fatal errors. They
884# were fixed in 5.13.7.
885ok eval {
886 my $glob = \*heen::ISA;
887 delete $::{"heen::"};
888 *$glob = *bar;
889}, "glob-to-*ISA assignment works when *ISA has lost its stash";
890ok eval {
891 my $glob = \*slare::ISA;
892 delete $::{"slare::"};
893 *$glob = [];
894}, "array-to-*ISA assignment works when *ISA has lost its stash";
895# These two crashed in 5.13.6. They were likewise fixed in 5.13.7.
896ok eval {
897 sub greck;
4a68a320 898 my $glob = do { no warnings "once"; \*phing::foo};
8d33f848
FC
899 delete $::{"phing::"};
900 *$glob = *greck;
dc115b7c 901}, "Assigning a glob-with-sub to a glob that has lost its stash works";
8d33f848
FC
902ok eval {
903 sub pon::foo;
904 my $glob = \*pon::foo;
905 delete $::{"pon::"};
906 *$glob = *foo;
dc115b7c 907}, "Assigning a glob to a glob-with-sub that has lost its stash works";
8d33f848 908
d8906c05
FC
909{
910 package Tie::Alias;
911 sub TIESCALAR{ bless \\pop }
912 sub FETCH { $${$_[0]} }
913 sub STORE { $${$_[0]} = $_[1] }
914 package main;
915 tie my $alias, 'Tie::Alias', my $var;
916 no warnings 'once';
917 $var = *galobbe;
918 {
919 local *$alias = [];
920 $var = 3;
921 is $alias, 3, "[perl #77926] Glob reification during localisation";
922 }
923}
8d33f848 924
b0d55c99
FC
925# This code causes gp_free to call a destructor when a glob is being
926# restored on scope exit. The destructor used to see SVs with a refcount of
927# zero inside the glob, which could result in crashes (though not in this
928# test case, which just panics).
929{
930 no warnings 'once';
931 my $survived;
932 *Trit::DESTROY = sub {
933 $thwext = 42; # panic
934 $survived = 1;
935 };
936 {
937 local *thwext;
938 $thwext = bless[],'Trit';
939 ();
940 }
941 ok $survived,
942 'no error when gp_free calls a destructor that assigns to the gv';
943}
944
4571f4a7
FC
945# This is a similar test, for destructors seeing a GV without a reference
946# count on its gp.
947sub undefine_me_if_you_dare {}
948bless \&undefine_me_if_you_dare, "Undefiner";
949sub Undefiner::DESTROY {
950 undef *undefine_me_if_you_dare;
951}
952{
953 my $w;
954 local $SIG{__WARN__} = sub { $w .= shift };
955 undef *undefine_me_if_you_dare;
956 is $w, undef,
957 'undeffing a gv in DESTROY triggered by undeffing the same gv'
958}
959
795eb8c8
FC
960# [perl #121242]
961# More gp_free madness. gp_free could call a destructor that frees the gv
962# whose gp is being freed.
963sub Fred::AUTOLOAD { $Fred::AUTOLOAD }
964undef *{"Fred::AUTOLOAD"};
965pass 'no crash from gp_free triggering gv_try_downgrade';
966sub _121242::DESTROY { delete $_121242::{$_[0][0]} };
967${"_121242::foo"} = bless ["foo"], _121242::;
968undef *{"_121242::foo"};
969pass 'no crash from pp_undef/gp_free freeing the gv';
970${"_121242::bar"} = bless ["bar"], _121242::;
971*{"_121242::bar"} = "bar";
972pass 'no crash from sv_setsv/gp_free freeing the gv';
973${"_121242::baz"} = bless ["baz"], _121242::;
974*{"_121242::baz"} = *foo;
975pass 'no crash from glob_assign_glob/gp_free freeing the gv';
976{
977 my $foo;
978 undef *_121242::DESTROY;
979 *_121242::DESTROY = sub { undef $foo };
980 my $set_up_foo = sub {
981 # Make $$foo into a fake glob whose array slot holds a blessed
982 # array that undefines $foo, freeing the fake glob.
983 $foo = undef;
984 $$foo = do {local *bar};
985 *$$foo = bless [], _121242::;
986 };
987 &$set_up_foo;
988 $$foo = 3;
989 pass 'no crash from sv_setsv/sv_unglob/gp_free freeing the gv';
990 &$set_up_foo;
991 utf8::encode $$foo;
992 pass 'no crash from sv_utf8_encode/sv_unglob/gp_free freeing the gv';
993 &$set_up_foo;
994 open BAR, "TEST";
995 $$foo .= <BAR>;
996 pass 'no crash from do_readline/sv_unglob/gp_free freeing the gv';
997 close BAR;
998 &$set_up_foo;
999 $$foo .= 3;
1000 pass 'no crash from pp_concat/sv_unglob/gp_free freeing the gv';
1001 &$set_up_foo;
1002 no warnings;
1003 $$foo++;
1004 pass 'no crash from sv_inc/sv_unglob/gp_free freeing the gv';
1005 &$set_up_foo;
1006 $$foo--;
1007 pass 'no crash from sv_dec/sv_unglob/gp_free freeing the gv';
1008 &$set_up_foo;
1009 undef $$foo;
1010 pass 'no crash from pp_undef/sv_unglob/gp_free freeing the gv';
1011 $foo = undef;
1012 $$foo = 3;
1013 $$foo =~ s/3/$$foo = do {local *bar}; *$$foo = bless [],_121242::; 4/e;
1014 pass 'no crash from pp_substcont/sv_unglob/gp_free freeing the gv';
1015}
1016
f132ae69
FC
1017# *{undef}
1018eval { *{my $undef} = 3 };
1019like $@, qr/^Can't use an undefined value as a symbol reference at /,
1020 '*{ $undef } assignment';
1021eval { *{;undef} = 3 };
1022like $@, qr/^Can't use an undefined value as a symbol reference at /,
1023 '*{ ;undef } assignment';
1024
914ecc63
FC
1025# [perl #99142] defined &{"foo"} when there is a constant stub
1026# If I break your module, you get to have it mentioned in Perl's tests. :-)
1027package HTTP::MobileAttribute::Plugin::Locator {
1028 use constant LOCATOR_GPS => 1;
1029 ::ok defined &{__PACKAGE__."::LOCATOR_GPS"},
1030 'defined &{"name of constant"}';
1031 ::ok Internals::SvREFCNT(${__PACKAGE__."::"}{LOCATOR_GPS}),
1032 "stash elem for slot is not freed prematurely";
1033}
1034
e38acfd7
FC
1035# Check that constants promoted to CVs point to the right GVs when the name
1036# contains a null.
1037package lrcg {
1038 use constant x => 3;
1039 # These two lines abuse the optimisation that copies the scalar ref from
1040 # one stash element to another, to get a constant with a null in its name
1041 *{"yz\0a"} = \&{"x"};
1042 my $ref = \&{"yz\0a"};
1043 ::ok !exists $lrcg::{yz},
1044 'constants w/nulls in their names point 2 the right GVs when promoted';
1045}
1046
af230ad6
FC
1047{
1048 no warnings 'io';
1049 stat *{"try_downgrade"};
1050 -T _;
1051 $bang = $!;
1052 eval "*try_downgrade if 0";
1053 -T _;
1054 is "$!",$bang,
1055 'try_downgrade does not touch PL_statgv (last stat handle)';
2be08ad1
FC
1056 readline *{"try_downgrade2"};
1057 my $lastfh = "${^LAST_FH}";
1058 eval "*try_downgrade2 if 0";
1059 is ${^LAST_FH}, $lastfh, 'try_downgrade does not touch PL_last_in_gv';
af230ad6
FC
1060}
1061
0fbaa0e5
FC
1062is runperl(prog => '$s = STDERR; close $s; undef *$s;'
1063 .'eval q-*STDERR if 0-; *$s = *STDOUT{IO}; warn'),
1064 "Warning: something's wrong at -e line 1.\n",
1065 "try_downgrade does not touch PL_stderrgv";
1066
8941bf97
FC
1067is runperl(prog =>
1068 'use constant foo=>1; BEGIN { $x = \&foo } undef &$x; $x->()',
1069 stderr=>1),
1070 "Undefined subroutine &main::foo called at -e line 1.\n",
1071 "gv_try_downgrade does not anonymise CVs referenced elsewhere";
1072
316a4c4b
JH
1073SKIP: {
1074 skip_if_miniperl("no dynamic loading on miniperl, so can't load IO::File", 4);
1075
acb187b4
FC
1076package glob_constant_test {
1077 sub foo { 42 }
1078 use constant bar => *foo;
1079 BEGIN { undef *foo }
1080 ::is eval { bar->() }, eval { &{+bar} },
1081 'glob_constant->() is not mangled at compile time';
1082 ::is "$@", "", 'no error from eval { &{+glob_constant} }';
7131132e
KF
1083 use constant quux => do {
1084 local *F;
1085 my $f = *F;
1086 *$f = *STDOUT{IO};
1087 };
1088 ::is eval { quux->autoflush; 420 }, 420,
1089 'glob_constant->method() works';
1090 ::is "$@", "", 'no error from eval { glob_constant->method() }';
acb187b4
FC
1091}
1092
316a4c4b
JH
1093}
1094
7bdb4ff0
FC
1095{
1096 my $free2;
1097 local $SIG{__WARN__} = sub { ++$free2 if shift =~ /Attempt to free/ };
1098 my $handleref;
1099 my $proxy = \$handleref;
1100 open $$proxy, "TEST";
1101 delete $::{*$handleref{NAME}}; # delete *main::_GEN_xxx
1102 undef $handleref;
1103 is $free2, undef,
1104 'no double free because of bad rv2gv/newGVgen refcounting';
1105}
1106
f9509170
FC
1107# Look away, please.
1108# This violates perl's internal structures by fiddling with stashes in a
1109# way that should never happen, but perl should not start trying to free
1110# unallocated memory as a result. There is no ok() or is() because the
1111# panic that used to occur only occurred during global destruction, and
1112# only with PERL_DESTRUCT_LEVEL=2. (The panic itself was sufficient for
1113# the harness to consider this test script to have failed.)
1114$::{aoeuaoeuaoeaoeu} = __PACKAGE__; # cow
1115() = *{"aoeuaoeuaoeaoeu"};
1116
2f222bbd
FC
1117$x = *_119051;
1118$y = \&$x;
1119undef $x;
1120eval { &$y };
1121pass "No crash due to CvGV(vivified stub) pointing to flattened glob copy";
1122# Not really supported, but this should not crash either:
1123$x = *_119051again;
1124delete $::{_119051again};
1125$::{_119051again} = $x; # now we have a fake glob under the right name
1126$y = \&$x; # so when this tries to look up the right GV for
1127undef $::{_119051again}; # CvGV, it still gets a fake one
1128eval { $y->() };
1129pass "No crash due to CvGV pointing to glob copy in the stash";
1130
ff2a62e0
FC
1131# Aliasing should disable no-common-vars optimisation.
1132{
1133 *x = *y;
1134 $x = 3;
1135 ($x, my $z) = (1, $y);
1136 is $z, 3, 'list assignment after aliasing [perl #89646]';
1137}
1138
3c62f09f
DM
1139# RT #125840: make sure *x = $x doesn't do bad things by freeing $x before
1140# it's assigned.
1141
1142{
1143 $a_125840 = 1;
1144 $b_125840 = 2;
1145 $a_125840 = *b_125840;
1146 *a_125840 = $a_125840;
1147 is($a_125840, 2, 'RT #125840: *a = $a');
1148
1149 $c_125840 = 1;
1150 $d_125840 = 2;
1151 *d_125840 = $d_125840 = *c_125840;
1152 is($d_125840, 1, 'RT #125840: *d=$d=*c');
1153 $c_125840 = $d_125840;
1154 is($c_125840, 1, 'RT #125840: $c=$d');
1155}
1156
a2637ca0
FC
1157# [perl #128597] Crash when gp_free calls ckWARN_d
1158# I am not sure this test even belongs in this file, as the crash was the
1159# result of various features interacting. But a call to ckWARN_d from
1160# gv.c:gp_free triggered the crash, so this seems as good a place as any.
1161# ‘die’ (or any abnormal scope exit) can cause the current cop to be freed,
1162# if the subroutine containing the ‘die’ gets freed as a result. That
1163# causes PL_curcop to be set to NULL. If a writable handle gets freed
1164# while PL_curcop is NULL, then gp_free will call ckWARN_d while that con-
1165# dition still holds, so ckWARN_d needs to know about PL_curcop possibly
1166# being NULL.
1167SKIP: {
1168 skip_if_miniperl("No PerlIO::scalar on miniperl", 1);
1169 runperl(prog => 'open my $fh, q|>|, \$buf;'
1170 .'my $sub = eval q|sub {exit 0}|; $sub->()');
1171 is ($? & 127, 0,"[perl #128597] No crash when gp_free calls ckWARN_d");
1172}
ff2a62e0 1173
1097da16
TC
1174{
1175 # [perl #131263]
1176 *sym = "\N{U+0080}";
1177 ok(*sym eq "*main::\N{U+0080}", "utf8 flag properly set");
1178 *sym = "\xC3\x80";
1179 ok(*sym eq "*main::\xC3\x80", "utf8 flag properly cleared");
1180}
1181
be294d8d
DM
1182# test gv_try_downgrade()
1183# If a GV can be stored in a stash in a compact, non-GV form, then
1184# whenever ops are freed which reference the GV, an attempt is made to
1185# downgrade the GV to something simpler. Made sure this happens.
1186
1187package GV_DOWNGRADE {
1188 use constant FOO => 1;
1189
1190 ::like "$GV_DOWNGRADE::{FOO}", qr/SCALAR/, "gv_downgrade: pre";
1191 eval q{
1192 my $x = \&FOO; # upgrades compact to full GV
1193 ::like "$GV_DOWNGRADE::{FOO}", qr/^\*/, "gv_downgrade: full";
1194 };
1195 # after the eval's ops are freed, the GV should get downgraded again
1196 ::like "$GV_DOWNGRADE::{FOO}", qr/SCALAR/, "gv_downgrade: post";
1197}
1198
790acdde 1199# [perl #131085] This used to crash; no ok() necessary.
cc8d035d 1200{ no warnings;
790acdde 1201$::{"A131085"} = sub {}; \&{"A131085"};
cc8d035d 1202}
790acdde
FC
1203
1204
64278e8c
A
1205#
1206# Deprecated before 5.28, fatal since then
1207#
1208undef $@;
1209eval << '--';
1210 sub Other::AUTOLOAD {1}
1211 sub Other::fred {}
1212 @ISA = qw [Other];
1213 fred ();
1214 my $x = \&barney;
1215 (bless []) -> barney;
1216--
1217like $@, qr /^Use of inherited AUTOLOAD for non-method main::fred\(\) is no longer allowed/, "Cannot inherit AUTOLOAD";
1218
1219undef $@;
1220eval << '--';
1221 use utf8;
1222 use open qw [:utf8 :std];
1223 sub Oᕞʀ::AUTOLOAD { 1 } sub Oᕞʀ::fᕃƌ {}
1224 @ISA = qw(Oᕞʀ) ;
1225 fᕃƌ() ;
1226--
1227like $@, qr /^Use of inherited AUTOLOAD for non-method main::f\x{1543}\x{18c}\(\) is no longer allowed/, "Cannot inherit AUTOLOAD";
1228
2c205b54
NC
1229# ASAN used to get very excited about this:
1230runperl(prog => '$a += (*a = 2)');
1231is ($?, 0,
1232 "work around lack of stack reference counting during typeglob assignment");
1233
1234# and this
1235runperl(prog => '$$ |= (*$ = $$)');
1236is ($?, 0,
1237 "work around lack of stack reference counting during typeglob assignment");
1238
1239done_testing();
1240
99491443 1241__END__
98e007d4
NC
1242Perl
1243Rules
1244perl
1245rocks