gv.c: Added gv_fetchmethod_(sv|pv|pvn)_flags.

In addition from taking a flags parameter, it also takes the
length of the method; This will eventually make method
lookup nul-clean.

diff --git a/MANIFEST b/MANIFEST
index 2e14f97..834d127 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3820,6 +3820,7 @@ 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_fetchmeth_autoload.t       XS::APItest: tests for gv_fetchmeth_autoload() and variants
+ext/XS-APItest/t/gv_fetchmethod_flags.t        XS::APItest: tests for gv_fetchmethod_flags() and variants
 ext/XS-APItest/t/gv_fetchmeth.t                XS::APItest: tests for gv_fetchmeth() and variants
 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

diff --git a/embed.fnc b/embed.fnc
index 58d9e30..9c643d7 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -455,8 +455,11 @@ Apd        |GV*    |gv_fetchmeth_pvn_autoload      |NULLOK HV* stash|NN const char* name \
 Apdmb  |GV*    |gv_fetchmethod |NN HV* stash|NN const char* name
 Apd    |GV*    |gv_fetchmethod_autoload|NN HV* stash|NN const char* name \
                                |I32 autoload
-ApM    |GV*    |gv_fetchmethod_flags|NN HV* stash|NN const char* name \
-                               |U32 flags
+ApM    |GV*    |gv_fetchmethod_sv_flags|NN HV* stash|NN SV* namesv|U32 flags
+ApM    |GV*    |gv_fetchmethod_pv_flags|NN HV* stash|NN const char* name \
+                               |U32 flags
+ApM    |GV*    |gv_fetchmethod_pvn_flags|NN HV* stash|NN const char* name \
+                               |STRLEN len|U32 flags
 Ap     |GV*    |gv_fetchpv     |NN const char *nambeg|I32 add|const svtype sv_type
 Ap     |void   |gv_fullname    |NN SV* sv|NN const GV* gv
 Apmb   |void   |gv_fullname3   |NN SV* sv|NN const GV* gv|NULLOK const char* prefix

diff --git a/embed.h b/embed.h
index 982ad14..70ed11f 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -176,7 +176,9 @@
 #define gv_fetchmeth_sv(a,b,c,d)       Perl_gv_fetchmeth_sv(aTHX_ a,b,c,d)
 #define gv_fetchmeth_sv_autoload(a,b,c,d)      Perl_gv_fetchmeth_sv_autoload(aTHX_ a,b,c,d)
 #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
-#define gv_fetchmethod_flags(a,b,c)    Perl_gv_fetchmethod_flags(aTHX_ a,b,c)
+#define gv_fetchmethod_pv_flags(a,b,c) Perl_gv_fetchmethod_pv_flags(aTHX_ a,b,c)
+#define gv_fetchmethod_pvn_flags(a,b,c,d)      Perl_gv_fetchmethod_pvn_flags(aTHX_ a,b,c,d)
+#define gv_fetchmethod_sv_flags(a,b,c) Perl_gv_fetchmethod_sv_flags(aTHX_ a,b,c)
 #define gv_fetchpv(a,b,c)      Perl_gv_fetchpv(aTHX_ a,b,c)
 #define gv_fetchpvn_flags(a,b,c,d)     Perl_gv_fetchpvn_flags(aTHX_ a,b,c,d)
 #define gv_fetchsv(a,b,c)      Perl_gv_fetchsv(aTHX_ a,b,c)

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index a71e61d..c7317bc 100644 (file)
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1925,6 +1925,35 @@ gv_fetchmeth_autoload_type(stash, methname, type, level, flags)
        XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
 
 void
