1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require "./test.pl"; 6 set_up_inc( qw(../lib) ); 7} 8 9plan( tests => 55 ); 10 11# Used to segfault (bug #15479) 12fresh_perl_like( 13 'delete $::{STDERR}; my %a = ""', 14 qr/Odd number of elements in hash assignment at - line 1\./, 15 { switches => [ '-w' ] }, 16 'delete $::{STDERR} and print a warning', 17); 18 19# Used to segfault 20fresh_perl_is( 21 'BEGIN { $::{"X::"} = 2 }', 22 '', 23 { switches => [ '-w' ] }, 24 q(Insert a non-GV in a stash, under warnings 'once'), 25); 26 27# Used to segfault, too 28SKIP: { 29 skip_if_miniperl('requires XS'); 30 fresh_perl_like( 31 'sub foo::bar{}; $mro::{get_mro}=*foo::bar; undef %foo::; require mro', 32 qr/^Subroutine mro::get_mro redefined at /, 33 { switches => [ '-w' ] }, 34 q(Defining an XSUB over an existing sub with no stash under warnings), 35 ); 36} 37 38# Used to warn 39# Unbalanced string table refcount: (1) for "A::" during global destruction. 40# for ithreads. 41{ 42 local $ENV{PERL_DESTRUCT_LEVEL} = 2; 43 fresh_perl_is( 44 'package A::B; sub a { // }; %A::=""', 45 '', 46 {}, 47 ); 48 # Variant of the above which creates an object that persists until global 49 # destruction, and triggers an assertion failure prior to change 50 # a420522db95b7762 51 fresh_perl_is( 52 'use Exporter; package A; sub a { // }; delete $::{$_} for keys %::', 53 '', 54 {}, 55 ); 56} 57 58# now tests with strictures 59 60{ 61 use strict; 62 ok( !exists $pig::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) ); 63} 64 65SKIP: { 66 eval { require B; 1 } or skip "no B", 29; 67 68 *b = \&B::svref_2object; 69 my $CVf_ANON = B::CVf_ANON(); 70 71 my $sub = do { 72 package one; 73 \&{"one"}; 74 }; 75 delete $one::{one}; 76 my $gv = b($sub)->GV; 77 78 object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV"); 79 is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); 80 is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); 81 is( eval { $gv->STASH->NAME }, "one", "...but leaves stash intact"); 82 83 $sub = do { 84 package two; 85 \&{"two"}; 86 }; 87 %two:: = (); 88 $gv = b($sub)->GV; 89 90 object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV"); 91 is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); 92 is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); 93 is( eval { $gv->STASH->NAME }, "two", "...but leaves stash intact"); 94 95 $sub = do { 96 package three; 97 \&{"three"}; 98 }; 99 undef %three::; 100 $gv = b($sub)->GV; 101 102 object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV"); 103 is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set"); 104 is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name"); 105 is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash"); 106 107 my $sub = do { 108 package four; 109 sub { 1 }; 110 }; 111 %four:: = (); 112 113 my $gv = B::svref_2object($sub)->GV; 114 ok($gv->isa(q/B::GV/), "cleared stash leaves anon CV with valid GV"); 115 116 my $st = eval { $gv->STASH->NAME }; 117 is($st, q/four/, "...but leaves the stash intact"); 118 119 my $sub = do { 120 package five; 121 sub { 1 }; 122 }; 123 undef %five::; 124 125 $gv = B::svref_2object($sub)->GV; 126 ok($gv->isa(q/B::GV/), "undefed stash leaves anon CV with valid GV"); 127 128 $st = eval { $gv->STASH->NAME }; 129 { local $TODO = 'STASHES not anonymized'; 130 is($st, q/__ANON__/, "...and an __ANON__ stash"); 131 } 132 133 my $sub = do { 134 package six; 135 \&{"six"} 136 }; 137 my $stash_glob = delete $::{"six::"}; 138 # Now free the GV while the stash still exists (though detached) 139 delete $$stash_glob{"six"}; 140 $gv = B::svref_2object($sub)->GV; 141 ok($gv->isa(q/B::GV/), 142 'anonymised CV whose stash is detached still has a GV'); 143 is $gv->STASH->NAME, '__ANON__', 144 'CV anonymised when its stash is detached becomes __ANON__::__ANON__'; 145 146 # CvSTASH should be null on a named sub if the stash has been deleted 147 { 148 package FOO; 149 sub foo {} 150 my $rfoo = \&foo; 151 package main; 152 delete $::{'FOO::'}; 153 my $cv = B::svref_2object($rfoo); 154 # (is there a better way of testing for NULL ?) 155 my $stash = $cv->STASH; 156 like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub"); 157 } 158 159 # on glob reassignment, orphaned CV should have anon CvGV 160 161 { 162 my $r; 163 eval q[ 164 package FOO2; 165 sub f{}; 166 $r = \&f; 167 *f = sub {}; 168 ]; 169 delete $FOO2::{f}; 170 my $cv = B::svref_2object($r); 171 my $gv = $cv->GV; 172 ok($gv->isa(q/B::GV/), "orphaned CV has valid GV"); 173 is($gv->NAME, '__ANON__', "orphaned CV has anon GV"); 174 } 175 176 # deleting __ANON__ glob shouldn't break things 177 178 { 179 package FOO3; 180 sub named {}; 181 my $anon = sub {}; 182 my $named = eval q[*named{CODE}]; # not \&named; we want a real GV 183 package main; 184 delete $FOO3::{named}; # make named anonymous 185 186 delete $FOO3::{__ANON__}; # whoops! 187 my ($cv,$gv); 188 $cv = B::svref_2object($named); 189 $gv = $cv->GV; 190 ok($gv->isa(q/B::GV/), "ex-named CV has valid GV"); 191 is($gv->NAME, '__ANON__', "ex-named CV has anon GV"); 192 193 $cv = B::svref_2object($anon); 194 $gv = $cv->GV; 195 ok($gv->isa(q/B::GV/), "anon CV has valid GV"); 196 is($gv->NAME, '__ANON__', "anon CV has anon GV"); 197 } 198 199 { 200 my $r; 201 { 202 package bloop; 203 204 BEGIN { 205 $r = \&main::whack; 206 } 207 } 208 209 my $br = B::svref_2object($r); 210 is ($br->STASH->NAME, 'bloop', 211 'stub records the package it was compiled in'); 212 # Arguably this shouldn't quite be here, but it's easy to add it 213 # here, and tricky to figure out a different good place for it. 214 like ($br->FILE, qr/stash/i, 215 'stub records the file it was compiled in'); 216 217 # We need to take this reference "late", after the subroutine is 218 # defined. 219 $br = B::svref_2object(eval 'sub whack {}; \&whack'); 220 die $@ if $@; 221 222 is ($br->STASH->NAME, 'main', 223 'definition overrides the package it was compiled in'); 224 like ($br->FILE, qr/eval/, 225 'definition overrides the file it was compiled in'); 226 } 227} 228 229# [perl #58530] 230fresh_perl_is( 231 'sub foo { 1 }; use overload q/""/ => \&foo;' . 232 'delete $main::{foo}; bless []', 233 "", 234 {}, 235 "no segfault with overload/deleted stash entry [#58530]", 236); 237 238# make sure having a sub called __ANON__ doesn't confuse perl. 239 240{ 241 my $c; 242 sub __ANON__ { $c = (caller(0))[3]; } 243 __ANON__(); 244 is ($c, 'main::__ANON__', '__ANON__ sub called ok'); 245} 246 247 248# Stashes that are effectively renamed 249{ 250 package rile; 251 252 use Config; 253 254 my $obj = bless []; 255 my $globref = \*tat; 256 257 # effectively rename a stash 258 *slin:: = *rile::; *rile:: = *zor::; 259 260 ::is *$globref, "*rile::tat", 261 'globs stringify the same way when stashes are moved'; 262 ::is ref $obj, "rile", 263 'ref() returns the same thing when an object\'s stash is moved'; 264 ::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z", 265 'objects stringify the same way when their stashes are moved'; 266 ::is eval '__PACKAGE__', 'rile', 267 '__PACKAGE__ returns the same when the current stash is moved'; 268 269 # Now detach it completely from the symtab, making it effect- 270 # ively anonymous 271 my $life_raft = \%slin::; 272 *slin:: = *zor::; 273 274 ::is *$globref, "*rile::tat", 275 'globs stringify the same way when stashes are detached'; 276 ::is ref $obj, "rile", 277 'ref() returns the same thing when an object\'s stash is detached'; 278 ::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z", 279 'objects stringify the same way when their stashes are detached'; 280 ::is eval '__PACKAGE__', 'rile', 281 '__PACKAGE__ returns the same when the current stash is detached'; 282} 283 284# Setting the name during undef %stash:: should have no effect. 285{ 286 my $glob = \*Phoo::glob; 287 sub o::DESTROY { eval '++$Phoo::bar' } 288 no strict 'refs'; 289 ${"Phoo::thing1"} = bless [], "o"; 290 undef %Phoo::; 291 is "$$glob", "*__ANON__::glob", 292 "setting stash name during undef has no effect"; 293} 294 295# [perl #88134] incorrect package structure 296{ 297 package Bear::; 298 sub baz{1} 299 package main; 300 ok eval { Bear::::baz() }, 301 'packages ending with :: are self-consistent'; 302} 303 304# [perl #88138] ' not equivalent to :: before a null 305${"a'\0b"} = "c"; 306is ${"a::\0b"}, "c", "' is equivalent to :: before a null"; 307 308# [perl #101486] Clobbering the current package 309ok eval ' 310 package Do; 311 BEGIN { *Do:: = *Re:: } 312 sub foo{}; 313 1 314 ', 'no crashing or errors when clobbering the current package'; 315 316# Bareword lookup should not vivify stashes 317is runperl( 318 prog => 319 'sub foo { print shift, qq-\n- } SUPER::foo bar if 0; foo SUPER', 320 stderr => 1, 321 ), 322 "SUPER\n", 323 'bareword lookup does not vivify stashes'; 324 325is runperl( 326 prog => '%0; *bar::=*foo::=0; print qq|ok\n|', 327 stderr => 1, 328 ), 329 "ok\n", 330 '[perl #123847] no crash from *foo::=*bar::=*glob_with_hash'; 331 332is runperl( 333 prog => '%h; *::::::=*h; delete $::{q|::|}; print qq|ok\n|', 334 stderr => 1, 335 ), 336 "ok\n", 337 '[perl #128086] no crash from assigning hash to *:::::: & deleting it'; 338 339is runperl( 340 prog => 'BEGIN { %: = 0; $^W=1}; print qq|ok\n|', 341 stderr => 1, 342 ), 343 "ok\n", 344 "[perl #128238] don't treat %: as a stash (needs 2 colons)"; 345 346is runperl( 347 prog => 'BEGIN { $::{q|foo::|}=*ENV; $^W=1}; print qq|ok\n|', 348 stderr => 1, 349 ), 350 "ok\n", 351 "[perl #128238] non-stashes in stashes"; 352 353is runperl( 354 prog => '%:: = (); print *{q|::|}, qq|\n|', 355 stderr => 1, 356 ), 357 "*main::main::\n", 358 "[perl #129869] lookup %:: by name after clearing %::"; 359