[perl5.git] / ext / XS-APItest / APItest.xs

#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_context(void)
{
    dTHX;
    dMY_CXT_INTERP(my_perl);
    return MY_CXT.sv;
}

SV*
my_cxt_getsv_interp(void)
{
    dMY_CXT;
    return MY_CXT.sv;
}

void
my_cxt_setsv_p(SV* sv _pMY_CXT)
{
    MY_CXT.sv = sv;
}


/* from exception.c */
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  */

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 = (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);
    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);
}


static I32
bitflip_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);

	    if (SvUTF8(keysv)) {
		const char *const end = p + len;
		while (p < end) {
		    STRLEN len;
		    UV chr = utf8_to_uvuni((U8 *)p, &len);
		    new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
		    p += len;
		}
		SvUTF8_on(newkey);
	    } else {
		while (len--)
		    *new_p++ = *p++ ^ 32;
	    }
	    *new_p = '\0';
	    SvCUR_set(newkey, SvCUR(keysv));
	    SvPOK_on(newkey);

	    mg->mg_obj = newkey;
	}
    }
    return 0;
}

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

STATIC I32
rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
    return 0;
}

STATIC MGVTBL rmagical_b = { 0 };

#include "const-c.inc"

MODULE = XS::APItest:Hash		PACKAGE = XS::APItest::Hash

INCLUDE: const-xs.inc

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));
	}

