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 824{ 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 } 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 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"; 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 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 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 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; 897 my $glob = do { no warnings "once"; \*phing::foo}; 898 delete $::{"phing::"}; 899 *$glob = *greck; 900}, "Assigning a glob-with-sub to a glob that has lost its stash works"; 901ok eval { 902 sub pon::foo; 903 my $glob = \*pon::foo; 904 delete $::{"pon::"}; 905 *$glob = *foo; 906}, "Assigning a glob to a glob-with-sub that has lost its stash works"; 907 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} 923 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 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 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 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 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 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 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)'; 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'; 1059} 1060 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 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 1072SKIP: { 1073 skip_if_miniperl("no dynamic loading on miniperl, so can't load IO::File", 4); 1074 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} }'; 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() }'; 1090} 1091 1092} 1093 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 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 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 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 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 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} 1172 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 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 1198# [perl #131085] This used to crash; no ok() necessary. 1199{ no warnings; 1200$::{"A131085"} = sub {}; \&{"A131085"}; 1201} 1202 1203 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 1228# ASAN used to get very excited about this: 1229runperl(prog => '$a += (*a = 2)'); 1230is ($?, 0, 1231 "work around lack of stack reference counting during typeglob assignment"); 1232 1233# and this 1234runperl(prog => '$$ |= (*$ = $$)'); 1235is ($?, 0, 1236 "work around lack of stack reference counting during typeglob assignment"); 1237 1238# and these (although a build with assertions would hit an assertion first) 1239 1240runperl(prog => '$foo::{ISA} = {}; delete $foo::{ISA}'); 1241is ($?, 0, "hv_delete_common must check SvTYPE before using GvAV"); 1242 1243runperl(prog => 'sub foo::ISA; delete $foo::{ISA}'); 1244is ($?, 0, "hv_delete_common must check SvTYPE before using GvAV"); 1245 1246{ 1247 my $w; 1248 local $SIG{__WARN__} = sub { $w .= shift }; 1249 1250 # This is a test case for a very long standing bug discovered while 1251 # investigating GH #19450 1252 sub thump; 1253 1254 is($::{thump} . "", '-1', "stub sub with no prototype stored as -1"); 1255 1256 is(eval 'sub thump {}; 1', 1, "can define the stub") 1257 or diag($@); 1258 is($w, undef, "define the stub without warnings"); 1259 undef $w; 1260 1261 # This is a testcase for the bug reported in GH #19450, which is a 1262 # regression introduced by commit bb5bc97fde9ef2f1 1263 sub tic_tac_toe; 1264 1265 is($::{tic_tac_toe} . "", '-1', "stub sub with no prototype stored as -1"); 1266 1267 is(eval '*tic_tac_toe = []; 1', 1, "can assign to the typeglob") 1268 or diag($a); 1269 is($w, undef, "assign to the typeglob without warnings"); 1270 undef $w; 1271 1272 # do both: 1273 sub comment_sign; 1274 1275 is($::{comment_sign} . "", '-1', "stub sub with no prototype stored as -1"); 1276 1277 is(eval '*comment_sign = []; 1', 1, "can assign to the typeglob") 1278 or diag($a); 1279 is($w, undef, "assign to the typeglob without warnings"); 1280 undef $w; 1281 1282 is(eval 'sub comment_sign {}; 1', 1, "can define the stub") 1283 or diag($@); 1284 is($w, undef, "define the stub without warnings"); 1285 undef $w; 1286 1287 # do both, reverse order: 1288 sub widget_mark; 1289 1290 is($::{widget_mark} . "", '-1', "stub sub with no prototype stored as -1"); 1291 1292 is(eval 'sub widget_mark {}; 1', 1, "can define the stub") 1293 or diag($@); 1294 is($w, undef, "define the stub without warnings"); 1295 undef $w; 1296 1297 is(eval '*widget_mark = []; 1', 1, "can assign to the typeglob") 1298 or diag($a); 1299 is($w, undef, "assign to the typeglob without warnings"); 1300 undef $w; 1301} 1302 1303done_testing(); 1304 1305__END__ 1306Perl 1307Rules 1308perl 1309rocks 1310