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