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 15plan(tests => 284); 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 186 # deprecation warning removed in v5.23 -- rjbs, 2015-12-31 187 # https://github.com/Perl/perl5/issues/15105 188 print {*x{IO}} (! defined $warn 189 ? "ok $test\n" : "not ok $test\n"); 190 curr_test(++$test); 191} 192 193is *x{NAME}, 'x', '*foo{NAME}'; 194is *x{PACKAGE}, 'main', '*foo{PACKAGE}'; 195{ no warnings 'once'; *x = *Foo::y; } 196is *x, '*Foo::y', 'glob stringifies as assignee after glob-to-glob assign'; 197is *x{NAME}, 'x', 'but *foo{NAME} still returns the original name'; 198is *x{PACKAGE}, 'main', 'and *foo{PACKAGE} the original package'; 199 200{ 201 # test if defined() doesn't create any new symbols 202 203 my $a = "SYM000"; 204 ok(!defined *{$a}); 205 206 ok(!defined ${$a}); 207 ok(!defined *{$a}); 208 209 ok(!defined &{$a}); 210 ok(!defined *{$a}); 211 212 my $state = "not"; 213 *{$a} = sub { $state = "ok" }; 214 ok(defined &{$a}); 215 ok(defined *{$a}); 216 &{$a}; 217 is ($state, 'ok'); 218} 219 220{ 221 # although it *should* if you're talking about magicals 222 223 my $a = "]"; 224 ok(defined *{$a}); 225 ok(defined ${$a}); 226 227 $a = "1"; 228 "o" =~ /(o)/; 229 ok(${$a}); 230 ok(defined *{$a}); 231 $a = "2"; 232 ok(!${$a}); 233 ok(defined *{$a}); 234 $a = "1x"; 235 ok(!defined ${$a}); 236 ok(!defined *{$a}); 237 $a = "11"; 238 "o" =~ /(((((((((((o)))))))))))/; 239 ok(${$a}); 240 ok(defined *{$a}); 241} 242 243# [ID 20010526.001 (#7038)] localized glob loses value when assigned to 244 245$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{}; 246 247is($j, 1); 248is($j{a}, 1); 249is($j[0], 1); 250 251{ 252 # does pp_readline() handle glob-ness correctly? 253 my $g = *foo; 254 $g = <DATA>; 255 is ($g, "Perl\n"); 256} 257 258{ 259 my $w = ''; 260 local $SIG{__WARN__} = sub { $w = $_[0] }; 261 sub abc1 (); 262 local *abc1 = sub { }; 263 is ($w, ''); 264 sub abc2 (); 265 local *abc2; 266 *abc2 = sub { }; 267 is ($w, ''); 268 sub abc3 (); 269 *abc3 = sub { }; 270 like ($w, qr/Prototype mismatch/); 271} 272 273{ 274 # [17375] rcatline to formerly-defined undef was broken. Fixed in 275 # do_readline by checking SvOK. AMS, 20020918 276 my $x = "not "; 277 $x = undef; 278 $x .= <DATA>; 279 is ($x, "Rules\n"); 280} 281 282{ 283 # test the assignment of a GLOB to an LVALUE 284 my $e = ''; 285 local $SIG{__DIE__} = sub { $e = $_[0] }; 286 my %v; 287 sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA } 288 f($v{v}); 289 is ($v{v}, '*main::DATA'); 290 is (ref\$v{v}, 'GLOB', 'lvalue assignment preserves globs'); 291 my $x = readline $v{v}; 292 is ($x, "perl\n"); 293 is ($e, '', '__DIE__ handler never called'); 294} 295 296{ 297 my $e = ''; 298 # GLOB assignment to tied element 299 local $SIG{__DIE__} = sub { $e = $_[0] }; 300 sub T::TIEARRAY { bless [] => "T" } 301 sub T::STORE { $_[0]->[ $_[1] ] = $_[2] } 302 sub T::FETCH { $_[0]->[ $_[1] ] } 303 sub T::FETCHSIZE { @{$_[0]} } 304 tie my @ary => "T"; 305 $ary[0] = *DATA; 306 is ($ary[0], '*main::DATA'); 307 is ( 308 ref\tied(@ary)->[0], 'GLOB', 309 'tied elem assignment preserves globs' 310 ); 311 is ($e, '', '__DIE__ handler not called'); 312 my $x = readline $ary[0]; 313 is($x, "rocks\n"); 314 is ($e, '', '__DIE__ handler never called'); 315} 316 317{ 318 # Need some sort of die or warn to get the global destruction text if the 319 # bug is still present 320 my $output = runperl(prog => <<'EOPROG'); 321package M; 322$| = 1; 323sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} 324package main; 325 326bless \$A::B, q{M}; 327*A:: = \*B::; 328EOPROG 329 like($output, qr/^Farewell M=SCALAR/, "DESTROY was called"); 330 unlike($output, qr/global destruction/, 331 "unreferenced symbol tables should be cleaned up immediately"); 332} 333 334# Possibly not the correct test file for these tests. 335# There are certain space optimisations implemented via promotion rules to 336# GVs 337 338foreach (qw (oonk ga_shloip)) { 339 ok(!exists $::{$_}, "no symbols of any sort to start with for $_"); 340} 341 342# A string in place of the typeglob is promoted to the function prototype 343$::{oonk} = "pie"; 344my $proto = eval 'prototype \&oonk'; 345die if $@; 346is ($proto, "pie", "String is promoted to prototype"); 347 348 349# A reference to a value is used to generate a constant subroutine 350foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2}, 351 \*STDIN, \&ok, \undef, *STDOUT) { 352 delete $::{oonk}; 353 $::{oonk} = \$value; 354 $proto = eval 'prototype \&oonk'; 355 die if $@; 356 is ($proto, '', "Prototype for a constant subroutine is empty"); 357 358 my $got = eval 'oonk'; 359 die if $@; 360 is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")"); 361 is ($got, $value, "Value is correctly set"); 362} 363 364delete $::{oonk}; 365$::{oonk} = \"Value"; 366 367*{"ga_shloip"} = \&{"oonk"}; 368 369is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is"); 370is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 371is (eval 'ga_shloip', "Value", "Constant has correct value"); 372is (ref $::{ga_shloip}, 'SCALAR', 373 "Inlining of constant doesn't change representation"); 374 375delete $::{ga_shloip}; 376 377eval 'sub ga_shloip (); 1' or die $@; 378is ($::{ga_shloip}, '', "Prototype is stored as an empty string"); 379 380# Check that a prototype expands. 381*{"ga_shloip"} = \&{"oonk"}; 382 383is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 384is (eval 'ga_shloip', "Value", "Constant has correct value"); 385is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob"); 386 387 388@::zwot = ('Zwot!'); 389 390# Check that assignment to an existing typeglob works 391{ 392 my $w = ''; 393 local $SIG{__WARN__} = sub { $w = $_[0] }; 394 *{"zwot"} = \&{"oonk"}; 395 is($w, '', "Should be no warning"); 396} 397 398is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 399is (eval 'zwot', "Value", "Constant has correct value"); 400is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob"); 401is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob"); 402 403sub spritsits () { 404 "Traditional"; 405} 406 407# Check that assignment to an existing subroutine works 408{ 409 my $w = ''; 410 local $SIG{__WARN__} = sub { $w = $_[0] }; 411 *{"spritsits"} = \&{"oonk"}; 412 like($w, qr/^Constant subroutine main::spritsits redefined/, 413 "Redefining a constant sub should warn"); 414} 415 416is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 417is (eval 'spritsits', "Value", "Constant has correct value"); 418is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob"); 419 420# Check that assignment to an existing typeglob works 421{ 422 my $w = ''; 423 local $SIG{__WARN__} = sub { $w = $_[0] }; 424 *{"plunk"} = []; 425 *{"plunk"} = \&{"oonk"}; 426 is($w, '', "Should be no warning"); 427} 428 429is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 430is (eval 'plunk', "Value", "Constant has correct value"); 431is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); 432 433my $gr = eval '\*plunk' or die; 434 435{ 436 my $w = ''; 437 local $SIG{__WARN__} = sub { $w = $_[0] }; 438 *{$gr} = \&{"oonk"}; 439 is($w, '', "Redefining a constant sub to another constant sub with the same underlying value should not warn (It's just re-exporting, and that was always legal)"); 440} 441 442is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 443is (eval 'plunk', "Value", "Constant has correct value"); 444is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); 445 446# Non-void context should defeat the optimisation, and will cause the original 447# to be promoted (what change 26482 intended) 448my $result; 449{ 450 my $w = ''; 451 local $SIG{__WARN__} = sub { $w = $_[0] }; 452 $result = *{"awkkkkkk"} = \&{"oonk"}; 453 is($w, '', "Should be no warning"); 454} 455 456is (ref \$result, 'GLOB', 457 "Non void assignment should still return a typeglob"); 458 459is (ref \$::{oonk}, 'GLOB', "This export does affect original"); 460is (eval 'plunk', "Value", "Constant has correct value"); 461is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob"); 462 463delete $::{oonk}; 464$::{oonk} = \"Value"; 465 466sub non_dangling { 467 my $w = ''; 468 local $SIG{__WARN__} = sub { $w = $_[0] }; 469 *{"zap"} = \&{"oonk"}; 470 is($w, '', "Should be no warning"); 471} 472 473non_dangling(); 474is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original"); 475is (eval 'zap', "Value", "Constant has correct value"); 476is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS"); 477 478sub dangling { 479 local $SIG{__WARN__} = sub { die $_[0] }; 480 *{"biff"} = \&{"oonk"}; 481} 482 483dangling(); 484is (ref \$::{oonk}, 'GLOB', "This export does affect original"); 485is (eval 'biff', "Value", "Constant has correct value"); 486is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob"); 487 488$::{yarrow} = [4,5,6]; 489is join("-", eval "yarrow()"), '4-5-6', 'array ref as stash elem'; 490is ref $::{yarrow}, "ARRAY", 'stash elem is still array ref after use'; 491is join("-", eval "&yarrow"), '4-5-6', 'calling const list with &'; 492is join("-", eval "&yarrow(1..10)"), '4-5-6', 'const list ignores & args'; 493is prototype "yarrow", "", 'const list has "" prototype'; 494is eval "yarrow", 3, 'const list in scalar cx returns length'; 495 496$::{borage} = \&ok; 497eval 'borage("sub ref in stash")' or fail "sub ref in stash"; 498 499{ 500 our ($glook, $smek, $foof); 501 # Check reference assignment isn't affected by the SV type (bug #38439) 502 $glook = 3; 503 $smek = 4; 504 $foof = "halt and cool down"; 505 506 my $rv = \*smek; 507 is($glook, 3); 508 *glook = $rv; 509 is($glook, 4); 510 511 my $pv = ""; 512 $pv = \*smek; 513 is($foof, "halt and cool down"); 514 *foof = $pv; 515 is($foof, 4); 516} 517 518format = 519. 520 521foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) { 522 # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns 523 # IO::Handle, which isn't what we want. 524 my $type = $value; 525 $type =~ s/.*=//; 526 $type =~ s/\(.*//; 527 delete $::{oonk}; 528 $::{oonk} = $value; 529 $proto = eval 'prototype \&oonk'; 530 like ($@, qr/^Cannot convert a reference to $type to typeglob/, 531 "Cannot upgrade ref-to-$type to typeglob"); 532} 533 534{ 535 no warnings qw(once uninitialized); 536 my $g = \*clatter; 537 my $r = eval {no strict; ${*{$g}{SCALAR}}}; 538 is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax"); 539 540 $g = \*vowm; 541 $r = eval {use strict; ${*{$g}{SCALAR}}}; 542 is ($@, '', 543 "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict"); 544} 545 546{ 547 # Bug reported by broquaint on IRC 548 *slosh::{HASH}->{ISA}=[]; 549 slosh->import; 550 pass("gv_fetchmeth coped with the unexpected"); 551 552 # An audit found these: 553 { 554 package slosh; 555 sub rip { 556 my $s = shift; 557 $s->SUPER::rip; 558 } 559 } 560 eval {slosh->rip;}; 561 like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER"); 562 563 is(slosh->isa('swoosh'), ''); 564 565 $CORE::GLOBAL::{"lock"}=[]; 566 eval "no warnings; lock"; 567 like($@, qr/^Not enough arguments for lock/, 568 "Can't trip up general keyword overloading"); 569 570 $CORE::GLOBAL::{"readline"}=[]; 571 eval "<STDOUT> if 0"; 572 is($@, '', "Can't trip up readline overloading"); 573 574 $CORE::GLOBAL::{"readpipe"}=[]; 575 eval "`` if 0"; 576 is($@, '', "Can't trip up readpipe overloading"); 577} 578 579{ 580 die if exists $::{BONK}; 581 $::{BONK} = \"powie"; 582 *{"BONK"} = \&{"BONK"}; 583 eval 'is(BONK(), "powie", 584 "Assignment works when glob created midway (bug 45607)"); 1' 585 or die $@; 586} 587 588# For now these tests are here, but they would probably be better in a file for 589# tests for croaks. (And in turn, that probably deserves to be in a different 590# directory. Gerard Goossen has a point about the layout being unclear 591 592sub coerce_integer { 593 no warnings 'numeric'; 594 $_[0] |= 0; 595} 596sub coerce_number { 597 no warnings 'numeric'; 598 $_[0] += 0; 599} 600sub coerce_string { 601 $_[0] .= ''; 602} 603 604foreach my $type (qw(integer number string)) { 605 my $prog = "coerce_$type(*STDERR)"; 606 is (scalar eval "$prog; 1", undef, "$prog failed..."); 607 like ($@, qr/Can't coerce GLOB to $type in/, 608 "with the correct error message"); 609} 610 611# RT #65582 anonymous glob should be defined, and not coredump when 612# stringified. The behaviours are: 613# 614# defined($glob) "$glob" $glob .= ... 615# 5.8.8 false "" with uninit warning "" with uninit warning 616# 5.10.0 true (coredump) (coredump) 617# 5.1[24] true "" "" with uninit warning 618# 5.16 true "*__ANON__::..." "*__ANON__::..." 619 620{ 621 my $io_ref = *STDOUT{IO}; 622 my $glob = *$io_ref; 623 ok(defined $glob, "RT #65582 anon glob should be defined"); 624 625 my $warn = ''; 626 local $SIG{__WARN__} = sub { $warn = $_[0] }; 627 use warnings; 628 my $str = "$glob"; 629 is($warn, '', "RT #65582 anon glob stringification shouldn't warn"); 630 is($str, '*__ANON__::__ANONIO__', 631 "RT #65582/#96326 anon glob stringification"); 632} 633 634# Another stringification bug: Test that recursion does not cause lexical 635# handles to lose their names. 636sub r { 637 my @output; 638 @output = r($_[0]-1) if $_[0]; 639 open my $fh, "TEST"; 640 push @output, $$fh; 641 close $fh; 642 @output; 643} 644is join(' ', r(4)), 645 '*main::$fh *main::$fh *main::$fh *main::$fh *main::$fh', 646 'recursion does not cause lex handles to lose their names'; 647 648# And sub cloning, too; not just recursion 649my $close_over_me; 650is join(' ', sub { 651 () = $close_over_me; 652 my @output; 653 @output = CORE::__SUB__->($_[0]-1) if $_[0]; 654 open my $fh, "TEST"; 655 push @output, $$fh; 656 close $fh; 657 @output; 658 }->(4)), 659 '*main::$fh *main::$fh *main::$fh *main::$fh *main::$fh', 660 'sub cloning does not cause lex handles to lose their names'; 661 662# [perl #71254] - Assigning a glob to a variable that has a current 663# match position. (We are testing that Perl_magic_setmglob respects globs' 664# special used of SvSCREAM.) 665{ 666 $m = 2; $m=~s/./0/gems; $m= *STDERR; 667 is( 668 "$m", "*main::STDERR", 669 '[perl #71254] assignment of globs to vars with pos' 670 ); 671} 672 673# [perl #72740] - indirect object syntax, heuristically imputed due to 674# the non-existence of a function, should not cause a stash entry to be 675# created for the non-existent function. 676{ 677 package RT72740a; 678 my $f = bless({}, RT72740b); 679 sub s1 { s2 $f; } 680 our $s4; 681 sub s3 { s4 $f; } 682} 683{ 684 package RT72740b; 685 sub s2 { "RT72740b::s2" } 686 sub s4 { "RT72740b::s4" } 687} 688ok(exists($RT72740a::{s1}), "RT72740a::s1 exists"); 689ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist"); 690ok(exists($RT72740a::{s3}), "RT72740a::s3 exists"); 691ok(exists($RT72740a::{s4}), "RT72740a::s4 exists"); 692is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly"); 693is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly"); 694 695# [perl #71686] Globs that are in symbol table can be un-globbed 696$sym = undef; 697$::{fake} = *sym; 698is (eval 'local *::fake = \"chuck"; $fake', 'chuck', 699 "Localized glob didn't coerce into a RV"); 700is ($@, '', "Can localize FAKE glob that's present in stash"); 701is (scalar $::{fake}, "*main::sym", 702 "Localized FAKE glob's value was correctly restored"); 703 704# [perl #1804] *$x assignment when $x is a copy of another glob 705# And [perl #77508] (same thing with list assignment) 706{ 707 no warnings 'once'; 708 my $x = *_random::glob_that_is_not_used_elsewhere; 709 *$x = sub{}; 710 is( 711 "$x", '*_random::glob_that_is_not_used_elsewhere', 712 '[perl #1804] *$x assignment when $x is FAKE', 713 ); 714 $x = *_random::glob_that_is_not_used_elsewhere; 715 (my $dummy, *$x) = (undef,[]); 716 is( 717 "$x", '*_random::glob_that_is_not_used_elsewhere', 718 '[perl #77508] *$x list assignment when $x is FAKE', 719 ) or require Devel::Peek, Devel::Peek::Dump($x); 720} 721 722# [perl #76540] 723# this caused panics or 'Attempt to free unreferenced scalar' 724# (its a compile-time issue, so the die lets us skip the prints) 725{ 726 my @warnings; 727 local $SIG{__WARN__} = sub { push @warnings, @_ }; 728 729 eval <<'EOF'; 730BEGIN { $::{FOO} = \'bar' } 731die "made it"; 732print FOO, "\n"; 733print FOO, "\n"; 734EOF 735 736 like($@, qr/made it/, "#76540 - no panic"); 737 ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'"); 738} 739 740# [perl #77362] various bugs related to globs as PVLVs 741{ 742 no warnings qw 'once void'; 743 my %h; # We pass a key of this hash to the subroutine to get a PVLV. 744 sub { for(shift) { 745 # Set up our glob-as-PVLV 746 $_ = *hon; 747 748 # Bad symbol for array 749 ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@; 750 751 # This should call TIEHANDLE, not TIESCALAR 752 *thext::TIEHANDLE = sub{}; 753 ok eval{ tie *$_, 'thext'; 1 }, 'PVLV globs can be tied as handles' 754 or diag $@; 755 756 # Assigning undef to the glob should not overwrite it... 757 { 758 my $w; 759 local $SIG{__WARN__} = sub { $w = shift }; 760 *$_ = undef; 761 is $_, "*main::hon", 'PVLV: assigning undef to the glob does nothing'; 762 like $w, qr\Undefined value assigned to typeglob\, 763 'PVLV: assigning undef to the glob warns'; 764 } 765 766 # Neither should reference assignment. 767 *$_ = []; 768 is $_, "*main::hon", "PVLV: arrayref assignment assigns to the AV slot"; 769 770 # Concatenation should still work. 771 ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@; 772 is $_, '*main::honthlew', 'PVLV concatenation works'; 773 774 # And we should be able to overwrite it with a string, number, or refer- 775 # ence, too, if we omit the *. 776 $_ = *hon; $_ = 'tzor'; 777 is $_, 'tzor', 'PVLV: assigning a string over a glob'; 778 $_ = *hon; $_ = 23; 779 is $_, 23, 'PVLV: assigning an integer over a glob'; 780 $_ = *hon; $_ = 23.23; 781 is $_, 23.23, 'PVLV: assigning a float over a glob'; 782 $_ = *hon; $_ = \my $sthat; 783 is $_, \$sthat, 'PVLV: assigning a reference over a glob'; 784 785 # This bug was found by code inspection. Could this ever happen in 786 # real life? :-) 787 # This duplicates a file handle, accessing it through a PVLV glob, the 788 # glob having been removed from the symbol table, so a stringified form 789 # of it does not work. This checks that sv_2io does not stringify a PVLV. 790 $_ = *quin; 791 open *quin, "test.pl"; # test.pl is as good a file as any 792 delete $::{quin}; 793 ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not' 794 or diag $@; 795 796 # Similar tests to make sure sv_2cv etc. do not stringify. 797 *$_ = sub { 1 }; 798 ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@; 799 *flelp = sub { 2 }; 800 $_ = 'flelp'; 801 is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub' 802 or diag $@; 803 804 # Coderef-to-glob assignment when the glob is no longer accessible 805 # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV 806 # optimisation takes PVLVs into account, which is why the RHSs have to be 807 # named subs. 808 use constant gheen => 'quare'; 809 $_ = *ming; 810 delete $::{ming}; 811 *$_ = \&gheen; 812 is eval { &$_ }, 'quare', 813 'PVLV: constant assignment when the glob is detached from the symtab' 814 or diag $@; 815 $_ = *bength; 816 delete $::{bength}; 817 *gheck = sub { 'lon' }; 818 *$_ = \&gheck; 819 is eval { &$_ }, 'lon', 820 'PVLV: coderef assignment when the glob is detached from the symtab' 821 or diag $@; 822 823SKIP: { 824 skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1); 825 # open should accept a PVLV as its first argument 826 $_ = *hon; 827 ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open' 828 or diag $@; 829 } 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__END__ 1229Perl 1230Rules 1231perl 1232rocks 1233