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

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