+#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(void)
+{
+#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);
+int apitest_exception(int);
+
+/* from core_or_not.inc */
+bool sv_setsv_cow_hashkey_core(void);
+bool sv_setsv_cow_hashkey_notcore(void);
/* A routine to test hv_delayfree_ent
(which itself is tested by testing on hv_free_ent */
/* 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_he_root)
+ if (!PL_body_roots[HE_SVSLOT])
croak("PL_he_root is 0");
- victim = PL_he_root;
- PL_he_root = HeNEXT(victim);
+ victim = (HE*) 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);
- victim->hent_val = test_scalar;
+ HeVAL(victim) = test_scalar;
/* Need this little game else we free the temps on the return stack. */
results[0] = SvREFCNT(test_scalar);
SvREFCNT_dec(test_scalar);
}
+
+static I32
+rot13_key(pTHX_ IV action, SV *field) {
+ MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
+ SV *keysv;
+ if (mg && (keysv = mg->mg_obj)) {
+ STRLEN len;
+ const char *p = SvPV(keysv, len);
+
+ if (len) {
+ SV *newkey = newSV(len);
+ char *new_p = SvPVX(newkey);
+
+ /* There's a deliberate fencepost error here to loop len + 1 times
+ to copy the trailing \0 */
+ do {
+ char new_c = *p++;
+ /* Try doing this cleanly and clearly in EBCDIC another way: */
+ switch (new_c) {
+ case 'A': new_c = 'N'; break;
+ case 'B': new_c = 'O'; break;
+ case 'C': new_c = 'P'; break;
+ case 'D': new_c = 'Q'; break;
+ case 'E': new_c = 'R'; break;
+ case 'F': new_c = 'S'; break;
+ case 'G': new_c = 'T'; break;
+ case 'H': new_c = 'U'; break;
+ case 'I': new_c = 'V'; break;
+ case 'J': new_c = 'W'; break;
+ case 'K': new_c = 'X'; break;
+ case 'L': new_c = 'Y'; break;
+ case 'M': new_c = 'Z'; break;
+ case 'N': new_c = 'A'; break;
+ case 'O': new_c = 'B'; break;
+ case 'P': new_c = 'C'; break;
+ case 'Q': new_c = 'D'; break;
+ case 'R': new_c = 'E'; break;
+ case 'S': new_c = 'F'; break;
+ case 'T': new_c = 'G'; break;
+ case 'U': new_c = 'H'; break;
+ case 'V': new_c = 'I'; break;
+ case 'W': new_c = 'J'; break;
+ case 'X': new_c = 'K'; break;
+ case 'Y': new_c = 'L'; break;
+ case 'Z': new_c = 'M'; break;
+ case 'a': new_c = 'n'; break;
+ case 'b': new_c = 'o'; break;
+ case 'c': new_c = 'p'; break;
+ case 'd': new_c = 'q'; break;
+ case 'e': new_c = 'r'; break;
+ case 'f': new_c = 's'; break;
+ case 'g': new_c = 't'; break;
+ case 'h': new_c = 'u'; break;
+ case 'i': new_c = 'v'; break;
+ case 'j': new_c = 'w'; break;
+ case 'k': new_c = 'x'; break;
+ case 'l': new_c = 'y'; break;
+ case 'm': new_c = 'z'; break;
+ case 'n': new_c = 'a'; break;
+ case 'o': new_c = 'b'; break;
+ case 'p': new_c = 'c'; break;
+ case 'q': new_c = 'd'; break;
+ case 'r': new_c = 'e'; break;
+ case 's': new_c = 'f'; break;
+ case 't': new_c = 'g'; break;
+ case 'u': new_c = 'h'; break;
+ case 'v': new_c = 'i'; break;
+ case 'w': new_c = 'j'; break;
+ case 'x': new_c = 'k'; break;
+ case 'y': new_c = 'l'; break;
+ case 'z': new_c = 'm'; break;
+ }
+ *new_p++ = new_c;
+ } while (len--);
+ SvCUR_set(newkey, SvCUR(keysv));
+ SvPOK_on(newkey);
+ if (SvUTF8(keysv))
+ SvUTF8_on(newkey);
+
+ mg->mg_obj = newkey;
+ }
+ }
+ return 0;
+}
+
MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
+void
+rot13_hash(hash)
+ HV *hash
+ CODE:
+ {
+ struct ufuncs uf;
+ uf.uf_val = rot13_key;
+ uf.uf_set = 0;
+ uf.uf_index = 0;
+
+ sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
+ }
+
#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
bool
PPCODE:
test_freeent(&Perl_hv_delayfree_ent);
XSRETURN(4);
-
+
+SV *
+test_share_unshare_pvn(input)
+ PREINIT:
+ 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
+
+bool
+refcounted_he_exists(key, level=0)
+ SV *key
+ IV level
+ CODE:
+ if (level) {
+ croak("level must be zero, not %"IVdf, level);
+ }
+ RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+ key, NULL, 0, 0, 0)
+ != &PL_sv_placeholder);
+ OUTPUT:
+ RETVAL
+
+
+SV *
+refcounted_he_fetch(key, level=0)
+ SV *key
+ IV level
+ CODE:
+ if (level) {
+ croak("level must be zero, not %"IVdf, level);
+ }
+ RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
+ NULL, 0, 0, 0);
+ SvREFCNT_inc(RETVAL);
+ OUTPUT:
+ RETVAL
+
+
=pod
sub TIEHASH { bless {}, $_[0] }
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
require_pv(pv);
int
-exception(throw_e)
+apitest_exception(throw_e)
int throw_e
OUTPUT:
RETVAL
void
-mycroak(pv)
- const char* pv
+mycroak(sv)
+ SV* sv
CODE:
- Perl_croak(aTHX_ "%s", pv);
+ if (SvOK(sv)) {
+ Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
+ }
+ else {
+ Perl_croak(aTHX_ NULL);
+ }
SV*
strtab()
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);
+
+bool
+sv_setsv_cow_hashkey_core()
+
+bool
+sv_setsv_cow_hashkey_notcore()
+
+void
+BEGIN()
+ CODE:
+ sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
+
+void
+CHECK()
+ CODE:
+ sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
+
+void
+UNITCHECK()
+ CODE:
+ sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
+
+void
+INIT()
+ CODE:
+ sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
+
+void
+END()
+ CODE:
+ sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
projects / p5sagit/p5-mst-13.2.git / blobdiff