OSSP CVS Repository

ossp - ossp-pkg/eperl/eperl_main.c 1.3
Not logged in
[Honeypot]  [Browse]  [Directory]  [Home]  [Login
[Reports]  [Search]  [Ticket]  [Timeline
  [Raw

ossp-pkg/eperl/eperl_main.c 1.3
/*
**        ____           _ 
**    ___|  _ \ ___ _ __| |
**   / _ \ |_) / _ \ '__| |
**  |  __/  __/  __/ |  | |
**   \___|_|   \___|_|  |_|
** 
**  ePerl -- Embedded Perl 5 Language
**
**  ePerl interprets an ASCII file bristled with Perl 5 program statements
**  by evaluating the Perl 5 code while passing through the plain ASCII
**  data. It can operate both as a standard Unix filter for general file
**  generation tasks and as a powerful Webserver scripting language for
**  dynamic HTML page programming. 
**
**  ======================================================================
**
**  Copyright (c) 1996,1997,1998 Ralf S. Engelschall <rse@engelschall.com>
**
**  This program is free software; it may be redistributed and/or modified
**  only under the terms of either the Artistic License or the GNU General
**  Public License, which may be found in the ePerl source distribution.
**  Look at the files ARTISTIC and COPYING or run ``eperl -l'' to receive
**  a built-in copy of both license files.
**
**  This program is distributed in the hope that it will be useful, but
**  WITHOUT ANY WARRANTY; without even the implied warranty of
**  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
**  Artistic License or the GNU General Public License for more details.
**
**  ======================================================================
**
**  eperl_main.c -- ePerl main procedure 
*/

#include "eperl_config.h"
#include "eperl_global.h"
#include "eperl_security.h"
#include "eperl_getopt.h"
#include "eperl_perl5.h"
#include "eperl_proto.h"

#define _EPERL_VERSION_C_AS_HEADER_
#include "eperl_version.c"
#undef  _EPERL_VERSION_C_AS_HEADER_

int mode = MODE_UNKNOWN;

char *allowed_file_ext[]   = LIST_OF_ALLOWED_FILE_EXT;
char *allowed_caller_uid[] = LIST_OF_ALLOWED_CALLER_UID;

/*
 *  Display an error message and a logfile content as a HTML page
 */
void PrintError(int mode, char *scripturl, char *scriptfile, char *logfile, char *str, ...)
{
    va_list ap;
    char ca[1024];
    char *cpBuf;
    char *cp;

    va_start(ap, str);
    vsprintf(ca, str, ap);

    IO_restore_stdout();
    IO_restore_stderr();

    if (mode == MODE_CGI || mode == MODE_NPHCGI) {
        if (mode == MODE_NPHCGI)
            HTTP_PrintResponseHeaders("");
        printf("Content-Type: text/html\n\n");
        printf("<html>\n");
        printf("<head>\n");
        printf("<title>ePerl: ERROR: %s</title>\n", ca);
        printf("</head>\n");
        printf("<body bgcolor=\"#d0d0d0\">\n");
        printf("<blockquote>\n");
        cp = getenv("SCRIPT_NAME");
        if (cp == NULL)
            cp = "UNKNOWN_IMG_DIR";
        printf("<a href=\"http://www.engelschall.com/sw/eperl/\"><img src=\"%s/powered.gif\" alt=\"Powered By ePerl\" align=right border=0></a>\n", cp);
        printf("<table cellspacing=0 cellpadding=0 border=0>\n");
        printf("<tr>\n");
        printf("<td><img src=\"%s/logo.gif\" alt=\"Embedded Perl 5 Language\"></td>\n", cp);
        printf("</tr>\n");
        printf("<tr>\n");
        printf("<td align=right><b>Version %s</b></td>\n", eperl_version.v_short);
        printf("</tr>\n");
        printf("</table>\n");
        printf("<p>\n");
        printf("<table bgcolor=\"#d0d0f0\" cellspacing=0 cellpadding=10 border=0>\n");
        printf("<tr><td bgcolor=\"#b0b0d0\">\n");
        printf("<font face=\"Arial, Helvetica\"><b>ERROR:</b></font>\n");
        printf("</td></tr>\n");
        printf("<tr><td>\n");
        printf("<h1><font color=\"#3333cc\">%s</font></h1>\n", ca);
        printf("</td></tr>\n");
        printf("</table>\n");
        if (logfile != NULL) {
            if ((cpBuf = ePerl_ReadErrorFile(logfile, scriptfile, scripturl)) != NULL) {
                printf("<p>");
                printf("<table bgcolor=\"#e0e0e0\" cellspacing=0 cellpadding=10 border=0>\n");
                printf("<tr><td bgcolor=\"#c0c0c0\">\n");
                printf("<font face=\"Arial, Helvetica\"><b>Contents of STDERR channel:</b></font>\n");
                printf("</td></tr>\n");
                printf("<tr><td>\n");
                printf("<pre>\n");
                printf("%s", cpBuf);
                printf("</pre>");
                printf("</td></tr>\n");
                printf("</table>\n");
            }
        }
        printf("</blockquote>\n");
        printf("</body>\n");
        printf("</html>\n");
    }
    else {
        fprintf(stderr, "ePerl:Error: %s\n", ca);
        if (logfile != NULL) {
            if ((cpBuf = ePerl_ReadErrorFile(logfile, scriptfile, scripturl)) != NULL) {
                fprintf(stderr, "\n");
                fprintf(stderr, "---- Contents of STDERR channel: ---------\n");
                fprintf(stderr, "%s", cpBuf);
                if (cpBuf[strlen(cpBuf)-1] != '\n')
                    fprintf(stderr, "\n");
                fprintf(stderr, "------------------------------------------\n");
            }
        }
    }
    fflush(stderr);
    fflush(stdout);
    
    va_end(ap);
    return;
}

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

void give_version_extended(void)
{
    give_version();
    fprintf(stdout, "Characteristics of this binary:\n");
    fprintf(stdout, "  Perl Version    : %s (%s)\n", AC_perl_vers, AC_perl_prog);
    fprintf(stdout, "  Perl I/O Layer  : %s\n", PERL_IO_LAYER_ID);
    fprintf(stdout, "  Perl Library    : %s/CORE/libperl.a\n", AC_perl_archlib);
    fprintf(stdout, "  Perl DynaLoader : %s\n", AC_perl_dla);
    fprintf(stdout, "  System Libs     : %s\n", AC_perl_libs);
    fprintf(stdout, "  Built User      : %s\n", AC_build_user);
    fprintf(stdout, "  Built Time      : %s\n", AC_build_time_iso);
    fprintf(stdout, "\n");
}

void give_readme(void)
{
    fprintf(stdout, ePerl_README);
}

void give_license(void)
{
    fprintf(stdout, ePerl_LICENSE);
}

void give_img_logo(void)
{
    if (mode == MODE_NPHCGI)
        HTTP_PrintResponseHeaders("");
    printf("Content-Type: image/gif\n\n");
    fwrite(ePerl_LOGO_data, ePerl_LOGO_size, 1, stdout);
}

void give_img_powered(void)
{
    if (mode == MODE_NPHCGI)
        HTTP_PrintResponseHeaders("");
    printf("Content-Type: image/gif\n\n");
    fwrite(ePerl_POWERED_data, ePerl_POWERED_size, 1, stdout);
}

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

char *RememberedINC[1024] = { NULL };

void RememberINC(char *str) 
{
    int i;

    for (i = 0; RememberedINC[i] != NULL; i++)
        ;
    RememberedINC[i++] = strdup(str);
    RememberedINC[i++] = NULL;
    return;
}

void mysighandler(int rc)
{
    /* ignore more signals */
    signal(SIGINT,  SIG_IGN);
    signal(SIGTERM, SIG_IGN);

    /* restore filehandles */
    IO_restore_stdout();
    IO_restore_stderr();

    /* give interrupt information */
    fprintf(stderr, "ePerl: **INTERRUPT**\n");

    /* exit immediately */
    myexit(EX_FAIL);
}

void myinit(void)
{
    /* caught signals */
    signal(SIGINT,  mysighandler);
    signal(SIGTERM, mysighandler);
}

void myexit(int rc)
{
    /* cleanup */
#ifndef DEBUG_ENABLED
    remove_mytmpfiles();
#endif

    /* restore signals */
    signal(SIGINT,  SIG_DFL);
    signal(SIGTERM, SIG_DFL);

#ifdef DEBUG_ENABLED
#ifdef HAVE_DMALLOC
    dmalloc_shutdown();
#endif
#endif

    /* die gracefully */
    exit(rc);
}

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

/*
 *  main procedure
 */
int main(int argc, char **argv, char **env)
{
    DECL_EXRC;
    FILE *fp = NULL;
    FILE *er = NULL;
    FILE *out = NULL;
    char *cpBuf = NULL;
    char *cpBuf2 = NULL;
    char *cpBuf3 = NULL;
    char perlscript[1024] = "";
    char perlstderr[1024] = "";
    char perlstdout[1024] = "";
    char dir_tmp[1024];
    char *dir_home;
    char *dir_script;
    char ca[1024] = "";
    int myargc;
    char *myargv[20];
    char *progname;
    int nBuf;
    int nOut;
    char *source = NULL;
    char sourcedir[2048];
    char *cp;
    static PerlInterpreter *my_perl = NULL; 
    struct stat st;
    char *cpOut = NULL;
    int size;
    struct passwd *pw;
    struct passwd *pw2;
    struct group *gr;
    int uid = 0, gid = 0;
    int keepcwd = FALSE;
    int c;
    char *cpScript = NULL;
    int allow;
    int i, n, k;
    char *outputfile = NULL;
    char cwd[MAXPATHLEN];
    int fCheck = FALSE;
    int fTaint = FALSE;
    int fWarn = FALSE;
    int fNoCase = FALSE;
    int fPP = FALSE;
    char *cwd2;
    int fOkSwitch;
    char *cpHost;
    char *cpPort;
    char *cpPath;
    char *cpCGIgi;
    char *cpCGIpt;
    char *cpCGIqs;
    int fCGIqsEqualChar;

    /*  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 */
    opterr = 0;
    while ((c = getopt_long(argc, argv, ":d:D:I:B:E:nkPCLTwxm:o:crlvVh", options, NULL)) != -1) {
        if (optarg == NULL) 
            optarg = "(null)";
        switch (c) {
            case 'd':
                Perl5_RememberScalar(optarg);
                break;
            case 'D':
                env = Perl5_SetEnvVar(env, optarg);
                break;
            case 'I':
                RememberINC(optarg);
                break;
            case 'B':
                ePerl_begin_delimiter = strdup(optarg);
                break;
            case 'E':
                ePerl_end_delimiter = strdup(optarg);
                break;
            case 'n':
                fNoCase = TRUE;
                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, "Unknown runtime mode `%s'", optarg);
                    CU(EX_USAGE);
                }
                break;
            case 'o':
                outputfile = strdup(optarg);
                break;
            case 'c':
                fCheck = TRUE;
                break;
            case 'r':
                give_readme();
                myexit(EX_OK);
            case 'l':
                give_license();
                myexit(EX_OK);
            case 'v':
                give_version();
                myexit(EX_OK);
            case 'V':
                give_version_extended();
                myexit(EX_OK);
            case 'h':
                give_usage(progname);
                myexit(EX_OK);
            case '?':
                if (isprint(optopt))
                    fprintf(stderr, "ePerl:Error: Unknown option `-%c'.\n", optopt);
                else
                    fprintf(stderr, "ePerl:Error: Unknown option character `\\x%x'.\n", optopt);
                fprintf(stderr, "Try `%s --help' for more information.\n", progname);
                myexit(EX_USAGE);
            case ':':
                if (isprint(optopt))
                    fprintf(stderr, "ePerl:Error: Missing argument for option `-%c'.\n", optopt);
                else
                    fprintf(stderr, "ePerl:Error: Missing argument for option character `\\x%x'.\n", optopt);
                fprintf(stderr, "Try `%s --help' for more information.\n", progname);
                myexit(EX_USAGE);
        }
    }

    /* 
     *  determine source filename and runtime mode 
     */

    if ((cpCGIgi = getenv("GATEWAY_INTERFACE")) == NULL)
        cpCGIgi = "";
    if ((cpCGIpt = getenv("PATH_TRANSLATED")) == NULL)
        cpCGIpt = "";
    if ((cpCGIqs = getenv("QUERY_STRING")) == NULL)
        cpCGIqs = "";
    fCGIqsEqualChar = FALSE;
    if (cpCGIqs != NULL && strchr(cpCGIqs, '=') != NULL)
        fCGIqsEqualChar = TRUE;

    /*
     *  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
     */
    if (   cpCGIgi[0] != NUL 
        && cpCGIpt[0] != NUL
        && (   (   optind == argc
                && (   cpCGIqs[0] == NUL 
                    || fCGIqsEqualChar      ) ) 
            || (   optind == argc-1 
                && !fCGIqsEqualChar 
                && stringEQ(argv[optind], cpCGIqs) )      ) ) {
        
        if (strncasecmp(cpCGIgi, "CGI/1", 5) != 0) {
            fprintf(stderr, "ePerl:Error: Unknown gateway interface: NOT CGI/1.x\n");
            CU(EX_IOERR);
        }

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

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

        /* set the command line for ``ps'' output */
        sprintf(ca, "%s %s [%sCGI/SSSL]", argv[0], source, mode == MODE_NPHCGI ? "NPH-" : "");
        argv[0] = strdup(ca);
    }
    /*
     *  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] != NUL
             && ( (   optind == argc-1 
                   && (   cpCGIqs[0] == NUL 
                       || fCGIqsEqualChar      ) ) ||
                  (   optind == argc-2 
                   && !fCGIqsEqualChar 
                   && stringEQ(argv[optind+1], cpCGIqs)) ) ) {

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

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

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

        /* set the command line for ``ps'' output */
        sprintf(ca, "%s %s [%sCGI/stand-alone]", argv[0], source, mode == MODE_NPHCGI ? "NPH-" : "");
        argv[0] = strdup(ca);
    }
    /*
     *  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] == NUL 
             && cpCGIpt[0] == NUL
             && cpCGIqs[0] == NUL 
             && 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 (stringEQ(source, "-")) {
            /* store stdin to tmpfile */
            source = mytmpfile("ePerl.stdin");
            if ((fp = fopen(source, "w")) == NULL) {
                PrintError(mode, source, NULL, NULL, "Cannot open tmpfile `%s' for writing", source);
                CU(EX_IOERR);
            }
            while ((c = fgetc(stdin)) != EOF) {
                fputc(c, fp);
            }
            fclose(fp); fp = NULL;

            /* 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");
        fprintf(stderr, "ePerl:Error: Use either a filename, `-' for STDIN or PATH_TRANSLATED.\n");
        fprintf(stderr, "Try `%s --help' for more information.\n", progname);
        myexit(EX_USAGE);
    }

    /* set default delimiters */
    if (ePerl_begin_delimiter == NULL) {
        if (mode == MODE_FILTER)
            ePerl_begin_delimiter = BEGIN_DELIMITER_FILTER;
        else
            ePerl_begin_delimiter = BEGIN_DELIMITER_CGI;
    }
    if (ePerl_end_delimiter == NULL) {
        if (mode == MODE_FILTER)
            ePerl_end_delimiter = END_DELIMITER_FILTER;
        else
            ePerl_end_delimiter = END_DELIMITER_CGI;
    }
    if (fNoCase)
        ePerl_case_sensitive_delimiters = FALSE;
    else
        ePerl_case_sensitive_delimiters = TRUE;

    /* the built-in GIF images */
    if ((mode == MODE_CGI || mode == MODE_NPHCGI) && (cp = getenv("PATH_INFO")) != NULL) { 
        if (stringEQ(cp, "/logo.gif")) {
            give_img_logo();
            myexit(0);
        }
        else if (stringEQ(cp, "/powered.gif")) {
            give_img_powered();
            myexit(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 valid source file */
    if (*source == NUL) {
        PrintError(mode, "", NULL, NULL, "Filename is empty");
        CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
    }

    /* check for existing source file */
    if ((stat(source, &st)) != 0) {
        PrintError(mode, source, NULL, NULL, "File `%s' not exists", source);
        CU(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 (i = 0; allowed_file_ext[i] != NULL; i++) {
                k = strlen(allowed_file_ext[i]);
                if (stringEQ(source+n-k, allowed_file_ext[i])) 
                    allow = TRUE;
            }
            if (!allow) {
                PrintError(mode, source, NULL, NULL, "File `%s' is not allowed to be interpreted by ePerl (wrong extension!)", source);
                CU(EX_OK);
            }
        }

        /*
         *
         *  == Perl Security ==
         *
         */

        /* perhaps force Taint mode */
        if (CGI_MODES_FORCE_TAINTING)
            fTaint = TRUE;

        /* perhaps force Warnings */
        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, "Invalid UID %d of caller", uid);
                    CU(EX_OK);
                }
                else
                    fOkSwitch = FALSE;
            }
            else {
                /* security check: allowed caller uid */
                if (SETUID_NEEDS_ALLOWED_CALLER_UID) {
                    allow = FALSE;
                    for (i = 0; allowed_caller_uid[i] != NULL; i++) {
                        if (isdigit(allowed_caller_uid[i][0]))
                            pw2 = getpwuid(atoi(allowed_caller_uid[i]));
                        else
                            pw2 = getpwnam(allowed_caller_uid[i]);
                        if (stringEQ(pw->pw_name, pw2->pw_name)) {
                            allow = TRUE;
                            break;
                        }
                    }
                    if (!allow) {
                        if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                            PrintError(mode, source, NULL, NULL, "UID %d of caller not allowed", uid);
                            CU(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, "Invalid UID %d of owner", st.st_uid);
                    CU(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, "Invalid GID %d of owner", st.st_gid);
                    CU(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 */
                cwd2 = getcwd(NULL, 1024);

                /* 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, "Invalid homedir ``%s'' of file owner", pw->pw_dir);
                        CU(EX_OK);
                    }
                    else 
                        fOkSwitch = FALSE;
                }
                else {
                    dir_home = getcwd(NULL, 1024);

                    /* determine physical dir of file */
                    strcpy(dir_tmp, source);
                    if ((cp = strrchr(dir_tmp, '/')) == NULL) {
                        if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                            PrintError(mode, source, NULL, NULL, "Invalid script ``%s'': no absolute path", source);
                            CU(EX_OK);
                        }
                        else 
                            fOkSwitch = FALSE;
                    }
                    else {
                        *cp = NUL;
                        if (chdir(dir_tmp) == -1) {
                            if (DO_FOR_FAILED_STEP == STOP_AND_ERROR) {
                                PrintError(mode, source, NULL, NULL, "Invalid script ``%s'': cannot chdir to its location", source);
                                CU(EX_OK);
                            }
                            else 
                                fOkSwitch = FALSE;
                        }
                        else {
                            dir_script = getcwd(NULL, 1024);
        
                            /* 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, "Invalid script ``%s'': does not stay below homedir of owner", source);
                                    CU(EX_OK);
                                }
                                else 
                                    fOkSwitch = FALSE;
                            }
            
                            free(dir_script);
                        }
                    }
                    free(dir_home);
                }

                /* restore original cwd */
                chdir(cwd2);
        
                free(cwd2);
            }
    
            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, "Unable to set GID %d: setgid/initgroups failed", gid);
                    CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
                }
                if ((setuid(uid)) != 0) {
                    PrintError(mode, source, NULL, NULL, "Unable to set UID %d: setuid failed", uid);
                    CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
                }
            }
        }
    }

    /* Security! Eliminate effective root permissions if we are running setuid */
    if (geteuid() == 0) {
        uid = getuid();
        gid = getgid();
#ifdef HAVE_SETEUID
        seteuid(uid);
#else
        /* HP/UX and others eliminate the effective UID with setuid(uid) ! */
        setuid(uid);
#endif
#ifdef HAVE_SETEGID
        setegid(uid);
#else
        /* HP/UX and others eliminate the effective GID with setgid(gid) ! */
        setgid(gid);
#endif
    }

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

    /* strip shebang prefix */
    if (strncmp(cpBuf, "#!", 2) == 0) {
        for (cpScript = cpBuf;
             (*cpScript != ' ' && *cpScript != '\t' && *cpScript != '\n') && (cpScript-cpBuf < nBuf);
             cpScript++)
            ;
        for (cpScript = cpBuf;
             *cpScript != '\n' && (cpScript-cpBuf < nBuf);
             cpScript++)
            ;
        cpScript++;
    }
    else
        cpScript = cpBuf;

    /* now set the additional env vars */
    env = mysetenv(env, "SCRIPT_SRC_PATH", "%s", abspath(source));
    env = mysetenv(env, "SCRIPT_SRC_PATH_FILE", "%s", filename(source));
    env = mysetenv(env, "SCRIPT_SRC_PATH_DIR", "%s", abspath(dirname(source)));
    if ((cpPath = getenv("PATH_INFO")) != NULL) {
        if ((cpHost = getenv("SERVER_NAME")) == NULL)
            cpHost = "localhost";
        cpPort = getenv("SERVER_PORT");
        if (stringEQ(cpPort, "80"))
            cpPort = NULL;
        sprintf(ca, "http://%s%s%s%s", 
                cpHost, cpPort != NULL ? ":" : "", cpPort != NULL ? cpPort : "", cpPath);
        env = mysetenv(env, "SCRIPT_SRC_URL", "%s", ca);
        env = mysetenv(env, "SCRIPT_SRC_URL_FILE", "%s", filename(ca));
        env = mysetenv(env, "SCRIPT_SRC_URL_DIR", "%s", dirname(ca));
    }
    else {
        env = mysetenv(env, "SCRIPT_SRC_URL", "file://%s", abspath(source));
        env = mysetenv(env, "SCRIPT_SRC_URL_FILE", "%s", filename(source));
        env = mysetenv(env, "SCRIPT_SRC_URL_DIR", "file://%s", abspath(source));
    }

    env = mysetenv(env, "SCRIPT_SRC_SIZE", "%d", nBuf);
    stat(source, &st);
    env = mysetenv(env, "SCRIPT_SRC_MODIFIED", "%d", st.st_mtime);
    cp = ctime(&(st.st_mtime));
    cp[strlen(cp)-1] = NUL;
    env = mysetenv(env, "SCRIPT_SRC_MODIFIED_CTIME", "%s", cp);
    env = mysetenv(env, "SCRIPT_SRC_MODIFIED_ISOTIME", "%s", isotime(&(st.st_mtime)));
    if ((pw = getpwuid(st.st_uid)) != NULL)
        env = mysetenv(env, "SCRIPT_SRC_OWNER", "%s", pw->pw_name);
    else
        env = mysetenv(env, "SCRIPT_SRC_OWNER", "unknown-uid-%d", st.st_uid);
    env = mysetenv(env, "VERSION_INTERPRETER", "%s", eperl_version.v_web);
    env = mysetenv(env, "VERSION_LANGUAGE", "Perl/%s", AC_perl_vers);

    /* optionally run the ePerl preprocessor */
    if (fPP) {
        /* switch to directory where script stays */
        getcwd(cwd, MAXPATHLEN);
        strcpy(sourcedir, source);
        for (cp = sourcedir+strlen(sourcedir); cp > sourcedir && *cp != '/'; cp--)
            ;
        *cp = NUL;
        chdir(sourcedir);
        /* run the preprocessor */
        if ((cpBuf3 = ePerl_PP(cpScript, RememberedINC)) == NULL) {
            PrintError(mode, source, NULL, NULL, "Preprocessing failed for `%s': %s", source, ePerl_PP_GetError());
            CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
        }
        cpScript = cpBuf3;
        /* switch to previous dir */
        chdir(cwd);
    }

    /* convert bristled source to valid Perl code */
    if ((cpBuf2 = ePerl_Bristled2Plain(cpScript)) == NULL) {
        PrintError(mode, source, NULL, NULL, "Cannot convert bristled code file `%s' to pure HTML", source);
        CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
    }
    cpScript = cpBuf2;

    /* write buffer to temporary script file */
    strcpy(perlscript, mytmpfile("ePerl.script"));
#ifndef DEBUG_ENABLED
    unlink(perlscript);
#endif
    if ((fp = fopen(perlscript, "w")) == NULL) {
        PrintError(mode, source, NULL, NULL, "Cannot open Perl script file `%s' for writing", perlscript);
        CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
    }
    fwrite(cpScript, strlen(cpScript), 1, fp);
    fclose(fp); fp = NULL;

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

    /* open a file for Perl's STDOUT channel
       and redirect stdout to the new channel */
    strcpy(perlstdout, mytmpfile("ePerl.stdout"));
#ifndef DEBUG_ENABLED
    unlink(perlstdout);
#endif
    if ((out = fopen(perlstdout, "w")) == NULL) {
        PrintError(mode, source, NULL, NULL, "Cannot open STDOUT file `%s' for writing", perlstdout);
        CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
    }
    IO_redirect_stdout(out);

    /* open a file for Perl's STDERR channel 
       and redirect stderr to the new channel */
    strcpy(perlstderr, mytmpfile("ePerl.stderr"));
#ifndef DEBUG_ENABLED
    unlink(perlstderr);
#endif
    if ((er = fopen(perlstderr, "w")) == NULL) {
        PrintError(mode, source, NULL, NULL, "Cannot open STDERR file `%s' for writing", perlstderr);
        CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
    }
    IO_redirect_stderr(er);

    /*  now allocate the Perl interpreter  */
    my_perl = perl_alloc();   
    perl_construct(my_perl); 
    /* perl_destruct_level = 1; */

    /*  initialise the Perl Locale environment  */
#if AC_perl_vnum < 500400
    perl_init_i18nl14n(1); /* Perl 5.003 or lower */
#else
    perl_init_i18nl10n(1); /* Perl 5.004 or higher */
#endif

    /*  create command line...  */
    myargc = 0;
    /*  - 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 (i = 0; RememberedINC[i] != NULL; i++) {
        myargv[myargc++] = "-I";
        myargv[myargc++] = RememberedINC[i];
    }
    /*  - and the script itself  */
    myargv[myargc++] = perlscript;   

    /*  now parse the script! 
        NOTICE: At this point, the script gets 
        only _parsed_, not evaluated/executed!  */
#ifdef HAVE_PERL_DYNALOADER
    rc = perl_parse(my_perl, Perl5_XSInit, myargc, myargv, env);
#else
    rc = perl_parse(my_perl, NULL, myargc, myargv, env);
#endif
    if (rc != 0) { 
        if (fCheck && mode == MODE_FILTER) {
            fclose(er); er = NULL;
            IO_restore_stdout();
            IO_restore_stderr();
            if ((cpBuf = ePerl_ReadErrorFile(perlstderr, perlscript, source)) != NULL) {
                fprintf(stderr, cpBuf);
            }
            CU(EX_IOERR);
        }
        else {
            fclose(er); er = NULL;
            PrintError(mode, source, perlscript, perlstderr, "Perl parsing error (interpreter rc=%d)", rc);
            CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
        }
    }

    /* Stop when we are just doing a syntax check */
    if (fCheck && mode == MODE_FILTER) {
        fclose(er); er = NULL;
        IO_restore_stdout();
        IO_restore_stderr();
        fprintf(stderr, "%s syntax OK\n", source);
        CU(EX_OK);
    }

    /* change to directory of script:
       this actually is not important to us, but really useful 
       for the ePerl source file programmer!! */
    cwd[0] = NUL;
    if (!keepcwd) {
        /* if running as a Unix filter remember the cwd for outputfile */
        if (mode == MODE_FILTER)
            getcwd(cwd, MAXPATHLEN);
        /* determine dir of source file and switch to it */
        strcpy(sourcedir, source);
        for (cp = sourcedir+strlen(sourcedir); cp > sourcedir && *cp != '/'; cp--)
            ;
        *cp = NUL;
        chdir(sourcedir);
    }

    /*  Set the previously remembered Perl 5 scalars (option -d) */
    Perl5_SetRememberedScalars();

    /*  Force unbuffered I/O */
    Perl5_ForceUnbufferedStdout();

    /*  NOW IT IS TIME to evaluate/execute the script!!! */
    rc = perl_run(my_perl);

    /*  pre-close the handles, to be able to check
        its size and to be able to display the contents */
    fclose(out); out = NULL;
    fclose(er);  er  = NULL;

    /*  when the Perl interpreter failed or there
        is data on stderr, we print a error page */
    if (stat(perlstderr, &st) == 0)
        size = st.st_size;
    else
        size = 0;
    if (rc != 0 || size > 0) {
        PrintError(mode, source, perlscript, perlstderr, "Perl runtime error (interpreter rc=%d)", rc);
        CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
    }

    /*  else all processing was fine, so
        we read in the stdout contents */
    if ((cpOut = ePerl_ReadSourceFile(perlstdout, &cpOut, &nOut)) == NULL) {
        PrintError(mode, source, NULL, NULL, "Cannot open STDOUT file `%s' for reading", perlstdout);
        CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
    }
    stat(perlstdout, &st);

    /* ok, now recover the stdout and stderr and
       print out the real contents on stdout or outputfile */
    IO_restore_stdout();
    IO_restore_stderr();

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

        /* 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\n");
            printf("Content-Length: %d\n", nOut);
            printf("\n");
        }
    }
    else if (mode == MODE_CGI) {
        HTTP_StripResponseHeaders(&cpOut, &nOut);

        /* 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\n");
            printf("Content-Length: %d\n", nOut);
            printf("\n");
        }
    }
    else if (mode == MODE_FILTER) {
        HTTP_StripResponseHeaders(&cpOut, &nOut);
    }

    /* now when the request was not a HEAD request we create the output */
    cp = getenv("REQUEST_METHOD");
    if (! ((mode == MODE_CGI || mode == MODE_NPHCGI) &&
           cp != NULL && stringEQ(cp, "HEAD"))) {
        if (outputfile != NULL && stringNE(outputfile, "-")) {
            /* if we remembered current working dir, restore it now */
            if (mode == MODE_FILTER && cwd[0] != NUL)
                chdir(cwd);
            /* open outputfile and write out the data */
            if ((fp = fopen(outputfile, "w")) == NULL) {
                PrintError(mode, source, NULL, NULL, "Cannot open output file `%s' for writing", outputfile);
                CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
            }
            fwrite(cpOut, nOut, 1, fp);
            fclose(fp); fp = NULL;
        }
        else {
            /* data just goes to stdout */
            fwrite(cpOut, nOut, 1, stdout);
            /* make sure that the data is out before we exit */
            fflush(stdout);
        }
    }

    CUS: /* the Clean Up Sequence */

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

    /* close all still open file handles */
    if (out)
        fclose(out);
    if (er)
        fclose(er);
    if (fp)
        fclose(fp);

    /* de-allocate the script buffer */
    if (cpBuf)
        free(cpBuf);
    if (cpBuf2)
        free(cpBuf2);
    if (cpOut)
        free(cpOut);

    /* remove temporary files */
#ifndef DEBUG_ENABLED
    if (*perlstderr != NUL)
        unlink(perlstderr);
    if (*perlstdout != NUL)
        unlink(perlstdout);
    if (*perlscript != NUL)
        unlink(perlscript);
#endif

    myexit(EXRC);
    return EXRC; /* make -Wall happy ;-) */
}

/*EOF*/

CVSTrac 2.0.1