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 (file)
--- 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\ 1";
+    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);
+        }
+    }
+}

diff --git a/gv.c b/gv.c
index 91d88db..0cc3207 100644 (file)
--- 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);