[p5sagit/p5-mst-13.2.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(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 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(p, &len);
		    new_p = uvuni_to_utf8(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;
}

#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

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

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