[p5sagit/p5-mst-13.2.git] / ext / XS / APItest / APItest.xs

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

    /* 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_he_root)
	croak("PL_he_root is 0");

    victim = PL_he_root;
    PL_he_root = HeNEXT(victim);

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