[perl5.git] / t / uni / stash.t

#!./perl

#
# various stash tests
#

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';
}

use utf8;
use open qw( :utf8 :std );

plan( tests => 58 );

#These come from op/my_stash.t
{
    use constant Myクラス => 'ꕽ::Ʉ::ꔬz::ꢨᙇ';
    
    {
        package ꕽ::Ʉ::ꔬz::ꢨᙇ;
        1;
    }
    
    for (qw(ꕽ ꕽ:: Myクラス __PACKAGE__)) {
        eval "sub { my $_ \$obj = shift; }";
        ok ! $@, "op/my_stash.t test, $_";
    }
    
    use constant NòClàss => '노pӬ::ꕽ::Ꜻ::BӢz::ʙࡆ';
    
    for (qw(노pӬ 노pӬ:: NòClàss)) {
        eval "sub { my $_ \$obj = shift; }";
        ok $@, "op/my_stash.t test";
    }
}

#op/stash.t
{
    {
        no warnings 'deprecated';
        ok( defined %왿ퟀⲺa::ᒫṡ::, q(stashes happen to be defined if not used) );
        ok( defined %{"왿ퟀⲺa::ᒫṡ::"}, q(- work with hard refs too) );
    
        ok( defined %ᛐⲞɲe::Šꇇᚽṙᆂṗ::, q(stashes are defined if seen at compile time) );
        ok( defined %{"ᛐⲞɲe::Šꇇᚽṙᆂṗ::"}, q(- work with hard refs too) );
    
        ok( defined %본go::ଶfʦbᚒƴ::, q(stashes are defined if a var is seen at compile time) );
        ok( defined %{"본go::ଶfʦbᚒƴ::"}, q(- work with hard refs too) );
    }

    
    package ᛐⲞɲe::Šꇇᚽṙᆂṗ;
    $본go::ଶfʦbᚒƴ::scalar = 1;
    
    package main;
        
    # now tests in eval
    
    ok( eval  { no warnings 'deprecated'; defined %앛hȚꟻࡃҥ:: },   'works in eval{}' );
    ok( eval q{ no warnings 'deprecated'; defined %Ṧㄘㇹen맠ㄦ:: }, 'works in eval("")' );
    
    # now tests with strictures
    
    {
        use strict;
        no warnings 'deprecated';
        ok( defined %piƓ::, q(referencing a non-existent stash doesn't produce stricture errors) );
        ok( !exists $piƓ::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) );
    }

    SKIP: {
        eval { require B; 1 } or skip "no B", 28;
    
        *b = \&B::svref_2object;
        my $CVf_ANON = B::CVf_ANON();
    
        my $sub = do {
            package 온ꪵ;
            \&{"온ꪵ"};
        };
        delete $온ꪵ::{온ꪵ};
        my $gv = b($sub)->GV;
    
        object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
        is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
        is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
        is( eval { $gv->STASH->NAME }, "온ꪵ", "...but leaves stash intact");
    
        $sub = do {
            package tꖿ;
            \&{"tꖿ"};
        };
        %tꖿ:: = ();
        $gv = b($sub)->GV;
    
        object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
        is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
        is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
        is( eval { $gv->STASH->NAME }, "tꖿ", "...but leaves stash intact");
    
        $sub = do {
            package ᖟ레ￇ;
            \&{"ᖟ레ￇ"};
        };
        undef %ᖟ레ￇ::;
        $gv = b($sub)->GV;
    
        object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
        is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
        is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
        is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash");
    
        my $sub = do {
            package ꃖᚢ;
            sub { 1 };
        };
        %ꃖᚢ:: = ();
    
        my $gv = B::svref_2object($sub)->GV;
        ok($gv->isa(q/B::GV/), "cleared stash leaves anon CV with valid GV");
    
        my $st = eval { $gv->STASH->NAME };
        is($st, q/ꃖᚢ/, "...but leaves the stash intact");
    
        $sub = do {
            package fꢄᶹᵌ;
            sub { 1 };
        };
        undef %fꢄᶹᵌ::;
    
        $gv = B::svref_2object($sub)->GV;
        ok($gv->isa(q/B::GV/), "undefed stash leaves anon CV with valid GV");
    
        $st = eval { $gv->STASH->NAME };

        { local $TODO = 'STASHES not anonymized';
            is($st, q/__ANON__/, "...and an __ANON__ stash");
        }

        $sub = do {
            package sӥㄒ;
            \&{"sӥㄒ"}
        };
        my $stash_glob = delete $::{"sӥㄒ::"};
        # Now free the GV while the stash still exists (though detached)
        delete $$stash_glob{"sӥㄒ"};
        $gv = B::svref_2object($sub)->GV;
        ok($gv->isa(q/B::GV/),
        'anonymised CV whose stash is detached still has a GV');
        #fails because mro_gather_and_rename isn't clean
        is $gv->STASH->NAME, '__ANON__',
        'CV anonymised when its stash is detached becomes __ANON__::__ANON__';

        # CvSTASH should be null on a named sub if the stash has been deleted
        {
            package ＦŌŌ;
            sub Ƒಓ {}
            my $rfoo = \&Ƒಓ;
            package main;
            delete $::{'ＦŌŌ::'};
            my $cv = B::svref_2object($rfoo);
            # (is there a better way of testing for NULL ?)
            my $stash = $cv->STASH;
            like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
        }
    
        # on glob reassignment, orphaned CV should have anon CvGV
    
        {
            my $r;
            eval q[
                package ＦŌŌ௨;
                sub Ƒ{};
                $r = \&Ƒ;
                *Ƒ = sub {};
            ];
            delete $ＦŌŌ௨::{Ƒ};
            my $cv = B::svref_2object($r);
            my $gv = $cv->GV;
            ok($gv->isa(q/B::GV/), "orphaned CV has valid GV");
            is($gv->NAME, '__ANON__', "orphaned CV has anon GV");
        }
    
        # deleting __ANON__ glob shouldn't break things
    
        {
            package ＦŌŌ３;
            sub 남えㄉ {};
            my $anon = sub {};
            my $남えㄉ = eval q[\&남えㄉ];
            package main;
            delete $ＦŌŌ３::{남えㄉ}; # make named anonymous
    
            delete $ＦŌŌ３::{__ANON__}; # whoops!
            my ($cv,$gv);
            $cv = B::svref_2object($남えㄉ);
            $gv = $cv->GV;
            ok($gv->isa(q/B::GV/), "ex-named CV has valid GV");
            is($gv->NAME, '__ANON__', "ex-named CV has anon GV");
    
            $cv = B::svref_2object($anon);
            $gv = $cv->GV;
            ok($gv->isa(q/B::GV/), "anon CV has valid GV");
            is($gv->NAME, '__ANON__', "anon CV has anon GV");
        }
    
        {
            my $r;
            {
                package bᓙṗ;
    
                BEGIN {
                    $r = \&main::Ẃⱒcᴷ;
                }
            }
    
            my $br = B::svref_2object($r);
            is ($br->STASH->NAME, 'bᓙṗ',
                'stub records the package it was compiled in');
    
            # We need to take this reference "late", after the subroutine is
            # defined.
            $br = B::svref_2object(eval 'sub Ẃⱒcᴷ {}; \&Ẃⱒcᴷ');
            die $@ if $@;
    
            is ($br->STASH->NAME, 'main',
                'definition overrides the package it was compiled in');
            like ($br->FILE, qr/eval/,
                'definition overrides the file it was compiled in');
        }
    }
    
    # make sure having a sub called __ANON__ doesn't confuse perl.
    
    {
        package クラス;
        my $c;
        sub __ANON__ { $c = (caller(0))[3]; }
        {
            local $@;
            eval { ok(1); };
            ::like($@, qr/^Undefined subroutine &クラス::ok/);
        }
        __ANON__();
        ::is ($c, 'クラス::__ANON__', '__ANON__ sub called ok');
    }

    # Stashes that are effectively renamed
    {
        package rìle;
    
        use Config;
    
        my $obj  = bless [];
        my $globref = \*tàt;
    
        # effectively rename a stash
        *slìn:: = *rìle::; *rìle:: = *zòr::;
        
        ::is *$globref, "*rìle::tàt",
        'globs stringify the same way when stashes are moved';
        ::is ref $obj, "rìle",
        'ref() returns the same thing when an object’s stash is moved';
        ::like "$obj", qr "^rìle=ARRAY\(0x[\da-f]+\)\z",
        'objects stringify the same way when their stashes are moved';
        ::is eval '__PACKAGE__', 'rìle',
            '__PACKAGE__ returns the same when the current stash is moved';
    
        # Now detach it completely from the symtab, making it effect-
        # ively anonymous
        my $life_raft = \%slìn::;
        *slìn:: = *zòr::;
    
        ::is *$globref, "*rìle::tàt",
        'globs stringify the same way when stashes are detached';
        ::is ref $obj, "rìle",
        'ref() returns the same thing when an object’s stash is detached';
        ::like "$obj", qr "^rìle=ARRAY\(0x[\da-f]+\)\z",
        'objects stringify the same way when their stashes are detached';
        ::is eval '__PACKAGE__', 'rìle',
            '__PACKAGE__ returns the same when the current stash is detached';
    }
    
    # Setting the name during undef %stash:: should have no effect.
    {
        my $glob = \*Phòò::glòb;
        sub ò::DESTROY { eval '++$Phòò::bòr' }
        no strict 'refs';
        ${"Phòò::thòng1"} = bless [], "ò";
        undef %Phòò::;
        is "$$glob", "*__ANON__::glòb",
        "setting stash name during undef has no effect";
    }
    
    # [perl #88134] incorrect package structure
    {
        package Bèàr::;
        sub bàz{1}
        package main;
        ok eval { Bèàr::::bàz() },
        'packages ending with :: are self-consistent';
    }
    
    # [perl #88138] ' not equivalent to :: before a null
    ${"à'\0b"} = "c";
    is ${"à::\0b"}, "c", "' is equivalent to :: before a null";
}
Commit	Line	Data
abe837ce BF	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: {
8cb149dc	75	eval { require B; 1 } or skip "no B", 28;
abe837ce BF	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
bbce3ca6	87	object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
abe837ce BF	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
bbce3ca6	99	object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
abe837ce BF	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
bbce3ca6	111	object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
abe837ce BF	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 ＦŌŌ;
	160	sub Ƒಓ {}
	161	my $rfoo = \&Ƒಓ;
	162	package main;
	163	delete $::{'ＦŌŌ::'};
	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 ＦŌŌ௨;
176	sub Ƒ{};
177	$r = \&Ƒ;
178	*Ƒ = sub {};
179	];
180	delete $ＦŌŌ௨::{Ƒ};
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 ＦŌŌ３;
191	sub 남えㄉ {};
192	my $anon = sub {};
193	my $남えㄉ = eval q[\&남えㄉ];
194	package main;
195	delete $ＦŌŌ３::{남えㄉ}; # make named anonymous
196
197	delete $ＦŌŌ３::{__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
2e434a10	252	{
abe837ce BF	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';
2b2e8705	269	::is eval '__PACKAGE__', 'rìle',
abe837ce	270	'__PACKAGE__ returns the same when the current stash is moved';
abe837ce BF	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';
9343f4cf	283	::is eval '__PACKAGE__', 'rìle',
abe837ce	284	'__PACKAGE__ returns the same when the current stash is detached';
abe837ce BF	285	}
	286
	287	# Setting the name during undef %stash:: should have no effect.
2e434a10	288	{
abe837ce BF	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	}