1#!./perl 2 3# 4# various typeglob tests 5# 6 7BEGIN { 8 chdir 't' if -d 't'; 9 require './test.pl'; 10 set_up_inc('../lib'); 11} 12 13use warnings; 14 15# type coercion on assignment 16$foo = 'foo'; 17$bar = *main::foo; 18$bar = $foo; 19is(ref(\$bar), 'SCALAR'); 20$foo = *main::bar; 21 22# type coercion (not) on misc ops 23 24ok($foo); 25is(ref(\$foo), 'GLOB'); 26 27unlike ($foo, qr/abcd/); 28is(ref(\$foo), 'GLOB'); 29 30is($foo, '*main::bar'); 31is(ref(\$foo), 'GLOB'); 32 33{ 34 no warnings; 35 ${\*$foo} = undef; 36 is(ref(\$foo), 'GLOB', 'no type coercion when assigning to *{} retval'); 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', 45 'no type coercion when assigning to retval of symbolic *{}' 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', 57 'no type coercion when assigning to retval of compile-time *{}' 58 ); 59} 60 61# type coercion on substitutions that match 62$a = *main::foo; 63$b = $a; 64$a =~ s/^X//; 65is(ref(\$a), 'GLOB'); 66$a =~ s/^\*//; 67is($a, 'main::foo'); 68is(ref(\$b), 'GLOB'); 69 70# typeglobs as lvalues 71substr($foo, 0, 1) = "XXX"; 72is(ref(\$foo), 'SCALAR'); 73is($foo, 'XXXmain::bar'); 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(); 83ok(defined $fuu); 84is(ref(\$fuu), 'GLOB'); 85 86 87ok(defined $baa); 88is(ref(\$baa), 'GLOB'); 89 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 95{ package Foo::Bar; no warnings 'once'; $test=1; } 96ok(exists $Foo::{'Bar::'}); 97is($Foo::{'Bar::'}, '*Foo::Bar::'); 98 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; 105is ($foo, undef); 106is (scalar @foo, 0); 107is (scalar %foo, 0); 108 109{ 110 # test warnings from assignment of undef to glob 111 my $msg = ''; 112 local $SIG{__WARN__} = sub { $msg = $_[0] }; 113 use warnings; 114 *foo = 'bar'; 115 is($msg, ''); 116 *foo = undef; 117 like($msg, qr/Undefined value assigned to typeglob/); 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 } 146} 147 148my $test = curr_test(); 149# test *glob{THING} syntax 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" } 157print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}}; 158# This needs to go here, after the print, as sub x will return the current 159# value of test 160++$test; 161format x = 162XXX This text isn't used. Should it be? 163. 164curr_test($test); 165 166is (ref *x{FORMAT}, "FORMAT"); 167is ("@{sub { *_{ARRAY} }->(1..3)}", "1 2 3", 168 'returning *_{ARRAY} from sub'); 169*x = *STDOUT; 170is (*{*x{GLOB}}, "*main::STDOUT"); 171 172{ 173 my $test = curr_test(); 174 175 print {*x{IO}} "ok $test\n"; 176 ++$test; 177 178 my $warn; 179 local $SIG{__WARN__} = sub { 180 $warn .= $_[0]; 181 }; 182 my $val = *x{FILEHANDLE}; 183 184 # deprecation warning removed in v5.23 -- rjbs, 2015-12-31 185 # https://github.com/Perl/perl5/issues/15105 186 print {*x{IO}} (! defined $warn 187 ? "ok $test\n" : "not ok $test\n"); 188 curr_test(++$test); 189} 190 191is *x{NAME}, 'x', '*foo{NAME}'; 192is *x{PACKAGE}, 'main', '*foo{PACKAGE}'; 193{ no warnings 'once'; *x = *Foo::y; } 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'; 197 198{ 199 # test if defined() doesn't create any new symbols 200 201 my $a = "SYM000"; 202 ok(!defined *{$a}); 203 204 ok(!defined ${$a}); 205 ok(!defined *{$a}); 206 207 ok(!defined &{$a}); 208 ok(!defined *{$a}); 209 210 my $state = "not"; 211 *{$a} = sub { $state = "ok" }; 212 ok(defined &{$a}); 213 ok(defined *{$a}); 214 &{$a}; 215 is ($state, 'ok'); 216} 217 218{ 219 # although it *should* if you're talking about magicals 220 221 my $a = "]"; 222 ok(defined *{$a}); 223 ok(defined ${$a}); 224 225 $a = "1"; 226 "o" =~ /(o)/; 227 ok(${$a}); 228 ok(defined *{$a}); 229 $a = "2"; 230 ok(!${$a}); 231 ok(defined *{$a}); 232 $a = "1x"; 233 ok(!defined ${$a}); 234 ok(!defined *{$a}); 235 $a = "11"; 236 "o" =~ /(((((((((((o)))))))))))/; 237 ok(${$a}); 238 ok(defined *{$a}); 239} 240 241# [ID 20010526.001 (#7038)] localized glob loses value when assigned to 242 243$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{}; 244 245is($j, 1); 246is($j{a}, 1); 247is($j[0], 1); 248 249{ 250 # does pp_readline() handle glob-ness correctly? 251 my $g = *foo; 252 $g = <DATA>; 253 is ($g, "Perl\n"); 254} 255 256{ 257 my $w = ''; 258 local $SIG{__WARN__} = sub { $w = $_[0] }; 259 sub abc1 (); 260 local *abc1 = sub { }; 261 is ($w, ''); 262 sub abc2 (); 263 local *abc2; 264 *abc2 = sub { }; 265 is ($w, ''); 266 sub abc3 (); 267 *abc3 = sub { }; 268 like ($w, qr/Prototype mismatch/); 269} 270 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>; 277 is ($x, "Rules\n"); 278} 279 280{ 281 # test the assignment of a GLOB to an LVALUE 282 my $e = ''; 283 local $SIG{__DIE__} = sub { $e = $_[0] }; 284 my %v; 285 sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA } 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}; 290 is ($x, "perl\n"); 291 is ($e, '', '__DIE__ handler never called'); 292} 293 294{ 295 my $e = ''; 296 # GLOB assignment to tied element 297 local $SIG{__DIE__} = sub { $e = $_[0] }; 298 sub T::TIEARRAY { bless [] => "T" } 299 sub T::STORE { $_[0]->[ $_[1] ] = $_[2] } 300 sub T::FETCH { $_[0]->[ $_[1] ] } 301 sub T::FETCHSIZE { @{$_[0]} } 302 tie my @ary => "T"; 303 $ary[0] = *DATA; 304 is ($ary[0], '*main::DATA'); 305 is ( 306 ref\tied(@ary)->[0], 'GLOB', 307 'tied elem assignment preserves globs' 308 ); 309 is ($e, '', '__DIE__ handler not called'); 310 my $x = readline $ary[0]; 311 is($x, "rocks\n"); 312 is ($e, '', '__DIE__ handler never called'); 313} 314 315{ 316 # Need some sort of die or warn to get the global destruction text if the 317 # bug is still present 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); 321 my $output = runperl(prog => <<'EOPROG'); 322package M; 323$| = 1; 324sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} 325package main; 326 327bless \$A::B, q{M}; 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} 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 339foreach (qw (oonk ga_shloip)) { 340 ok(!exists $::{$_}, "no symbols of any sort to start with for $_"); 341} 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}, 352 \*STDIN, \&ok, \undef, *STDOUT) { 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 $@; 361 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")"); 362 is ($got, $value, "Value is correctly set"); 363} 364 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', 374 "Inlining of constant doesn't change representation"); 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 421# Check that assignment to an existing typeglob works 422{ 423 my $w = ''; 424 local $SIG{__WARN__} = sub { $w = $_[0] }; 425 *{"plunk"} = []; 426 *{"plunk"} = \&{"oonk"}; 427 is($w, '', "Should be no warning"); 428} 429 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] }; 439 *{$gr} = \&{"oonk"}; 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)"); 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 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 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 497$::{borage} = \&ok; 498eval 'borage("sub ref in stash")' or fail "sub ref in stash"; 499 500{ 501 our ($glook, $smek, $foof); 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 519format = 520. 521 522foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) { 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} 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 547{ 548 # Bug reported by broquaint on IRC 549 *slosh::{HASH}->{ISA}=[]; 550 slosh->import; 551 pass("gv_fetchmeth coped with the unexpected"); 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"}=[]; 572 eval "<STDOUT> if 0"; 573 is($@, '', "Can't trip up readline overloading"); 574 575 $CORE::GLOBAL::{"readpipe"}=[]; 576 eval "`` if 0"; 577 is($@, '', "Can't trip up readpipe overloading"); 578} 579 580{ 581 die if exists $::{BONK}; 582 $::{BONK} = \"powie"; 583 *{"BONK"} = \&{"BONK"}; 584 eval 'is(BONK(), "powie", 585 "Assignment works when glob created midway (bug 45607)"); 1' 586 or die $@; 587} 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 612# RT #65582 anonymous glob should be defined, and not coredump when 613# stringified. The behaviours are: 614# 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__::..." 620 621{ 622 my $io_ref = *STDOUT{IO}; 623 my $glob = *$io_ref; 624 ok(defined $glob, "RT #65582 anon glob should be defined"); 625 626 my $warn = ''; 627 local $SIG{__WARN__} = sub { $warn = $_[0] }; 628 use warnings; 629 my $str = "$glob"; 630 is($warn, '', "RT #65582 anon glob stringification shouldn't warn"); 631 is($str, '*__ANON__::__ANONIO__', 632 "RT #65582/#96326 anon glob stringification"); 633} 634 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 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 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 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 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 705# [perl #1804] *$x assignment when $x is a copy of another glob 706# And [perl #77508] (same thing with list assignment) 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 ); 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); 721} 722 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 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 767 # Neither should reference assignment. 768 *$_ = []; 769 is $_, "*main::hon", "PVLV: arrayref assignment assigns to the AV slot"; 770 771 # Concatenation should still work. 772 ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@; 773 is $_, '*main::honthlew', 'PVLV concatenation works'; 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 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 } 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 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"; 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 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 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 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; 898 my $glob = do { no warnings "once"; \*phing::foo}; 899 delete $::{"phing::"}; 900 *$glob = *greck; 901}, "Assigning a glob-with-sub to a glob that has lost its stash works"; 902ok eval { 903 sub pon::foo; 904 my $glob = \*pon::foo; 905 delete $::{"pon::"}; 906 *$glob = *foo; 907}, "Assigning a glob to a glob-with-sub that has lost its stash works"; 908 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} 924 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 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 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 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 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 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 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)'; 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'; 1060} 1061 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 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 1073SKIP: { 1074 skip_if_miniperl("no dynamic loading on miniperl, so can't load IO::File", 4); 1075 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} }'; 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() }'; 1091} 1092 1093} 1094 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 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 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 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 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 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} 1173 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 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 1199# [perl #131085] This used to crash; no ok() necessary. 1200{ no warnings; 1201$::{"A131085"} = sub {}; \&{"A131085"}; 1202} 1203 1204 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 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 1239# and these (although a build with assertions would hit an assertion first) 1240 1241runperl(prog => '$foo::{ISA} = {}; delete $foo::{ISA}'); 1242is ($?, 0, "hv_delete_common must check SvTYPE before using GvAV"); 1243 1244runperl(prog => 'sub foo::ISA; delete $foo::{ISA}'); 1245is ($?, 0, "hv_delete_common must check SvTYPE before using GvAV"); 1246 1247{ 1248 my $w; 1249 local $SIG{__WARN__} = sub { $w .= shift }; 1250 1251 # This is a test case for a very long standing bug discovered while 1252 # investigating GH #19450 1253 sub thump; 1254 1255 is($::{thump} . "", '-1', "stub sub with no prototype stored as -1"); 1256 1257 is(eval 'sub thump {}; 1', 1, "can define the stub") 1258 or diag($@); 1259 is($w, undef, "define the stub without warnings"); 1260 undef $w; 1261 1262 # This is a testcase for the bug reported in GH #19450, which is a 1263 # regression introduced by commit bb5bc97fde9ef2f1 1264 sub tic_tac_toe; 1265 1266 is($::{tic_tac_toe} . "", '-1', "stub sub with no prototype stored as -1"); 1267 1268 is(eval '*tic_tac_toe = []; 1', 1, "can assign to the typeglob") 1269 or diag($a); 1270 is($w, undef, "assign to the typeglob without warnings"); 1271 undef $w; 1272 1273 # do both: 1274 sub comment_sign; 1275 1276 is($::{comment_sign} . "", '-1', "stub sub with no prototype stored as -1"); 1277 1278 is(eval '*comment_sign = []; 1', 1, "can assign to the typeglob") 1279 or diag($a); 1280 is($w, undef, "assign to the typeglob without warnings"); 1281 undef $w; 1282 1283 is(eval 'sub comment_sign {}; 1', 1, "can define the stub") 1284 or diag($@); 1285 is($w, undef, "define the stub without warnings"); 1286 undef $w; 1287 1288 # do both, reverse order: 1289 sub widget_mark; 1290 1291 is($::{widget_mark} . "", '-1', "stub sub with no prototype stored as -1"); 1292 1293 is(eval 'sub widget_mark {}; 1', 1, "can define the stub") 1294 or diag($@); 1295 is($w, undef, "define the stub without warnings"); 1296 undef $w; 1297 1298 is(eval '*widget_mark = []; 1', 1, "can assign to the typeglob") 1299 or diag($a); 1300 is($w, undef, "assign to the typeglob without warnings"); 1301 undef $w; 1302} 1303 1304done_testing(); 1305 1306__END__ 1307Perl 1308Rules 1309perl 1310rocks 1311