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

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