/* 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 "eperl_security.h"
#include <getopt.h>
#include <libgen.h>
#ifdef HAVE_PWD_H
#include <pwd.h>
#endif
#ifdef HAVE_GRP_H
#include <grp.h>
#endif


/*
 *  Display an error message and a logfile content as a HTML page
 */
void PrintError(enum runtime_mode mode, const char *scripturl, const char *scriptfile, char **errstr, size_t *errstrN, const char *str, ...)
{
    char *ca;
    va_list ap;
    va_start(ap, str);
    if (vasprintf(&ca, str, ap) == -1)
        ca = NULL;
    va_end(ap);

    IO_restore_stdout();
    IO_restore_stderr();
    if (errstr)
        ePerl_SubstErrorLog(errstr, errstrN, scriptfile, scripturl);

    if (mode == MODE_CGI || mode == MODE_NPHCGI) {
        const char *script_name = getenv("SCRIPT_NAME") ?: "UNKNOWN_IMG_DIR";
        if (mode == MODE_NPHCGI)
            HTTP_PrintResponseHeaders("");
        printf("Content-Type: text/html\r\n"
               "\r\n"
               "<html>\n"
               "<title>ePerl: ERROR: %1$s</title>\n"
               "<body bgcolor=\"#d0d0d0\">\n"
               "<a href=\"http://www.engelschall.com/sw/eperl/\"><img src=\"%2$s/powered.gif\" alt=\"Powered By ePerl\" align=right></a>\n"
               "<table cellspacing=0 cellpadding=0>\n"
               "<tr>\n"
               "<td><img src=\"%2$s/logo.gif\" alt=\"Embedded Perl 5 Language\"></td>\n"
               "</tr>\n"
               "<tr>\n"
               "<td align=right><b>Version %3$s</b></td>\n"
               "</tr>\n"
               "</table>\n"
               "<p>\n"
               "<table bgcolor=\"#d0d0f0\" cellspacing=0 cellpadding=10>\n"
               "<tr><th align=left bgcolor=\"#b0b0d0\">"
               "ERROR:"
               "</th></tr>\n"
               "<tr><td>\n"
               "<h1><font color=\"#3333cc\">%1$s</font></h1>\n"
               "</td></tr>\n"
               "</table>\n",
               ca, script_name, EPERL_VERSION_SHORT);
        if (errstr && *errstrN) {
            puts("<p>"
                 "<table bgcolor=\"#e0e0e0\" cellspacing=0 cellpadding=10>\n"
                 "<tr><th align=left bgcolor=\"#c0c0c0\">"
                 "Contents of STDERR channel:"
                 "</th></tr>\n"
                 "<tr><td>\n"
                 "<pre>");
            fwrite(*errstr, 1, *errstrN, stdout);
            puts("</pre>"
                 "</td></tr>\n"
                 "</table>");
        }
        puts("</body>\n"
             "</html>");
        fflush(stdout);
    }
    else {
        fprintf(stderr, "ePerl:Error: %s\n", ca);
        if (errstr && *errstrN) {
            fprintf(stderr, "\n"
                            "---- Contents of STDERR channel: ---------\n");
            fwrite(*errstr, 1, *errstrN, stderr);
            if ((*errstr)[strlen(*errstr) - 1] != '\n')
                fprintf(stderr, "\n");
            fprintf(stderr, "------------------------------------------\n");
        }
        fflush(stderr);
    }
    free(ca);
}

static void give_version(void)
{
    fprintf(stdout, "This is ePerl, Version %s (%s)\n"
                    "\n"
                    "Copyright (c) 1996-2000 Ralf S. Engelschall <rse@engelschall.com>\n"
                    "\n"
                    "This program is distributed in the hope that it will be useful,\n"
                    "but WITHOUT ANY WARRANTY; without even the implied warranty of\n"
                    "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either\n"
                    "the Artistic License or the GNU General Public License for more details.\n",
                    EPERL_VERSION_SHORT, EPERL_VERSION_DATE);
}

static void give_version_extended(void)
{
    give_version();
    fprintf(stdout, "\n"
                    "Characteristics of this binary:\n"
                    "  Perl Version    : %s (%s)\n"
                    "  Perl Library    : %s/CORE/libperl.a\n"
                    "  Perl DynaLoader : %s\n"
                    "  System Libs     : %s\n",
                    AC_perl_vers, AC_perl_prog, AC_perl_archlib, AC_perl_dla, AC_perl_libs);
}

