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