#include "p5embed.h" #include #include "perlxsi.c" /* define to enable pugsembed debug messages */ #define PERL5_EMBED_DEBUG 0 #if PERL5_EMBED_DEBUG #define oRZ "" #define hate Perl_croak(aTHX_ "hate software") #else #define oRZ "#" #define hate #endif /* Workaround for mapstart: the only op which needs a different ppaddr */ #undef Perl_pp_mapstart #define Perl_pp_mapstart Perl_pp_grepstart #undef OP_MAPSTART #define OP_MAPSTART OP_GREPSTART static PerlInterpreter *my_perl; int _P5EMBED_INIT = 0; SV * perl5_sv_undef () { return(&PL_sv_undef); } SV * perl5_sv_yes () { return(&PL_sv_yes); } SV * perl5_sv_no () { return(&PL_sv_no); } PerlInterpreter * perl5_init ( int argc, char **argv ) { int exitstatus; int i; #ifdef PERL_GPROF_MONCONTROL PERL_GPROF_MONCONTROL(0); #endif #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && defined(HAS_PTHREAD_ATFORK) /* XXX Ideally, this should really be happening in perl_alloc() or * perl_construct() to keep libperl.a transparently fork()-safe. * It is currently done here only because Apache/mod_perl have * problems due to lack of a call to cancel pthread_atfork() * handlers when shared objects that contain the handlers may * be dlclose()d. This forces applications that embed perl to * call PTHREAD_ATFORK() explicitly, but if and only if it hasn't * been called at least once before in the current process. * --GSAR 2001-07-20 */ PTHREAD_ATFORK(Perl_atfork_lock, Perl_atfork_unlock, Perl_atfork_unlock); #endif if (!PL_do_undump) { my_perl = perl_alloc(); if (!my_perl) exit(1); perl_construct( my_perl ); PL_perl_destruct_level = 0; } #ifdef PERL_EXIT_DESTRUCT_END PL_exit_flags |= PERL_EXIT_DESTRUCT_END; #endif /* PERL_EXIT_DESTRUCT_END */ #ifdef PERL_EXIT_EXPECTED PL_exit_flags |= PERL_EXIT_EXPECTED; #endif /* PERL_EXIT_EXPECTED */ #if (defined(CSH) && defined(PL_cshname)) if (!PL_cshlen) PL_cshlen = strlen(PL_cshname); #endif exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL); if (exitstatus == 0) exitstatus = perl_run( my_perl ); _P5EMBED_INIT = 1; /* newXS((char*) "pugs::guts::invoke", _pugs_guts_invoke, (char*)__FILE__); newXS((char*) "pugs::guts::eval_apply", _pugs_guts_eval_apply, (char*)__FILE__); */ #if PERL5_EMBED_DEBUG fprintf(stderr, "(%s)", pugs_guts_code); #endif /* eval_pv(pugs_guts_code, TRUE); */ if (SvTRUE(ERRSV)) { STRLEN n_a; printf("Error init perl: %s\n", SvPV(ERRSV,n_a)); exit(1); } return my_perl; } SV ** perl5_eval(char *code, int len, int cxt) { dSP; SV* sv; int count; ENTER; SAVETMPS; sv = newSVpvn(code, len); #ifdef SvUTF8_on SvUTF8_on(sv); #endif count = eval_sv(sv, cxt); SvREFCNT_dec(sv); return perl5_return_conv(count); } SV ** perl5_return_conv (int count) { SV **out; int i; dSP; SPAGAIN; if (SvTRUE(ERRSV)) { Newz(42, out, 3, SV*); if (SvROK(ERRSV)) { out[0] = newSVsv(ERRSV); out[1] = NULL; } else { out[0] = ERRSV; out[1] = ERRSV; /* for Haskell-side to read PV */ } out[2] = NULL; } else { Newz(42, out, count+2, SV*); out[0] = NULL; for (i=count; i>0; --i) { out[i] = newSVsv(POPs); } out[count+1] = NULL; } PUTBACK; FREETMPS; LEAVE; /* pugs_setenv(old_env); */ return out; } char * perl5_SvPV ( SV *sv ) { char *rv; rv = SvPV_nolen(sv); return rv; } SV * perl5_newSVpvn ( char * pv, int len ) { SV *sv = newSVpvn(pv, len); #ifdef SvUTF8_on SvUTF8_on(sv); #endif return(sv); } SV ** perl5_apply(SV *sub, SV *inv, SV** args, int cxt) { SV **arg; SV *rv; SV *sv; dSP; ENTER; SAVETMPS; PUSHMARK(SP); if (inv != NULL) { XPUSHs(inv); } for (arg = args; *arg != NULL; arg++) { XPUSHs(*arg); } PUTBACK; if (inv != NULL) { perl5_return_conv(call_method(SvPV_nolen(sub), cxt|G_EVAL)); } else { perl5_return_conv(call_sv(sub, cxt|G_EVAL)); } } SV * perl5_newSViv ( int iv ) { return(newSViv(iv)); } SV * perl5_newSVnv ( double iv ) { return(newSVnv(iv)); } int perl5_SvIV ( SV *sv ) { return((int)SvIV(sv)); } double perl5_SvNV ( SV *sv ) { return((double)SvNV(sv)); } bool perl5_SvTRUE ( SV * sv ) { bool rv; rv = SvTRUE(sv); return(rv ? 1 : 0); }