test various types of SVs with call_sv

call_sv takes RVs, PVs, CVs, GVs, and an immortal. This isn't well
documented. CVs and immortals can't, or can't easily be tested from
pure perl, so do it from XS. SVt_PVLV with isGV_with_GP is one thing
call_sv takes but is not tested by this commit. Part of [perl #120826] .

3 files changed, 84 insertions, 2 deletions

diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 0a07d0efe1..e454b01d43 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -5,7 +5,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '0.58';
+our $VERSION = '0.59';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index f8770473ad..e35219592d 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1942,6 +1942,81 @@ mxpushu()
 	mXPUSHu(3);
 	XSRETURN(3);
 
+void
+call_sv_C()
+PREINIT:
+    CV * i_sub;
+    GV * i_gv;
+    I32 retcnt;
+    SV * errsv;
+    char * errstr;
+    SV * miscsv = sv_newmortal();
+    HV * hv = (HV*)sv_2mortal((SV*)newHV());
+CODE:
+    i_sub = get_cv("i", 0);
+    PUSHMARK(SP);
+    /* PUTBACK not needed since this sub was called with 0 args, and is calling
+      0 args, so global SP doesn't need to be moved before a call_* */
+    retcnt = call_sv((SV*)i_sub, 0); /* try a CV* */
+    SPAGAIN;
+    SP -= retcnt; /* dont care about return count, wipe everything off */
+    sv_setpvs(miscsv, "i");
+    PUSHMARK(SP);
+    retcnt = call_sv(miscsv, 0); /* try a PV */
+    SPAGAIN;
+    SP -= retcnt;
+    /* no add and SVt_NULL are intentional, sub i should be defined already */
+    i_gv = gv_fetchpvn_flags("i", sizeof("i")-1, 0, SVt_NULL);
+    PUSHMARK(SP);
+    retcnt = call_sv((SV*)i_gv, 0); /* try a GV* */
+    SPAGAIN;
+    SP -= retcnt;
+    /* the tests below are not declaring this being public API behavior,
+       only current internal behavior, these tests can be changed in the
+       future if necessery */
+    PUSHMARK(SP);
+    retcnt = call_sv(&PL_sv_yes, 0); /* does nothing */
+    SPAGAIN;
+    SP -= retcnt;
+    PUSHMARK(SP);
+    retcnt = call_sv(&PL_sv_no, G_EVAL);
+    SPAGAIN;
+    SP -= retcnt;
+    errsv = ERRSV;
+    errstr = SvPV_nolen(errsv);
+    if(strnEQ(errstr, "Undefined subroutine &main:: called at",
+              sizeof("Undefined subroutine &main:: called at") - 1)) {
+        PUSHMARK(SP);
+        retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
+        SPAGAIN;
+        SP -= retcnt;
+    }
+    PUSHMARK(SP);
+    retcnt = call_sv(&PL_sv_undef,  G_EVAL);
+    SPAGAIN;
+    SP -= retcnt;
+    errsv = ERRSV;
+    errstr = SvPV_nolen(errsv);
+    if(strnEQ(errstr, "Can't use an undefined value as a subroutine reference at",
+              sizeof("Can't use an undefined value as a subroutine reference at") - 1)) {
+        PUSHMARK(SP);
+        retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
+        SPAGAIN;
+        SP -= retcnt;
+    }
+    PUSHMARK(SP);
+    retcnt = call_sv((SV*)hv,  G_EVAL);
+    SPAGAIN;
+    SP -= retcnt;
+    errsv = ERRSV;
+    errstr = SvPV_nolen(errsv);
+    if(strnEQ(errstr, "Not a CODE reference at",
+              sizeof("Not a CODE reference at") - 1)) {
+        PUSHMARK(SP);
+        retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
+        SPAGAIN;
+        SP -= retcnt;
+    }
 
 void
 call_sv(sv, flags, ...)
diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index 7ff99337f6..54f45ec489 100644
--- a/ext/XS-APItest/t/call.t
+++ b/ext/XS-APItest/t/call.t
@@ -11,7 +11,7 @@ use strict;
 
 BEGIN {
     require '../../t/test.pl';
-    plan(436);
+    plan(437);
     use_ok('XS::APItest')
 };
 
@@ -28,6 +28,13 @@ sub f {
     @_, defined wantarray ? wantarray ? 'x' :  'y' : 'z';
 }
 
+our $call_sv_count = 0;
+sub i {
+    $call_sv_count++;
+}
+call_sv_C();
+is($call_sv_count, 6, "call_sv_C passes");
+
 sub d {
     die "its_dead_jim\n";
 }