void
bitflip_hash(hash)
	HV *hash
	CODE:
	{
	    struct ufuncs uf;
	    uf.uf_val = bitflip_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
exists(hash, key_sv)
	PREINIT:
	STRLEN len;
	const char *key;
	INPUT:
	HV *hash
	SV *key_sv
	CODE:
	key = SvPV(key_sv, len);
	RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
        OUTPUT:
        RETVAL

bool
exists_ent(hash, key_sv)
	PREINIT:
	INPUT:
	HV *hash
	SV *key_sv
	CODE:
	RETVAL = hv_exists_ent(hash, key_sv, 0);
        OUTPUT:
        RETVAL

SV *
delete(hash, key_sv, flags = 0)
	PREINIT:
	STRLEN len;
	const char *key;
	INPUT:
	HV *hash
	SV *key_sv
	I32 flags;
	CODE:
	key = SvPV(key_sv, len);
	/* It's already mortal, so need to increase reference count.  */
	RETVAL
	    = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
        OUTPUT:
        RETVAL

SV *
delete_ent(hash, key_sv, flags = 0)
	INPUT:
	HV *hash
	SV *key_sv
	I32 flags;
	CODE:
	/* It's already mortal, so need to increase reference count.  */
	RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
        OUTPUT:
        RETVAL

SV *
store_ent(hash, key, value)
	PREINIT:
	SV *copy;
	HE *result;
	INPUT:
	HV *hash
	SV *key
	SV *value
	CODE:
	copy = newSV(0);
	result = hv_store_ent(hash, key, copy, 0);
	SvSetMagicSV(copy, value);
	if (!result) {
	    SvREFCNT_dec(copy);
	    XSRETURN_EMPTY;
	}
	/* It's about to become mortal, so need to increase reference count.
	 */
	RETVAL = SvREFCNT_inc(HeVAL(result));
        OUTPUT:
        RETVAL

SV *
store(hash, key_sv, value)
	PREINIT:
	STRLEN len;
	const char *key;
	SV *copy;
	SV **result;
	INPUT:
	HV *hash
	SV *key_sv
	SV *value
	CODE:
	key = SvPV(key_sv, len);
	copy = newSV(0);
	result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
	SvSetMagicSV(copy, value);
	if (!result) {
	    SvREFCNT_dec(copy);
	    XSRETURN_EMPTY;
	}
	/* It's about to become mortal, so need to increase reference count.
	 */
	RETVAL = SvREFCNT_inc(*result);
        OUTPUT:
        RETVAL

SV *
fetch_ent(hash, key_sv)
	PREINIT:
	HE *result;
	INPUT:
	HV *hash
	SV *key_sv
	CODE:
	result = hv_fetch_ent(hash, key_sv, 0, 0);
	if (!result) {
	    XSRETURN_EMPTY;
	}
	/* Force mg_get  */
	RETVAL = newSVsv(HeVAL(result));
        OUTPUT:
        RETVAL

SV *
fetch(hash, key_sv)
	PREINIT:
	STRLEN len;
	const char *key;
	SV **result;
	INPUT:
	HV *hash
	SV *key_sv
	CODE:
	key = SvPV(key_sv, len);
	result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
	if (!result) {
	    XSRETURN_EMPTY;
	}
	/* Force mg_get  */
	RETVAL = newSVsv(*result);
        OUTPUT:
        RETVAL

#if defined (hv_common)

SV *
common(params)
	INPUT:
	HV *params
	PREINIT:
	HE *result;
	HV *hv = NULL;
	SV *keysv = NULL;
	const char *key = NULL;
	STRLEN klen = 0;
	int flags = 0;
	int action = 0;
	SV *val = NULL;
	U32 hash = 0;
	SV **svp;
	CODE:
	if ((svp = hv_fetchs(params, "hv", 0))) {
	    SV *const rv = *svp;
	    if (!SvROK(rv))
		croak("common passed a non-reference for parameter hv");
	    hv = (HV *)SvRV(rv);
	}
	if ((svp = hv_fetchs(params, "keysv", 0)))
	    keysv = *svp;
	if ((svp = hv_fetchs(params, "keypv", 0))) {
	    key = SvPV_const(*svp, klen);
	    if (SvUTF8(*svp))
		flags = HVhek_UTF8;
	}
	if ((svp = hv_fetchs(params, "action", 0)))
	    action = SvIV(*svp);
	if ((svp = hv_fetchs(params, "val", 0)))
	    val = newSVsv(*svp);
	if ((svp = hv_fetchs(params, "hash", 0)))
	    hash = SvUV(*svp);

	if ((svp = hv_fetchs(params, "hash_pv", 0))) {
	    PERL_HASH(hash, key, klen);
	}
	if ((svp = hv_fetchs(params, "hash_sv", 0))) {
	    STRLEN len;
	    const char *const p = SvPV(keysv, len);
	    PERL_HASH(hash, p, len);
	}

	result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
	if (!result) {
	    XSRETURN_EMPTY;
	}
	/* Force mg_get  */
	RETVAL = newSVsv(HeVAL(result));
        OUTPUT:
        RETVAL

#endif

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:
	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

#if PERL_VERSION >= 9

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
	
#endif
	
=pod

sub TIEHASH  { bless {}, $_[0] }
sub STORE    { $_[0]->{$_[1]} = $_[2] }
sub FETCH    { $_[0]->{$_[1]} }
sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY  { each %{$_[0]} }
sub EXISTS   { exists $_[0]->{$_[1]} }
sub DELETE   { delete $_[0]->{$_[1]} }
sub CLEAR    { %{$_[0]} = () }

=cut

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
        CODE:
        printf("%5.3f\n",val);

int
have_long_double()
        CODE:
#ifdef HAS_LONG_DOUBLE
        RETVAL = 1;
#else
        RETVAL = 0;
#endif
        OUTPUT:
        RETVAL

void
print_long_double()
        CODE:
#ifdef HAS_LONG_DOUBLE
#   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
        long double val = 7.0;
        printf("%5.3" PERL_PRIfldbl "\n",val);
#   else
        double val = 7.0;
        printf("%5.3f\n",val);
#   endif
#endif

void
print_int(val)
        int val
        CODE:
        printf("%d\n",val);

void
print_long(val)
        long val
        CODE:
        printf("%ld\n",val);

void
print_float(val)
        float val
        CODE:
        printf("%5.3f\n",val);
	
void
print_flush()
    	CODE:
	fflush(stdout);

void
mpushp()
	PPCODE:
	EXTEND(SP, 3);
	mPUSHp("one", 3);
	mPUSHp("two", 3);
	mPUSHp("three", 5);
	XSRETURN(3);

void
mpushn()
	PPCODE:
	EXTEND(SP, 3);
	mPUSHn(0.5);
	mPUSHn(-0.25);
	mPUSHn(0.125);
	XSRETURN(3);

void
mpushi()
	PPCODE:
	EXTEND(SP, 3);
	mPUSHi(-1);
	mPUSHi(2);
	mPUSHi(-3);
	XSRETURN(3);

void
mpushu()
	PPCODE:
	EXTEND(SP, 3);
	mPUSHu(1);
	mPUSHu(2);
	mPUSHu(3);
	XSRETURN(3);

void
mxpushp()
	PPCODE:
	mXPUSHp("one", 3);
	mXPUSHp("two", 3);
	mXPUSHp("three", 5);
	XSRETURN(3);

void
mxpushn()
	PPCODE:
	mXPUSHn(0.5);
	mXPUSHn(-0.25);
	mXPUSHn(0.125);
	XSRETURN(3);

void
mxpushi()
	PPCODE:
	mXPUSHi(-1);
	mXPUSHi(2);
	mXPUSHi(-3);
	XSRETURN(3);

void
mxpushu()
	PPCODE:
	mXPUSHu(1);
	mXPUSHu(2);
	mXPUSHu(3);
	XSRETURN(3);


void
call_sv(sv, flags, ...)
    SV* sv
    I32 flags
    PREINIT:
	I32 i;
    PPCODE:
	for (i=0; i<items-2; i++)
	    ST(i) = ST(i+2); /* pop first two args */
	PUSHMARK(SP);
	SP += items - 2;
	PUTBACK;
	i = call_sv(sv, flags);
	SPAGAIN;
	EXTEND(SP, 1);
	PUSHs(sv_2mortal(newSViv(i)));

void
call_pv(subname, flags, ...)
    char* subname
    I32 flags
    PREINIT:
	I32 i;
    PPCODE:
	for (i=0; i<items-2; i++)
	    ST(i) = ST(i+2); /* pop first two args */
	PUSHMARK(SP);
	SP += items - 2;
	PUTBACK;
	i = call_pv(subname, flags);
	SPAGAIN;
	EXTEND(SP, 1);
	PUSHs(sv_2mortal(newSViv(i)));

void
call_method(methname, flags, ...)
    char* methname
    I32 flags
    PREINIT:
	I32 i;
    PPCODE:
	for (i=0; i<items-2; i++)
	    ST(i) = ST(i+2); /* pop first two args */
	PUSHMARK(SP);
	SP += items - 2;
	PUTBACK;
	i = call_method(methname, flags);
	SPAGAIN;
	EXTEND(SP, 1);
	PUSHs(sv_2mortal(newSViv(i)));

void
eval_sv(sv, flags)
    SV* sv
    I32 flags
    PREINIT:
    	I32 i;
    PPCODE:
	PUTBACK;
	i = eval_sv(sv, flags);
	SPAGAIN;
	EXTEND(SP, 1);
	PUSHs(sv_2mortal(newSViv(i)));

void
eval_pv(p, croak_on_error)
    const char* p
    I32 croak_on_error
    PPCODE:
	PUTBACK;
	EXTEND(SP, 1);
	PUSHs(eval_pv(p, croak_on_error));

void
require_pv(pv)
    const char* pv
    PPCODE:
	PUTBACK;
	require_pv(pv);

int
apitest_exception(throw_e)
    int 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(how)
    bool how;
    PPCODE:
	EXTEND(SP, 1);
	ST(0) = how ? my_cxt_getsv_interp_context() : 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
rmagical_cast(sv, type)
    SV *sv;
    SV *type;
    PREINIT:
	struct ufuncs uf;
    PPCODE:
	if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
	sv = SvRV(sv);
	if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
	uf.uf_val = rmagical_a_dummy;
	uf.uf_set = NULL;
	uf.uf_index = 0;
	if (SvTRUE(type)) { /* b */
	    sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
	} else { /* a */
	    sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
	}
	XSRETURN_YES;

void
rmagical_flags(sv)
    SV *sv;
    PPCODE:
	if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
	sv = SvRV(sv);
        EXTEND(SP, 3); 
	mXPUSHu(SvFLAGS(sv) & SVs_GMG);
	mXPUSHu(SvFLAGS(sv) & SVs_SMG);
	mXPUSHu(SvFLAGS(sv) & SVs_RMG);
        XSRETURN(3);

void
DPeek (sv)
    SV   *sv

  PPCODE:
    ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
    XSRETURN (1);

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

void
utf16_to_utf8 (sv, ...)
    SV* sv
	ALIAS:
	    utf16_to_utf8_reversed = 1
    PREINIT:
        STRLEN len;
	U8 *source;
	SV *dest;
	I32 got; /* Gah, badly thought out APIs */
    CODE:
	source = (U8 *)SvPVbyte(sv, len);
	/* Optionally only convert part of the buffer.  */ 	
	if (items > 1) {
	    len = SvUV(ST(1));
 	}
	/* Mortalise this right now, as we'll be testing croak()s  */
	dest = sv_2mortal(newSV(len * 3 / 2 + 1));
	if (ix) {
	    utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
	} else {
	    utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
	}
	SvCUR_set(dest, got);
	SvPVX(dest)[got] = '\0';
	SvPOK_on(dest);
 	ST(0) = dest;
	XSRETURN(1);

U32
pmflag (flag, before = 0)
	int flag
	U32 before
   CODE:
	pmflag(&before, flag);
	RETVAL = before;
    OUTPUT:
	RETVAL

void
my_exit(int exitcode)
        PPCODE:
        my_exit(exitcode);
Commit	Line	Data
6a93a7e5	1	#define PERL_IN_XS_APITEST
3e61d65a JH	2	#include "EXTERN.h"
	3	#include "perl.h"
	4	#include "XSUB.h"
	5
85ce96a1 DM	6
	7	/* for my_cxt tests */
	8
	9	#define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
	10
	11	typedef struct {
	12	int i;
	13	SV *sv;
	14	} my_cxt_t;
	15
	16	START_MY_CXT
	17
	18	/* indirect functions to test the [pa]MY_CXT macros */
f16dd614	19
85ce96a1 DM	20	int
	21	my_cxt_getint_p(pMY_CXT)
	22	{
	23	return MY_CXT.i;
	24	}
f16dd614	25
85ce96a1 DM	26	void
	27	my_cxt_setint_p(pMY_CXT_ int i)
	28	{
	29	MY_CXT.i = i;
	30	}
f16dd614 DM	31
f16dd614 DM	32	SV*
9568a123	33	my_cxt_getsv_interp_context(void)
f16dd614	34	{
f16dd614 DM	35	dTHX;
f16dd614 DM	36	dMY_CXT_INTERP(my_perl);
9568a123 NC	37	return MY_CXT.sv;
	38	}
	39
	40	SV*
	41	my_cxt_getsv_interp(void)
	42	{
f16dd614	43	dMY_CXT;
f16dd614 DM	44	return MY_CXT.sv;
	45	}
	46
85ce96a1 DM	47	void
	48	my_cxt_setsv_p(SV* sv _pMY_CXT)
	49	{
	50	MY_CXT.sv = sv;
	51	}
	52
	53
9b5c3821	54	/* from exception.c */
7a646707	55	int apitest_exception(int);
0314122a	56
ff66e713 SH	57	/* from core_or_not.inc */
	58	bool sv_setsv_cow_hashkey_core(void);
	59	bool sv_setsv_cow_hashkey_notcore(void);
	60
2dc92170 NC	61	/* A routine to test hv_delayfree_ent
	62	(which itself is tested by testing on hv_free_ent */
	63
	64	typedef void (freeent_function)(pTHX_ HV , register HE );
	65
	66	void
	67	test_freeent(freeent_function *f) {
	68	dTHX;
	69	dSP;
	70	HV *test_hash = newHV();
	71	HE *victim;
	72	SV *test_scalar;
	73	U32 results[4];
	74	int i;
	75
8afd2d2e NC	76	#ifdef PURIFY
	77	victim = (HE*)safemalloc(sizeof(HE));
	78	#else
2dc92170 NC	79	/* Storing then deleting something should ensure that a hash entry is
	80	available. */
	81	hv_store(test_hash, "", 0, &PL_sv_yes, 0);
	82	hv_delete(test_hash, "", 0, 0);
	83
	84	/* We need to "inline" new_he here as it's static, and the functions we
	85	test expect to be able to call del_HE on the HE */
6a93a7e5	86	if (!PL_body_roots[HE_SVSLOT])
2dc92170	87	croak("PL_he_root is 0");
8a722a80	88	victim = (HE*) PL_body_roots[HE_SVSLOT];
6a93a7e5	89	PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
8afd2d2e	90	#endif
2dc92170 NC	91
	92	victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
	93
	94	test_scalar = newSV(0);
	95	SvREFCNT_inc(test_scalar);
de616631	96	HeVAL(victim) = test_scalar;
2dc92170 NC	97
	98	/* Need this little game else we free the temps on the return stack. */
	99	results[0] = SvREFCNT(test_scalar);
	100	SAVETMPS;
	101	results[1] = SvREFCNT(test_scalar);
	102	f(aTHX_ test_hash, victim);
	103	results[2] = SvREFCNT(test_scalar);
	104	FREETMPS;
	105	results[3] = SvREFCNT(test_scalar);
	106
	107	i = 0;
	108	do {
	109	mPUSHu(results[i]);
	110	} while (++i < sizeof(results)/sizeof(results[0]));
	111
	112	/* Goodbye to our extra reference. */
	113	SvREFCNT_dec(test_scalar);
	114	}
	115
b54b4831 NC	116
b54b4831 NC	117	static I32
53c40a8f NC	118	bitflip_key(pTHX_ IV action, SV *field) {
	119	MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
	120	SV *keysv;
	121	if (mg && (keysv = mg->mg_obj)) {
	122	STRLEN len;
	123	const char *p = SvPV(keysv, len);
	124
	125	if (len) {
	126	SV *newkey = newSV(len);
	127	char *new_p = SvPVX(newkey);
	128
	129	if (SvUTF8(keysv)) {
	130	const char *const end = p + len;
	131	while (p < end) {
	132	STRLEN len;
a75fcbca SP	133	UV chr = utf8_to_uvuni((U8 *)p, &len);
a75fcbca SP	134	new_p = (char )uvuni_to_utf8((U8 )new_p, chr ^ 32);
53c40a8f NC	135	p += len;
	136	}
	137	SvUTF8_on(newkey);
	138	} else {
	139	while (len--)
	140	new_p++ = p++ ^ 32;
	141	}
	142	*new_p = '\0';
	143	SvCUR_set(newkey, SvCUR(keysv));
	144	SvPOK_on(newkey);
	145
	146	mg->mg_obj = newkey;
	147	}
	148	}
	149	return 0;
	150	}
	151
	152	static I32
b54b4831 NC	153	rot13_key(pTHX_ IV action, SV *field) {
	154	MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
	155	SV *keysv;
	156	if (mg && (keysv = mg->mg_obj)) {
	157	STRLEN len;
	158	const char *p = SvPV(keysv, len);
	159
	160	if (len) {
	161	SV *newkey = newSV(len);
	162	char *new_p = SvPVX(newkey);
	163
	164	/* There's a deliberate fencepost error here to loop len + 1 times
	165	to copy the trailing \0 */
	166	do {
	167	char new_c = *p++;
	168	/* Try doing this cleanly and clearly in EBCDIC another way: */
	169	switch (new_c) {
	170	case 'A': new_c = 'N'; break;
	171	case 'B': new_c = 'O'; break;
	172	case 'C': new_c = 'P'; break;
	173	case 'D': new_c = 'Q'; break;
	174	case 'E': new_c = 'R'; break;
	175	case 'F': new_c = 'S'; break;
	176	case 'G': new_c = 'T'; break;
	177	case 'H': new_c = 'U'; break;
	178	case 'I': new_c = 'V'; break;
	179	case 'J': new_c = 'W'; break;
	180	case 'K': new_c = 'X'; break;
	181	case 'L': new_c = 'Y'; break;
	182	case 'M': new_c = 'Z'; break;
	183	case 'N': new_c = 'A'; break;
	184	case 'O': new_c = 'B'; break;
	185	case 'P': new_c = 'C'; break;
	186	case 'Q': new_c = 'D'; break;
	187	case 'R': new_c = 'E'; break;
	188	case 'S': new_c = 'F'; break;
	189	case 'T': new_c = 'G'; break;
	190	case 'U': new_c = 'H'; break;
	191	case 'V': new_c = 'I'; break;
	192	case 'W': new_c = 'J'; break;
	193	case 'X': new_c = 'K'; break;
	194	case 'Y': new_c = 'L'; break;
	195	case 'Z': new_c = 'M'; break;
	196	case 'a': new_c = 'n'; break;
	197	case 'b': new_c = 'o'; break;
	198	case 'c': new_c = 'p'; break;
	199	case 'd': new_c = 'q'; break;
	200	case 'e': new_c = 'r'; break;
	201	case 'f': new_c = 's'; break;
	202	case 'g': new_c = 't'; break;
	203	case 'h': new_c = 'u'; break;
	204	case 'i': new_c = 'v'; break;
	205	case 'j': new_c = 'w'; break;
	206	case 'k': new_c = 'x'; break;
	207	case 'l': new_c = 'y'; break;
	208	case 'm': new_c = 'z'; break;
	209	case 'n': new_c = 'a'; break;
	210	case 'o': new_c = 'b'; break;
	211	case 'p': new_c = 'c'; break;
	212	case 'q': new_c = 'd'; break;
	213	case 'r': new_c = 'e'; break;
	214	case 's': new_c = 'f'; break;
	215	case 't': new_c = 'g'; break;
	216	case 'u': new_c = 'h'; break;
217	case 'v': new_c = 'i'; break;
218	case 'w': new_c = 'j'; break;
219	case 'x': new_c = 'k'; break;
220	case 'y': new_c = 'l'; break;
221	case 'z': new_c = 'm'; break;
222	}
223	*new_p++ = new_c;
224	} while (len--);
225	SvCUR_set(newkey, SvCUR(keysv));
226	SvPOK_on(newkey);
227	if (SvUTF8(keysv))
228	SvUTF8_on(newkey);
229
230	mg->mg_obj = newkey;
231	}
232	}
233	return 0;
234	}
235
218787bd VP	236	STATIC I32
	237	rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
	238	return 0;
	239	}
	240
	241	STATIC MGVTBL rmagical_b = { 0 };
	242
