HsPerl5-0.0.1: p5embed.c

#include "p5embed.h"
#include <XSUB.h>
#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);
}

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 cxt)
{
    dSP;
    SV* sv;

    ENTER;
    SAVETMPS;

    sv = newSVpv(code, 0);
#ifdef SvUTF8_on
    SvUTF8_on(sv);
#endif
    eval_sv(sv, cxt);
    SvREFCNT_dec(sv);

    SPAGAIN;
    sv = POPs;
    SvREFCNT_inc(sv);
    PUTBACK;

    if (SvTRUE(ERRSV)) {
        STRLEN n_a;
        fprintf(stderr, "Error eval perl5: \"%s\"\n*** %s\n", code, SvPV(ERRSV,n_a));
    }

    FREETMPS;
    LEAVE;

    return sv;
}

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