view release on metacpan or  search on metacpan

src/perl5/p5embed.c  view on Meta::CPAN

bool
perl5_SvTRUE ( SV * sv )
{
    bool rv;
    rv = SvTRUE(sv);
    return(rv ? 1 : 0);
}

bool
perl5_SvROK ( SV * sv )
{
    bool rv;
    sv_dump(sv);
    rv = SvROK(sv);
    return(rv ? 1 : 0);
}

SV *
perl5_sv_undef ()
{
    return(&PL_sv_undef);
}

SV *
perl5_newSVpvn ( char * pv, int len )
{
    SV *sv = newSVpvn(pv, len);
#ifdef SvUTF8_on
    SvUTF8_on(sv);
#endif
    return(sv);
}

SV *
perl5_newSViv ( int iv )
{
    return(newSViv(iv));
}

SV *
perl5_newSVnv ( double iv )
{
    return(newSVnv(iv));
}

SV **
perl5_apply(SV *sub, SV *inv, SV** args, void *env, int cxt)
{
    SV **arg;
    SV **out;
    SV *rv;
    SV *sv;
    void *old_env = pugs_getenv();
    int count, i;

    dSP;

    ENTER;
    SAVETMPS;

    pugs_setenv(env);

    PUSHMARK(SP);
    if (inv != NULL) {
        XPUSHs(inv);
    }
    for (arg = args; *arg != NULL; arg++) {
        XPUSHs(*arg);
    }
    PUTBACK;

    if (inv != NULL) {
        count = call_method(SvPV_nolen(sub), cxt|G_EVAL);
    }
    else {
        count = call_sv(sub, cxt|G_EVAL);
    }

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

SV *
perl5_get_sv(const char *name)
{
    SV *sv = get_sv(name, 1);
    /* sv_dump(sv); */
    return sv;
}

SV *
perl5_eval(char *code, void *env, int cxt)
{
    dSP;
    SV* sv;
    void *old_env = pugs_getenv();

    ENTER;
    SAVETMPS;

    pugs_setenv(env);

    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;

    pugs_setenv(old_env);
    return sv;
}

bool
perl5_can(SV *inv, char *subname)
{
    int rv;

    dSP;

    ENTER;
    SAVETMPS;

    PUSHMARK(SP);
    XPUSHs(inv);
    XPUSHs(newSVpv(subname, 0));
    PUTBACK;

    call_pv("UNIVERSAL::can", G_SCALAR);

    SPAGAIN;

    rv = (POPi != 0);
    /* printf("Checking: %s->can(%s), ret %d\n", SvPV_nolen(inv), subname, rv); */

    PUTBACK;
    FREETMPS;
    LEAVE;

    return rv;
}

void perl5_finalize ( SV* sv )
{
    SvREFCNT_dec(sv);
}