55289a74 NC	243	#include "const-c.inc"
55289a74 NC	244
0314122a NC	245	MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
0314122a NC	246
55289a74 NC	247	INCLUDE: const-xs.inc
55289a74 NC	248
b54b4831 NC	249	void
	250	rot13_hash(hash)
	251	HV *hash
	252	CODE:
	253	{
	254	struct ufuncs uf;
	255	uf.uf_val = rot13_key;
	256	uf.uf_set = 0;
	257	uf.uf_index = 0;
	258
	259	sv_magic((SV)hash, NULL, PERL_MAGIC_uvar, (char)&uf, sizeof(uf));
	260	}
	261
53c40a8f NC	262	void
	263	bitflip_hash(hash)
	264	HV *hash
	265	CODE:
	266	{
	267	struct ufuncs uf;
	268	uf.uf_val = bitflip_key;
	269	uf.uf_set = 0;
	270	uf.uf_index = 0;
	271
	272	sv_magic((SV)hash, NULL, PERL_MAGIC_uvar, (char)&uf, sizeof(uf));
	273	}
	274
028f8eaa MHM	275	#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
028f8eaa MHM	276
0314122a NC	277	bool
	278	exists(hash, key_sv)
	279	PREINIT:
	280	STRLEN len;
	281	const char *key;
	282	INPUT:
	283	HV *hash
	284	SV *key_sv
	285	CODE:
	286	key = SvPV(key_sv, len);
