gv.c: Added gv_init_(sv|pv|pvn), renamed gv_init_sv as gv_init_svtype.

gv_init_pvn() is the same as the old gv_init(), but takes
a flags parameter, which will be used for the UTF-8 cleanup.

The old gv_init() is now implemeneted as a macro in gv.h.

Also included is some minimal testing in XS::APItest.

diff --git a/MANIFEST b/MANIFEST
index 432b6af..2aa93a3 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3819,6 +3819,7 @@ ext/XS-APItest/t/exception.t      XS::APItest extension
 ext/XS-APItest/t/fetch_pad_names.t     Tests for UTF8 names in pad
 ext/XS-APItest/t/gotosub.t     XS::APItest: tests goto &xsub and hints
 ext/XS-APItest/t/grok.t                XS::APItest: tests for grok* functions
+ext/XS-APItest/t/gv_init.t     XS::APItest: tests for gv_init and variants
 ext/XS-APItest/t/hash.t                XS::APItest: tests for hash related APIs
 ext/XS-APItest/t/keyword_multiline.t   test keyword plugin parsing across lines
 ext/XS-APItest/t/keyword_plugin.t      test keyword plugin mechanism

diff --git a/embed.fnc b/embed.fnc
index 2243397..4b1ee0a 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -452,7 +452,11 @@ Ap |void   |gv_fullname4   |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|bool
 pMox   |GP *   |newGP          |NN GV *const gv
 pX     |void   |cvgv_set       |NN CV* cv|NULLOK GV* gv
 pX     |void   |cvstash_set    |NN CV* cv|NULLOK HV* stash
-Ap     |void   |gv_init        |NN GV* gv|NULLOK HV* stash|NN const char* name|STRLEN len|int multi
+Ap     |void   |gv_init_sv     |NN GV* gv|NULLOK HV* stash|NN SV* namesv|int multi|U32 flags
+Ap     |void   |gv_init_pv     |NN GV* gv|NULLOK HV* stash|NN const char* name \
+                                |int multi|U32 flags
+Ap     |void   |gv_init_pvn    |NN GV* gv|NULLOK HV* stash|NN const char* name \
+                                |STRLEN len|int multi|U32 flags
 Ap     |void   |gv_name_set    |NN GV* gv|NN const char *name|U32 len|U32 flags
 XMpd   |void   |gv_try_downgrade|NN GV* gv
 Apd    |HV*    |gv_stashpv     |NN const char* name|I32 flags
@@ -1586,7 +1590,7 @@ sR        |I32    |do_trans_complex_utf8  |NN SV * const sv
 #endif
 
 #if defined(PERL_IN_GV_C)
-s      |void   |gv_init_sv     |NN GV *gv|const svtype sv_type
+s      |void   |gv_init_svtype |NN GV *gv|const svtype sv_type
 s      |void   |gv_magicalize_isa      |NN GV *gv
 s      |void   |gv_magicalize_overload |NN GV *gv
 s      |HV*    |gv_get_super_pkg|NN const char* name|I32 namelen

diff --git a/embed.h b/embed.h
index f033d74..925bb60 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -179,7 +179,9 @@
 #define gv_fullname(a,b)       Perl_gv_fullname(aTHX_ a,b)
 #define gv_fullname4(a,b,c,d)  Perl_gv_fullname4(aTHX_ a,b,c,d)
 #define gv_handler(a,b)                Perl_gv_handler(aTHX_ a,b)
-#define gv_init(a,b,c,d,e)     Perl_gv_init(aTHX_ a,b,c,d,e)
+#define gv_init_pv(a,b,c,d,e)  Perl_gv_init_pv(aTHX_ a,b,c,d,e)
+#define gv_init_pvn(a,b,c,d,e,f)       Perl_gv_init_pvn(aTHX_ a,b,c,d,e,f)
+#define gv_init_sv(a,b,c,d,e)  Perl_gv_init_sv(aTHX_ a,b,c,d,e)
 #define gv_name_set(a,b,c,d)   Perl_gv_name_set(aTHX_ a,b,c,d)
 #define gv_stashpv(a,b)                Perl_gv_stashpv(aTHX_ a,b)
 #define gv_stashpvn(a,b,c)     Perl_gv_stashpvn(aTHX_ a,b,c)
@@ -1292,7 +1294,7 @@
 #  endif
 #  if defined(PERL_IN_GV_C)
 #define gv_get_super_pkg(a,b)  S_gv_get_super_pkg(aTHX_ a,b)
-#define gv_init_sv(a,b)                S_gv_init_sv(aTHX_ a,b)
+#define gv_init_svtype(a,b)    S_gv_init_svtype(aTHX_ a,b)
 #define gv_magicalize_isa(a)   S_gv_magicalize_isa(aTHX_ a)
 #define gv_magicalize_overload(a)      S_gv_magicalize_overload(aTHX_ a)
 #define require_tie_mod(a,b,c,d,e)     S_require_tie_mod(aTHX_ a,b,c,d,e)

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 37f7a0e..d555931 100644 (file)
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1840,6 +1840,35 @@ call_method(methname, flags, ...)
        PUSHs(sv_2mortal(newSViv(i)));
 
 void
