/******************************************************************************* * * !!!!! Do NOT edit this file directly! -- Edit PPPort_xs.PL instead. !!!!! * ******************************************************************************** * * Perl/Pollution/Portability * ******************************************************************************** * * $Revision: 9 $ * $Author: mhx $ * $Date: 2006/01/14 18:07:55 +0100 $ * ******************************************************************************** * * Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz. * Version 2.x, Copyright (C) 2001, Paul Marquess. * Version 1.x, Copyright (C) 1999, Kenneth Albanowski. * * This program is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. * *******************************************************************************/ /* ========== BEGIN XSHEAD ================================================== */ /* =========== END XSHEAD =================================================== */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* ========== BEGIN XSINIT ================================================== */ /* ---- from parts/inc/call ---- */ #define NEED_eval_pv /* ---- from parts/inc/grok ---- */ #define NEED_grok_number #define NEED_grok_numeric_radix #define NEED_grok_bin #define NEED_grok_hex #define NEED_grok_oct /* ---- from parts/inc/newCONSTSUB ---- */ #define NEED_newCONSTSUB /* ---- from parts/inc/newRV ---- */ #define NEED_newRV_noinc /* ---- from parts/inc/snprintf ---- */ #define NEED_my_snprintf /* ---- from parts/inc/sv_xpvf ---- */ #define NEED_vnewSVpvf #define NEED_sv_catpvf_mg #define NEED_sv_catpvf_mg_nocontext #define NEED_sv_setpvf_mg #define NEED_sv_setpvf_mg_nocontext /* ---- from parts/inc/SvPV ---- */ #define NEED_sv_2pv_nolen #define NEED_sv_2pvbyte /* ---- from parts/inc/variables ---- */ #define NEED_PL_signals /* ---- from parts/inc/warn ---- */ #define NEED_warner /* =========== END XSINIT =================================================== */ #include "ppport.h" /* ========== BEGIN XSMISC ================================================== */ /* ---- from parts/inc/exception ---- */ /* defined in module3.c */ int exception(int throw_e); /* ---- from parts/inc/misc ---- */ XS(XS_Devel__PPPort_dXSTARG); /* prototype */ XS(XS_Devel__PPPort_dXSTARG) { dXSARGS; dXSTARG; IV iv; SP -= items; iv = SvIV(ST(0)) + 1; PUSHi(iv); XSRETURN(1); } XS(XS_Devel__PPPort_dAXMARK); /* prototype */ XS(XS_Devel__PPPort_dAXMARK) { dSP; dAXMARK; dITEMS; IV iv; SP -= items; iv = SvIV(ST(0)) - 1; PUSHs(sv_2mortal(newSViv(iv))); XSRETURN(1); } /* ---- from parts/inc/MY_CXT ---- */ #define MY_CXT_KEY "Devel::PPPort::_guts" XS_VERSION typedef struct { /* Put Global Data in here */ int dummy; } my_cxt_t; START_MY_CXT /* ---- from parts/inc/newCONSTSUB ---- */ void call_newCONSTSUB_1(void) { #ifdef PERL_NO_GET_CONTEXT dTHX; #endif newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1)); } extern void call_newCONSTSUB_2(void); extern void call_newCONSTSUB_3(void); /* ---- from parts/inc/sv_xpvf ---- */ static SV * test_vnewSVpvf(pTHX_ const char *pat, ...) { SV *sv; va_list args; va_start(args, pat); #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) sv = vnewSVpvf(pat, &args); #else sv = newSVpv(pat, 0); #endif va_end(args); return sv; } static void test_sv_vcatpvf(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) sv_vcatpvf(sv, pat, &args); #else sv_catpv(sv, pat); #endif va_end(args); } static void test_sv_vsetpvf(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) sv_vsetpvf(sv, pat, &args); #else sv_setpv(sv, pat); #endif va_end(args); } /* ---- from parts/inc/variables ---- */ U32 get_PL_signals_1(void) { return PL_signals; } extern U32 get_PL_signals_2(void); extern U32 get_PL_signals_3(void); /* =========== END XSMISC =================================================== */ MODULE = Devel::PPPort PACKAGE = Devel::PPPort BOOT: /* ---- from parts/inc/misc ---- */ newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, file); newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file); /* ---- from parts/inc/MY_CXT ---- */ { MY_CXT_INIT; /* If any of the fields in the my_cxt_t struct need * to be initialised, do it here. */ MY_CXT.dummy = 42; } ##---------------------------------------------------------------------- ## XSUBs from parts/inc/call ##---------------------------------------------------------------------- I32 G_SCALAR() CODE: RETVAL = G_SCALAR; OUTPUT: RETVAL I32 G_ARRAY() CODE: RETVAL = G_ARRAY; OUTPUT: RETVAL I32 G_DISCARD() CODE: RETVAL = G_DISCARD; OUTPUT: RETVAL 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) char* p I32 croak_on_error PPCODE: PUTBACK; EXTEND(SP, 1); PUSHs(eval_pv(p, croak_on_error)); void call_sv(sv, flags, ...) SV* sv I32 flags PREINIT: I32 i; PPCODE: for (i=0; i 8) /* play safe */ XSRETURN_UNDEF; for (i=2; i 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) x = newSVpvf("[%"SVf"]", x); #endif XPUSHs(x); XSRETURN(1); ##---------------------------------------------------------------------- ## XSUBs from parts/inc/mPUSH ##---------------------------------------------------------------------- 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); ##---------------------------------------------------------------------- ## XSUBs from parts/inc/MY_CXT ##---------------------------------------------------------------------- int MY_CXT_1() CODE: dMY_CXT; RETVAL = MY_CXT.dummy == 42; ++MY_CXT.dummy; OUTPUT: RETVAL int MY_CXT_2() CODE: dMY_CXT; RETVAL = MY_CXT.dummy == 43; OUTPUT: RETVAL int MY_CXT_CLONE() CODE: MY_CXT_CLONE; RETVAL = 42; OUTPUT: RETVAL ##---------------------------------------------------------------------- ## XSUBs from parts/inc/newCONSTSUB ##---------------------------------------------------------------------- void call_newCONSTSUB_1() void call_newCONSTSUB_2() void call_newCONSTSUB_3() ##---------------------------------------------------------------------- ## XSUBs from parts/inc/newRV ##---------------------------------------------------------------------- U32 newRV_inc_REFCNT() PREINIT: SV *sv, *rv; CODE: sv = newSViv(42); rv = newRV_inc(sv); SvREFCNT_dec(sv); RETVAL = SvREFCNT(sv); sv_2mortal(rv); OUTPUT: RETVAL U32 newRV_noinc_REFCNT() PREINIT: SV *sv, *rv; CODE: sv = newSViv(42); rv = newRV_noinc(sv); RETVAL = SvREFCNT(sv); sv_2mortal(rv); OUTPUT: RETVAL ##---------------------------------------------------------------------- ## XSUBs from parts/inc/pvs ##---------------------------------------------------------------------- void newSVpvs() PPCODE: XPUSHs(newSVpvs("newSVpvs")); XSRETURN(1); void sv_catpvs(sv) SV *sv PPCODE: sv_catpvs(sv, "sv_catpvs"); void sv_setpvs(sv) SV *sv PPCODE: sv_setpvs(sv, "sv_setpvs"); void hv_fetchs(hv) SV *hv PREINIT: SV **s; PPCODE: s = hv_fetchs((HV *) SvRV(hv), "hv_fetchs", 0); XPUSHs(sv_mortalcopy(*s)); XSRETURN(1); void hv_stores(hv, sv) SV *hv SV *sv PPCODE: hv_stores((HV *) SvRV(hv), "hv_stores", SvREFCNT_inc(sv), 0); ##---------------------------------------------------------------------- ## XSUBs from parts/inc/snprintf ##---------------------------------------------------------------------- void my_snprintf() PREINIT: char buf[128]; int len; PPCODE: len = my_snprintf(buf, sizeof buf, "foo%s%d", "bar", 42); XPUSHs(newSViv(len)); XPUSHs(newSVpv(buf, 0)); XSRETURN(2); ##---------------------------------------------------------------------- ## XSUBs from parts/inc/Sv_set ##---------------------------------------------------------------------- IV TestSvUV_set(sv, val) SV *sv UV val CODE: SvUV_set(sv, val); RETVAL = SvUVX(sv) == val ? 42 : -1; OUTPUT: RETVAL IV TestSvPVX_const(sv) SV *sv CODE: RETVAL = strEQ(SvPVX_const(sv), "mhx") ? 43 : -1; OUTPUT: RETVAL IV TestSvPVX_mutable(sv) SV *sv CODE: RETVAL = strEQ(SvPVX_mutable(sv), "mhx") ? 44 : -1; OUTPUT: RETVAL void TestSvSTASH_set(sv, name) SV *sv char *name CODE: sv = SvRV(sv); SvREFCNT_dec(SvSTASH(sv)); SvSTASH_set(sv, (HV*) SvREFCNT_inc(gv_stashpv(name, 0))); ##---------------------------------------------------------------------- ## XSUBs from parts/inc/sv_xpvf ##---------------------------------------------------------------------- SV * vnewSVpvf() CODE: RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42); OUTPUT: RETVAL SV * sv_vcatpvf(sv) SV *sv CODE: RETVAL = newSVsv(sv); test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); OUTPUT: RETVAL SV * sv_vsetpvf(sv) SV *sv CODE: RETVAL = newSVsv(sv); test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42); OUTPUT: RETVAL void sv_catpvf_mg(sv) SV *sv CODE: #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) sv_catpvf_mg(sv, "%s-%d", "Perl", 42); #endif void Perl_sv_catpvf_mg(sv) SV *sv CODE: #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43); #endif void sv_catpvf_mg_nocontext(sv) SV *sv CODE: #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) #ifdef PERL_IMPLICIT_CONTEXT sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44); #else sv_catpvf_mg(sv, "%s-%d", "-Perl", 44); #endif #endif void sv_setpvf_mg(sv) SV *sv CODE: #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) sv_setpvf_mg(sv, "%s-%d", "mhx", 42); #endif void Perl_sv_setpvf_mg(sv) SV *sv CODE: #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43); #endif void sv_setpvf_mg_nocontext(sv) SV *sv CODE: #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) #ifdef PERL_IMPLICIT_CONTEXT sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44); #else sv_setpvf_mg(sv, "%s-%d", "bar", 44); #endif #endif ##---------------------------------------------------------------------- ## XSUBs from parts/inc/SvPV ##---------------------------------------------------------------------- IV SvPVbyte(sv) SV *sv PREINIT: STRLEN len; const char *str; CODE: str = SvPVbyte(sv, len); RETVAL = strEQ(str, "mhx") ? (IV) len : (IV) -1; OUTPUT: RETVAL IV SvPV_nolen(sv) SV *sv PREINIT: const char *str; CODE: str = SvPV_nolen(sv); RETVAL = strEQ(str, "mhx") ? 42 : 0; OUTPUT: RETVAL ##---------------------------------------------------------------------- ## XSUBs from parts/inc/threads ##---------------------------------------------------------------------- IV no_THX_arg(sv) SV *sv CODE: RETVAL = 1 + sv_2iv(sv); OUTPUT: RETVAL void with_THX_arg(error) char *error PPCODE: Perl_croak(aTHX_ "%s", error); ##---------------------------------------------------------------------- ## XSUBs from parts/inc/uv ##---------------------------------------------------------------------- SV * sv_setuv(uv) UV uv CODE: RETVAL = newSViv(1); sv_setuv(RETVAL, uv); OUTPUT: RETVAL SV * newSVuv(uv) UV uv CODE: RETVAL = newSVuv(uv); OUTPUT: RETVAL UV sv_2uv(sv) SV *sv CODE: RETVAL = sv_2uv(sv); OUTPUT: RETVAL UV SvUVx(sv) SV *sv CODE: sv--; RETVAL = SvUVx(++sv); OUTPUT: RETVAL void XSRETURN_UV() PPCODE: XSRETURN_UV(42); void PUSHu() PREINIT: dTARG; PPCODE: TARG = sv_newmortal(); EXTEND(SP, 1); PUSHu(42); XSRETURN(1); void XPUSHu() PREINIT: dTARG; PPCODE: TARG = sv_newmortal(); XPUSHu(43); XSRETURN(1); ##---------------------------------------------------------------------- ## XSUBs from parts/inc/variables ##---------------------------------------------------------------------- int compare_PL_signals() CODE: { U32 ref = get_PL_signals_1(); RETVAL = ref == get_PL_signals_2() && ref == get_PL_signals_3(); } OUTPUT: RETVAL ##---------------------------------------------------------------------- ## XSUBs from parts/inc/warn ##---------------------------------------------------------------------- void warner() CODE: #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) warner(packWARN(WARN_MISC), "warner %s:%d", "bar", 42); #endif void Perl_warner() CODE: #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) Perl_warner(aTHX_ packWARN(WARN_MISC), "Perl_warner %s:%d", "bar", 42); #endif void Perl_warner_nocontext() CODE: #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) Perl_warner_nocontext(packWARN(WARN_MISC), "Perl_warner_nocontext %s:%d", "bar", 42); #endif void ckWARN() CODE: #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) if (ckWARN(WARN_MISC)) Perl_warner_nocontext(packWARN(WARN_MISC), "ckWARN %s:%d", "bar", 42); #endif