[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"

/* from exception.c */
int exception(int);

/* A routine to test hv_delayfree_ent
   (which itself is tested by testing on hv_free_ent  */

typedef void (freeent_function)(pTHX_ HV *, register HE *);

void
test_freeent(freeent_function *f) {
    dTHX;
    dSP;
    HV *test_hash = newHV();
    HE *victim;
    SV *test_scalar;
    U32 results[4];
    int i;

#ifdef PURIFY
    victim = (HE*)safemalloc(sizeof(HE));
#else
    /* Storing then deleting something should ensure that a hash entry is
       available.  */
    hv_store(test_hash, "", 0, &PL_sv_yes, 0);
    hv_delete(test_hash, "", 0, 0);

    /* We need to "inline" new_he here as it's static, and the functions we
       test expect to be able to call del_HE on the HE  */
    if (!PL_body_roots[HE_SVSLOT])
	croak("PL_he_root is 0");
    victim = PL_body_roots[HE_SVSLOT];
    PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
#endif

    victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);

    test_scalar = newSV(0);
    SvREFCNT_inc(test_scalar);
    victim->hent_val = test_scalar;

    /* Need this little game else we free the temps on the return stack.  */
    results[0] = SvREFCNT(test_scalar);
    SAVETMPS;
    results[1] = SvREFCNT(test_scalar);
    f(aTHX_ test_hash, victim);
    results[2] = SvREFCNT(test_scalar);
    FREETMPS;
    results[3] = SvREFCNT(test_scalar);

    i = 0;
    do {
	mPUSHu(results[i]);
    } while (++i < sizeof(results)/sizeof(results[0]));

    /* Goodbye to our extra reference.  */
    SvREFCNT_dec(test_scalar);
}

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

#define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)

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

SV *
delete(hash, key_sv)
	PREINIT:
	STRLEN len;
	const char *key;
	INPUT:
	HV *hash
	SV *key_sv
	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), 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(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);
	    
=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

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
exception(throw_e)
    int throw_e
    OUTPUT:
        RETVAL

void
mycroak(pv)
    const char* pv
    CODE:
    Perl_croak(aTHX_ "%s", pv);

SV*
strtab()
   CODE:
   RETVAL = newRV_inc((SV*)PL_strtab);
   OUTPUT:
   RETVAL
Commit	Line	Data
6a93a7e5	1	#define PERL_IN_XS_APITEST
3e61d65a	2	#include "EXTERN.h"
	3	#include "perl.h"
	4	#include "XSUB.h"
	5
9b5c3821	6	/* from exception.c */
9b5c3821	7	int exception(int);
0314122a	8
2dc92170	9	/* A routine to test hv_delayfree_ent
	10	(which itself is tested by testing on hv_free_ent */
	11
	12	typedef void (freeent_function)(pTHX_ HV , register HE );
	13
	14	void
	15	test_freeent(freeent_function *f) {
	16	dTHX;
	17	dSP;
	18	HV *test_hash = newHV();
	19	HE *victim;
	20	SV *test_scalar;
	21	U32 results[4];
	22	int i;
	23
8afd2d2e	24	#ifdef PURIFY
	25	victim = (HE*)safemalloc(sizeof(HE));
	26	#else
2dc92170	27	/* Storing then deleting something should ensure that a hash entry is
	28	available. */
	29	hv_store(test_hash, "", 0, &PL_sv_yes, 0);
	30	hv_delete(test_hash, "", 0, 0);
	31
	32	/* We need to "inline" new_he here as it's static, and the functions we
	33	test expect to be able to call del_HE on the HE */
6a93a7e5	34	if (!PL_body_roots[HE_SVSLOT])
2dc92170	35	croak("PL_he_root is 0");
6a93a7e5	36	victim = PL_body_roots[HE_SVSLOT];
6a93a7e5	37	PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
8afd2d2e	38	#endif
2dc92170	39
	40	victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
	41
	42	test_scalar = newSV(0);
	43	SvREFCNT_inc(test_scalar);
	44	victim->hent_val = test_scalar;
	45
	46	/* Need this little game else we free the temps on the return stack. */
	47	results[0] = SvREFCNT(test_scalar);
	48	SAVETMPS;
	49	results[1] = SvREFCNT(test_scalar);
	50	f(aTHX_ test_hash, victim);
	51	results[2] = SvREFCNT(test_scalar);
	52	FREETMPS;
	53	results[3] = SvREFCNT(test_scalar);
	54
	55	i = 0;
	56	do {
	57	mPUSHu(results[i]);
	58	} while (++i < sizeof(results)/sizeof(results[0]));
	59
	60	/* Goodbye to our extra reference. */
	61	SvREFCNT_dec(test_scalar);
	62	}
	63
0314122a	64	MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
0314122a	65
028f8eaa	66	#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
028f8eaa	67
0314122a	68	bool
	69	exists(hash, key_sv)
	70	PREINIT:
	71	STRLEN len;
	72	const char *key;
	73	INPUT:
	74	HV *hash
	75	SV *key_sv
	76	CODE:
	77	key = SvPV(key_sv, len);