+gv_init_type(namesv, multi, flags, type)
+    SV* namesv
+    int multi
+    I32 flags
+    int type
+    PREINIT:
+        STRLEN len;
+        const char * const name = SvPV_const(namesv, len);
+        GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
+    PPCODE:
+        if (SvTYPE(gv) == SVt_PVGV)
+            Perl_croak(aTHX_ "GV is already a PVGV");
+        switch (type) {
+           case 0:
+              gv_init(gv, PL_defstash, name, len, multi);
+               break;
+           case 1:
+               gv_init_sv(gv, PL_defstash, namesv, multi, flags);
+               break;
+           case 2:
+               gv_init_pv(gv, PL_defstash, name, multi, flags | SvUTF8(namesv));
+               break;
+           case 3:
+               gv_init_pvn(gv, PL_defstash, name, len, multi, flags | SvUTF8(namesv));
+               break;
+        }
+       XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
+
+void
 eval_sv(sv, flags)
     SV* sv
     I32 flags

diff --git a/ext/XS-APItest/t/gv_init.t b/ext/XS-APItest/t/gv_init.t
new file mode 100644 (file)
index 0000000..fee41f6
--- /dev/null
+++ b/ext/XS-APItest/t/gv_init.t
@@ -0,0 +1,15 @@
+#!perl
+
+use strict;
+use warnings;
+use Test::More tests => 10;
+
+use XS::APItest;
+
+is my $glob = 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";
+    ok $::{"test$type"};
+}

diff --git a/gv.c b/gv.c
index b5c3590..4bb3625 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -249,7 +249,26 @@ Perl_cvstash_set(pTHX_ CV *cv, HV *st)
 }
 
 void
-Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
+Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, int multi, U32 flags)
+{
+   char *namepv;
+   STRLEN namelen;
+   PERL_ARGS_ASSERT_GV_INIT_SV;
+   namepv = SvPV(namesv, namelen);
+   if (SvUTF8(namesv))
+       flags |= SVf_UTF8;
+   gv_init_pvn(gv, stash, namepv, namelen, multi, flags);
+}
+
+void
+Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, int multi, U32 flags)
+{
+   PERL_ARGS_ASSERT_GV_INIT_PV;
+   gv_init_pvn(gv, stash, name, strlen(name), multi, flags);
+}
+
+void
+Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi, U32 flags)
 {
     dVAR;
     const U32 old_type = SvTYPE(gv);
@@ -259,7 +278,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 
-    PERL_ARGS_ASSERT_GV_INIT;
+    PERL_ARGS_ASSERT_GV_INIT_PVN;
     assert (!(proto && has_constant));
 
     if (has_constant) {
@@ -344,9 +363,9 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 }
 
 STATIC void
-S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
+S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
 {
-    PERL_ARGS_ASSERT_GV_INIT_SV;
+    PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
 
     switch (sv_type) {
     case SVt_PVIO:
@@ -1397,7 +1416,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     if (SvTYPE(gv) == SVt_PVGV) {
        if (add) {
            GvMULTI_on(gv);
-           gv_init_sv(gv, sv_type);
+           gv_init_svtype(gv, sv_type);
            if (len == 1 && stash == PL_defstash
                && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
                if (*name == '!')
@@ -1755,7 +1774,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            (void)hv_store(stash,name,len,(SV *)gv,0);
        else SvREFCNT_dec(gv), gv = NULL;
     }
-    if (gv) gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
+    if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
     return gv;
 }
 

diff --git a/gv.h b/gv.h
index 6134ba4..e48d648 100644 (file)
--- a/gv.h
+++ b/gv.h
@@ -237,6 +237,7 @@ Return the SV from the GV.
 #define gv_efullname3(sv,gv,prefix) gv_efullname4(sv,gv,prefix,TRUE)
 #define gv_fetchmethod(stash, name) gv_fetchmethod_autoload(stash, name, TRUE)
 #define gv_fetchsv_nomg(n,f,t) gv_fetchsv(n,(f)|GV_NO_SVGMAGIC,t)
+#define gv_init(gv,stash,name,len,multi) gv_init_pvn(gv,stash,name,len,multi,0)
 
 #define gv_AVadd(gv) gv_add_by_type((gv), SVt_PVAV)
 #define gv_HVadd(gv) gv_add_by_type((gv), SVt_PVHV)

diff --git a/proto.h b/proto.h
index 1a4e571..054387a 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1256,12 +1256,24 @@ PERL_CALLCONV void      Perl_gv_fullname4(pTHX_ SV* sv, const GV* gv, const char* pre
 PERL_CALLCONV CV*      Perl_gv_handler(pTHX_ HV* stash, I32 id)
                        __attribute__warn_unused_result__;
 
-PERL_CALLCONV void     Perl_gv_init(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi)
+PERL_CALLCONV void     Perl_gv_init_pv(pTHX_ GV* gv, HV* stash, const char* name, int multi, U32 flags)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_3);
-#define PERL_ARGS_ASSERT_GV_INIT       \
+#define PERL_ARGS_ASSERT_GV_INIT_PV    \
        assert(gv); assert(name)
 
+PERL_CALLCONV void     Perl_gv_init_pvn(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi, U32 flags)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GV_INIT_PVN   \
+       assert(gv); assert(name)
+
+PERL_CALLCONV void     Perl_gv_init_sv(pTHX_ GV* gv, HV* stash, SV* namesv, int multi, U32 flags)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_GV_INIT_SV    \
+       assert(gv); assert(namesv)
+
 PERL_CALLCONV void     Perl_gv_name_set(pTHX_ GV* gv, const char *name, U32 len, U32 flags)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
@@ -5302,9 +5314,9 @@ STATIC HV*        S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
 #define PERL_ARGS_ASSERT_GV_GET_SUPER_PKG      \
        assert(name)
 
-STATIC void    S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
+STATIC void    S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
                        __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_GV_INIT_SV    \
+#define PERL_ARGS_ASSERT_GV_INIT_SVTYPE        \
        assert(gv)
 
 STATIC void    S_gv_magicalize_isa(pTHX_ GV *gv)