028f8eaa	287	RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a NC	288	OUTPUT:
	289	RETVAL
	290
bdee33e4 NC	291	bool
	292	exists_ent(hash, key_sv)
	293	PREINIT:
	294	INPUT:
	295	HV *hash
	296	SV *key_sv
	297	CODE:
	298	RETVAL = hv_exists_ent(hash, key_sv, 0);
	299	OUTPUT:
	300	RETVAL
	301
b60cf05a	302	SV *
55289a74	303	delete(hash, key_sv, flags = 0)
b60cf05a NC	304	PREINIT:
	305	STRLEN len;
	306	const char *key;
	307	INPUT:
	308	HV *hash
	309	SV *key_sv
55289a74	310	I32 flags;
b60cf05a NC	311	CODE:
	312	key = SvPV(key_sv, len);
	313	/* It's already mortal, so need to increase reference count. */
55289a74 NC	314	RETVAL
	315	= SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
	316	OUTPUT:
	317	RETVAL
	318
	319	SV *
	320	delete_ent(hash, key_sv, flags = 0)
	321	INPUT:
	322	HV *hash
	323	SV *key_sv
	324	I32 flags;
	325	CODE:
	326	/* It's already mortal, so need to increase reference count. */
	327	RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
b60cf05a NC	328	OUTPUT:
	329	RETVAL
	330
	331	SV *
