X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/14b40fa7a92ebfc0647a15ef6114c7c26b280915..35ab56323549cd3c972fa3918e0e9a2875081466:/ext/XS/APItest/APItest.xs

diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index c562b98..ff0a8fb 100644
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -1,10 +1,111 @@
+#define PERL_IN_XS_APITEST
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 
+
+/* for my_cxt tests */
+
+#define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
+
+typedef struct {
+    int i;
+    SV *sv;
+} my_cxt_t;
+
+START_MY_CXT
+
+/* indirect functions to test the [pa]MY_CXT macros */
+
+int
+my_cxt_getint_p(pMY_CXT)
+{
+    return MY_CXT.i;
+}
+
+void
+my_cxt_setint_p(pMY_CXT_ int i)
+{
+    MY_CXT.i = i;
+}
+
+SV*
+my_cxt_getsv_interp()
+{
+#ifdef PERL_IMPLICIT_CONTEXT
+    dTHX;
+    dMY_CXT_INTERP(my_perl);
+#else
+    dMY_CXT;
+#endif
+    return MY_CXT.sv;
+}
+
+void
+my_cxt_setsv_p(SV* sv _pMY_CXT)
+{
+    MY_CXT.sv = sv;
+}
+
+
 /* from exception.c */
 int exception(int);
 
+/* A routine to test hv_delayfree_ent
+   (which itself is tested by testing on hv_free_ent  */
+
+typedef void (freeent_function)(pTHX_ HV *, register HE *);
+
+void
+test_freeent(freeent_function *f) {
+    dTHX;
+    dSP;
+    HV *test_hash = newHV();
+    HE *victim;
+    SV *test_scalar;
+    U32 results[4];
+    int i;
+
+#ifdef PURIFY
+    victim = (HE*)safemalloc(sizeof(HE));
+#else
+    /* Storing then deleting something should ensure that a hash entry is
+       available.  */
+    hv_store(test_hash, "", 0, &PL_sv_yes, 0);
+    hv_delete(test_hash, "", 0, 0);
+
+    /* We need to "inline" new_he here as it's static, and the functions we
+       test expect to be able to call del_HE on the HE  */
+    if (!PL_body_roots[HE_SVSLOT])
+	croak("PL_he_root is 0");
+    victim = PL_body_roots[HE_SVSLOT];
+    PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
+#endif
+
+    victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
+
+    test_scalar = newSV(0);
+    SvREFCNT_inc(test_scalar);
+    HeVAL(victim) = test_scalar;
+
+    /* Need this little game else we free the temps on the return stack.  */
+    results[0] = SvREFCNT(test_scalar);
+    SAVETMPS;
+    results[1] = SvREFCNT(test_scalar);
+    f(aTHX_ test_hash, victim);
+    results[2] = SvREFCNT(test_scalar);
+    FREETMPS;
+    results[3] = SvREFCNT(test_scalar);
+
+    i = 0;
+    do {
+	mPUSHu(results[i]);
+    } while (++i < sizeof(results)/sizeof(results[0]));
+
+    /* Goodbye to our extra reference.  */
+    SvREFCNT_dec(test_scalar);
+}
+
 MODULE = XS::APItest:Hash		PACKAGE = XS::APItest::Hash
 
 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
@@ -108,6 +209,38 @@ fetch(hash, key_sv)
 	RETVAL = newSVsv(*result);
         OUTPUT:
         RETVAL
+
+void
+test_hv_free_ent()
+	PPCODE:
+	test_freeent(&Perl_hv_free_ent);
+	XSRETURN(4);
+
+void
+test_hv_delayfree_ent()
+	PPCODE:
+	test_freeent(&Perl_hv_delayfree_ent);
+	XSRETURN(4);
+
+SV *
+test_share_unshare_pvn(input)
+	PREINIT:
+	SV *output;
+	STRLEN len;
+	U32 hash;
+	char *pvx;
+	char *p;
+	INPUT:
+	SV *input
+	CODE:
+	pvx = SvPV(input, len);
+	PERL_HASH(hash, pvx, len);
+	p = sharepvn(pvx, len, hash);
+	RETVAL = newSVpvn(p, len);
+	unsharepvn(p, len, hash);
+	OUTPUT:
+	RETVAL
+	
 =pod
 
 sub TIEHASH  { bless {}, $_[0] }
@@ -125,6 +258,19 @@ MODULE = XS::APItest		PACKAGE = XS::APItest
 
 PROTOTYPES: DISABLE
 
+BOOT:
+{
+    MY_CXT_INIT;
+    MY_CXT.i  = 99;
+    MY_CXT.sv = newSVpv("initial",0);
+}                              
+
+void
+CLONE(...)
+    CODE:
+    MY_CXT_CLONE;
+    MY_CXT.sv = newSVpv("initial_clone",0);
+
 void
 print_double(val)
         double val
@@ -311,7 +457,7 @@ eval_sv(sv, flags)
 	EXTEND(SP, 1);
 	PUSHs(sv_2mortal(newSViv(i)));
 
-SV*
+void
 eval_pv(p, croak_on_error)
     const char* p
     I32 croak_on_error
@@ -333,3 +479,51 @@ exception(throw_e)
     OUTPUT:
         RETVAL
 
+void
+mycroak(sv)
+    SV* sv
+    CODE:
+    if (SvOK(sv)) {
+        Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
+    }
+    else {
+	Perl_croak(aTHX_ NULL);
+    }
+
+SV*
+strtab()
+   CODE:
+   RETVAL = newRV_inc((SV*)PL_strtab);
+   OUTPUT:
+   RETVAL
+
+int
+my_cxt_getint()
+    CODE:
+	dMY_CXT;
+	RETVAL = my_cxt_getint_p(aMY_CXT);
+    OUTPUT:
+        RETVAL
+
+void
+my_cxt_setint(i)
+    int i;
+    CODE:
+	dMY_CXT;
+	my_cxt_setint_p(aMY_CXT_ i);
+
+void
+my_cxt_getsv()
+    PPCODE:
+	EXTEND(SP, 1);
+	ST(0) = my_cxt_getsv_interp();
+	XSRETURN(1);
+
+void
+my_cxt_setsv(sv)
+    SV *sv;
+    CODE:
+	dMY_CXT;
+	SvREFCNT_dec(MY_CXT.sv);
+	my_cxt_setsv_p(sv _aMY_CXT);
+	SvREFCNT_inc(sv);