| 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 FŌŌ; |
| 140 | sub Ƒಓ {} |
| 141 | my $rfoo = \&Ƒಓ; |
| 142 | package main; |
| 143 | delete $::{'FŌŌ::'}; |
| 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 FŌŌ௨; |
| 156 | sub Ƒ{}; |
| 157 | $r = \&Ƒ; |
| 158 | *Ƒ = sub {}; |
| 159 | ]; |
| 160 | delete $FŌŌ௨::{Ƒ}; |
| 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 FŌŌ3; |
| 171 | sub 남えㄉ {}; |
| 172 | my $anon = sub {}; |
| 173 | my $남えㄉ = eval q[\&남えㄉ]; |
| 174 | package main; |
| 175 | delete $FŌŌ3::{남えㄉ}; # make named anonymous |
| 176 | |
| 177 | delete $FŌŌ3::{__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 | } |