858117f8 NC	332	store_ent(hash, key, value)
	333	PREINIT:
	334	SV *copy;
	335	HE *result;
	336	INPUT:
	337	HV *hash
	338	SV *key
	339	SV *value
	340	CODE:
	341	copy = newSV(0);
	342	result = hv_store_ent(hash, key, copy, 0);
	343	SvSetMagicSV(copy, value);
	344	if (!result) {
	345	SvREFCNT_dec(copy);
	346	XSRETURN_EMPTY;
	347	}
	348	/* It's about to become mortal, so need to increase reference count.
	349	*/
	350	RETVAL = SvREFCNT_inc(HeVAL(result));
	351	OUTPUT:
	352	RETVAL
	353
858117f8	354	SV *
b60cf05a NC	355	store(hash, key_sv, value)
	356	PREINIT:
	357	STRLEN len;
	358	const char *key;
	359	SV *copy;
	360	SV **result;
	361	INPUT:
	362	HV *hash
	363	SV *key_sv
	364	SV *value
	365	CODE:
	366	key = SvPV(key_sv, len);
	367	copy = newSV(0);
028f8eaa	368	result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8	369	SvSetMagicSV(copy, value);
b60cf05a NC	370	if (!result) {
	371	SvREFCNT_dec(copy);
	372	XSRETURN_EMPTY;
	373	}
	374	/* It's about to become mortal, so need to increase reference count.
	375	*/
	376	RETVAL = SvREFCNT_inc(*result);
	377	OUTPUT:
	378	RETVAL
	379
bdee33e4 NC	380	SV *
	381	fetch_ent(hash, key_sv)
	382	PREINIT:
	383	HE *result;
	384	INPUT:
	385	HV *hash
	386	SV *key_sv
	387	CODE:
	388	result = hv_fetch_ent(hash, key_sv, 0, 0);
	389	if (!result) {
	390	XSRETURN_EMPTY;
	391	}
	392	/* Force mg_get */
	393	RETVAL = newSVsv(HeVAL(result));
	394	OUTPUT:
	395	RETVAL
b60cf05a NC	396
	397	SV *
	398	fetch(hash, key_sv)
	399	PREINIT:
	400	STRLEN len;
	401	const char *key;
	402	SV **result;
	403	INPUT:
	404	HV *hash
	405	SV *key_sv
	406	CODE:
	407	key = SvPV(key_sv, len);
028f8eaa	408	result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a NC	409	if (!result) {
	410	XSRETURN_EMPTY;
	411	}
	412	/* Force mg_get */
	413	RETVAL = newSVsv(*result);
	414	OUTPUT:
	415	RETVAL
