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

8 files changed, 136 insertions, 6 deletions

diff --git a/MANIFEST b/MANIFEST
index 834d1278bd..c3c52a00e1 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_autoload4.t	XS::APItest: tests for gv_autoload4() and variants
 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
diff --git a/embed.fnc b/embed.fnc
index 9c643d77d6..d54f54daf0 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -429,7 +429,11 @@ Ap	|GV*	|gv_add_by_type	|NULLOK GV *gv|svtype type
 Apmb	|GV*	|gv_AVadd	|NULLOK GV *gv
 Apmb	|GV*	|gv_HVadd	|NULLOK GV *gv
 Apmb	|GV*	|gv_IOadd	|NULLOK GV* gv
-ApR	|GV*	|gv_autoload4	|NULLOK HV* stash|NN const char* name|STRLEN len|I32 method
+ApR	|GV*	|gv_autoload4_sv	|NULLOK HV* stash|NN SV* namesv|I32 method|U32 flags
+ApR	|GV*	|gv_autoload4_pv	|NULLOK HV* stash|NN const char* namepv \
+                                        |I32 method|U32 flags
+ApR	|GV*	|gv_autoload4_pvn	|NULLOK HV* stash|NN const char* name \
+                                        |STRLEN len|I32 method|U32 flags
 Ap	|void	|gv_check	|NN const HV* stash
 Ap	|void	|gv_efullname	|NN SV* sv|NN const GV* gv
 Apmb	|void	|gv_efullname3	|NN SV* sv|NN const GV* gv|NULLOK const char* prefix
diff --git a/embed.h b/embed.h
index 70ed11fdb7..a606ba93a4 100644
--- a/embed.h
+++ b/embed.h
@@ -161,7 +161,9 @@
 #define grok_numeric_radix(a,b)	Perl_grok_numeric_radix(aTHX_ a,b)
 #define grok_oct(a,b,c,d)	Perl_grok_oct(aTHX_ a,b,c,d)
 #define gv_add_by_type(a,b)	Perl_gv_add_by_type(aTHX_ a,b)
-#define gv_autoload4(a,b,c,d)	Perl_gv_autoload4(aTHX_ a,b,c,d)
+#define gv_autoload4_pv(a,b,c,d)	Perl_gv_autoload4_pv(aTHX_ a,b,c,d)
+#define gv_autoload4_pvn(a,b,c,d,e)	Perl_gv_autoload4_pvn(aTHX_ a,b,c,d,e)
+#define gv_autoload4_sv(a,b,c,d)	Perl_gv_autoload4_sv(aTHX_ a,b,c,d)
 #define gv_check(a)		Perl_gv_check(aTHX_ a)
 #define gv_const_sv(a)		Perl_gv_const_sv(aTHX_ a)
 #define gv_dump(a)		Perl_gv_dump(aTHX_ a)
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index c7317bc48d..d0fa057f81 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1950,7 +1950,34 @@ gv_fetchmethod_flags_type(stash, methname, type, flags)
                break;
             }
         }
+	XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
 
+void
+gv_autoload4_type(stash, methname, type, method, flags)
+    HV* stash
+    SV* methname
+    int type
+    I32 method
+    I32 flags
+    PREINIT:
+        STRLEN len;
+        const char * const name = SvPV_const(methname, len);
+	GV* gv;
+    PPCODE:
+        switch (type) {
+           case 0:
+	       gv = gv_autoload4(stash, name, len, method);
+               break;
+           case 1:
+               gv = gv_autoload4_sv(stash, methname, method, flags);
+               break;
+           case 2:
+               gv = gv_autoload4_pv(stash, name, method, flags | SvUTF8(methname));
+               break;
+           case 3:
+               gv = gv_autoload4_pvn(stash, name, len, method, flags | SvUTF8(methname));
+               break;
+        }
 	XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
 
 void
