This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #129916] Allow sub-in-stash outside of main
[perl5.git] / 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 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[*남えㄉ{CODE}]; # not \&남えㄉ; need a real GV
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 }