diff options
| -rw-r--r-- | ext/XS-APItest/t/gv_fetchmeth.t | 33 | ||||
| -rw-r--r-- | gv.c | 7 |
2 files changed, 35 insertions, 5 deletions
diff --git a/ext/XS-APItest/t/gv_fetchmeth.t b/ext/XS-APItest/t/gv_fetchmeth.t index bcce7c1271..9f6e884a11 100644 --- a/ext/XS-APItest/t/gv_fetchmeth.t +++ b/ext/XS-APItest/t/gv_fetchmeth.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 25; +use Test::More tests => 40; use_ok('XS::APItest'); @@ -20,7 +20,7 @@ for my $type ( 0..3 ) { for my $type ( 0..3 ) { my $meth = "gen$type"; - ok !XS::APItest::gv_fetchmeth_type(\%::, $meth, $type, -1, 0), "With level = -1, $types[$type] returns false"; + ok !XS::APItest::gv_fetchmeth_type(\%::, $meth, $type, -1, 0), "With level = -1, $types[$type] returns false."; ok !$::{$meth}, "...and doesn't vivify the glob."; ok !XS::APItest::gv_fetchmeth_type(\%::, $meth, $type, 0, 0), "With level = 0, $types[$type] still returns false."; @@ -36,3 +36,32 @@ ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 0, $level, 0), "g ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 1, $level, 0), "gv_fetchmeth_sv() is nul-clean"; is XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 2, $level, 0), "*main::method", "gv_fetchmeth_pv() is not nul-clean"; ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 3, $level, 0), "gv_fetchmeth_pvn() is nul-clean"; + +{ + use utf8; + use open qw( :utf8 :std ); + + package ｍａｉｎ; + + sub ｍｅｔｈｏｄ { 1 } + + my $meth_as_octets = + "\357\275\215\357\275\205\357\275\224\357\275\210\357\275\217\357\275\204"; + + $level = 1; + for my $type ( 1..3 ) { + ::is XS::APItest::gv_fetchmeth_type(\%ｍａｉｎ::, "ｍｅｔｈｏｄ", $type, $level, 0), "*ｍａｉｎ::ｍｅｔｈｏｄ", "$types[$type] is UTF-8 clean"; + ::ok !XS::APItest::gv_fetchmeth_type(\%ｍａｉｎ::, $meth_as_octets, $type, $level, 0); + ::ok !XS::APItest::gv_fetchmeth_type(\%ｍａｉｎ::, "method", $type, $level, 0); + + { + no strict 'refs'; + ::ok !XS::APItest::gv_fetchmeth_type( + \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"}, + "ｍｅｔｈｏｄ", $type, $level, 0); + ::ok !XS::APItest::gv_fetchmeth_type( + \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"}, + "method", $type, $level, 0); + } + } +} @@ -665,7 +665,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; /* check locally for a real method or a cache entry */ - gvp = (GV**)hv_fetch(stash, name, len, create); + gvp = (GV**)hv_fetch(stash, name, is_utf8 ? -len : len, create); if(gvp) { topgv = *gvp; have_gv: @@ -699,7 +699,8 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { HV* basestash; packlen -= 7; - basestash = gv_stashpvn(hvname, packlen, GV_ADD); + basestash = gv_stashpvn(hvname, packlen, + GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0)); linear_av = mro_get_linear_isa(basestash); } else { @@ -721,7 +722,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, assert(cstash); - gvp = (GV**)hv_fetch(cstash, name, len, 0); + gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -len : len, 0); if (!gvp) { if (len > 1 && HvNAMELEN_get(cstash) == 4) { const char *hvname = HvNAME(cstash); assert(hvname); |