diff --git a/ext/XS-APItest/t/gv_autoload4.t b/ext/XS-APItest/t/gv_autoload4.t
new file mode 100644
index 0000000000..beec17e130
--- /dev/null
+++ b/ext/XS-APItest/t/gv_autoload4.t
@@ -0,0 +1,64 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 19; #31;
+
+use_ok('XS::APItest');
+
+my $method = 0;
+my @types  = map { 'gv_autoload4' . $_ } '', qw( _sv _pv _pvn );
+
+sub AUTOLOAD {
+    our $AUTOLOAD;
+    my ($subname, $message) = @_;
+    is $subname, $AUTOLOAD, $message;
+}
+
+my $sub = "nothing";
+
+ok my $glob = XS::APItest::gv_autoload4_type(\%::, $sub, 1, $method, 0);
+*{$glob}{CODE}->( __PACKAGE__ . "::" . $sub, '$AUTOLOAD set correctly' );
+
+$sub = "some_sub";
+for my $type ( 0..3 ) {
+    is $glob = XS::APItest::gv_autoload4_type(\%::, $sub, $type, $method, 0), "*main::AUTOLOAD", "*main::AUTOLOAD if autoload is true in $types[$type].";
+    *{$glob}{CODE}->( __PACKAGE__ . "::" . $sub, '$AUTOLOAD set correctly' );
+}
+
+$sub = "method\0not quite!";
+
+ok $glob = XS::APItest::gv_autoload4_type(\%::, $sub, 0, $method, 0);
+*{$glob}{CODE}->( __PACKAGE__ . "::" . $sub, "gv_autoload4() is nul-clean");
+
+ok $glob = XS::APItest::gv_autoload4_type(\%::, $sub, 1, $method, 0);
+*{$glob}{CODE}->( __PACKAGE__ . "::" . $sub, "gv_autoload4_sv() is nul-clean");
+
+ok $glob = XS::APItest::gv_autoload4_type(\%::, $sub, 2, $method, 0);
+*{$glob}{CODE}->( __PACKAGE__ . "::" . ($sub =~ s/\0.*//r), "gv_autoload4_pv() is not nul-clean");
+
+ok $glob = XS::APItest::gv_autoload4_type(\%::, $sub, 3, $method, 0);
+*{$glob}{CODE}->( __PACKAGE__ . "::" . $sub, "gv_autoload4_pvn() is nul-clean");
+
+=begin
+{
+    use utf8;
+    use open qw( :utf8 :std );
+
+    package ｍａｉｎ;
+
+    sub AUTOLOAD {
+        our $AUTOLOAD;
+        my ($subname, $message) = @_;
+        ::is $subname, $AUTOLOAD, $message;
+    }
+
+    for my $type ( 1..3 ) {
+        ::ok $glob = XS::APItest::gv_autoload4_type(\%ｍａｉｎ::, $sub = "ｍｅｔｈｏｄ", $type, $method, 0);
+        *{$glob}{CODE}->( "ｍａｉｎ::" . $sub, "$types[$type]() is UTF8-clean when both the stash and the sub are in UTF-8");
+        ::ok $glob = XS::APItest::gv_autoload4_type(\%ｍａｉｎ::, $sub = "method", $type, $method, 0);
+        *{$glob}{CODE}->( "ｍａｉｎ::" . $sub, "$types[$type]() is UTF8-clean when only the stash is in UTF-8");
+    }
+}
+=cut
diff --git a/gv.c b/gv.c
index 89ee978b45..77d3ef0b0b 100644
--- a/gv.c
+++ b/gv.c
@@ -1079,7 +1079,26 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
 }
 
 GV*
-Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
+Perl_gv_autoload4_sv(pTHX_ HV *stash, SV* namesv, I32 method, U32 flags)
+{
+   char *namepv;
+   STRLEN namelen;
+   PERL_ARGS_ASSERT_GV_AUTOLOAD4_SV;
+   namepv = SvPV(namesv, namelen);
+   if (SvUTF8(namesv))
+       flags |= SVf_UTF8;
+   return gv_autoload4_pvn(stash, namepv, namelen, method, flags);
+}
+
+GV*
+Perl_gv_autoload4_pv(pTHX_ HV *stash, const char *namepv, I32 method, U32 flags)
+{
+   PERL_ARGS_ASSERT_GV_AUTOLOAD4_PV;
+   return gv_autoload4_pvn(stash, namepv, strlen(namepv), method, flags);
+}
+
+GV*
+Perl_gv_autoload4_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 method, U32 flags)
 {
     dVAR;
     GV* gv;
@@ -1090,7 +1109,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     const char *packname = "";
     STRLEN packname_len = 0;
 
-    PERL_ARGS_ASSERT_GV_AUTOLOAD4;
+    PERL_ARGS_ASSERT_GV_AUTOLOAD4_PVN;
 
     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 	return NULL;
diff --git a/gv.h b/gv.h
index c182e829b0..451433408d 100644
--- a/gv.h
+++ b/gv.h
@@ -240,6 +240,7 @@ Return the SV from the GV.
 #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_autoload4(stash, name, len, method) gv_autoload4_pvn(stash, name, len, method, 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 1d08d25b7d..4cf0a143a8 100644
--- a/proto.h
+++ b/proto.h
@@ -1142,12 +1142,24 @@ PERL_CALLCONV UV	Perl_grok_oct(pTHX_ const char* start, STRLEN* len_p, I32* flag
 /* PERL_CALLCONV GV*	Perl_gv_HVadd(pTHX_ GV *gv); */
 /* PERL_CALLCONV GV*	Perl_gv_IOadd(pTHX_ GV* gv); */
 PERL_CALLCONV GV*	Perl_gv_add_by_type(pTHX_ GV *gv, svtype type);
-PERL_CALLCONV GV*	Perl_gv_autoload4(pTHX_ HV* stash, const char* name, STRLEN len, I32 method)
+PERL_CALLCONV GV*	Perl_gv_autoload4_pv(pTHX_ HV* stash, const char* namepv, I32 method, U32 flags)
 			__attribute__warn_unused_result__
 			__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_GV_AUTOLOAD4	\
+#define PERL_ARGS_ASSERT_GV_AUTOLOAD4_PV	\
+	assert(namepv)
+
+PERL_CALLCONV GV*	Perl_gv_autoload4_pvn(pTHX_ HV* stash, const char* name, STRLEN len, I32 method, U32 flags)
+			__attribute__warn_unused_result__
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_AUTOLOAD4_PVN	\
 	assert(name)
 
+PERL_CALLCONV GV*	Perl_gv_autoload4_sv(pTHX_ HV* stash, SV* namesv, I32 method, U32 flags)
+			__attribute__warn_unused_result__
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_AUTOLOAD4_SV	\
+	assert(namesv)
+
 PERL_CALLCONV void	Perl_gv_check(pTHX_ const HV* stash)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_GV_CHECK	\