2dc92170	416
9568a123 NC	417	#if defined (hv_common)
9568a123 NC	418
6b4de907 NC	419	SV *
	420	common(params)
	421	INPUT:
	422	HV *params
	423	PREINIT:
	424	HE *result;
	425	HV *hv = NULL;
	426	SV *keysv = NULL;
	427	const char *key = NULL;
	428	STRLEN klen = 0;
	429	int flags = 0;
	430	int action = 0;
	431	SV *val = NULL;
	432	U32 hash = 0;
	433	SV **svp;
	434	CODE:
	435	if ((svp = hv_fetchs(params, "hv", 0))) {
	436	SV const rv = svp;
	437	if (!SvROK(rv))
	438	croak("common passed a non-reference for parameter hv");
	439	hv = (HV *)SvRV(rv);
	440	}
	441	if ((svp = hv_fetchs(params, "keysv", 0)))
	442	keysv = *svp;
	443	if ((svp = hv_fetchs(params, "keypv", 0))) {
	444	key = SvPV_const(*svp, klen);
	445	if (SvUTF8(*svp))
	446	flags = HVhek_UTF8;
	447	}
	448	if ((svp = hv_fetchs(params, "action", 0)))
	449	action = SvIV(*svp);
	450	if ((svp = hv_fetchs(params, "val", 0)))
527df579	451	val = newSVsv(*svp);
6b4de907	452	if ((svp = hv_fetchs(params, "hash", 0)))
a44093a9	453	hash = SvUV(*svp);
6b4de907	454
527df579 NC	455	if ((svp = hv_fetchs(params, "hash_pv", 0))) {
	456	PERL_HASH(hash, key, klen);
	457	}
58ca560a NC	458	if ((svp = hv_fetchs(params, "hash_sv", 0))) {
	459	STRLEN len;
	460	const char *const p = SvPV(keysv, len);
	461	PERL_HASH(hash, p, len);
	462	}
527df579	463
a75fcbca	464	result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
6b4de907 NC	465	if (!result) {
	466	XSRETURN_EMPTY;
	467	}
	468	/* Force mg_get */
	469	RETVAL = newSVsv(HeVAL(result));
	470	OUTPUT:
	471	RETVAL
	472
9568a123 NC	473	#endif
9568a123 NC	474
439efdfe	475	void
2dc92170 NC	476	test_hv_free_ent()
	477	PPCODE:
	478	test_freeent(&Perl_hv_free_ent);
	479	XSRETURN(4);
	480
439efdfe	481	void
2dc92170 NC	482	test_hv_delayfree_ent()
	483	PPCODE:
	484	test_freeent(&Perl_hv_delayfree_ent);
	485	XSRETURN(4);
35ab5632 NC	486
	487	SV *
	488	test_share_unshare_pvn(input)
	489	PREINIT:
35ab5632 NC	490	STRLEN len;
	491	U32 hash;
	492	char *pvx;
	493	char *p;
	494	INPUT:
	495	SV *input
	496	CODE:
	497	pvx = SvPV(input, len);
	498	PERL_HASH(hash, pvx, len);
	499	p = sharepvn(pvx, len, hash);
	500	RETVAL = newSVpvn(p, len);
	501	unsharepvn(p, len, hash);
	502	OUTPUT:
	503	RETVAL
d8c5b3c5	504
9568a123 NC	505	#if PERL_VERSION >= 9
9568a123 NC	506
d8c5b3c5 NC	507	bool
	508	refcounted_he_exists(key, level=0)
	509	SV *key
	510	IV level
	511	CODE:
	512	if (level) {
	513	croak("level must be zero, not %"IVdf, level);
	514	}
	515	RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
	516	key, NULL, 0, 0, 0)
	517	!= &PL_sv_placeholder);
	518	OUTPUT:
	519	RETVAL
	520
d8c5b3c5 NC	521	SV *
	522	refcounted_he_fetch(key, level=0)
	523	SV *key
	524	IV level
	525	CODE:
	526	if (level) {
	527	croak("level must be zero, not %"IVdf, level);
	528	}
	529	RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
	530	NULL, 0, 0, 0);
	531	SvREFCNT_inc(RETVAL);
	532	OUTPUT:
	533	RETVAL
	534
9568a123	535	#endif
35ab5632	536
0314122a NC	537	=pod
	538
	539	sub TIEHASH { bless {}, $_[0] }
	540	sub STORE { $_[0]->{$_[1]} = $_[2] }
	541	sub FETCH { $_[0]->{$_[1]} }
	542	sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
	543	sub NEXTKEY { each %{$_[0]} }
	544	sub EXISTS { exists $_[0]->{$_[1]} }
	545	sub DELETE { delete $_[0]->{$_[1]} }
	546	sub CLEAR { %{$_[0]} = () }
	547
	548	=cut
	549
3e61d65a JH	550	MODULE = XS::APItest PACKAGE = XS::APItest
	551
	552	PROTOTYPES: DISABLE
	553
85ce96a1 DM	554	BOOT:
	555	{
	556	MY_CXT_INIT;
	557	MY_CXT.i = 99;
	558	MY_CXT.sv = newSVpv("initial",0);
	559	}
	560
	561	void
	562	CLONE(...)
	563	CODE:
	564	MY_CXT_CLONE;
	565	MY_CXT.sv = newSVpv("initial_clone",0);
	566
3e61d65a JH	567	void
	568	print_double(val)
	569	double val
	570	CODE:
	571	printf("%5.3f\n",val);
	572
	573	int
	574	have_long_double()
	575	CODE:
	576	#ifdef HAS_LONG_DOUBLE
	577	RETVAL = 1;
	578	#else
	579	RETVAL = 0;
	580	#endif
