gv.c: Added gv_fetchmeth_(sv|pv|pvn).

I'm probably pushing this too early. Can't do the
Perl-level tests because of that. TODO.

8 files changed, 139 insertions, 18 deletions

diff --git a/MANIFEST b/MANIFEST
index 2aa93a3666..8e2d6ba04d 100644
--- 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_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
 ext/XS-APItest/t/keyword_multiline.t	test keyword plugin parsing across lines
diff --git a/embed.fnc b/embed.fnc
index 4ebe6f3e59..adf1c6d361 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -437,7 +437,11 @@ Ap	|void	|gv_efullname4	|NN SV* sv|NN const GV* gv|NULLOK const char* prefix|boo
 Ap	|GV*	|gv_fetchfile	|NN const char* name
 Ap	|GV*	|gv_fetchfile_flags|NN const char *const name|const STRLEN len\
 				|const U32 flags
-Apd	|GV*	|gv_fetchmeth	|NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
+Apd	|GV*	|gv_fetchmeth_sv	|NULLOK HV* stash|NN SV* namesv|I32 level|U32 flags
+Apd	|GV*	|gv_fetchmeth_pv	|NULLOK HV* stash|NN const char* name \
+                                        |I32 level|U32 flags
+Apd	|GV*	|gv_fetchmeth_pvn	|NULLOK HV* stash|NN const char* name \
+                                        |STRLEN len|I32 level|U32 flags
 Apd	|GV*	|gv_fetchmeth_autoload	|NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
 Apdmb	|GV*	|gv_fetchmethod	|NN HV* stash|NN const char* name
 Apd	|GV*	|gv_fetchmethod_autoload|NN HV* stash|NN const char* name \
diff --git a/embed.h b/embed.h
index 925bb603df..8b687d5b8a 100644
--- a/embed.h
+++ b/embed.h
@@ -169,8 +169,10 @@
 #define gv_efullname4(a,b,c,d)	Perl_gv_efullname4(aTHX_ a,b,c,d)
 #define gv_fetchfile(a)		Perl_gv_fetchfile(aTHX_ a)
 #define gv_fetchfile_flags(a,b,c)	Perl_gv_fetchfile_flags(aTHX_ a,b,c)
-#define gv_fetchmeth(a,b,c,d)	Perl_gv_fetchmeth(aTHX_ a,b,c,d)
 #define gv_fetchmeth_autoload(a,b,c,d)	Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d)
+#define gv_fetchmeth_pv(a,b,c,d)	Perl_gv_fetchmeth_pv(aTHX_ a,b,c,d)
+#define gv_fetchmeth_pvn(a,b,c,d,e)	Perl_gv_fetchmeth_pvn(aTHX_ a,b,c,d,e)
+#define gv_fetchmeth_sv(a,b,c,d)	Perl_gv_fetchmeth_sv(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_fetchpv(a,b,c)	Perl_gv_fetchpv(aTHX_ a,b,c)
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index d555931c49..56c9dd92d5 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1869,6 +1869,34 @@ gv_init_type(namesv, multi, flags, type)
 	XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
 
 void
+gv_fetchmeth_type(stash, methname, type, level, flags)
+    HV* stash
+    SV* methname
+    int type
+    I32 level
+    I32 flags
+    PREINIT:
+        STRLEN len;
+        const char * const name = SvPV_const(methname, len);
+	GV* gv;
+    PPCODE:
+        switch (type) {
+           case 0:
+	       gv = gv_fetchmeth(stash, name, len, level);
+               break;
+           case 1:
+               gv = gv_fetchmeth_sv(stash, methname, level, flags);
+               break;
+           case 2:
+               gv = gv_fetchmeth_pv(stash, name, level, flags | SvUTF8(methname));
+               break;
+           case 3:
+               gv = gv_fetchmeth_pvn(stash, name, len, level, flags | SvUTF8(methname));
+               break;
+        }
+	XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
+
+void
 eval_sv(sv, flags)
     SV* sv
     I32 flags
diff --git a/ext/XS-APItest/t/gv_fetchmeth.t b/ext/XS-APItest/t/gv_fetchmeth.t
new file mode 100644
index 0000000000..a69e91972f
--- /dev/null
+++ b/ext/XS-APItest/t/gv_fetchmeth.t
@@ -0,0 +1,36 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 25;
+
+use_ok('XS::APItest');
+
+my $level = -1;
+my @types = map { 'gv_fetchmeth' . $_ } '', qw( _sv _pv _pvn );
+
+sub test { "Sanity check" }
+
+for my $type ( 0..3 ) {
+    is *{XS::APItest::gv_fetchmeth_type(\%::, "test", 1, $level, 0)}{CODE}->(), "Sanity check";
+}
+
+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 !$::{$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.";
+    ok $::{$meth}, "...but does vivify the glob.";
+}
+
+{
+    no warnings 'once';
+    *method = sub { 1 };
+}
+
+ok !XS::APItest::gv_fetchmeth_type(\%::, "method\0not quite!", 0, $level, 0), "gv_fetchmeth() is nul-clean";
+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";
diff --git a/gv.c b/gv.c
index 5bc52d1037..243f16e9d4 100644
--- a/gv.c
+++ b/gv.c
@@ -555,7 +555,44 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
 }
 
 /*
-=for apidoc gv_fetchmeth
+=for apidoc gv_fetchmeth_sv
+
+Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
+{
+   char *namepv;
+   STRLEN namelen;
+   PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
+   namepv = SvPV(namesv, namelen);
+   if (SvUTF8(namesv))
+       flags |= SVf_UTF8;
+   return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
+}
+
+/*
+=for apidoc gv_fetchmeth_pv
+
+Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string 
+instead of a string/length pair.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
+{
+    PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
+    return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
+}
+
+/*
+=for apidoc gv_fetchmeth_pvn
 
 Returns the glob with the given C<name> and a defined subroutine or
 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
@@ -566,6 +603,8 @@ side-effect creates a glob with the given C<name> in the given C<stash>
 which in the case of success contains an alias for the subroutine, and sets
 up caching info for this glob.
 
+Currently, the only significant value for C<flags> is SVf_UTF8.
+
 This function grants C<"SUPER"> token as a postfix of the stash name. The
 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 visible to Perl code.  So when calling C<call_sv>, you should not use
@@ -578,7 +617,7 @@ obtained from the GV with the C<GvCV> macro.
 /* NOTE: No support for tied ISA */
 
 GV *
-Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
+Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 {
     dVAR;
     GV** gvp;
@@ -595,7 +634,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
     STRLEN packlen;
     U32 topgen_cmp;
 
-    PERL_ARGS_ASSERT_GV_FETCHMETH;
+    PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
 
     /* UNIVERSAL methods should be callable without a stash */
     if (!stash) {
@@ -709,7 +748,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 
     /* Check UNIVERSAL without caching */
     if(level == 0 || level == -1) {
-        candidate = gv_fetchmeth(NULL, name, len, 1);
+        candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags);
         if(candidate) {
             cand_cv = GvCV(candidate);
             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
@@ -747,7 +786,7 @@ of the result may be zero.
 GV *
 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 {
-    GV *gv = gv_fetchmeth(stash, name, len, level);
+    GV *gv = gv_fetchmeth_pvn(stash, name, len, level, 0);
 
     PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD;
 
@@ -759,14 +798,14 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le
 	    return NULL;	/* UNIVERSAL::AUTOLOAD could cause trouble */
 	if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 	    return NULL;
-	if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
+	if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 0)))
 	    return NULL;
 	cv = GvCV(gv);
 	if (!(CvROOT(cv) || CvXSUB(cv)))
 	    return NULL;
 	/* Have an autoload */
 	if (level < 0)	/* Cannot do without a stub */
-	    gv_fetchmeth(stash, name, len, 0);
+	    gv_fetchmeth_pvn(stash, name, len, 0, 0);
 	gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 	if (!gvp)
 	    return NULL;
@@ -903,7 +942,7 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
 	ostash = stash;
     }
 
-    gv = gv_fetchmeth(stash, name, nend - name, 0);
+    gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0);
     if (!gv) {
 	if (strEQ(name,"import") || strEQ(name,"unimport"))
 	    gv = MUTABLE_GV(&PL_sv_yes);
@@ -923,7 +962,7 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
 				       HV_FETCH_ISEXISTS, NULL, 0)
 		) {
 		    require_pv("IO/File.pm");
-		    gv = gv_fetchmeth(stash, name, nend - name, 0);
+		    gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0);
 		    if (gv)
 			return gv;
 		}
@@ -998,7 +1037,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 	    packname_len = HvNAMELEN_get(stash);
 	}
     }
-    if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
+    if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 0)))
 	return NULL;
     cv = GvCV(gv);
 
@@ -2076,7 +2115,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
 
     /* Try to find via inheritance. */
-    GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
+    GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
     SV * const sv = gv ? GvSV(gv) : NULL;
     CV* cv;
 
@@ -2112,7 +2151,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
 	if (i >= DESTROY_amg)
 	    gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
 	else				/* Autoload taken care of below */
-	    gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
+	    gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
         cv = 0;
         if (gv && (cv = GvCV(gv))) {
 	    if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
diff --git a/gv.h b/gv.h
index e48d648604..b75da5a5b1 100644
--- a/gv.h
+++ b/gv.h
@@ -238,6 +238,7 @@ Return the SV from the GV.
 #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_fetchmeth(stash,name, len,level) gv_fetchmeth_pvn(stash, name, len, level, 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 2e32f5f2a4..121e6a9278 100644
--- a/proto.h
+++ b/proto.h
@@ -1192,16 +1192,26 @@ PERL_CALLCONV GV*	Perl_gv_fetchfile_flags(pTHX_ const char *const name, const ST
 #define PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS	\
 	assert(name)
 
-PERL_CALLCONV GV*	Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
+PERL_CALLCONV GV*	Perl_gv_fetchmeth_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
 			__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GV_FETCHMETH	\
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD	\
 	assert(name)
 
-PERL_CALLCONV GV*	Perl_gv_fetchmeth_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
+PERL_CALLCONV GV*	Perl_gv_fetchmeth_pv(pTHX_ HV* stash, const char* name, I32 level, U32 flags)
 			__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD	\
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_PV	\
+	assert(name)
+
+PERL_CALLCONV GV*	Perl_gv_fetchmeth_pvn(pTHX_ HV* stash, const char* name, STRLEN len, I32 level, U32 flags)
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_PVN	\
 	assert(name)
 
+PERL_CALLCONV GV*	Perl_gv_fetchmeth_sv(pTHX_ HV* stash, SV* namesv, I32 level, U32 flags)
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_SV	\
+	assert(namesv)
+
 /* PERL_CALLCONV GV*	Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2); */