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

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

static void throws_exception(int throw_e)
{
  if (throw_e)
    croak("boo\n");
}

static int exception(int throw_e)
{
  dTHR;
  dXCPT;
  SV *caught = get_sv("XS::APItest::exception_caught", 0);

  XCPT_TRY_START {
    throws_exception(throw_e);
  } XCPT_TRY_END

  XCPT_CATCH
  {
    sv_setiv(caught, 1);
    XCPT_RETHROW;
  }

  sv_setiv(caught, 0);

  return 42;
}

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

SV*
eval_pv(p, croak_on_error)
    const char* p
    I32 croak_on_error
    PREINIT:
    	I32 i;
    PPCODE:
	PUTBACK;
	EXTEND(SP, 1);
	PUSHs(eval_pv(p, croak_on_error));

void
require_pv(pv)
    const char* pv
    PREINIT:
    	I32 i;
    PPCODE:
	PUTBACK;
	require_pv(pv);

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