t/uni/stash.t

   1 #!./perl
   2
   3 #
   4 # various stash tests
   5 #
   6
   7 BEGIN {
   8     chdir 't' if -d 't';
   9     require './test.pl';
  10     set_up_inc('../lib');
  11 }
  12
  13 use utf8;
  14 use open qw( :utf8 :std );
  15
  16 plan( tests => 49 );
  17
  18 #These come from op/my_stash.t
  19 {
  20     use constant Myクラス => 'ꕽ::Ʉ::ꔬz::ꢨᙇ';
  21
  22     {
  23         package ꕽ::Ʉ::ꔬz::ꢨᙇ;
  24         1;
  25     }
  26
  27     for (qw(ꕽ ꕽ:: Myクラス __PACKAGE__)) {
  28         eval "sub { my $_ \$obj = shift; }";
  29         ok ! $@, "op/my_stash.t test, $_";
  30     }
  31
  32     use constant NòClàss => '노pӬ::ꕽ::Ꜻ::BӢz::ʙࡆ';
  33
  34     for (qw(노pӬ 노pӬ:: NòClàss)) {
  35         eval "sub { my $_ \$obj = shift; }";
  36         ok $@, "op/my_stash.t test";
  37     }
  38 }
  39
  40 #op/stash.t
  41 {
  42     package ᛐⲞɲe::Šꇇᚽṙᆂṗ;
  43     $본go::ଶfʦbᚒƴ::scalar = 1;
  44
  45     package main;
  46
  47     # now tests with strictures
  48
  49     {
  50         use strict;
  51         ok( !exists $piƓ::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) );
  52     }
  53
  54     SKIP: {
  55         eval { require B; 1 } or skip "no B", 28;
  56
  57         *b = \&B::svref_2object;
  58         my $CVf_ANON = B::CVf_ANON();
  59
  60         my $sub = do {
  61             package 온ꪵ;
  62             \&{"온ꪵ"};
  63         };
  64         delete $온ꪵ::{온ꪵ};
  65         my $gv = b($sub)->GV;
  66
  67         object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
  68         is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
  69         is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
  70         is( eval { $gv->STASH->NAME }, "온ꪵ", "...but leaves stash intact");
  71
  72         $sub = do {
  73             package tꖿ;
  74             \&{"tꖿ"};
  75         };
  76         %tꖿ:: = ();
  77         $gv = b($sub)->GV;
  78
  79         object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
  80         is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
  81         is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
  82         is( eval { $gv->STASH->NAME }, "tꖿ", "...but leaves stash intact");
  83
  84         $sub = do {
  85             package ᖟ레ￇ;
  86             \&{"ᖟ레ￇ"};
  87         };
  88         undef %ᖟ레ￇ::;
  89         $gv = b($sub)->GV;
  90
  91         object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
  92         is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
  93         is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
  94         is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash");
  95
  96         my $sub = do {
  97             package ꃖᚢ;
  98             sub { 1 };
  99         };
 100         %ꃖᚢ:: = ();
 101
 102         my $gv = B::svref_2object($sub)->GV;
 103         ok($gv->isa(q/B::GV/), "cleared stash leaves anon CV with valid GV");
 104
 105         my $st = eval { $gv->STASH->NAME };
 106         is($st, q/ꃖᚢ/, "...but leaves the stash intact");
 107
 108         $sub = do {
 109             package fꢄᶹᵌ;
 110             sub { 1 };
 111         };
 112         undef %fꢄᶹᵌ::;
 113
 114         $gv = B::svref_2object($sub)->GV;
 115         ok($gv->isa(q/B::GV/), "undefed stash leaves anon CV with valid GV");
 116
 117         $st = eval { $gv->STASH->NAME };
 118
 119         { local $TODO = 'STASHES not anonymized';
 120             is($st, q/__ANON__/, "...and an __ANON__ stash");
 121         }
 122
 123         $sub = do {
 124             package sӥㄒ;
 125             \&{"sӥㄒ"}
 126         };
 127         my $stash_glob = delete $::{"sӥㄒ::"};
 128         # Now free the GV while the stash still exists (though detached)
 129         delete $$stash_glob{"sӥㄒ"};
 130         $gv = B::svref_2object($sub)->GV;
 131         ok($gv->isa(q/B::GV/),
 132         'anonymised CV whose stash is detached still has a GV');
 133         #fails because mro_gather_and_rename isn't clean
 134         is $gv->STASH->NAME, '__ANON__',
 135         'CV anonymised when its stash is detached becomes __ANON__::__ANON__';
 136
 137         # CvSTASH should be null on a named sub if the stash has been deleted
 138         {
 139             package ＦŌŌ;
 140             sub Ƒಓ {}
 141             my $rfoo = \&Ƒಓ;
 142             package main;
 143             delete $::{'ＦŌŌ::'};
 144             my $cv = B::svref_2object($rfoo);
 145             # (is there a better way of testing for NULL ?)
 146             my $stash = $cv->STASH;
 147             like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
 148         }
 149
 150         # on glob reassignment, orphaned CV should have anon CvGV
 151
 152         {
 153             my $r;
 154             eval q[
 155                 package ＦŌŌ௨;
 156                 sub Ƒ{};
 157                 $r = \&Ƒ;
 158                 *Ƒ = sub {};
 159             ];
 160             delete $ＦŌŌ௨::{Ƒ};
 161             my $cv = B::svref_2object($r);
 162             my $gv = $cv->GV;
 163             ok($gv->isa(q/B::GV/), "orphaned CV has valid GV");
 164             is($gv->NAME, '__ANON__', "orphaned CV has anon GV");
 165         }
 166
 167         # deleting __ANON__ glob shouldn't break things
 168
 169         {
 170             package ＦŌŌ３;
 171             sub 남えㄉ {};
 172             my $anon = sub {};
 173             my $남えㄉ = eval q[\&남えㄉ];
 174             package main;
 175             delete $ＦŌŌ３::{남えㄉ}; # make named anonymous
 176
 177             delete $ＦŌŌ３::{__ANON__}; # whoops!
 178             my ($cv,$gv);
 179             $cv = B::svref_2object($남えㄉ);
 180             $gv = $cv->GV;
 181             ok($gv->isa(q/B::GV/), "ex-named CV has valid GV");
 182             is($gv->NAME, '__ANON__', "ex-named CV has anon GV");
 183
 184             $cv = B::svref_2object($anon);
 185             $gv = $cv->GV;
 186             ok($gv->isa(q/B::GV/), "anon CV has valid GV");
 187             is($gv->NAME, '__ANON__', "anon CV has anon GV");
 188         }
 189
 190         {
 191             my $r;
 192             {
 193                 package bᓙṗ;
 194
 195                 BEGIN {
 196                     $r = \&main::Ẃⱒcᴷ;
 197                 }
 198             }
 199
 200             my $br = B::svref_2object($r);
 201             is ($br->STASH->NAME, 'bᓙṗ',
 202                 'stub records the package it was compiled in');
 203
 204             # We need to take this reference "late", after the subroutine is
 205             # defined.
 206             $br = B::svref_2object(eval 'sub Ẃⱒcᴷ {}; \&Ẃⱒcᴷ');
 207             die $@ if $@;
 208
 209             is ($br->STASH->NAME, 'main',
 210                 'definition overrides the package it was compiled in');
 211             like ($br->FILE, qr/eval/,
 212                 'definition overrides the file it was compiled in');
 213         }
 214     }
 215
 216     # make sure having a sub called __ANON__ doesn't confuse perl.
 217
 218     {
 219         package クラス;
 220         my $c;
 221         sub __ANON__ { $c = (caller(0))[3]; }
 222         {
 223             local $@;
 224             eval { ok(1); };
 225             ::like($@, qr/^Undefined subroutine &クラス::ok/);
 226         }
 227         __ANON__();
 228         ::is ($c, 'クラス::__ANON__', '__ANON__ sub called ok');
 229     }
 230
 231     # Stashes that are effectively renamed
 232     {
 233         package rìle;
 234
 235         use Config;
 236
 237         my $obj  = bless [];
 238         my $globref = \*tàt;
 239
 240         # effectively rename a stash
 241         *slìn:: = *rìle::; *rìle:: = *zòr::;
 242
 243         ::is *$globref, "*rìle::tàt",
 244         'globs stringify the same way when stashes are moved';
 245         ::is ref $obj, "rìle",
 246         'ref() returns the same thing when an object’s stash is moved';
 247         ::like "$obj", qr "^rìle=ARRAY\(0x[\da-f]+\)\z",
 248         'objects stringify the same way when their stashes are moved';
 249         ::is eval '__PACKAGE__', 'rìle',
 250             '__PACKAGE__ returns the same when the current stash is moved';
 251
 252         # Now detach it completely from the symtab, making it effect-
 253         # ively anonymous
 254         my $life_raft = \%slìn::;
 255         *slìn:: = *zòr::;
 256
 257         ::is *$globref, "*rìle::tàt",
 258         'globs stringify the same way when stashes are detached';
 259         ::is ref $obj, "rìle",
 260         'ref() returns the same thing when an object’s stash is detached';
 261         ::like "$obj", qr "^rìle=ARRAY\(0x[\da-f]+\)\z",
 262         'objects stringify the same way when their stashes are detached';
 263         ::is eval '__PACKAGE__', 'rìle',
 264             '__PACKAGE__ returns the same when the current stash is detached';
 265     }
 266
 267     # Setting the name during undef %stash:: should have no effect.
 268     {
 269         my $glob = \*Phòò::glòb;
 270         sub ò::DESTROY { eval '++$Phòò::bòr' }
 271         no strict 'refs';
 272         ${"Phòò::thòng1"} = bless [], "ò";
 273         undef %Phòò::;
 274         is "$$glob", "*__ANON__::glòb",
 275         "setting stash name during undef has no effect";
 276     }
 277
 278     # [perl #88134] incorrect package structure
 279     {
 280         package Bèàr::;
 281         sub bàz{1}
 282         package main;
 283         ok eval { Bèàr::::bàz() },
 284         'packages ending with :: are self-consistent';
 285     }
 286
 287     # [perl #88138] ' not equivalent to :: before a null
 288     ${"à'\0b"} = "c";
 289     is ${"à::\0b"}, "c", "' is equivalent to :: before a null";
 290 }