cabb36f0 CN	581	OUTPUT:
cabb36f0 CN	582	RETVAL
3e61d65a JH	583
	584	void
	585	print_long_double()
	586	CODE:
	587	#ifdef HAS_LONG_DOUBLE
fc0bf671	588	# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a JH	589	long double val = 7.0;
	590	printf("%5.3" PERL_PRIfldbl "\n",val);
	591	# else
	592	double val = 7.0;
	593	printf("%5.3f\n",val);
	594	# endif
	595	#endif
	596
	597	void
3e61d65a JH	598	print_int(val)
	599	int val
	600	CODE:
	601	printf("%d\n",val);
	602
	603	void
	604	print_long(val)
	605	long val
	606	CODE:
	607	printf("%ld\n",val);
	608
	609	void
	610	print_float(val)
	611	float val
	612	CODE:
	613	printf("%5.3f\n",val);
9d911683 NIS	614
	615	void
	616	print_flush()
	617	CODE:
	618	fflush(stdout);
d4b90eee SH	619
	620	void
	621	mpushp()
	622	PPCODE:
	623	EXTEND(SP, 3);
	624	mPUSHp("one", 3);
	625	mPUSHp("two", 3);
	626	mPUSHp("three", 5);
	627	XSRETURN(3);
	628
	629	void
	630	mpushn()
	631	PPCODE:
	632	EXTEND(SP, 3);
	633	mPUSHn(0.5);
	634	mPUSHn(-0.25);
	635	mPUSHn(0.125);
	636	XSRETURN(3);
	637
	638	void
	639	mpushi()
	640	PPCODE:
	641	EXTEND(SP, 3);
d75b63cf MHM	642	mPUSHi(-1);
	643	mPUSHi(2);
	644	mPUSHi(-3);
d4b90eee SH	645	XSRETURN(3);
	646
	647	void
	648	mpushu()
	649	PPCODE:
	650	EXTEND(SP, 3);
d75b63cf MHM	651	mPUSHu(1);
	652	mPUSHu(2);
	653	mPUSHu(3);
d4b90eee SH	654	XSRETURN(3);
	655
	656	void
	657	mxpushp()
	658	PPCODE:
	659	mXPUSHp("one", 3);
	660	mXPUSHp("two", 3);
	661	mXPUSHp("three", 5);
	662	XSRETURN(3);
	663
	664	void
	665	mxpushn()
	666	PPCODE:
	667	mXPUSHn(0.5);
	668	mXPUSHn(-0.25);
	669	mXPUSHn(0.125);
	670	XSRETURN(3);
	671
	672	void
	673	mxpushi()
	674	PPCODE:
d75b63cf MHM	675	mXPUSHi(-1);
	676	mXPUSHi(2);
	677	mXPUSHi(-3);
d4b90eee SH	678	XSRETURN(3);
	679
	680	void
	681	mxpushu()
	682	PPCODE:
d75b63cf MHM	683	mXPUSHu(1);
	684	mXPUSHu(2);
	685	mXPUSHu(3);
d4b90eee	686	XSRETURN(3);
d1f347d7 DM	687
	688
	689	void
	690	call_sv(sv, flags, ...)
	691	SV* sv
	692	I32 flags
	693	PREINIT:
	694	I32 i;
	695	PPCODE:
	696	for (i=0; i<items-2; i++)
	697	ST(i) = ST(i+2); /* pop first two args */
	698	PUSHMARK(SP);
	699	SP += items - 2;
	700	PUTBACK;
	701	i = call_sv(sv, flags);
	702	SPAGAIN;
	703	EXTEND(SP, 1);
	704	PUSHs(sv_2mortal(newSViv(i)));
	705
	706	void
	707	call_pv(subname, flags, ...)
	708	char* subname
	709	I32 flags
	710	PREINIT:
	711	I32 i;
	712	PPCODE:
	713	for (i=0; i<items-2; i++)
	714	ST(i) = ST(i+2); /* pop first two args */
	715	PUSHMARK(SP);
	716	SP += items - 2;
	717	PUTBACK;
	718	i = call_pv(subname, flags);
	719	SPAGAIN;
	720	EXTEND(SP, 1);
	721	PUSHs(sv_2mortal(newSViv(i)));
	722
	723	void
	724	call_method(methname, flags, ...)
	725	char* methname
	726	I32 flags
	727	PREINIT:
	728	I32 i;
	729	PPCODE:
	730	for (i=0; i<items-2; i++)
	731	ST(i) = ST(i+2); /* pop first two args */
	732	PUSHMARK(SP);
	733	SP += items - 2;
	734	PUTBACK;
	735	i = call_method(methname, flags);
	736	SPAGAIN;
	737	EXTEND(SP, 1);
	738	PUSHs(sv_2mortal(newSViv(i)));
	739
	740	void
	741	eval_sv(sv, flags)
	742	SV* sv
	743	I32 flags
	744	PREINIT:
	745	I32 i;
	746	PPCODE:
	747	PUTBACK;
	748	i = eval_sv(sv, flags);
	749	SPAGAIN;
	750	EXTEND(SP, 1);
751	PUSHs(sv_2mortal(newSViv(i)));
752
b8e65a9b	753	void
d1f347d7 DM	754	eval_pv(p, croak_on_error)
	755	const char* p
	756	I32 croak_on_error
d1f347d7 DM	757	PPCODE:
	758	PUTBACK;
	759	EXTEND(SP, 1);
	760	PUSHs(eval_pv(p, croak_on_error));
	761
	762	void
	763	require_pv(pv)
	764	const char* pv
d1f347d7 DM	765	PPCODE:
	766	PUTBACK;
	767	require_pv(pv);
	768