+gv_fetchmethod_flags_type(stash, methname, type, flags)
+    HV* stash
+    SV* methname
+    int type
+    I32 flags
+    PREINIT:
+       GV* gv;
+    PPCODE:
+        switch (type) {
+           case 0:
+              gv = gv_fetchmethod_flags(stash, SvPVX_const(methname), flags);
+               break;
+           case 1:
+               gv = gv_fetchmethod_sv_flags(stash, methname, flags);
+               break;
+           case 2:
+               gv = gv_fetchmethod_pv_flags(stash, SvPV_nolen(methname), flags | SvUTF8(methname));
+               break;
+           case 3: {
+               STRLEN len;
+               const char * const name = SvPV_const(methname, len);
+               gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
+               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_fetchmethod_flags.t b/ext/XS-APItest/t/gv_fetchmethod_flags.t
new file mode 100644 (file)
index 0000000..068cfec
--- /dev/null
+++ b/ext/XS-APItest/t/gv_fetchmethod_flags.t
@@ -0,0 +1,52 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 9; #23;
+
+use_ok('XS::APItest');
+
+sub method { 1 }
+
+ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "nothing", 1, 0);
+
+for my $type ( 1..3 ) {
+    is XS::APItest::gv_fetchmethod_flags_type(\%::, "method", $type, 0), "*main::method", "Sanity check";
+}
+
+ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 1, 0), "gv_fetchmethod_flags_sv() is nul-clean";
+ok !XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 3, 0), "gv_fetchmethod_flags_pvn() is nul-clean";
+
+ok XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 0, 0), "gv_fetchmethod_flags() is not nul-clean";
+is XS::APItest::gv_fetchmethod_flags_type(\%::, "method\0not quite!", 2, 0), "*main::method", "gv_fetchmethod_flags_pv() is not nul-clean";
+
+=begin
+{
+    use utf8;
+    use open qw( :utf8 :std );
+
+    package ｍａｉｎ;
+    
+    sub ｍｅｔｈｏｄ { 1 }
+    sub method { 1 }
+
+    for my $type ( 1..3 ) {
+        ::is XS::APItest::gv_fetchmethod_flags_type(\%ｍａｉｎ::, "ｍｅｔｈｏｄ", $type, 0), "*ｍａｉｎ::ｍｅｔｈｏｄ";
+        ::is XS::APItest::gv_fetchmethod_flags_type(\%ｍａｉｎ::, "method", $type, 0), "*ｍａｉｎ::method";
+        
+        {
+            no strict 'refs';
+            ::ok !XS::APItest::gv_fetchmethod_flags_type(
+                            \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
+                            "ｍｅｔｈｏｄ", $type, 0);
+            ::ok !XS::APItest::gv_fetchmethod_flags_type(
+                            \%{"\357\275\215\357\275\201\357\275\211\357\275\216::"},
+                            "method", $type, 0);
+        }
+        ::ok !XS::APItest::gv_fetchmethod_flags_type(\%ｍａｉｎ::,
+                  "\357\275\215\357\275\205\357\275\224\357\275\210\357\275\217\357\275\204",
+                   $type, 0);
+    }
+}
+=cut

diff --git a/gv.c b/gv.c
index 7fcd705..1055f8b 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -931,10 +931,29 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
 }
 
+GV *
+Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
+{
+    char *namepv;
+    STRLEN namelen;
+    PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
+    namepv = SvPV(namesv, namelen);
+    if (SvUTF8(namesv))
+       flags |= SVf_UTF8;
+    return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
+}
+
+GV *
+Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
+{
+    PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
+    return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
+}
+
 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
    even a U32 hash */
 GV *
-Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
+Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
 {
     dVAR;
     register const char *nend;
@@ -946,7 +965,7 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
     const U32 autoload = flags & GV_AUTOLOAD;
     const U32 do_croak = flags & GV_CROAK;
 
-    PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
+    PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
 
     if (SvTYPE(stash) < SVt_PVHV)
        stash = NULL;
@@ -956,7 +975,7 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
           the error reporting code.  */
     }
 
-    for (nend = name; *nend; nend++) {
+    for (nend = name; *nend || nend != (origname + len); nend++) {
        if (*nend == '\'') {
            nsplit = nend;
            name = nend + 1;

diff --git a/gv.h b/gv.h
index 29de70c..c182e82 100644 (file)
--- a/gv.h
+++ b/gv.h
@@ -239,6 +239,7 @@ Return the SV from the GV.
 #define gv_init(gv,stash,name,len,multi) gv_init_pvn(gv,stash,name,len,multi,0)
 #define gv_fetchmeth(stash,name,len,level) gv_fetchmeth_pvn(stash, name, len, level, 0)
 #define gv_fetchmeth_autoload(stash,name,len,level) gv_fetchmeth_pvn_autoload(stash, name, len, level, 0)
+#define gv_fetchmethod_flags(stash,name,flags) gv_fetchmethod_pv_flags(stash, name, flags)
 
 #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 49aaf99..1d08d25 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1240,12 +1240,24 @@ PERL_CALLCONV GV*       Perl_gv_fetchmethod_autoload(pTHX_ HV* stash, const char* name
 #define PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD       \
        assert(stash); assert(name)
 
-PERL_CALLCONV GV*      Perl_gv_fetchmethod_flags(pTHX_ HV* stash, const char* name, U32 flags)
+PERL_CALLCONV GV*      Perl_gv_fetchmethod_pv_flags(pTHX_ HV* stash, const char* name, U32 flags)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS  \
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS       \
        assert(stash); assert(name)
 
+PERL_CALLCONV GV*      Perl_gv_fetchmethod_pvn_flags(pTHX_ HV* stash, const char* name, STRLEN len, U32 flags)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS      \
+       assert(stash); assert(name)
+
+PERL_CALLCONV GV*      Perl_gv_fetchmethod_sv_flags(pTHX_ HV* stash, SV* namesv, U32 flags)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS       \
+       assert(stash); assert(namesv)
+
 PERL_CALLCONV GV*      Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_GV_FETCHPV    \