028f8eaa	78	RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a	79	OUTPUT:
	80	RETVAL
	81
b60cf05a	82	SV *
	83	delete(hash, key_sv)
	84	PREINIT:
	85	STRLEN len;
	86	const char *key;
	87	INPUT:
	88	HV *hash
	89	SV *key_sv
	90	CODE:
	91	key = SvPV(key_sv, len);
	92	/* It's already mortal, so need to increase reference count. */
028f8eaa	93	RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
b60cf05a	94	OUTPUT:
	95	RETVAL
	96
	97	SV *
858117f8	98	store_ent(hash, key, value)
	99	PREINIT:
	100	SV *copy;
	101	HE *result;
	102	INPUT:
	103	HV *hash
	104	SV *key
	105	SV *value
	106	CODE:
	107	copy = newSV(0);
	108	result = hv_store_ent(hash, key, copy, 0);
	109	SvSetMagicSV(copy, value);
	110	if (!result) {
	111	SvREFCNT_dec(copy);
	112	XSRETURN_EMPTY;
	113	}
	114	/* It's about to become mortal, so need to increase reference count.
	115	*/
	116	RETVAL = SvREFCNT_inc(HeVAL(result));
	117	OUTPUT:
	118	RETVAL
	119
	120
	121	SV *
b60cf05a	122	store(hash, key_sv, value)
	123	PREINIT:
	124	STRLEN len;
	125	const char *key;
	126	SV *copy;
	127	SV **result;
	128	INPUT:
	129	HV *hash
	130	SV *key_sv
	131	SV *value
	132	CODE:
	133	key = SvPV(key_sv, len);
	134	copy = newSV(0);
028f8eaa	135	result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8	136	SvSetMagicSV(copy, value);
b60cf05a	137	if (!result) {
	138	SvREFCNT_dec(copy);
	139	XSRETURN_EMPTY;
	140	}
	141	/* It's about to become mortal, so need to increase reference count.
	142	*/
	143	RETVAL = SvREFCNT_inc(*result);
	144	OUTPUT:
	145	RETVAL
	146
	147
	148	SV *
	149	fetch(hash, key_sv)
	150	PREINIT:
	151	STRLEN len;
	152	const char *key;
	153	SV **result;
	154	INPUT:
	155	HV *hash
	156	SV *key_sv
	157	CODE:
	158	key = SvPV(key_sv, len);
028f8eaa	159	result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a	160	if (!result) {
	161	XSRETURN_EMPTY;
	162	}
	163	/* Force mg_get */
	164	RETVAL = newSVsv(*result);
	165	OUTPUT:
	166	RETVAL
2dc92170	167
439efdfe	168	void
2dc92170	169	test_hv_free_ent()
	170	PPCODE:
	171	test_freeent(&Perl_hv_free_ent);
	172	XSRETURN(4);
	173
439efdfe	174	void
2dc92170	175	test_hv_delayfree_ent()
	176	PPCODE:
	177	test_freeent(&Perl_hv_delayfree_ent);
	178	XSRETURN(4);
	179
0314122a	180	=pod
	181
	182	sub TIEHASH { bless {}, $_[0] }
	183	sub STORE { $_[0]->{$_[1]} = $_[2] }
	184	sub FETCH { $_[0]->{$_[1]} }
	185	sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
	186	sub NEXTKEY { each %{$_[0]} }
	187	sub EXISTS { exists $_[0]->{$_[1]} }
	188	sub DELETE { delete $_[0]->{$_[1]} }
	189	sub CLEAR { %{$_[0]} = () }
	190
	191	=cut
	192
3e61d65a	193	MODULE = XS::APItest PACKAGE = XS::APItest
	194
	195	PROTOTYPES: DISABLE
	196
	197	void
	198	print_double(val)
	199	double val
	200	CODE:
	201	printf("%5.3f\n",val);
	202
	203	int
	204	have_long_double()
	205	CODE:
	206	#ifdef HAS_LONG_DOUBLE
	207	RETVAL = 1;
	208	#else
	209	RETVAL = 0;
	210	#endif
cabb36f0	211	OUTPUT:
cabb36f0	212	RETVAL
3e61d65a	213
	214	void
	215	print_long_double()
	216	CODE:
	217	#ifdef HAS_LONG_DOUBLE
fc0bf671	218	# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a	219	long double val = 7.0;
	220	printf("%5.3" PERL_PRIfldbl "\n",val);
	221	# else
	222	double val = 7.0;
	223	printf("%5.3f\n",val);
	224	# endif
	225	#endif
	226
	227	void
3e61d65a	228	print_int(val)
	229	int val
	230	CODE:
	231	printf("%d\n",val);
	232
	233	void
	234	print_long(val)
	235	long val
	236	CODE:
	237	printf("%ld\n",val);
	238
	239	void
	240	print_float(val)
	241	float val
	242	CODE:
	243	printf("%5.3f\n",val);
9d911683	244
	245	void
	246	print_flush()
	247	CODE:
	248	fflush(stdout);
