/* SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-2.0-only
**  Copyright (c) 1996,1997,1998 Ralf S. Engelschall <rse@engelschall.com>
*/

#include "eperl.h"
#include "eperl_perl5.h"
#include <pthread.h>

#ifdef HAVE_PERL_DYNALOADER
extern void boot_DynaLoader _((pTHX_ CV* cv));

/*
**  the Perl XS init function for dynamic library loading
*/
static void Perl5_XSInit(pTHX)
{
   /* do newXS() the available modules */
   DO_NEWXS_STATIC_MODULES
}
#else
#define Perl5_XSInit NULL
#endif /* HAVE_PERL_DYNALOADER */

/*
**
**  sets a Perl scalar variable
**
*/
static void Perl5_SetScalar(pTHX_ char *pname, char *vname, char *vvalue)
{
    dTHR;
    ENTER;
    save_hptr(&PL_curstash);
    PL_curstash = gv_stashpv(pname, true);
    sv_setpv(perl_get_sv(vname, true), vvalue);
    LEAVE;
}

/*
**  remember a Perl scalar variable
**  and set it later
**
**  (this is needed because we have to
**   remember the scalars when parsing
**   the command line, but actually setting
**   them can only be done later when the
**   Perl 5 interpreter is allocated !!)
*/
static char **Perl5_RememberedScalars;
static size_t Perl5_RememberedScalarsLen;
void Perl5_RememberScalar(char *str)
{
    Perl5_RememberedScalars = reallocarray(Perl5_RememberedScalars, Perl5_RememberedScalarsLen + 1, sizeof(*Perl5_RememberedScalars));
    Perl5_RememberedScalars[Perl5_RememberedScalarsLen++] = str;
}

static void Perl5_SetRememberedScalars(pTHX)
{
    for (size_t i = 0; i < Perl5_RememberedScalarsLen; ++i) {
        char *cp = strchr(Perl5_RememberedScalars[i], '=');
        *cp++ = '\0';
        Perl5_SetScalar(aTHX_ "main", Perl5_RememberedScalars[i], cp);
    }
    free(Perl5_RememberedScalars);
}

struct stdfd_thread_state {
    FILE *memfd;
    int pipe[2];
};
static void *stdfd_thread(void *arg)
{
    struct stdfd_thread_state *state = arg;
    FILE *piperd = fdopen(state->pipe[0], "r");
    if (piperd)
        ePerl_CopyFILE(piperd, state->memfd);
    state->pipe[0] = -1;
    fclose(piperd);
    return 0;
}
static void stdfd_thread_cu(struct stdfd_thread_state *state, pthread_t *thread)
{
    if (state->pipe[1] != -1) {
        close(state->pipe[1]);
        state->pipe[1] = -1;
    }
    if (*thread) {
        pthread_join(*thread, NULL);
        *thread = 0;
    }
    if (state->pipe[0] != -1) {
        close(state->pipe[0]);
        state->pipe[0] = -1;
    }
    if (state->memfd) {
        fclose(state->memfd);
        state->memfd = NULL;
    }
}

int Perl5_Run(int myargc, char **myargv, enum runtime_mode mode, bool fCheck, bool keepcwd, int *cwd,
              const char *sourcedir, const char *source, const char *perlscript, char **stdoutBuf, size_t *nstdoutBuf)
{
    int rc;
    bool rc_checkstderr = false;
    PerlInterpreter *my_perl = NULL;
    char *stderrBuf;
    size_t nstderrBuf;
    pthread_t stdout_thread = 0, stderr_thread = 0;

    struct stdfd_thread_state perlstdout = {open_memstream( stdoutBuf,  nstdoutBuf), {-1, -1}};
    struct stdfd_thread_state perlstderr = {open_memstream(&stderrBuf, &nstderrBuf), {-1, -1}};
    if (pipe2(perlstdout.pipe, O_CLOEXEC) ||
        pipe2(perlstderr.pipe, O_CLOEXEC) ||
        ((errno = pthread_create(&stdout_thread, NULL, stdfd_thread, &perlstdout)) && ((stdout_thread = 0), true)) ||
        ((errno = pthread_create(&stderr_thread, NULL, stdfd_thread, &perlstderr)) && ((stderr_thread = 0), true))) {
        PrintError(mode, source, NULL, NULL, NULL, "Cannot open script I/O: %s", strerror(errno));
        CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
    }
    IO_redirect_stdout(perlstdout.pipe[1]);
    IO_redirect_stderr(perlstderr.pipe[1]);
    close(perlstdout.pipe[1]);
    close(perlstderr.pipe[1]);
    perlstdout.pipe[1] = -1;
    perlstderr.pipe[1] = -1;


    /*  now allocate the Perl interpreter  */
    PERL_SYS_INIT(&myargc, &myargv);
    my_perl = perl_alloc();
    perl_construct(my_perl);

    /*  now parse the script!
        NOTICE: At this point, the script gets
        only _parsed_, not evaluated/executed!  */
    rc = perl_parse(my_perl, Perl5_XSInit, myargc, myargv, NULL);
    if (rc != 0) {
        IO_restore_stderr();
        stdfd_thread_cu(&perlstderr, &stderr_thread);
        if (fCheck && mode == MODE_FILTER) {
            if (nstderrBuf) {
                ePerl_SubstErrorLog(&stderrBuf, &nstderrBuf, perlscript, source);
                fwrite(stderrBuf, 1, nstderrBuf, stderr);
            }
            CU(EX_FAIL);
        }
        else {
            PrintError(mode, source, perlscript, &stderrBuf, &nstderrBuf, "Perl parsing error (interpreter rc=%d)", rc);
            CU(mode == MODE_FILTER ? EX_FAIL : EX_OK);
        }
    }

    /* Stop when we are just doing a syntax check */
    if (fCheck && mode == MODE_FILTER)
        CU(-1);  // sentinel "ok :), quick exit"

    /* change to directory of script:
       this actually is not important to us, but really useful
       for the ePerl source file programmer!! */
    if (!keepcwd) {
        /* if running as a Unix filter remember the cwd for outputfile */
        if (mode == MODE_FILTER)
            *cwd = *cwd != -1 ? *cwd : open(".", O_PATH | O_CLOEXEC);
        /* determine dir of source file and switch to it */
        if (strcmp(sourcedir, "."))
            chdir(sourcedir);
    }

    Perl5_SetRememberedScalars(aTHX);  // eperl -d
    rc = perl_run(my_perl);
    rc_checkstderr = true;

CUS:
    /* Ok, the script got evaluated. Now we can destroy
       and de-allocate the Perl interpreter */
    if (my_perl) {
       perl_destruct(my_perl);
       perl_free(my_perl);
    }

    IO_restore_stdout();
    IO_restore_stderr();

    stdfd_thread_cu(&perlstdout, &stdout_thread);
    stdfd_thread_cu(&perlstderr, &stderr_thread);

    if (rc_checkstderr) {
        /*  when the Perl interpreter failed or there
            is data on stderr, we print a error page */
        if (rc != 0 || nstderrBuf) {
            PrintError(mode, source, perlscript, &stderrBuf, &nstderrBuf, "Perl runtime error (interpreter rc=%d)", rc);
            rc = mode == MODE_FILTER ? EX_FAIL : EX_OK;
        }
    }
    free(stderrBuf);
    return rc;
}
