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

diff --git a/MANIFEST b/MANIFEST
index 8e2d6ba..2e14f97 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_fetchmeth_autoload.t       XS::APItest: tests for gv_fetchmeth_autoload() 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 2f7c51e..2064b3c 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -444,7 +444,11 @@ 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
+Apd    |GV*    |gv_fetchmeth_sv_autoload       |NULLOK HV* stash|NN SV* namesv|I32 level|U32 flags
+Apd    |GV*    |gv_fetchmeth_pv_autoload       |NULLOK HV* stash|NN const char* name \
+                                        |I32 level|U32 flags
+Apd    |GV*    |gv_fetchmeth_pvn_autoload      |NULLOK HV* stash|NN const char* name \
+                                        |STRLEN len|I32 level|U32 flags
 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

diff --git a/embed.h b/embed.h
index 8b687d5..982ad14 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -169,10 +169,12 @@
 #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_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_pv_autoload(a,b,c,d)      Perl_gv_fetchmeth_pv_autoload(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_pvn_autoload(a,b,c,d,e)   Perl_gv_fetchmeth_pvn_autoload(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_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_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 56c9dd9..a71e61d 100644 (file)
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1897,6 +1897,34 @@ gv_fetchmeth_type(stash, methname, type, level, flags)
        XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
 
 void
+gv_fetchmeth_autoload_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_autoload(stash, name, len, level);
+               break;
+           case 1:
+               gv = gv_fetchmeth_sv_autoload(stash, methname, level, flags);
+               break;
+           case 2:
+               gv = gv_fetchmeth_pv_autoload(stash, name, level, flags | SvUTF8(methname));
+               break;
+           case 3:
+               gv = gv_fetchmeth_pvn_autoload(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_autoload.t b/ext/XS-APItest/t/gv_fetchmeth_autoload.t
new file mode 100644 (file)
index 0000000..e27059f
--- /dev/null
+++ b/ext/XS-APItest/t/gv_fetchmeth_autoload.t
@@ -0,0 +1,47 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 35;
+
+use_ok('XS::APItest');
+
+my $level = -1;
+my @types = map { 'gv_fetchmeth' . $_ . "_autoload" } '', qw( _sv _pv _pvn );
+
+sub test { "Sanity check" }
+
+for my $type ( 0..3 ) {
+    is *{XS::APItest::gv_fetchmeth_autoload_type(\%::, "test", 1, $level, 0)}{CODE}->(), "Sanity check";
+}
+
+{
+    ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "etc", 1, $level, 0), "fails when the glob doesn't exist and AUTOLOAD is undefined,";
+    local *AUTOLOAD = sub { 1 };
+    is XS::APItest::gv_fetchmeth_autoload_type(\%::, "etc", 1, $level, 0), "*main::etc", "..but defining AUTOLOAD makes it succeed.";
+}
+
+for my $type ( 0..3 ) {
+    my $meth = "gen$type";
+    ok !XS::APItest::gv_fetchmeth_autoload_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_autoload_type(\%::, $meth, $type, 0, 0), "With level = 0, $types[$type] still returns false.";
+    ok $::{$meth}, "...but does vivify the glob.";
+
+    ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth . $type, $type, $level, 0), "$types[$type] fails when the glob doesn't exist and AUTOLOAD is undefined,";
+    local *AUTOLOAD = sub { 1 };
+    is XS::APItest::gv_fetchmeth_autoload_type(\%::, $meth . $type, $type, $level, 0), "*main::$meth$type", "..but defining AUTOLOAD makes it succeed.";
+}
+
+{
+    no warnings 'once';
+    *method = sub { 1 };
+}
+
+ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 0, $level, 0), "gv_fetchmeth() is nul-clean";
+ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 1, $level, 0), "gv_fetchmeth_autoload_sv() is nul-clean";
+is XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 2, $level, 0), "*main::method", "gv_fetchmeth_autoload_pv() is not nul-clean";
+ok !XS::APItest::gv_fetchmeth_autoload_type(\%::, "method\0not quite!", 3, $level, 0), "gv_fetchmeth_autoload_pvn() is nul-clean";
+

diff --git a/gv.c b/gv.c
index 9c3fdd5..1da1a90 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -775,24 +775,63 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
 }
 
 /*
-=for apidoc gv_fetchmeth_autoload
+=for apidoc gv_fetchmeth_sv_autoload
 
-Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
+Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
+{
+   char *namepv;
+   STRLEN namelen;
+   PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
+   namepv = SvPV(namesv, namelen);
+   if (SvUTF8(namesv))
+       flags |= SVf_UTF8;
+   return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
+}
+
+/*
+=for apidoc gv_fetchmeth_pv_autoload
+
+Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
+instead of a string/length pair.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
+{
+    PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
+    return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
+}
+
+/*
+=for apidoc gv_fetchmeth_pvn_autoload
+
+Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
 Returns a glob for the subroutine.
 
 For an autoloaded subroutine without a GV, will create a GV even
 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 of the result may be zero.
 
+Currently, the only significant value for C<flags> is SVf_UTF8.
+
 =cut
 */
 
 GV *
-Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
+Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 {
     GV *gv = gv_fetchmeth_pvn(stash, name, len, level, 0);
 
-    PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD;
+    PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
 
     if (!gv) {
        CV *cv;
@@ -802,14 +841,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_pvn(stash, S_autoload, S_autolen, FALSE, 0)))
+       if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
            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_pvn(stash, name, len, 0, 0);
+           gv_fetchmeth_pvn(stash, name, len, 0, flags);
        gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
        if (!gvp)
            return NULL;
@@ -2153,7 +2192,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
           But if B overloads "bool", we may want to use it for
           numifying instead of C's "+0". */
        if (i >= DESTROY_amg)
-           gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
+           gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
        else                            /* Autoload taken care of below */
            gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
         cv = 0;

diff --git a/gv.h b/gv.h
index 9aa4eff..29de70c 100644 (file)
--- a/gv.h
+++ b/gv.h
@@ -237,7 +237,8 @@ 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_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_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 fc84a55..1abf972 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1195,14 +1195,14 @@ PERL_CALLCONV GV*       Perl_gv_fetchfile_flags(pTHX_ const char *const name, const ST
 /* PERL_CALLCONV GV*   gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
                        __attribute__nonnull__(pTHX_2); */
 
-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_pv(pTHX_ HV* stash, const char* name, I32 level, U32 flags)
+PERL_CALLCONV GV*      Perl_gv_fetchmeth_pv_autoload(pTHX_ HV* stash, const char* name, I32 level, U32 flags)
                        __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GV_FETCHMETH_PV       \
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD      \
        assert(name)
 
 PERL_CALLCONV GV*      Perl_gv_fetchmeth_pvn(pTHX_ HV* stash, const char* name, STRLEN len, I32 level, U32 flags)
@@ -1210,11 +1210,21 @@ PERL_CALLCONV GV*       Perl_gv_fetchmeth_pvn(pTHX_ HV* stash, const char* name, STRLE
 #define PERL_ARGS_ASSERT_GV_FETCHMETH_PVN      \
        assert(name)
 
+PERL_CALLCONV GV*      Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV* stash, const char* name, STRLEN len, I32 level, U32 flags)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD     \
+       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_fetchmeth_sv_autoload(pTHX_ HV* stash, SV* namesv, I32 level, U32 flags)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD      \
+       assert(namesv)
+
 /* PERL_CALLCONV GV*   Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2); */