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

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
=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
	8	MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
	9
028f8eaa	10	#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
028f8eaa	11
0314122a	12	bool
	13	exists(hash, key_sv)
	14	PREINIT:
	15	STRLEN len;
	16	const char *key;
	17	INPUT:
	18	HV *hash
	19	SV *key_sv
	20	CODE:
	21	key = SvPV(key_sv, len);
028f8eaa	22	RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a	23	OUTPUT:
	24	RETVAL
	25
b60cf05a	26	SV *
	27	delete(hash, key_sv)
	28	PREINIT:
	29	STRLEN len;
	30	const char *key;
	31	INPUT:
	32	HV *hash
	33	SV *key_sv
	34	CODE:
	35	key = SvPV(key_sv, len);
	36	/* It's already mortal, so need to increase reference count. */
028f8eaa	37	RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
b60cf05a	38	OUTPUT:
	39	RETVAL
	40
	41	SV *
858117f8	42	store_ent(hash, key, value)
	43	PREINIT:
	44	SV *copy;
	45	HE *result;
	46	INPUT:
	47	HV *hash
	48	SV *key
	49	SV *value
	50	CODE:
	51	copy = newSV(0);
	52	result = hv_store_ent(hash, key, copy, 0);
	53	SvSetMagicSV(copy, value);
	54	if (!result) {
	55	SvREFCNT_dec(copy);
	56	XSRETURN_EMPTY;
	57	}
	58	/* It's about to become mortal, so need to increase reference count.
	59	*/
	60	RETVAL = SvREFCNT_inc(HeVAL(result));
	61	OUTPUT:
	62	RETVAL
	63
	64
	65	SV *
b60cf05a	66	store(hash, key_sv, value)
	67	PREINIT:
	68	STRLEN len;
	69	const char *key;
	70	SV *copy;
	71	SV **result;
	72	INPUT:
	73	HV *hash
	74	SV *key_sv
	75	SV *value
	76	CODE:
	77	key = SvPV(key_sv, len);
	78	copy = newSV(0);
028f8eaa	79	result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8	80	SvSetMagicSV(copy, value);
b60cf05a	81	if (!result) {
	82	SvREFCNT_dec(copy);
	83	XSRETURN_EMPTY;
	84	}
	85	/* It's about to become mortal, so need to increase reference count.
	86	*/
	87	RETVAL = SvREFCNT_inc(*result);
	88	OUTPUT:
	89	RETVAL
	90
	91
	92	SV *
	93	fetch(hash, key_sv)
	94	PREINIT:
	95	STRLEN len;
	96	const char *key;
	97	SV **result;
	98	INPUT:
	99	HV *hash
	100	SV *key_sv
	101	CODE:
	102	key = SvPV(key_sv, len);
028f8eaa	103	result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a	104	if (!result) {
	105	XSRETURN_EMPTY;
	106	}
	107	/* Force mg_get */
	108	RETVAL = newSVsv(*result);
	109	OUTPUT:
	110	RETVAL
0314122a	111	=pod
	112
	113	sub TIEHASH { bless {}, $_[0] }
	114	sub STORE { $_[0]->{$_[1]} = $_[2] }
	115	sub FETCH { $_[0]->{$_[1]} }
	116	sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
	117	sub NEXTKEY { each %{$_[0]} }
	118	sub EXISTS { exists $_[0]->{$_[1]} }
	119	sub DELETE { delete $_[0]->{$_[1]} }
	120	sub CLEAR { %{$_[0]} = () }
	121
	122	=cut
	123
3e61d65a	124	MODULE = XS::APItest PACKAGE = XS::APItest
	125
	126	PROTOTYPES: DISABLE
	127
	128	void
	129	print_double(val)
	130	double val
	131	CODE:
	132	printf("%5.3f\n",val);
	133
	134	int
	135	have_long_double()
	136	CODE:
	137	#ifdef HAS_LONG_DOUBLE
	138	RETVAL = 1;
	139	#else
	140	RETVAL = 0;
	141	#endif
cabb36f0	142	OUTPUT:
cabb36f0	143	RETVAL
3e61d65a	144
	145	void
	146	print_long_double()
	147	CODE:
	148	#ifdef HAS_LONG_DOUBLE
fc0bf671	149	# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a	150	long double val = 7.0;
	151	printf("%5.3" PERL_PRIfldbl "\n",val);
	152	# else
	153	double val = 7.0;
	154	printf("%5.3f\n",val);
	155	# endif
	156	#endif
	157
	158	void
3e61d65a	159	print_int(val)
	160	int val
	161	CODE:
	162	printf("%d\n",val);
	163
	164	void
	165	print_long(val)
	166	long val
	167	CODE:
	168	printf("%ld\n",val);
	169
	170	void
	171	print_float(val)
	172	float val
	173	CODE:
	174	printf("%5.3f\n",val);
9d911683	175
	176	void
	177	print_flush()
	178	CODE:
	179	fflush(stdout);