static void give_img(enum runtime_mode mode, const uint8_t *data, size_t len, const char *type)
{
    if (mode == MODE_NPHCGI)
        HTTP_PrintResponseHeaders("");
    printf("Content-Type: image/%s\r\n"
           "\r\n",
           type);
    fwrite(data, 1, len, stdout);
}

static void give_usage(const char *self)
{
    fprintf(stderr, "Usage: %s [options] [scriptfile]\n"
                    "\n"
                    "Input Options:\n"
                    "  -d, --define=NAME=VALUE   define global Perl variable ($main::name)\n"
                    "  -D, --setenv=NAME=VALUE   define environment variable ($ENV{'name'})\n"
                    "  -I, --includedir=PATH     add @INC/#include directory\n"
                    "  -B, --block-begin=STR     set begin block delimiter\n"
                    "  -E, --block-end=STR       set end block delimiter\n"
                    "  -n, --nocase              force block delimiters to be case insensitive\n"
                    "  -k, --keepcwd             force keeping of current working directory\n"
                    "  -P, --preprocess          enable ePerl Preprocessor\n"
                    "  -C, --convert-entity      enable HTML entity conversion for ePerl blocks\n"
                    "  -L, --line-continue       enable line continuation via backslashes\n"
                    "\n"
                    "Output Options:\n"
                    "  -T, --tainting            enable Perl Tainting\n"
                    "  -w, --warnings            enable Perl Warnings\n"
                    "  -x, --debug               enable ePerl debugging output on console\n"
                    "  -m, --mode=STR            force runtime mode to FILTER, CGI or NPH-CGI\n"
                    "  -o, --outputfile=PATH     force the output to be send to this file (default=stdout)\n"
                    "  -c, --check               run syntax check only and exit (no execution)\n"
                    "\n"
                    "Giving Feedback:\n"
                    "  -r, --readme              display ePerl README file\n"
                    "  -l, --license             display ePerl license files (COPYING and ARTISTIC)\n"
                    "  -v, --version             display ePerl VERSION id\n"
                    "  -V, --ingredients         display ePerl VERSION id & compilation parameters\n"
                    "  -h, --help                display ePerl usage list (this one)\n",
                    self);
}

static const char **RememberedINC;
static size_t RememberedINCLen;
static void RememberINC(const char *str)
{
    RememberedINC = reallocarray(RememberedINC, RememberedINCLen + 1, sizeof(*RememberedINC));
    RememberedINC[RememberedINCLen++] = str;
}

static void mysighandler(int rc);
static void myinit(void)
{
    struct sigaction sa = {.sa_handler = mysighandler};
    sigfillset(&sa.sa_mask);
    sigaction(SIGINT,  &sa, NULL);
    sigaction(SIGTERM, &sa, NULL);

    atexit(remove_mytmpfiles);
}

static void mysighandler(int rc)
{
    (void) rc;

    IO_restore_stderr();
    fputs("ePerl: **INTERRUPT**\n", stderr);
    exit(EX_FAIL);
}

static const struct option options[] = {
    { "define",         required_argument, NULL, 'd' },
    { "setenv",         required_argument, NULL, 'D' },
    { "includedir",     required_argument, NULL, 'I' },
    { "block-begin",    required_argument, NULL, 'B' },
    { "block-end",      required_argument, NULL, 'E' },
    { "nocase",         no_argument,       NULL, 'n' },
    { "keepcwd",        no_argument,       NULL, 'k' },
    { "preprocess",     no_argument,       NULL, 'P' },
    { "convert-entity", no_argument,       NULL, 'C' },
    { "line-continue",  no_argument,       NULL, 'L' },
    { "tainting",       no_argument,       NULL, 'T' },
    { "warnings",       no_argument,       NULL, 'w' },
    { "debug",          no_argument,       NULL, 'x' },
    { "mode",           required_argument, NULL, 'm' },
    { "outputfile",     required_argument, NULL, 'o' },
    { "check",          no_argument,       NULL, 'c' },
    { "readme",         no_argument,       NULL, 'r' },
    { "license",        no_argument,       NULL, 'l' },
    { "version",        no_argument,       NULL, 'v' },
    { "ingredients",    no_argument,       NULL, 'V' },
    { "help",           no_argument,       NULL, 'h' },
    {0},
};

/*
 *  main procedure
 */