d4b90eee	249
	250	void
	251	mpushp()
	252	PPCODE:
	253	EXTEND(SP, 3);
	254	mPUSHp("one", 3);
	255	mPUSHp("two", 3);
	256	mPUSHp("three", 5);
	257	XSRETURN(3);
	258
	259	void
	260	mpushn()
	261	PPCODE:
	262	EXTEND(SP, 3);
	263	mPUSHn(0.5);
	264	mPUSHn(-0.25);
	265	mPUSHn(0.125);
	266	XSRETURN(3);
	267
	268	void
	269	mpushi()
	270	PPCODE:
	271	EXTEND(SP, 3);
d75b63cf	272	mPUSHi(-1);
	273	mPUSHi(2);
	274	mPUSHi(-3);
d4b90eee	275	XSRETURN(3);
	276
	277	void
	278	mpushu()
	279	PPCODE:
	280	EXTEND(SP, 3);
d75b63cf	281	mPUSHu(1);
	282	mPUSHu(2);
	283	mPUSHu(3);
d4b90eee	284	XSRETURN(3);
	285
	286	void
	287	mxpushp()
	288	PPCODE:
	289	mXPUSHp("one", 3);
	290	mXPUSHp("two", 3);
	291	mXPUSHp("three", 5);
	292	XSRETURN(3);
	293
	294	void
	295	mxpushn()
	296	PPCODE:
	297	mXPUSHn(0.5);
	298	mXPUSHn(-0.25);
	299	mXPUSHn(0.125);
	300	XSRETURN(3);
	301
	302	void
	303	mxpushi()
	304	PPCODE:
d75b63cf	305	mXPUSHi(-1);
	306	mXPUSHi(2);
	307	mXPUSHi(-3);
d4b90eee	308	XSRETURN(3);
	309
	310	void
	311	mxpushu()
	312	PPCODE:
d75b63cf	313	mXPUSHu(1);
	314	mXPUSHu(2);
	315	mXPUSHu(3);
d4b90eee	316	XSRETURN(3);
d1f347d7	317
	318
	319	void
	320	call_sv(sv, flags, ...)
	321	SV* sv
	322	I32 flags
	323	PREINIT:
	324	I32 i;
	325	PPCODE:
	326	for (i=0; i<items-2; i++)
	327	ST(i) = ST(i+2); /* pop first two args */
	328	PUSHMARK(SP);
	329	SP += items - 2;
	330	PUTBACK;
	331	i = call_sv(sv, flags);
	332	SPAGAIN;
	333	EXTEND(SP, 1);
	334	PUSHs(sv_2mortal(newSViv(i)));
	335
	336	void
	337	call_pv(subname, flags, ...)
	338	char* subname
	339	I32 flags
	340	PREINIT:
	341	I32 i;
	342	PPCODE:
	343	for (i=0; i<items-2; i++)
	344	ST(i) = ST(i+2); /* pop first two args */
	345	PUSHMARK(SP);
	346	SP += items - 2;
	347	PUTBACK;
	348	i = call_pv(subname, flags);
	349	SPAGAIN;
	350	EXTEND(SP, 1);
	351	PUSHs(sv_2mortal(newSViv(i)));
	352
	353	void
	354	call_method(methname, flags, ...)
	355	char* methname
	356	I32 flags
	357	PREINIT:
	358	I32 i;
	359	PPCODE:
	360	for (i=0; i<items-2; i++)
	361	ST(i) = ST(i+2); /* pop first two args */
	362	PUSHMARK(SP);
	363	SP += items - 2;
	364	PUTBACK;
	365	i = call_method(methname, flags);
	366	SPAGAIN;
	367	EXTEND(SP, 1);
	368	PUSHs(sv_2mortal(newSViv(i)));
	369
	370	void
	371	eval_sv(sv, flags)
	372	SV* sv
	373	I32 flags
	374	PREINIT:
	375	I32 i;
	376	PPCODE:
	377	PUTBACK;
	378	i = eval_sv(sv, flags);
	379	SPAGAIN;
	380	EXTEND(SP, 1);
381	PUSHs(sv_2mortal(newSViv(i)));
382
b8e65a9b	383	void
d1f347d7	384	eval_pv(p, croak_on_error)
	385	const char* p
	386	I32 croak_on_error
d1f347d7	387	PPCODE:
	388	PUTBACK;
	389	EXTEND(SP, 1);
	390	PUSHs(eval_pv(p, croak_on_error));
	391
	392	void
	393	require_pv(pv)
	394	const char* pv
d1f347d7	395	PPCODE:
	396	PUTBACK;
	397	require_pv(pv);
	398
0ca3a874	399	int
	400	exception(throw_e)
	401	int throw_e
	402	OUTPUT:
	403	RETVAL
d1f347d7	404
ef469b03	405	void
	406	mycroak(pv)
	407	const char* pv
	408	CODE:
	409	Perl_croak(aTHX_ "%s", pv);
5d2b1485	410
	411	SV*
	412	strtab()
	413	CODE:
	414	RETVAL = newRV_inc((SV*)PL_strtab);
	415	OUTPUT:
	416	RETVAL