t/op/stash.t

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