int main(int argc, char **argv)
{
    int rc;
    FILE *fp;
    char *cpBufScript = NULL;
    char *cpBufSprinkled2Plain = NULL;
    char *progname;
    size_t nBuf;
    const char *source = NULL;
    char *cp;
    struct stat st;
    struct passwd *pw;
    struct passwd *pw2;
    struct group *gr;
    int uid = 0, gid = 0;
    bool keepcwd = false;
    int c;
    char *cpScript = NULL;
    bool allow;
    int n, k;
    char *outputfile = NULL;
    int cwd = -1;
    bool fCheck = false;
    bool fTaint = false;
    bool fWarn = false;
    bool fPP = false;
    bool fDebug = false;
    bool fOkSwitch;
    enum runtime_mode mode = MODE_UNKNOWN;
    const char *ePerl_begin_delimiter    = NULL;
    const char *ePerl_end_delimiter      = NULL;
    bool ePerl_case_sensitive_delimiters = true;
    bool ePerl_convert_entities          = false;

    /*  first step: our process initialisation */
    myinit();

    /*  second step: canonicalize program name */
    progname = argv[0];
    if ((cp = strrchr(progname, '/')) != NULL) {
        progname = cp+1;
    }

    /*  parse the option arguments */
    while ((c = getopt_long(argc, argv, "d:D:I:B:E:nkPCLTwxm:o:crlvVh", options, NULL)) != -1)
        switch (c) {
            case 'd':
                Perl5_RememberScalar(optarg);
                break;
            case 'D':
                putenv(optarg);
                break;
            case 'I':
                RememberINC(optarg);
                break;
            case 'B':
                ePerl_begin_delimiter = optarg;
                break;
            case 'E':
                ePerl_end_delimiter = optarg;
                break;
            case 'n':
                ePerl_case_sensitive_delimiters = false;
                break;
            case 'k':
                keepcwd = true;
                break;
            case 'P':
                fPP = true;
                break;
            case 'C':
                ePerl_convert_entities = true;
                break;
            case 'L':
                ePerl_line_continuation = true;
                break;
            case 'T':
                fTaint = true;
                break;
            case 'w':
                fWarn = true;
                break;
            case 'x':
                fDebug = true;
                break;
            case 'm':
                if (strcasecmp(optarg, "f") == 0     ||
                    strcasecmp(optarg, "filter") == 0  ) {
                    mode = MODE_FILTER;
                }
                else if (strcasecmp(optarg, "c") == 0   ||
                         strcasecmp(optarg, "cgi") == 0   ) {
                    mode = MODE_CGI;
                }
                else if (strcasecmp(optarg, "n") == 0      ||
                         strcasecmp(optarg, "nph") == 0    ||
                         strcasecmp(optarg, "nphcgi") == 0 ||
                         strcasecmp(optarg, "nph-cgi") == 0  ) {
                    mode = MODE_NPHCGI;
                }
                else {
                    PrintError(mode, "", NULL, NULL, NULL, "Unknown runtime mode %s", optarg);
                    return EX_USAGE;
                }
                break;
            case 'o':
                outputfile = optarg;
                break;
            case 'c':
                fCheck = true;
                break;
            case 'r':
                (void) fwrite(ePerl_README, 1, ePerl_README_size, stdout);
                return EX_OK;
            case 'l':
                (void) fwrite(ePerl_LICENSE, 1, ePerl_LICENSE_size, stdout);
                return EX_OK;
            case 'v':
                give_version();
                return EX_OK;
            case 'V':
                give_version_extended();
                return EX_OK;
            case 'h':
                give_usage(progname);
                return EX_OK;
            case '?':
                fprintf(stderr, "Try %s --help for more information.\n", progname);
                return EX_USAGE;
        }

    /*
     *  determine source filename and runtime mode
     */
    const char *cpCGIgi = getenv("GATEWAY_INTERFACE") ?: "";
    const char *cpCGIpt = getenv("PATH_TRANSLATED") ?: "";
    const char *cpCGIqs = getenv("QUERY_STRING") ?: "";
    bool fCGIqsEqualChar = strchr(cpCGIqs, '=');

    /*
     *  Server-Side-Scripting-Language:
     *
     *  Request:
     *      /url/to/nph-eperl/url/to/script.phtml[?query-string]
     *  Environment:
     *      GATEWAY_INTERFACE=CGI/1.1
     *      SCRIPT_NAME=/url/to/nph-eperl
     *      SCRIPT_FILENAME=/path/to/nph-eperl
     *      PATH_INFO=/url/to/script.phtml
     *      PATH_TRANSLATED=/path/to/script.phtml
     *      a) QUERY_STRING=""
     *         optind=argc
     *      b) QUERY_STRING=query-string (containing "=" char)
     *         optind=argc
     *      c) QUERY_STRING=query-string (containing NO "=" char)
     *         optind=argc-1
     *         argv[optind]=query-string
     */
    const char *sssl_standalone;
    if (   cpCGIgi[0] != '\0'
        && cpCGIpt[0] != '\0'
        && (   (   optind == argc
                && (   cpCGIqs[0] == '\0'
                    || fCGIqsEqualChar      ) )
            || (   optind == argc-1
                && !fCGIqsEqualChar
                && !strcmp(argv[optind], cpCGIqs) )      ) ) {

        if (strncasecmp(cpCGIgi, "CGI/1", 5) != 0) {
            fprintf(stderr, "ePerl:Error: Unknown gateway interface: NOT CGI/1.x\n");
            return EX_IOERR;
        }

        /*  CGI/1.1 or NPH-CGI/1.1 script,
            source in PATH_TRANSLATED. */
        source = cpCGIpt;
        sssl_standalone = "SSSL";

    purecgi_nph_and_proctitle:
        /*  determine whether pure CGI or NPH-CGI mode */
        if (mode == MODE_UNKNOWN) {
            mode = MODE_CGI;
            if ((cp = getenv("SCRIPT_FILENAME")) != NULL) {
                char *cp2 = cp;
                if ((cp = strrchr(cp2, '/')) != NULL)
                    ++cp;
                else
                    cp = cp2;
                if (!strncasecmp(cp, "nph-", 4))
                    mode = MODE_NPHCGI;
            }
        }

#if HAVE_SETPROCTITLE
        /* set the command line for ps output */
        setproctitle("%s %s [%sCGI/%s]", argv[0], source, mode == MODE_NPHCGI ? "NPH-" : "", sssl_standalone);
#else
        (void)sssl_standalone;
#endif
    }
    /*
     *  Stand-Alone inside Webserver environment:
     *
     *  Request:
     *      /url/to/script.cgi[/path-info][?query-string]
     *      [script.cgi has shebang #!/path/to/eperl]
     *  Environment:
     *      GATEWAY_INTERFACE=CGI/1.1
     *      SCRIPT_NAME=/url/to/script.cgi
     *      SCRIPT_FILENAME=/path/to/script.cgi
     *      PATH_INFO=/path-info
     *      PATH_TRANSLATED=/path/to/docroot/path-info
     *      a) QUERY_STRING=""
     *         optind=argc-1
     *         argv[optind]=/path/to/script.cgi
     *      b) QUERY_STRING=query-string (containing "=" char)
     *         optind=argc-1
     *         argv[optind]=/path/to/script.cgi
     *      c) QUERY_STRING=query-string (containing NO "=" char)
     *         optind=argc-2
     *         argv[optind]=/path/to/script.cgi
     *         argv[optind+1]=query-string
     */
    else if (   cpCGIgi[0] != '\0'
             && ( (   optind == argc-1
                   && (   cpCGIqs[0] == '\0'
                       || fCGIqsEqualChar      ) ) ||
                  (   optind == argc-2
                   && !fCGIqsEqualChar
                   && !strcmp(argv[optind+1], cpCGIqs)) ) ) {

        if (strncasecmp(cpCGIgi, "CGI/1", 5) != 0) {
            fprintf(stderr, "ePerl:Error: Unknown gateway interface: NOT CGI/1.x\n");
            return EX_IOERR;
        }

        /*  CGI/1.1 or NPH-CGI/1.1 script,
            source in ARGV */
        source = argv[optind];
        sssl_standalone = "stand-alone";

        goto purecgi_nph_and_proctitle;
    }
    /*
     *  Stand-Alone outside Webserver environment:
     *
     *  Request:
     *      eperl script
     *  Environment:
     *      GATEWAY_INTERFACE=""
     *      SCRIPT_NAME=""
     *      SCRIPT_FILENAME=""
     *      PATH_INFO=""
     *      PATH_TRANSLATED=""
     *      QUERY_STRING=""
     *      optind=argc-1
     *      argv[optind]=script
     */
    else if (   cpCGIgi[0] == '\0'
             && cpCGIpt[0] == '\0'
             && cpCGIqs[0] == '\0'
             && optind == argc-1  ) {

        /*  stand-alone filter, source as argument:
            either manually on the console or via shebang */
        source = argv[optind];
        mode   = (mode == MODE_UNKNOWN ? MODE_FILTER : mode);

        /*  provide flexibility by recognizing "-" for stdin */
        if (!strcmp(source, "-")) {
            /* store stdin to tmpfile */
            struct tmpfile tmp = mytmpfile(tmpfile_stdin);
            if (tmp.fd == -1) {
                PrintError(mode, source, NULL, NULL, NULL, "Cannot open tmpfile for writing");
                return EX_IOERR;
            }
            source = tmp.filename;
            if (!(fp = fdopen(tmp.fd, "w")) || !ePerl_CopyFILE(stdin, fp) || fclose(fp)) {
                PrintError(mode, source, NULL, NULL, NULL, "Cannot copy stdin: %s", strerror(errno));
                return EX_IOERR;
            }

            /* stdin script implies keeping of cwd */
            keepcwd = true;
        }
    }
    /*
     *   Any other calling environment is an error...
     */
    else {
        fprintf(stderr, "ePerl:Error: Missing required file to process\n"
                        "ePerl:Error: Use either a filename, '-' for STDIN or PATH_TRANSLATED.\n"
                        "Try %s --help for more information.\n",
                        progname);
        return EX_USAGE;
    }

    /* set default delimiters */
    if (ePerl_begin_delimiter == NULL)
        ePerl_begin_delimiter = (mode == MODE_FILTER) ? "<:" : "<?";
    if (ePerl_end_delimiter == NULL)
        ePerl_end_delimiter   = (mode == MODE_FILTER) ? ":>" : "!>";

    /* the built-in GIF images */
    if ((mode == MODE_CGI || mode == MODE_NPHCGI) && (cp = getenv("PATH_INFO")) != NULL) {
        if (!strcmp(cp, "/logo.gif")) {
            give_img(mode, ePerl_LOGO, ePerl_LOGO_size, "gif");
            return 0;
        }
        else if (!strcmp(cp, "/powered.gif")) {
            give_img(mode, ePerl_POWERED, ePerl_POWERED_size, "png");
            return 0;
        }
    }

    /* CGI modes imply
       - Preprocessor usage
       - HTML entity conversions
       - adding of DOCUMENT_ROOT to include paths */
    if (mode == MODE_CGI || mode == MODE_NPHCGI) {
        fPP = true;
        ePerl_convert_entities = true;
        if ((cp = getenv("DOCUMENT_ROOT")) != NULL)
            RememberINC(cp);
    }

    /* check for existing source file */
    if ((stat(source, &st)) != 0) {
        PrintError(mode, source, NULL, NULL, NULL, "%s does not exist", source);
        return mode == MODE_FILTER ? EX_IOERR : EX_OK;
    }

    /*
     * Security Checks for the CGI modes
     */
    if (mode == MODE_CGI || mode == MODE_NPHCGI) {
        /*
         *  == General Security ==
         */
        /* general security check: allowed file extension */
        if (CGI_NEEDS_ALLOWED_FILE_EXT) {
            allow = false;
            n = strlen(source);
            for (size_t i = 0; i < sizeof(allowed_file_ext) / sizeof(*allowed_file_ext); ++i) {
                k = strlen(allowed_file_ext[i]);
                if (!strcmp(source+n-k, allowed_file_ext[i]))
                    allow = true;
            }
            if (!allow) {
                PrintError(mode, source, NULL, NULL, NULL, "File %s is not allowed to be interpreted by ePerl (wrong extension!)", source);
                return EX_OK;
            }
        }

        /*
         *  == Perl Security ==
         */
        if (CGI_MODES_FORCE_TAINTING)
            fTaint = true;
        if (CGI_MODES_FORCE_WARNINGS)
            fWarn = true;

        /*
         * == UID/GID switching ==
         */
        /* we can only do a switching if we have euid == 0 (root) */
        if (geteuid() == 0) {
            fOkSwitch = true;

            /* get our real user id (= caller uid) */
            uid = getuid();

            /* security check: valid caller uid */
            pw = getpwuid(uid);
            if (SETUID_NEEDS_VALID_CALLER_UID && pw == NULL) {
                if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                    PrintError(mode, source, NULL, NULL, NULL, "Invalid UID %d of caller", uid);
                    return EX_OK;
                }
                else
                    fOkSwitch = false;
            }
            else {
                /* security check: allowed caller uid */
                if (SETUID_NEEDS_ALLOWED_CALLER_UID) {
                    allow = false;
                    for (size_t i = 0; i < sizeof(allowed_caller_uid) / sizeof(*allowed_caller_uid); ++i) {
                        if (isdigit(allowed_caller_uid[i][0]))
                            pw2 = getpwuid(atoi(allowed_caller_uid[i]));
                        else
                            pw2 = getpwnam(allowed_caller_uid[i]);
                        if (pw2 && !strcmp(pw->pw_name, pw2->pw_name)) {
                            allow = true;
                            break;
                        }
                    }
                    if (!allow) {
                        if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                            PrintError(mode, source, NULL, NULL, NULL, "UID %d of caller not allowed", uid);
                            return EX_OK;
                        }
                        else
                            fOkSwitch = false;
                    }
                }
            }

            /* security check: valid owner UID */
            pw = getpwuid(st.st_uid);
            if (SETUID_NEEDS_VALID_OWNER_UID && pw == NULL)
                if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                    PrintError(mode, source, NULL, NULL, NULL, "Invalid UID %d of owner", st.st_uid);
                    return EX_OK;
                }
                else
                    fOkSwitch = false;
            else
                uid = pw->pw_uid;

            /* security check: valid owner GID */
            gr = getgrgid(st.st_gid);
            if (SETUID_NEEDS_VALID_OWNER_GID && gr == NULL)
                if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                    PrintError(mode, source, NULL, NULL, NULL, "Invalid GID %d of owner", st.st_gid);
                    return EX_OK;
                }
                else
                    fOkSwitch = false;
            else
                gid = gr->gr_gid;

            /* security check: file has to stay below owner homedir */
            if (fOkSwitch && SETUID_NEEDS_BELOW_OWNER_HOME) {
                /* preserve current working directory */
                cwd = cwd != -1 ? cwd : open(".", O_PATH | O_CLOEXEC);

                /* determine physical homedir of owner */
                pw = getpwuid(st.st_uid);
                if (chdir(pw->pw_dir) == -1) {
                    if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                        PrintError(mode, source, NULL, NULL, NULL, "Invalid homedir %s of file owner", pw->pw_dir);
                        return EX_OK;
                    }
                    else
                        fOkSwitch = false;
                }
                else {
                    char *dir_home = getcwd(NULL, 0);

                    /* determine physical dir of file */
                    if ((cp = strrchr(source, '/')) == NULL) {
                        if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                            PrintError(mode, source, NULL, NULL, NULL, "Invalid script %s: no absolute path", source);
                            return EX_OK;
                        }
                        else
                            fOkSwitch = false;
                    }
                    else {
                        *cp = '\0';
                        int ch = chdir(source);
                        *cp = '/';
                        if (ch == -1) {
                            if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                                PrintError(mode, source, NULL, NULL, NULL, "Invalid script %s: cannot chdir to its location", source);
                                return EX_OK;
                            }
                            else
                                fOkSwitch = false;
                        }
                        else {
                            char *dir_script = getcwd(NULL, 0);

                            /* dir_home has to be a prefix of dir_script */
                            if (strncmp(dir_script, dir_home, strlen(dir_home)) < 0) {
                                if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                                    PrintError(mode, source, NULL, NULL, NULL, "Invalid script %s: does not stay below homedir of owner", source);
                                    return EX_OK;
                                }
                                else
                                    fOkSwitch = false;
                            }

                            free(dir_script);
                        }
                    }
                    free(dir_home);
                }

                /* restore original cwd */
                fchdir(cwd);
            }

            if (fOkSwitch && uid != 0 && gid != 0) {
                /* switch to new uid/gid */
                if (((setgid(gid)) != 0) || (initgroups(pw->pw_name,gid) != 0)) {
                    PrintError(mode, source, NULL, NULL, NULL, "Unable to set GID %d: setgid/initgroups failed", gid);
                    return mode == MODE_FILTER ? EX_IOERR : EX_OK;
                }
                if ((setuid(uid)) != 0) {
                    PrintError(mode, source, NULL, NULL, NULL, "Unable to set UID %d: setuid failed", uid);
                    return mode == MODE_FILTER ? EX_IOERR : EX_OK;
                }
            }
        }
    }

    /* Security! Eliminate effective root permissions if we are running setuid */
    if (geteuid() == 0) {
        setegid(getgid());
        seteuid(getuid());
    }

    /* read source file into internal buffer */
    if (!ePerl_ReadSourceFile(source, &cpBufScript, &nBuf)) {
        PrintError(mode, source, NULL, NULL, NULL, "Cannot open source file %s for reading\n%s", source, ePerl_ErrorString);
        return mode == MODE_FILTER ? EX_IOERR : EX_OK;
    }

    /* strip shebang prefix */
    cpScript = cpBufScript;
    if (strncmp(cpScript, "#!", 2) == 0) {
        char *line = memchr(cpBufScript, '\n', nBuf);
        if (!line)
            cpScript = "";
        else
            cpScript = line + 1;
    }

    /* now set the additional env vars */
    {
        char *realsource = realpath(source, NULL), *fellbacksource = realsource ?: (char *)source, *cpPath;
        char *bn = basename(fellbacksource);
        putenvf("SCRIPT_SRC_PATH=%s", fellbacksource);
        putenvf("SCRIPT_SRC_PATH_FILE=%s", bn);
        putenvf("SCRIPT_SRC_PATH_DIR=%.*s", (int)(bn - fellbacksource) ?: 1, fellbacksource);

        if ((cpPath = getenv("PATH_INFO")) != NULL) {
            const char *cpHost = getenv("SERVER_NAME") ?: "localhost";
            const char *cpPort = getenv("SERVER_PORT");
            if (cpPort && !strcmp(cpPort, "80"))
                cpPort = NULL;

            char *fullurl;
            int fullurllen = asprintf(&fullurl, "http://%s%.*s%s%s", cpHost, !!cpPort, ":", cpPort ?: "", cpPath);
            bn = fullurl[fullurllen - 1] == '/' ? fullurl + fullurllen : basename(fullurl);
            putenvf("SCRIPT_SRC_URL=%s", fullurl);
            putenvf("SCRIPT_SRC_URL_FILE=%s", bn);
            putenvf("SCRIPT_SRC_URL_DIR=%.*s", (int)(bn - fullurl) ?: 1, fullurl);
            free(fullurl);
        }
        else {
            putenvf("SCRIPT_SRC_URL=file://%s", fellbacksource);
            putenvf("SCRIPT_SRC_URL_FILE=%s", bn);
            putenvf("SCRIPT_SRC_URL_DIR=file://%.*s", (int)(bn - fellbacksource) ?: 1, fellbacksource);
        }
        free(realsource);
    }

    putenvf("SCRIPT_SRC_SIZE=%zu", nBuf);
    stat(source, &st);
    struct tm *tm = localtime(&st.st_mtime);
    putenvf("SCRIPT_SRC_MODIFIED=%lld", (long long)st.st_mtime);
    putenvf("SCRIPT_SRC_MODIFIED_CTIME=%.24s", ctime(&st.st_mtime));
    putenvf("SCRIPT_SRC_MODIFIED_ISOTIME=%02d-%02d-%04d %02d:%02d", tm->tm_mday, tm->tm_mon+1, tm->tm_year+1900, tm->tm_hour, tm->tm_min);
    if ((pw = getpwuid(st.st_uid)) != NULL)
        putenvf("SCRIPT_SRC_OWNER=%s", pw->pw_name);
    else
        putenvf("SCRIPT_SRC_OWNER=unknown-uid-%d", st.st_uid);
    putenvf("VERSION_INTERPRETER=ePerl/%s", EPERL_VERSION_SHORT);
    putenvf("VERSION_LANGUAGE=Perl/%s", AC_perl_vers);

    char *sourcedir = dirname(strdup(source));
    /* optionally run the ePerl preprocessor */
    if (fPP) {
        /* switch to directory where script stays */
        cwd = cwd != -1 ? cwd : open(".", O_PATH | O_CLOEXEC);
        if (strcmp(sourcedir, "."))
            chdir(sourcedir);
        /* run the preprocessor */
        char *cpBufPP = ePerl_PP(cpScript, RememberedINC, RememberedINCLen, ePerl_begin_delimiter, ePerl_end_delimiter, ePerl_case_sensitive_delimiters);
        if (cpBufPP == NULL) {
            PrintError(mode, source, NULL, NULL, NULL, "Preprocessing failed for %s: %s", source, ePerl_ErrorString);
            return mode == MODE_FILTER ? EX_IOERR : EX_OK;
        }
        cpScript = cpBufPP;
        /* switch to previous dir */
        fchdir(cwd);
        free(cpBufScript);
        cpBufScript = cpBufPP;
    }

    /* convert sprinkled source to valid Perl code */
    if ((cpBufSprinkled2Plain = ePerl_Sprinkled2Plain(cpScript, ePerl_begin_delimiter, ePerl_end_delimiter, ePerl_case_sensitive_delimiters, ePerl_convert_entities)) == NULL) {
        PrintError(mode, source, NULL, NULL, NULL, "Cannot convert sprinkled code file %s to pure HTML: %s", source, ePerl_ErrorString);
        return mode == MODE_FILTER ? EX_IOERR : EX_OK;
    }
    cpScript = cpBufSprinkled2Plain;
    free(cpBufScript);

    /* write buffer to temporary script file */
    struct tmpfile perlscript = mytmpfile(tmpfile_script);
    if (perlscript.fd == -1 || (fp = fdopen(perlscript.fd, "w")) == NULL || fputs(cpScript, fp) == EOF || fclose(fp)) {
        PrintError(mode, source, NULL, NULL, NULL, "Cannot open Perl script file %s for writing", perlscript.filename);
        return mode == MODE_FILTER ? EX_IOERR : EX_OK;
    }

    /* in Debug mode output the script to the console */
    if (fDebug) {
        if ((fp = fopen("/dev/tty", "w")) == NULL) {
            PrintError(mode, source, NULL, NULL, NULL, "Cannot open /dev/tty for debugging message");
            return mode == MODE_FILTER ? EX_IOERR : EX_OK;
        }
        fputs("----internally created Perl script-----------------------------------\n", fp);
        fputs(cpScript, fp);
        if (cpScript[strlen(cpScript) - 1] != '\n')
            fputc('\n', fp);
        fputs("----internally created Perl script-----------------------------------\n", fp);
        fclose(fp);
    }
    free(cpBufSprinkled2Plain);

    /*  create command line...  */
    int myargc = 0;
    char **myargv = reallocarray(NULL, 1 + fTaint + fWarn + 2 * RememberedINCLen + 1 + 1, sizeof(*myargv));
    /*  - program name and possible -T -w options */
    myargv[myargc++] = progname;
    if (fTaint)
        myargv[myargc++] = "-T";
    if (fWarn)
        myargv[myargc++] = "-w";
    /*  - previously remembered Perl 5 INC entries (option -I) */
    for (size_t i = 0; i != RememberedINCLen; ++i) {
        myargv[myargc++] = "-I";
        myargv[myargc++] = (char *)RememberedINC[i];
    }
    /*  - and the script itself  */
    myargv[myargc++] = perlscript.filename;
    myargv[myargc]   = NULL;

    char *cpOut;
    size_t nOut;
    rc = Perl5_Run(myargc, myargv, mode, fCheck, keepcwd, &cwd, sourcedir, source, perlscript.filename, &cpOut, &nOut);
    /*  Return code:
     *     0: ok
     *    -1: fCheck && mode == MODE_FILTER and
     *        no error detected by perl_parse()
     *    otherwise: error detected by perl_parse() or perl_run()
     *  Error message has already been delivered bu Perl5_Run.
     */
    if (rc == -1) {
        fprintf(stderr, "%s syntax OK\n", source);
        return EX_OK;
    } else if (rc != 0)
        return mode == MODE_FILTER ? EX_FAIL : EX_OK;

    if (mode == MODE_NPHCGI || mode == MODE_CGI) {
        /*  if we are running as a NPH-CGI/1.1 script
            we had to provide the HTTP reponse headers ourself */
        if (mode == MODE_NPHCGI) {
            size_t skip = HTTP_PrintResponseHeaders(cpOut);
            cpOut += skip;
            nOut  -= skip;
        }

        /* if there are no HTTP header lines, we print a basic
           Content-Type header which should be ok */
        if (!HTTP_HeadersExists(cpOut)) {
            printf("Content-Type: text/html\r\n"
                   "Content-Length: %zu\r\n"
                   "\r\n",
                   nOut);
        }
    }

    /* now we create the output */
    if (outputfile != NULL && strcmp(outputfile, "-")) {
        /* if we remembered current working dir, restore it now */
        if (mode == MODE_FILTER && cwd != -1)
            fchdir(cwd);
        /* open outputfile */
        if (freopen(outputfile, "w", stdout) == NULL) {
            PrintError(mode, source, NULL, NULL, NULL, "Cannot open output file %s for writing", outputfile);
            return mode == MODE_FILTER ? EX_IOERR : EX_OK;
        }
    }
    /* and write out the data */
    fwrite(cpOut, nOut, 1, stdout);
    return rc;
}
