gv.c: gv_name_set and gv_init_(etc) now initialize the GV's name as UTF-8 if passed...

newCONSTSUB is still unclean however, so constant subs are
still generated under a wrong name.

gv_fullname4 is also UTF-8 aware now; While that should've gotten
it's own commit and tests, it's not possible to test the
UTF-8 part without the gv_init changes, and it's not possible
to test the gv_init changes without gv_fullname4.
Chicken and egg, as it were. So let's compromise and
wait for the relevant tests once globs can be intiialized as
UTF-8 from the Perl level without XS magic.

diff --git a/ext/XS-APItest/t/gv_init.t b/ext/XS-APItest/t/gv_init.t
index fee41f6..23d4aa5 100644 (file)
--- a/ext/XS-APItest/t/gv_init.t
+++ b/ext/XS-APItest/t/gv_init.t
@@ -2,14 +2,20 @@
 
 use strict;
 use warnings;
-use Test::More tests => 10;
+use Test::More tests => 12;
 
 use XS::APItest;
 
-is my $glob = XS::APItest::gv_init_type("sanity_check", 0, 0, 0), "*main::sanity_check";
+is XS::APItest::gv_init_type("sanity_check", 0, 0, 0), "*main::sanity_check";
 ok $::{sanity_check};
 
 for my $type (0..3) {
-    is my $glob = XS::APItest::gv_init_type("test$type", 0, 0, $type), "*main::test$type";
+    is XS::APItest::gv_init_type("test$type", 0, 0, $type), "*main::test$type";
     ok $::{"test$type"};
 }
+
+my $latin_1 = "è";
+my $utf8    = "\x{30cb}";
+
+is XS::APItest::gv_init_type($latin_1, 0, 0, 1), "*main::$latin_1";
+is XS::APItest::gv_init_type($utf8, 0, 0, 1), "*main::$utf8";

diff --git a/gv.c b/gv.c
index fa5ed65..d2a0ed0 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -358,7 +358,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int mult
     GvSTASH(gv) = stash;
     if (stash)
        Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
-    gv_name_set(gv, name, len, GV_ADD);
+    gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
     if (multi || doproto)              /* doproto means it _was_ mentioned */
        GvMULTI_on(gv);
     if (doproto) {                     /* Replicate part of newSUB here. */
@@ -637,6 +637,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
     I32 items;
     STRLEN packlen;
     U32 topgen_cmp;
+    U32 is_utf8 = flags & SVf_UTF8;
 
     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
 
@@ -667,7 +668,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
       have_gv:
         assert(topgv);
         if (SvTYPE(topgv) != SVt_PVGV)
-            gv_init(topgv, stash, name, len, TRUE);
+            gv_init_pvn(topgv, stash, name, len, TRUE, is_utf8);
         if ((cand_cv = GvCV(topgv))) {
             /* If genuine method or valid cache entry, use it */
             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
@@ -732,7 +733,8 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
         else candidate = *gvp;
        have_candidate:
         assert(candidate);
-        if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
+        if (SvTYPE(candidate) != SVt_PVGV)
+            gv_init_pvn(candidate, cstash, name, len, TRUE, is_utf8);
         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
             /*
              * Found real method, cache method in topgv if:
@@ -909,7 +911,7 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
     stash = gv_stashpvn(name, namelen, GV_ADD);
     gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
     gv = *gvp;
-    gv_init(gv, stash, "ISA", 3, TRUE);
+    gv_init_pvn(gv, stash, "ISA", 3, TRUE, flags & SVf_UTF8);
     superisa = GvAVn(gv);
     GvMULTI_on(gv);
     sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
@@ -1164,7 +1166,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
     ENTER;
 
     if (!isGV(vargv)) {
-       gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
+       gv_init_pvn(vargv, varstash, S_autoload, S_autolen, FALSE, 0);
 #ifdef PERL_DONT_CREATE_GVSV
        GvSV(vargv) = newSV(0);
 #endif
@@ -1368,6 +1370,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
     const I32 no_expand = flags & GV_NOEXPAND;
     const I32 add = flags & ~GV_NOADD_MASK;
+    const U32 is_utf8 = flags & SVf_UTF8;
     bool addmg = !!(flags & GV_ADDMG);
     const char *const name_end = nambeg + full_len;
     const char *const name_em1 = name_end - 1;
@@ -1415,7 +1418,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                gv = gvp ? *gvp : NULL;
                if (gv && gv != (const GV *)&PL_sv_undef) {
                    if (SvTYPE(gv) != SVt_PVGV)
-                       gv_init(gv, stash, key, len, (add & GV_ADDMULTI));
+                       gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI), is_utf8);
                    else
                        GvMULTI_on(gv);
                }
@@ -1616,7 +1619,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
     if (add & GV_ADDWARN)
        Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
-    gv_init(gv, stash, name, len, add & GV_ADDMULTI);
+    gv_init_pvn(gv, stash, name, len, add & GV_ADDMULTI, is_utf8);
 
     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
                                            : (PL_dowarn & G_WARN_ON ) ) )
@@ -1948,8 +1951,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 void
 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 {
-    const char *name;
-    STRLEN namelen;
+    SV *name;
     const HV * const hv = GvSTASH(gv);
 
     PERL_ARGS_ASSERT_GV_FULLNAME4;
@@ -1960,19 +1962,15 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
     }
     sv_setpv(sv, prefix ? prefix : "");
 
-    name = HvNAME_get(hv);
-    if (name) {
-       namelen = HvNAMELEN_get(hv);
-    } else {
-       name = "__ANON__";
-       namelen = 8;
-    }
+    name = HvNAME_get(hv)
+            ? sv_2mortal(newSVhek(HvNAME_HEK(hv)))
+            : newSVpvn_flags( "__ANON__", 8, SVs_TEMP );
 
-    if (keepmain || strNE(name, "main")) {
-       sv_catpvn(sv,name,namelen);
+    if (keepmain || strnNE(SvPV_nolen(name), "main", SvCUR(name))) {
+       sv_catsv(sv,name);
        sv_catpvs(sv,"::");
     }
-    sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+    sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
 }
 
 void
@@ -2904,7 +2902,6 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
     U32 hash;
 
     PERL_ARGS_ASSERT_GV_NAME_SET;
-    PERL_UNUSED_ARG(flags);
 
     if (len > I32_MAX)
        Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
@@ -2914,7 +2911,7 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
     }
 
     PERL_HASH(hash, name, len);
-    GvNAME_HEK(gv) = share_hek(name, len, hash);
+    GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -len : len), hash);
 }
 
 /*