From: Brian Fraser Date: Mon, 26 Sep 2011 05:15:55 +0000 (-0700) Subject: gv.c: gv_fetchmeth_pvn UTF8 cleanup. X-Git-Tag: accepted/trunk/20130322.191538~2492^2~69 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=772d5078e19623501bc9e2e30401b270f2b64bcc;p=platform%2Fupstream%2Fperl.git gv.c: gv_fetchmeth_pvn UTF8 cleanup. Since gv_fetchmeth_pvn is primarily used from within gv.c, and not much of anything is passing in the flag yet, this has no visible changes on the Perl level; So tests remain entirely in XS::APItest for the time being. --- diff --git a/ext/XS-APItest/t/gv_fetchmeth.t b/ext/XS-APItest/t/gv_fetchmeth.t index bcce7c1..9f6e884 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 main; + + sub method { 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(\%main::, "method", $type, $level, 0), "*main::method", "$types[$type] is UTF-8 clean"; + ::ok !XS::APItest::gv_fetchmeth_type(\%main::, $meth_as_octets, $type, $level, 0); + ::ok !XS::APItest::gv_fetchmeth_type(\%main::, "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::"}, + "method", $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); + } + } +} diff --git a/gv.c b/gv.c index 91d88db..0cc3207 100644 --- a/gv.c +++ b/gv.c @@ -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);