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 => 58 );
  11
  12 # Used to segfault (bug #15479)
  13 fresh_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
  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_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
  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::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
  78 ok( eval  { no warnings 'deprecated'; defined %achtfaden:: },   'works in eval{}' );
  79 ok( 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
  90 SKIP: {
  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]
 255 fresh_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";
 331 is ${"a::\0b"}, "c", "' is equivalent to :: before a null";
 332
 333 # [perl #101486] Clobbering the current package
 334 ok eval '
 335      package Do;
 336      BEGIN { *Do:: = *Re:: }
 337      sub foo{};
 338      1
 339   ', 'no crashing or errors when clobbering the current package';