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