0ca3a874	769	int
7a646707	770	apitest_exception(throw_e)
0ca3a874 MHM	771	int throw_e
	772	OUTPUT:
	773	RETVAL
d1f347d7	774
ef469b03	775	void
7e7a3dfc GA	776	mycroak(sv)
7e7a3dfc GA	777	SV* sv
ef469b03	778	CODE:
7e7a3dfc GA	779	if (SvOK(sv)) {
	780	Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
	781	}
	782	else {
	783	Perl_croak(aTHX_ NULL);
	784	}
5d2b1485 NC	785
	786	SV*
	787	strtab()
	788	CODE:
	789	RETVAL = newRV_inc((SV*)PL_strtab);
	790	OUTPUT:
	791	RETVAL
85ce96a1 DM	792
	793	int
	794	my_cxt_getint()
	795	CODE:
	796	dMY_CXT;
	797	RETVAL = my_cxt_getint_p(aMY_CXT);
	798	OUTPUT:
	799	RETVAL
	800
	801	void
	802	my_cxt_setint(i)
	803	int i;
	804	CODE:
	805	dMY_CXT;
	806	my_cxt_setint_p(aMY_CXT_ i);
	807
	808	void
9568a123 NC	809	my_cxt_getsv(how)
9568a123 NC	810	bool how;
85ce96a1	811	PPCODE:
85ce96a1	812	EXTEND(SP, 1);
9568a123	813	ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
85ce96a1 DM	814	XSRETURN(1);
	815
	816	void
	817	my_cxt_setsv(sv)
	818	SV *sv;
	819	CODE:
	820	dMY_CXT;
	821	SvREFCNT_dec(MY_CXT.sv);
	822	my_cxt_setsv_p(sv _aMY_CXT);
	823	SvREFCNT_inc(sv);
34482cd6 NC	824
	825	bool
	826	sv_setsv_cow_hashkey_core()
	827
	828	bool
	829	sv_setsv_cow_hashkey_notcore()
84ac5fd7 NC	830
84ac5fd7 NC	831	void
218787bd VP	832	rmagical_cast(sv, type)
	833	SV *sv;
	834	SV *type;
	835	PREINIT:
	836	struct ufuncs uf;
	837	PPCODE:
	838	if (!SvOK(sv) \|\| !SvROK(sv) \|\| !SvOK(type)) { XSRETURN_UNDEF; }
	839	sv = SvRV(sv);
	840	if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
	841	uf.uf_val = rmagical_a_dummy;
	842	uf.uf_set = NULL;
	843	uf.uf_index = 0;
	844	if (SvTRUE(type)) { /* b */
	845	sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
	846	} else { /* a */
	847	sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
	848	}
	849	XSRETURN_YES;
	850
	851	void
	852	rmagical_flags(sv)
	853	SV *sv;
	854	PPCODE:
	855	if (!SvOK(sv) \|\| !SvROK(sv)) { XSRETURN_UNDEF; }
	856	sv = SvRV(sv);
	857	EXTEND(SP, 3);
	858	mXPUSHu(SvFLAGS(sv) & SVs_GMG);
	859	mXPUSHu(SvFLAGS(sv) & SVs_SMG);
	860	mXPUSHu(SvFLAGS(sv) & SVs_RMG);
	861	XSRETURN(3);
	862
	863	void
f9c17636 MB	864	DPeek (sv)
	865	SV *sv
	866
	867	PPCODE:
5b1f7359	868	ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
f9c17636 MB	869	XSRETURN (1);
	870
	871	void
84ac5fd7 NC	872	BEGIN()
	873	CODE:
	874	sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD\|GV_ADDMULTI));
	875
	876	void
	877	CHECK()
	878	CODE:
	879	sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD\|GV_ADDMULTI));
	880
	881	void
	882	UNITCHECK()
	883	CODE:
0932863f	884	sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD\|GV_ADDMULTI));
84ac5fd7 NC	885
	886	void
	887	INIT()
	888	CODE:
	889	sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD\|GV_ADDMULTI));
	890
	891	void
	892	END()
	893	CODE:
	894	sv_inc(get_sv("XS::APItest::END_called", GV_ADD\|GV_ADDMULTI));
30685b56 NC	895
	896	void
	897	utf16_to_utf8 (sv, ...)
	898	SV* sv
	899	ALIAS:
	900	utf16_to_utf8_reversed = 1
	901	PREINIT:
	902	STRLEN len;
	903	U8 *source;
	904	SV *dest;
	905	I32 got; /* Gah, badly thought out APIs */
	906	CODE:
	907	source = (U8 *)SvPVbyte(sv, len);
	908	/* Optionally only convert part of the buffer. */
	909	if (items > 1) {
	910	len = SvUV(ST(1));
	911	}
	912	/* Mortalise this right now, as we'll be testing croak()s */
	913	dest = sv_2mortal(newSV(len * 3 / 2 + 1));
	914	if (ix) {
25f2e844	915	utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
30685b56	916	} else {
25f2e844	917	utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
30685b56 NC	918	}
	919	SvCUR_set(dest, got);
	920	SvPVX(dest)[got] = '\0';
	921	SvPOK_on(dest);
	922	ST(0) = dest;
	923	XSRETURN(1);
879d0c72 NC	924
	925	U32
	926	pmflag (flag, before = 0)
	927	int flag
	928	U32 before
	929	CODE:
	930	pmflag(&before, flag);
	931	RETVAL = before;
	932	OUTPUT:
	933	RETVAL
6bd7445c GG	934
	935	void
	936	my_exit(int exitcode)
	937	PPCODE:
	938	my_exit(exitcode);