1#!./perl 2 3# 4# various typeglob tests 5# 6 7BEGIN { 8 chdir 't' if -d 't'; 9 @INC = '../lib'; 10 require './test.pl'; 11} 12 13use warnings; 14 15plan( tests => 271 ); 16 17# type coercion on assignment 18$foo = 'foo'; 19$bar = *main::foo; 20$bar = $foo; 21is(ref(\$bar), 'SCALAR'); 22$foo = *main::bar; 23 24# type coercion (not) on misc ops 25 26ok($foo); 27is(ref(\$foo), 'GLOB'); 28 29unlike ($foo, qr/abcd/); 30is(ref(\$foo), 'GLOB'); 31 32is($foo, '*main::bar'); 33is(ref(\$foo), 'GLOB'); 34 35{ 36 no warnings; 37 ${\*$foo} = undef; 38 is(ref(\$foo), 'GLOB', 'no type coercion when assigning to *{} retval'); 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', 47 'no type coercion when assigning to retval of symbolic *{}' 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', 59 'no type coercion when assigning to retval of compile-time *{}' 60 ); 61} 62 63# type coercion on substitutions that match 64$a = *main::foo; 65$b = $a; 66$a =~ s/^X//; 67is(ref(\$a), 'GLOB'); 68$a =~ s/^\*//; 69is($a, 'main::foo'); 70is(ref(\$b), 'GLOB'); 71 72# typeglobs as lvalues 73substr($foo, 0, 1) = "XXX"; 74is(ref(\$foo), 'SCALAR'); 75is($foo, 'XXXmain::bar'); 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(); 85ok(defined $fuu); 86is(ref(\$fuu), 'GLOB'); 87 88 89ok(defined $baa); 90is(ref(\$baa), 'GLOB'); 91 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 97{ package Foo::Bar; no warnings 'once'; $test=1; } 98ok(exists $Foo::{'Bar::'}); 99is($Foo::{'Bar::'}, '*Foo::Bar::'); 100 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; 107is ($foo, undef); 108is (scalar @foo, 0); 109is (scalar %foo, 0); 110 111{ 112 # test warnings from assignment of undef to glob 113 my $msg = ''; 114 local $SIG{__WARN__} = sub { $msg = $_[0] }; 115 use warnings; 116 *foo = 'bar'; 117 is($msg, ''); 118 *foo = undef; 119 like($msg, qr/Undefined value assigned to typeglob/); 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 } 148} 149 150my $test = curr_test(); 151# test *glob{THING} syntax 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" } 159print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}}; 160# This needs to go here, after the print, as sub x will return the current 161# value of test 162++$test; 163format x = 164XXX This text isn't used. Should it be? 165. 166curr_test($test); 167 168is (ref *x{FORMAT}, "FORMAT"); 169is ("@{sub { *_{ARRAY} }->(1..3)}", "1 2 3", 170 'returning *_{ARRAY} from sub'); 171*x = *STDOUT; 172is (*{*x{GLOB}}, "*main::STDOUT"); 173 174{ 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}; 185 print {*x{IO}} ($warn =~ /is deprecated/ 186 ? "ok $test\n" : "not ok $test\n"); 187 curr_test(++$test); 188} 189 190is *x{NAME}, 'x', '*foo{NAME}'; 191is *x{PACKAGE}, 'main', '*foo{PACKAGE}'; 192{ no warnings 'once'; *x = *Foo::y; } 193is *x, '*Foo::y', 'glob stringifies as assignee after glob-to-glob assign'; 194is *x{NAME}, 'x', 'but *foo{NAME} still returns the original name'; 195is *x{PACKAGE}, 'main', 'and *foo{PACKAGE} the original package'; 196 197{ 198 # test if defined() doesn't create any new symbols 199 200 my $a = "SYM000"; 201 ok(!defined *{$a}); 202 203 { 204 no warnings 'deprecated'; 205 ok(!defined @{$a}); 206 } 207 ok(!defined *{$a}); 208 209 { 210 no warnings 'deprecated'; 211 ok(!defined %{$a}); 212 } 213 ok(!defined *{$a}); 214 215 ok(!defined ${$a}); 216 ok(!defined *{$a}); 217 218 ok(!defined &{$a}); 219 ok(!defined *{$a}); 220 221 my $state = "not"; 222 *{$a} = sub { $state = "ok" }; 223 ok(defined &{$a}); 224 ok(defined *{$a}); 225 &{$a}; 226 is ($state, 'ok'); 227} 228 229{ 230 # although it *should* if you're talking about magicals 231 232 my $a = "]"; 233 ok(defined *{$a}); 234 ok(defined ${$a}); 235 236 $a = "1"; 237 "o" =~ /(o)/; 238 ok(${$a}); 239 ok(defined *{$a}); 240 $a = "2"; 241 ok(!${$a}); 242 ok(defined *{$a}); 243 $a = "1x"; 244 ok(!defined ${$a}); 245 ok(!defined *{$a}); 246 $a = "11"; 247 "o" =~ /(((((((((((o)))))))))))/; 248 ok(${$a}); 249 ok(defined *{$a}); 250} 251 252# [ID 20010526.001] localized glob loses value when assigned to 253 254$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{}; 255 256is($j, 1); 257is($j{a}, 1); 258is($j[0], 1); 259 260{ 261 # does pp_readline() handle glob-ness correctly? 262 my $g = *foo; 263 $g = <DATA>; 264 is ($g, "Perl\n"); 265} 266 267{ 268 my $w = ''; 269 local $SIG{__WARN__} = sub { $w = $_[0] }; 270 sub abc1 (); 271 local *abc1 = sub { }; 272 is ($w, ''); 273 sub abc2 (); 274 local *abc2; 275 *abc2 = sub { }; 276 is ($w, ''); 277 sub abc3 (); 278 *abc3 = sub { }; 279 like ($w, qr/Prototype mismatch/); 280} 281 282{ 283 # [17375] rcatline to formerly-defined undef was broken. Fixed in 284 # do_readline by checking SvOK. AMS, 20020918 285 my $x = "not "; 286 $x = undef; 287 $x .= <DATA>; 288 is ($x, "Rules\n"); 289} 290 291{ 292 # test the assignment of a GLOB to an LVALUE 293 my $e = ''; 294 local $SIG{__DIE__} = sub { $e = $_[0] }; 295 my %v; 296 sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA } 297 f($v{v}); 298 is ($v{v}, '*main::DATA'); 299 is (ref\$v{v}, 'GLOB', 'lvalue assignment preserves globs'); 300 my $x = readline $v{v}; 301 is ($x, "perl\n"); 302 is ($e, '', '__DIE__ handler never called'); 303} 304 305{ 306 my $e = ''; 307 # GLOB assignment to tied element 308 local $SIG{__DIE__} = sub { $e = $_[0] }; 309 sub T::TIEARRAY { bless [] => "T" } 310 sub T::STORE { $_[0]->[ $_[1] ] = $_[2] } 311 sub T::FETCH { $_[0]->[ $_[1] ] } 312 sub T::FETCHSIZE { @{$_[0]} } 313 tie my @ary => "T"; 314 $ary[0] = *DATA; 315 is ($ary[0], '*main::DATA'); 316 is ( 317 ref\tied(@ary)->[0], 'GLOB', 318 'tied elem assignment preserves globs' 319 ); 320 is ($e, '', '__DIE__ handler not called'); 321 my $x = readline $ary[0]; 322 is($x, "rocks\n"); 323 is ($e, '', '__DIE__ handler never called'); 324} 325 326{ 327 # Need some sort of die or warn to get the global destruction text if the 328 # bug is still present 329 my $output = runperl(prog => <<'EOPROG'); 330package M; 331$| = 1; 332sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} 333package main; 334 335bless \$A::B, q{M}; 336*A:: = \*B::; 337EOPROG 338 like($output, qr/^Farewell M=SCALAR/, "DESTROY was called"); 339 unlike($output, qr/global destruction/, 340 "unreferenced symbol tables should be cleaned up immediately"); 341} 342 343# Possibly not the correct test file for these tests. 344# There are certain space optimisations implemented via promotion rules to 345# GVs 346 347foreach (qw (oonk ga_shloip)) { 348 ok(!exists $::{$_}, "no symbols of any sort to start with for $_"); 349} 350 351# A string in place of the typeglob is promoted to the function prototype 352$::{oonk} = "pie"; 353my $proto = eval 'prototype \&oonk'; 354die if $@; 355is ($proto, "pie", "String is promoted to prototype"); 356 357 358# A reference to a value is used to generate a constant subroutine 359foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2}, 360 \*STDIN, \&ok, \undef, *STDOUT) { 361 delete $::{oonk}; 362 $::{oonk} = \$value; 363 $proto = eval 'prototype \&oonk'; 364 die if $@; 365 is ($proto, '', "Prototype for a constant subroutine is empty"); 366 367 my $got = eval 'oonk'; 368 die if $@; 369 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")"); 370 is ($got, $value, "Value is correctly set"); 371} 372 373delete $::{oonk}; 374$::{oonk} = \"Value"; 375 376*{"ga_shloip"} = \&{"oonk"}; 377 378is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is"); 379is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 380is (eval 'ga_shloip', "Value", "Constant has correct value"); 381is (ref $::{ga_shloip}, 'SCALAR', 382 "Inlining of constant doesn't change representation"); 383 384delete $::{ga_shloip}; 385 386eval 'sub ga_shloip (); 1' or die $@; 387is ($::{ga_shloip}, '', "Prototype is stored as an empty string"); 388 389# Check that a prototype expands. 390*{"ga_shloip"} = \&{"oonk"}; 391 392is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 393is (eval 'ga_shloip', "Value", "Constant has correct value"); 394is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob"); 395 396 397@::zwot = ('Zwot!'); 398 399# Check that assignment to an existing typeglob works 400{ 401 my $w = ''; 402 local $SIG{__WARN__} = sub { $w = $_[0] }; 403 *{"zwot"} = \&{"oonk"}; 404 is($w, '', "Should be no warning"); 405} 406 407is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 408is (eval 'zwot', "Value", "Constant has correct value"); 409is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob"); 410is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob"); 411 412sub spritsits () { 413 "Traditional"; 414} 415 416# Check that assignment to an existing subroutine works 417{ 418 my $w = ''; 419 local $SIG{__WARN__} = sub { $w = $_[0] }; 420 *{"spritsits"} = \&{"oonk"}; 421 like($w, qr/^Constant subroutine main::spritsits redefined/, 422 "Redefining a constant sub should warn"); 423} 424 425is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 426is (eval 'spritsits', "Value", "Constant has correct value"); 427is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob"); 428 429# Check that assignment to an existing typeglob works 430{ 431 my $w = ''; 432 local $SIG{__WARN__} = sub { $w = $_[0] }; 433 *{"plunk"} = []; 434 *{"plunk"} = \&{"oonk"}; 435 is($w, '', "Should be no warning"); 436} 437 438is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 439is (eval 'plunk', "Value", "Constant has correct value"); 440is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); 441 442my $gr = eval '\*plunk' or die; 443 444{ 445 my $w = ''; 446 local $SIG{__WARN__} = sub { $w = $_[0] }; 447 *{$gr} = \&{"oonk"}; 448 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)"); 449} 450 451is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 452is (eval 'plunk', "Value", "Constant has correct value"); 453is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); 454 455# Non-void context should defeat the optimisation, and will cause the original 456# to be promoted (what change 26482 intended) 457my $result; 458{ 459 my $w = ''; 460 local $SIG{__WARN__} = sub { $w = $_[0] }; 461 $result = *{"awkkkkkk"} = \&{"oonk"}; 462 is($w, '', "Should be no warning"); 463} 464 465is (ref \$result, 'GLOB', 466 "Non void assignment should still return a typeglob"); 467 468is (ref \$::{oonk}, 'GLOB', "This export does affect original"); 469is (eval 'plunk', "Value", "Constant has correct value"); 470is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); 471 472delete $::{oonk}; 473$::{oonk} = \"Value"; 474 475sub non_dangling { 476 my $w = ''; 477 local $SIG{__WARN__} = sub { $w = $_[0] }; 478 *{"zap"} = \&{"oonk"}; 479 is($w, '', "Should be no warning"); 480} 481 482non_dangling(); 483is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 484is (eval 'zap', "Value", "Constant has correct value"); 485is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS"); 486 487sub dangling { 488 local $SIG{__WARN__} = sub { die $_[0] }; 489 *{"biff"} = \&{"oonk"}; 490} 491 492dangling(); 493is (ref \$::{oonk}, 'GLOB', "This export does affect original"); 494is (eval 'biff', "Value", "Constant has correct value"); 495is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob"); 496 497$::{yarrow} = [4,5,6]; 498is join("-", eval "yarrow()"), '4-5-6', 'array ref as stash elem'; 499is ref $::{yarrow}, "ARRAY", 'stash elem is still array ref after use'; 500is join("-", eval "&yarrow"), '4-5-6', 'calling const list with &'; 501is join("-", eval "&yarrow(1..10)"), '4-5-6', 'const list ignores & args'; 502is prototype "yarrow", "", 'const list has "" prototype'; 503is eval "yarrow", 3, 'const list in scalar cx returns length'; 504 505{ 506 use vars qw($glook $smek $foof); 507 # Check reference assignment isn't affected by the SV type (bug #38439) 508 $glook = 3; 509 $smek = 4; 510 $foof = "halt and cool down"; 511 512 my $rv = \*smek; 513 is($glook, 3); 514 *glook = $rv; 515 is($glook, 4); 516 517 my $pv = ""; 518 $pv = \*smek; 519 is($foof, "halt and cool down"); 520 *foof = $pv; 521 is($foof, 4); 522} 523 524format = 525. 526 527foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) { 528 # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns 529 # IO::Handle, which isn't what we want. 530 my $type = $value; 531 $type =~ s/.*=//; 532 $type =~ s/\(.*//; 533 delete $::{oonk}; 534 $::{oonk} = $value; 535 $proto = eval 'prototype \&oonk'; 536 like ($@, qr/^Cannot convert a reference to $type to typeglob/, 537 "Cannot upgrade ref-to-$type to typeglob"); 538} 539 540{ 541 no warnings qw(once uninitialized); 542 my $g = \*clatter; 543 my $r = eval {no strict; ${*{$g}{SCALAR}}}; 544 is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax"); 545 546 $g = \*vowm; 547 $r = eval {use strict; ${*{$g}{SCALAR}}}; 548 is ($@, '', 549 "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict"); 550} 551 552{ 553 # Bug reported by broquaint on IRC 554 *slosh::{HASH}->{ISA}=[]; 555 slosh->import; 556 pass("gv_fetchmeth coped with the unexpected"); 557 558 # An audit found these: 559 { 560 package slosh; 561 sub rip { 562 my $s = shift; 563 $s->SUPER::rip; 564 } 565 } 566 eval {slosh->rip;}; 567 like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER"); 568 569 is(slosh->isa('swoosh'), ''); 570 571 $CORE::GLOBAL::{"lock"}=[]; 572 eval "no warnings; lock"; 573 like($@, qr/^Not enough arguments for lock/, 574 "Can't trip up general keyword overloading"); 575 576 $CORE::GLOBAL::{"readline"}=[]; 577 eval "<STDOUT> if 0"; 578 is($@, '', "Can't trip up readline overloading"); 579 580 $CORE::GLOBAL::{"readpipe"}=[]; 581 eval "`` if 0"; 582 is($@, '', "Can't trip up readpipe overloading"); 583} 584 585{ 586 die if exists $::{BONK}; 587 $::{BONK} = \"powie"; 588 *{"BONK"} = \&{"BONK"}; 589 eval 'is(BONK(), "powie", 590 "Assignment works when glob created midway (bug 45607)"); 1' 591 or die $@; 592} 593 594# For now these tests are here, but they would probably be better in a file for 595# tests for croaks. (And in turn, that probably deserves to be in a different 596# directory. Gerard Goossen has a point about the layout being unclear 597 598sub coerce_integer { 599 no warnings 'numeric'; 600 $_[0] |= 0; 601} 602sub coerce_number { 603 no warnings 'numeric'; 604 $_[0] += 0; 605} 606sub coerce_string { 607 $_[0] .= ''; 608} 609 610foreach my $type (qw(integer number string)) { 611 my $prog = "coerce_$type(*STDERR)"; 612 is (scalar eval "$prog; 1", undef, "$prog failed..."); 613 like ($@, qr/Can't coerce GLOB to $type in/, 614 "with the correct error message"); 615} 616 617# RT #65582 anonymous glob should be defined, and not coredump when 618# stringified. The behaviours are: 619# 620# defined($glob) "$glob" $glob .= ... 621# 5.8.8 false "" with uninit warning "" with uninit warning 622# 5.10.0 true (coredump) (coredump) 623# 5.1[24] true "" "" with uninit warning 624# 5.16 true "*__ANON__::..." "*__ANON__::..." 625 626{ 627 my $io_ref = *STDOUT{IO}; 628 my $glob = *$io_ref; 629 ok(defined $glob, "RT #65582 anon glob should be defined"); 630 631 my $warn = ''; 632 local $SIG{__WARN__} = sub { $warn = $_[0] }; 633 use warnings; 634 my $str = "$glob"; 635 is($warn, '', "RT #65582 anon glob stringification shouldn't warn"); 636 is($str, '*__ANON__::__ANONIO__', 637 "RT #65582/#96326 anon glob stringification"); 638} 639 640# Another stringification bug: Test that recursion does not cause lexical 641# handles to lose their names. 642sub r { 643 my @output; 644 @output = r($_[0]-1) if $_[0]; 645 open my $fh, "TEST"; 646 push @output, $$fh; 647 close $fh; 648 @output; 649} 650is join(' ', r(4)), 651 '*main::$fh *main::$fh *main::$fh *main::$fh *main::$fh', 652 'recursion does not cause lex handles to lose their names'; 653 654# And sub cloning, too; not just recursion 655my $close_over_me; 656is join(' ', sub { 657 () = $close_over_me; 658 my @output; 659 @output = CORE::__SUB__->($_[0]-1) if $_[0]; 660 open my $fh, "TEST"; 661 push @output, $$fh; 662 close $fh; 663 @output; 664 }->(4)), 665 '*main::$fh *main::$fh *main::$fh *main::$fh *main::$fh', 666 'sub cloning does not cause lex handles to lose their names'; 667 668# [perl #71254] - Assigning a glob to a variable that has a current 669# match position. (We are testing that Perl_magic_setmglob respects globs' 670# special used of SvSCREAM.) 671{ 672 $m = 2; $m=~s/./0/gems; $m= *STDERR; 673 is( 674 "$m", "*main::STDERR", 675 '[perl #71254] assignment of globs to vars with pos' 676 ); 677} 678 679# [perl #72740] - indirect object syntax, heuristically imputed due to 680# the non-existence of a function, should not cause a stash entry to be 681# created for the non-existent function. 682{ 683 package RT72740a; 684 my $f = bless({}, RT72740b); 685 sub s1 { s2 $f; } 686 our $s4; 687 sub s3 { s4 $f; } 688} 689{ 690 package RT72740b; 691 sub s2 { "RT72740b::s2" } 692 sub s4 { "RT72740b::s4" } 693} 694ok(exists($RT72740a::{s1}), "RT72740a::s1 exists"); 695ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist"); 696ok(exists($RT72740a::{s3}), "RT72740a::s3 exists"); 697ok(exists($RT72740a::{s4}), "RT72740a::s4 exists"); 698is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly"); 699is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly"); 700 701# [perl #71686] Globs that are in symbol table can be un-globbed 702$sym = undef; 703$::{fake} = *sym; 704is (eval 'local *::fake = \"chuck"; $fake', 'chuck', 705 "Localized glob didn't coerce into a RV"); 706is ($@, '', "Can localize FAKE glob that's present in stash"); 707is (scalar $::{fake}, "*main::sym", 708 "Localized FAKE glob's value was correctly restored"); 709 710# [perl #1804] *$x assignment when $x is a copy of another glob 711# And [perl #77508] (same thing with list assignment) 712{ 713 no warnings 'once'; 714 my $x = *_random::glob_that_is_not_used_elsewhere; 715 *$x = sub{}; 716 is( 717 "$x", '*_random::glob_that_is_not_used_elsewhere', 718 '[perl #1804] *$x assignment when $x is FAKE', 719 ); 720 $x = *_random::glob_that_is_not_used_elsewhere; 721 (my $dummy, *$x) = (undef,[]); 722 is( 723 "$x", '*_random::glob_that_is_not_used_elsewhere', 724 '[perl #77508] *$x list assignment when $x is FAKE', 725 ) or require Devel::Peek, Devel::Peek::Dump($x); 726} 727 728# [perl #76540] 729# this caused panics or 'Attempt to free unreferenced scalar' 730# (its a compile-time issue, so the die lets us skip the prints) 731{ 732 my @warnings; 733 local $SIG{__WARN__} = sub { push @warnings, @_ }; 734 735 eval <<'EOF'; 736BEGIN { $::{FOO} = \'bar' } 737die "made it"; 738print FOO, "\n"; 739print FOO, "\n"; 740EOF 741 742 like($@, qr/made it/, "#76540 - no panic"); 743 ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'"); 744} 745 746# [perl #77362] various bugs related to globs as PVLVs 747{ 748 no warnings qw 'once void'; 749 my %h; # We pass a key of this hash to the subroutine to get a PVLV. 750 sub { for(shift) { 751 # Set up our glob-as-PVLV 752 $_ = *hon; 753 754 # Bad symbol for array 755 ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@; 756 757 # This should call TIEHANDLE, not TIESCALAR 758 *thext::TIEHANDLE = sub{}; 759 ok eval{ tie *$_, 'thext'; 1 }, 'PVLV globs can be tied as handles' 760 or diag $@; 761 762 # Assigning undef to the glob should not overwrite it... 763 { 764 my $w; 765 local $SIG{__WARN__} = sub { $w = shift }; 766 *$_ = undef; 767 is $_, "*main::hon", 'PVLV: assigning undef to the glob does nothing'; 768 like $w, qr\Undefined value assigned to typeglob\, 769 'PVLV: assigning undef to the glob warns'; 770 } 771 772 # Neither should reference assignment. 773 *$_ = []; 774 is $_, "*main::hon", "PVLV: arrayref assignment assigns to the AV slot"; 775 776 # Concatenation should still work. 777 ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@; 778 is $_, '*main::honthlew', 'PVLV concatenation works'; 779 780 # And we should be able to overwrite it with a string, number, or refer- 781 # ence, too, if we omit the *. 782 $_ = *hon; $_ = 'tzor'; 783 is $_, 'tzor', 'PVLV: assigning a string over a glob'; 784 $_ = *hon; $_ = 23; 785 is $_, 23, 'PVLV: assigning an integer over a glob'; 786 $_ = *hon; $_ = 23.23; 787 is $_, 23.23, 'PVLV: assigning a float over a glob'; 788 $_ = *hon; $_ = \my $sthat; 789 is $_, \$sthat, 'PVLV: assigning a reference over a glob'; 790 791 # This bug was found by code inspection. Could this ever happen in 792 # real life? :-) 793 # This duplicates a file handle, accessing it through a PVLV glob, the 794 # glob having been removed from the symbol table, so a stringified form 795 # of it does not work. This checks that sv_2io does not stringify a PVLV. 796 $_ = *quin; 797 open *quin, "test.pl"; # test.pl is as good a file as any 798 delete $::{quin}; 799 ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not' 800 or diag $@; 801 802 # Similar tests to make sure sv_2cv etc. do not stringify. 803 *$_ = sub { 1 }; 804 ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@; 805 *flelp = sub { 2 }; 806 $_ = 'flelp'; 807 is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub' 808 or diag $@; 809 810 # Coderef-to-glob assignment when the glob is no longer accessible 811 # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV 812 # optimisation takes PVLVs into account, which is why the RHSs have to be 813 # named subs. 814 use constant gheen => 'quare'; 815 $_ = *ming; 816 delete $::{ming}; 817 *$_ = \&gheen; 818 is eval { &$_ }, 'quare', 819 'PVLV: constant assignment when the glob is detached from the symtab' 820 or diag $@; 821 $_ = *bength; 822 delete $::{bength}; 823 *gheck = sub { 'lon' }; 824 *$_ = \&gheck; 825 is eval { &$_ }, 'lon', 826 'PVLV: coderef assignment when the glob is detached from the symtab' 827 or diag $@; 828 829SKIP: { 830 skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1); 831 # open should accept a PVLV as its first argument 832 $_ = *hon; 833 ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open' 834 or diag $@; 835 } 836 837 # -t should not stringify 838 $_ = *thlit; delete $::{thlit}; 839 *$_ = *STDOUT{IO}; 840 ok defined -t $_, 'PVLV: -t does not stringify'; 841 842 # neither should -T 843 # but some systems don’t support this on file handles 844 my $pass; 845 ok 846 eval { 847 open my $quile, "<", 'test.pl'; 848 $_ = *$quile; 849 $pass = -T $_; 850 1 851 } ? $pass : $@ =~ /not implemented on filehandles/, 852 "PVLV: -T does not stringify"; 853 854 # Unopened file handle 855 { 856 my $w; 857 local $SIG{__WARN__} = sub { $w .= shift }; 858 $_ = *vor; 859 close $_; 860 like $w, qr\unopened filehandle vor\, 861 'PVLV globs get their names reported in unopened error messages'; 862 } 863 864 }}->($h{k}); 865} 866 867*aieee = 4; 868pass('Can assign integers to typeglobs'); 869*aieee = 3.14; 870pass('Can assign floats to typeglobs'); 871*aieee = 'pi'; 872pass('Can assign strings to typeglobs'); 873 874{ 875 package thrext; 876 sub TIESCALAR{bless[]} 877 sub STORE{ die "No!"} 878 sub FETCH{ no warnings 'once'; *thrit } 879 tie my $a, "thrext"; 880 () = "$a"; # do a fetch; now $a holds a glob 881 eval { *$a = sub{} }; 882 untie $a; 883 eval { $a = "bar" }; 884 ::is $a, "bar", 885 "[perl #77812] Globs in tied scalars can be reified if STORE dies" 886} 887 888# These two crashed prior to 5.13.6. In 5.13.6 they were fatal errors. They 889# were fixed in 5.13.7. 890ok eval { 891 my $glob = \*heen::ISA; 892 delete $::{"heen::"}; 893 *$glob = *bar; 894}, "glob-to-*ISA assignment works when *ISA has lost its stash"; 895ok eval { 896 my $glob = \*slare::ISA; 897 delete $::{"slare::"}; 898 *$glob = []; 899}, "array-to-*ISA assignment works when *ISA has lost its stash"; 900# These two crashed in 5.13.6. They were likewise fixed in 5.13.7. 901ok eval { 902 sub greck; 903 my $glob = do { no warnings "once"; \*phing::foo}; 904 delete $::{"phing::"}; 905 *$glob = *greck; 906}, "Assigning a glob-with-sub to a glob that has lost its stash works"; 907ok eval { 908 sub pon::foo; 909 my $glob = \*pon::foo; 910 delete $::{"pon::"}; 911 *$glob = *foo; 912}, "Assigning a glob to a glob-with-sub that has lost its stash works"; 913 914{ 915 package Tie::Alias; 916 sub TIESCALAR{ bless \\pop } 917 sub FETCH { $${$_[0]} } 918 sub STORE { $${$_[0]} = $_[1] } 919 package main; 920 tie my $alias, 'Tie::Alias', my $var; 921 no warnings 'once'; 922 $var = *galobbe; 923 { 924 local *$alias = []; 925 $var = 3; 926 is $alias, 3, "[perl #77926] Glob reification during localisation"; 927 } 928} 929 930# This code causes gp_free to call a destructor when a glob is being 931# restored on scope exit. The destructor used to see SVs with a refcount of 932# zero inside the glob, which could result in crashes (though not in this 933# test case, which just panics). 934{ 935 no warnings 'once'; 936 my $survived; 937 *Trit::DESTROY = sub { 938 $thwext = 42; # panic 939 $survived = 1; 940 }; 941 { 942 local *thwext; 943 $thwext = bless[],'Trit'; 944 (); 945 } 946 ok $survived, 947 'no error when gp_free calls a destructor that assigns to the gv'; 948} 949 950# This is a similar test, for destructors seeing a GV without a reference 951# count on its gp. 952sub undefine_me_if_you_dare {} 953bless \&undefine_me_if_you_dare, "Undefiner"; 954sub Undefiner::DESTROY { 955 undef *undefine_me_if_you_dare; 956} 957{ 958 my $w; 959 local $SIG{__WARN__} = sub { $w .= shift }; 960 undef *undefine_me_if_you_dare; 961 is $w, undef, 962 'undeffing a gv in DESTROY triggered by undeffing the same gv' 963} 964 965# [perl #121242] 966# More gp_free madness. gp_free could call a destructor that frees the gv 967# whose gp is being freed. 968sub Fred::AUTOLOAD { $Fred::AUTOLOAD } 969undef *{"Fred::AUTOLOAD"}; 970pass 'no crash from gp_free triggering gv_try_downgrade'; 971sub _121242::DESTROY { delete $_121242::{$_[0][0]} }; 972${"_121242::foo"} = bless ["foo"], _121242::; 973undef *{"_121242::foo"}; 974pass 'no crash from pp_undef/gp_free freeing the gv'; 975${"_121242::bar"} = bless ["bar"], _121242::; 976*{"_121242::bar"} = "bar"; 977pass 'no crash from sv_setsv/gp_free freeing the gv'; 978${"_121242::baz"} = bless ["baz"], _121242::; 979*{"_121242::baz"} = *foo; 980pass 'no crash from glob_assign_glob/gp_free freeing the gv'; 981{ 982 my $foo; 983 undef *_121242::DESTROY; 984 *_121242::DESTROY = sub { undef $foo }; 985 my $set_up_foo = sub { 986 # Make $$foo into a fake glob whose array slot holds a blessed 987 # array that undefines $foo, freeing the fake glob. 988 $foo = undef; 989 $$foo = do {local *bar}; 990 *$$foo = bless [], _121242::; 991 }; 992 &$set_up_foo; 993 $$foo = 3; 994 pass 'no crash from sv_setsv/sv_unglob/gp_free freeing the gv'; 995 &$set_up_foo; 996 utf8::encode $$foo; 997 pass 'no crash from sv_utf8_encode/sv_unglob/gp_free freeing the gv'; 998 &$set_up_foo; 999 open BAR, "TEST"; 1000 $$foo .= <BAR>; 1001 pass 'no crash from do_readline/sv_unglob/gp_free freeing the gv'; 1002 close BAR; 1003 &$set_up_foo; 1004 $$foo .= 3; 1005 pass 'no crash from pp_concat/sv_unglob/gp_free freeing the gv'; 1006 &$set_up_foo; 1007 no warnings; 1008 $$foo++; 1009 pass 'no crash from sv_inc/sv_unglob/gp_free freeing the gv'; 1010 &$set_up_foo; 1011 $$foo--; 1012 pass 'no crash from sv_dec/sv_unglob/gp_free freeing the gv'; 1013 &$set_up_foo; 1014 undef $$foo; 1015 pass 'no crash from pp_undef/sv_unglob/gp_free freeing the gv'; 1016 $foo = undef; 1017 $$foo = 3; 1018 $$foo =~ s/3/$$foo = do {local *bar}; *$$foo = bless [],_121242::; 4/e; 1019 pass 'no crash from pp_substcont/sv_unglob/gp_free freeing the gv'; 1020} 1021 1022# *{undef} 1023eval { *{my $undef} = 3 }; 1024like $@, qr/^Can't use an undefined value as a symbol reference at /, 1025 '*{ $undef } assignment'; 1026eval { *{;undef} = 3 }; 1027like $@, qr/^Can't use an undefined value as a symbol reference at /, 1028 '*{ ;undef } assignment'; 1029 1030# [perl #99142] defined &{"foo"} when there is a constant stub 1031# If I break your module, you get to have it mentioned in Perl's tests. :-) 1032package HTTP::MobileAttribute::Plugin::Locator { 1033 use constant LOCATOR_GPS => 1; 1034 ::ok defined &{__PACKAGE__."::LOCATOR_GPS"}, 1035 'defined &{"name of constant"}'; 1036 ::ok Internals::SvREFCNT(${__PACKAGE__."::"}{LOCATOR_GPS}), 1037 "stash elem for slot is not freed prematurely"; 1038} 1039 1040# Check that constants promoted to CVs point to the right GVs when the name 1041# contains a null. 1042package lrcg { 1043 use constant x => 3; 1044 # These two lines abuse the optimisation that copies the scalar ref from 1045 # one stash element to another, to get a constant with a null in its name 1046 *{"yz\0a"} = \&{"x"}; 1047 my $ref = \&{"yz\0a"}; 1048 ::ok !exists $lrcg::{yz}, 1049 'constants w/nulls in their names point 2 the right GVs when promoted'; 1050} 1051 1052{ 1053 no warnings 'io'; 1054 stat *{"try_downgrade"}; 1055 -T _; 1056 $bang = $!; 1057 eval "*try_downgrade if 0"; 1058 -T _; 1059 is "$!",$bang, 1060 'try_downgrade does not touch PL_statgv (last stat handle)'; 1061 readline *{"try_downgrade2"}; 1062 my $lastfh = "${^LAST_FH}"; 1063 eval "*try_downgrade2 if 0"; 1064 is ${^LAST_FH}, $lastfh, 'try_downgrade does not touch PL_last_in_gv'; 1065} 1066 1067is runperl(prog => '$s = STDERR; close $s; undef *$s;' 1068 .'eval q-*STDERR if 0-; *$s = *STDOUT{IO}; warn'), 1069 "Warning: something's wrong at -e line 1.\n", 1070 "try_downgrade does not touch PL_stderrgv"; 1071 1072is runperl(prog => 1073 'use constant foo=>1; BEGIN { $x = \&foo } undef &$x; $x->()', 1074 stderr=>1), 1075 "Undefined subroutine &main::foo called at -e line 1.\n", 1076 "gv_try_downgrade does not anonymise CVs referenced elsewhere"; 1077 1078# Look away, please. 1079# This violates perl's internal structures by fiddling with stashes in a 1080# way that should never happen, but perl should not start trying to free 1081# unallocated memory as a result. There is no ok() or is() because the 1082# panic that used to occur only occurred during global destruction, and 1083# only with PERL_DESTRUCT_LEVEL=2. (The panic itself was sufficient for 1084# the harness to consider this test script to have failed.) 1085$::{aoeuaoeuaoeaoeu} = __PACKAGE__; # cow 1086() = *{"aoeuaoeuaoeaoeu"}; 1087 1088$x = *_119051; 1089$y = \&$x; 1090undef $x; 1091eval { &$y }; 1092pass "No crash due to CvGV(vivified stub) pointing to flattened glob copy"; 1093# Not really supported, but this should not crash either: 1094$x = *_119051again; 1095delete $::{_119051again}; 1096$::{_119051again} = $x; # now we have a fake glob under the right name 1097$y = \&$x; # so when this tries to look up the right GV for 1098undef $::{_119051again}; # CvGV, it still gets a fake one 1099eval { $y->() }; 1100pass "No crash due to CvGV pointing to glob copy in the stash"; 1101 1102__END__ 1103Perl 1104Rules 1105perl 1106rocks 1107