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

#define PERL_IN_XS_APITEST
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

typedef SV *SVREF;
typedef PTR_TBL_t *XS__APItest__PtrTable;

/* 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::PtrTable	PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_

void
ptr_table_new(classname)
const char * classname
    PPCODE:
    PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));

void
DESTROY(table)
XS::APItest::PtrTable table
    CODE:
    ptr_table_free(table);

void
ptr_table_store(table, from, to)
XS::APItest::PtrTable table
SVREF from
SVREF to
   CODE:
   ptr_table_store(table, from, to);

UV
ptr_table_fetch(table, from)
XS::APItest::PtrTable table
SVREF from
   CODE:
   RETVAL = PTR2UV(ptr_table_fetch(table, from));
   OUTPUT:
   RETVAL

void
ptr_table_split(table)
XS::APItest::PtrTable table

void
ptr_table_clear(table)
XS::APItest::PtrTable table

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

void
my_exit(int exitcode)
        PPCODE:
        my_exit(exitcode);

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