d4b90eee	180
	181	void
	182	mpushp()
	183	PPCODE:
	184	EXTEND(SP, 3);
	185	mPUSHp("one", 3);
	186	mPUSHp("two", 3);
	187	mPUSHp("three", 5);
	188	XSRETURN(3);
	189
	190	void
	191	mpushn()
	192	PPCODE:
	193	EXTEND(SP, 3);
	194	mPUSHn(0.5);
	195	mPUSHn(-0.25);
	196	mPUSHn(0.125);
	197	XSRETURN(3);
	198
	199	void
	200	mpushi()
	201	PPCODE:
	202	EXTEND(SP, 3);
d75b63cf	203	mPUSHi(-1);
	204	mPUSHi(2);
	205	mPUSHi(-3);
d4b90eee	206	XSRETURN(3);
	207
	208	void
	209	mpushu()
	210	PPCODE:
	211	EXTEND(SP, 3);
d75b63cf	212	mPUSHu(1);
	213	mPUSHu(2);
	214	mPUSHu(3);
d4b90eee	215	XSRETURN(3);
	216
	217	void
	218	mxpushp()
	219	PPCODE:
	220	mXPUSHp("one", 3);
	221	mXPUSHp("two", 3);
	222	mXPUSHp("three", 5);
	223	XSRETURN(3);
	224
	225	void
	226	mxpushn()
	227	PPCODE:
	228	mXPUSHn(0.5);
	229	mXPUSHn(-0.25);
	230	mXPUSHn(0.125);
	231	XSRETURN(3);
	232
	233	void
	234	mxpushi()
	235	PPCODE:
d75b63cf	236	mXPUSHi(-1);
	237	mXPUSHi(2);
	238	mXPUSHi(-3);
d4b90eee	239	XSRETURN(3);
	240
	241	void
	242	mxpushu()
	243	PPCODE:
d75b63cf	244	mXPUSHu(1);
	245	mXPUSHu(2);
	246	mXPUSHu(3);
d4b90eee	247	XSRETURN(3);
d1f347d7	248
	249
	250	void
	251	call_sv(sv, flags, ...)
	252	SV* sv
	253	I32 flags
	254	PREINIT:
	255	I32 i;
	256	PPCODE:
	257	for (i=0; i<items-2; i++)
	258	ST(i) = ST(i+2); /* pop first two args */
	259	PUSHMARK(SP);
	260	SP += items - 2;
	261	PUTBACK;
	262	i = call_sv(sv, flags);
	263	SPAGAIN;
	264	EXTEND(SP, 1);
	265	PUSHs(sv_2mortal(newSViv(i)));
	266
	267	void
	268	call_pv(subname, flags, ...)
	269	char* subname
	270	I32 flags
	271	PREINIT:
	272	I32 i;
	273	PPCODE:
	274	for (i=0; i<items-2; i++)
	275	ST(i) = ST(i+2); /* pop first two args */
	276	PUSHMARK(SP);
	277	SP += items - 2;
	278	PUTBACK;
	279	i = call_pv(subname, flags);
	280	SPAGAIN;
	281	EXTEND(SP, 1);
	282	PUSHs(sv_2mortal(newSViv(i)));
	283
	284	void
	285	call_method(methname, flags, ...)
	286	char* methname
	287	I32 flags
	288	PREINIT:
	289	I32 i;
	290	PPCODE:
	291	for (i=0; i<items-2; i++)
	292	ST(i) = ST(i+2); /* pop first two args */
	293	PUSHMARK(SP);
	294	SP += items - 2;
	295	PUTBACK;
	296	i = call_method(methname, flags);
	297	SPAGAIN;
	298	EXTEND(SP, 1);
	299	PUSHs(sv_2mortal(newSViv(i)));
	300
	301	void
	302	eval_sv(sv, flags)
	303	SV* sv
	304	I32 flags
	305	PREINIT:
	306	I32 i;
	307	PPCODE:
	308	PUTBACK;
	309	i = eval_sv(sv, flags);
	310	SPAGAIN;
	311	EXTEND(SP, 1);
312	PUSHs(sv_2mortal(newSViv(i)));
313
b8e65a9b	314	void
d1f347d7	315	eval_pv(p, croak_on_error)
	316	const char* p
	317	I32 croak_on_error
d1f347d7	318	PPCODE:
	319	PUTBACK;
	320	EXTEND(SP, 1);
	321	PUSHs(eval_pv(p, croak_on_error));
	322
	323	void
	324	require_pv(pv)
	325	const char* pv
d1f347d7	326	PPCODE:
	327	PUTBACK;
	328	require_pv(pv);
	329
0ca3a874	330	int
	331	exception(throw_e)
	332	int throw_e
	333	OUTPUT:
	334	RETVAL
d1f347d7	335
ef469b03	336	void
	337	mycroak(pv)
	338	const char* pv
	339	CODE:
	340	Perl_croak(aTHX_ "%s", pv);
5d2b1485	341
	342	SV*
	343	strtab()
	344	CODE:
	345	RETVAL = newRV_inc((SV*)PL_strtab);
	346	OUTPUT:
	347	RETVAL