1#!./perl
2
3#
4# various stash tests
5#
6
7BEGIN {
8    chdir 't' if -d 't';
9    require './test.pl';
10    set_up_inc('../lib');
11}
12
13use utf8;
14use open qw( :utf8 :std );
15
16plan( 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[*남えㄉ{CODE}]; # not \&남えㄉ; need a real GV
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}