diff options
author | Brian Fraser <fraserbn@gmail.com> | 2011-07-22 10:10:48 -0300 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2011-10-06 13:01:14 -0700 |
commit | abe837ceb750d111c7eb0b9a23922a2a49d70064 (patch) | |
tree | 8ad02cf0319fb55e633799fbc5b446266490ce7a /t | |
parent | ce139e02098c388fe219b05275fb3063b39a4113 (diff) | |
download | perl-abe837ceb750d111c7eb0b9a23922a2a49d70064.tar.gz |
Tests for UTF-8 stashes.
Diffstat (limited to 't')
-rw-r--r-- | t/uni/stash.t | 318 |
1 files changed, 318 insertions, 0 deletions
diff --git a/t/uni/stash.t b/t/uni/stash.t new file mode 100644 index 0000000000..0c5fd995c9 --- /dev/null +++ b/t/uni/stash.t @@ -0,0 +1,318 @@ +#!./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", 29; + + *b = \&B::svref_2object; + my $CVf_ANON = B::CVf_ANON(); + + my $sub = do { + package 온ꪵ; + \&{"온ꪵ"}; + }; + delete $온ꪵ::{온ꪵ}; + my $gv = b($sub)->GV; + + isa_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; + + isa_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; + + isa_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 FŌŌ; + sub Ƒಓ {} + my $rfoo = \&Ƒಓ; + package main; + delete $::{'FŌŌ::'}; + 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 FŌŌ௨; + sub Ƒ{}; + $r = \&Ƒ; + *Ƒ = sub {}; + ]; + delete $FŌŌ௨::{Ƒ}; + 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 FŌŌ3; + sub 남えㄉ {}; + my $anon = sub {}; + my $남えㄉ = eval q[\&남えㄉ]; + package main; + delete $FŌŌ3::{남えㄉ}; # make named anonymous + + delete $FŌŌ3::{__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 + TODO: { + local our $TODO = "Glob stringify"; + 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'; + { + local $::TODO = $Config{useithreads} ? "fails under threads" : undef; + ::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'; + { + local $::TODO = $Config{useithreads} ? "fails under threads" : undef; + ::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. + TODO: { + local our $TODO = "Glob stringify"; + 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"; +}
\ No newline at end of file |