Commit | Line | Data |
---|---|---|
abe837ce BF |
1 | #!./perl |
2 | ||
3 | # | |
4 | # various stash tests | |
5 | # | |
6 | ||
7 | BEGIN { | |
8 | chdir 't' if -d 't'; | |
abe837ce | 9 | require './test.pl'; |
d8e927e4 | 10 | set_up_inc('../lib'); |
abe837ce BF |
11 | } |
12 | ||
13 | use utf8; | |
14 | use open qw( :utf8 :std ); | |
15 | ||
e35475de | 16 | plan( tests => 49 ); |
abe837ce BF |
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 | { | |
abe837ce BF |
42 | package ᛐⲞɲe::Šꇇᚽṙᆂṗ; |
43 | $본go::ଶfʦbᚒƴ::scalar = 1; | |
44 | ||
45 | package main; | |
46 | ||
abe837ce BF |
47 | # now tests with strictures |
48 | ||
49 | { | |
50 | use strict; | |
abe837ce BF |
51 | ok( !exists $piƓ::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) ); |
52 | } | |
53 | ||
54 | SKIP: { | |
8cb149dc | 55 | eval { require B; 1 } or skip "no B", 28; |
abe837ce BF |
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 | ||
bbce3ca6 | 67 | object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV"); |
abe837ce BF |
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 | ||
bbce3ca6 | 79 | object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV"); |
abe837ce BF |
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 | ||
bbce3ca6 | 91 | object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV"); |
abe837ce BF |
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 {}; | |
6881372e | 173 | my $남えㄉ = eval q[*남えㄉ{CODE}]; # not \&남えㄉ; need a real GV |
abe837ce BF |
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 | |
2e434a10 | 232 | { |
abe837ce BF |
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'; | |
2b2e8705 | 249 | ::is eval '__PACKAGE__', 'rìle', |
abe837ce | 250 | '__PACKAGE__ returns the same when the current stash is moved'; |
abe837ce BF |
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'; | |
9343f4cf | 263 | ::is eval '__PACKAGE__', 'rìle', |
abe837ce | 264 | '__PACKAGE__ returns the same when the current stash is detached'; |
abe837ce BF |
265 | } |
266 | ||
267 | # Setting the name during undef %stash:: should have no effect. | |
2e434a10 | 268 | { |
abe837ce BF |
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 | } |