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.

2 files changed, 64 insertions, 0 deletions

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";