/*
* Copyright (C) 2003 Sam Horrocks
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* 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 the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*
*/
#include "perperl.h"
/*
* Accomodate 5.004
*/
#if PATCHLEVEL < 5
#define newSVpvn(s,l) newSVpv((l) ? (s) : "", (l))
#endif
/* For declaring xs_init prior to 5.6 */
#ifndef pTHXo
#define pTHXo void
#endif
/*
* Prior to perl 5.6.0 these funcs were prefixed with "perl_"
*/
#ifndef get_sv
# define get_sv perl_get_sv
#endif
#ifndef get_av
# define get_av perl_get_av
#endif
#ifndef get_cv
# define get_cv perl_get_cv
#endif
#ifndef get_hv
# define get_hv perl_get_hv
#endif
#ifndef call_sv
# define call_sv perl_call_sv
#endif
#ifndef eval_sv
# define eval_sv perl_eval_sv
#endif
#ifndef eval_pv
# define eval_pv perl_eval_pv
#endif
#ifndef call_pv
# define call_pv perl_call_pv
#endif
/*
* Convert integer to a hex-string in reverse. Works for any number of bits
*/
#define HEX_STR_SIZE(type) (sizeof(type)*2)
#define NIB_TO_HEX(n) ("0123456789abcdef"[n])
#define HEX_CVT(i,b) \
{ \
int cnt = HEX_STR_SIZE(i); \
do { \
*(b)++ = NIB_TO_HEX((i)&15); \
(i) = (i) >> 4; \
} while (i && --cnt); \
}
#define DEVFD "/dev/fd/%d"
#define DEVINO_STR_SIZE \
(HEX_STR_SIZE(perperl_dev_t)+HEX_STR_SIZE(perperl_ino_t)+2)
#define DEVINO_SAME(a,b) ((a).i == (b).i && (a).d == (b).d)
#define DEVINO_GET(fp,devino) PerlIO_read(fp, &(devino), sizeof(devino))
#define my_SvPV(sv) SvPV(sv, junk_len)
#define chdir_path_sv(sv) chdir_path(my_SvPV(sv), NULL)
#define my_hv_store(hash, key, klen, val) \
do { \
if (!hv_store((hash), (key), (klen), (val), 0)) \
SvREFCNT_dec(val); \
} while (0)
typedef struct {
int refcnt;
SV *path;
PersistentDevIno devino;
} PersistentCwd;
typedef struct {
SV *handler;
PersistentCwd *last_cwd;
} PersistentScript;
typedef struct {
void *ptr;
const svtype type;
const char *name;
} PersistentPerlVar;
extern void xs_init(pTHXo);
/* Generated by util/perlvars */
#define PERLVAR_ENV (PersistentPerlVars[0])
#define PERLVAL_ENV ((HV*)(PersistentPerlVars[0].ptr))
#define PERLVAR_ARGV (PersistentPerlVars[1])
#define PERLVAL_ARGV ((AV*)(PersistentPerlVars[1].ptr))
#define PERLVAR_STDIN (PersistentPerlVars[2])
#define PERLVAL_STDIN ((GV*)(PersistentPerlVars[2].ptr))
#define PERLVAR_STDOUT (PersistentPerlVars[3])
#define PERLVAL_STDOUT ((GV*)(PersistentPerlVars[3].ptr))
#define PERLVAR_STDERR (PersistentPerlVars[4])
#define PERLVAL_STDERR ((GV*)(PersistentPerlVars[4].ptr))
#define PERLVAR_PROGRAM_NAME (PersistentPerlVars[5])
#define PERLVAL_PROGRAM_NAME ((SV*)(PersistentPerlVars[5].ptr))
#define PERLVAR_EVAL_ERROR (PersistentPerlVars[6])
#define PERLVAL_EVAL_ERROR ((SV*)(PersistentPerlVars[6].ptr))
#define PERLVAR_RESET_GLOBALS (PersistentPerlVars[7])
#define PERLVAL_RESET_GLOBALS ((CV*)(PersistentPerlVars[7].ptr))
#define PERLVAR_OPTS_CHANGED (PersistentPerlVars[8])
#define PERLVAL_OPTS_CHANGED ((SV*)(PersistentPerlVars[8].ptr))
#define PERLVAR_OPTS (PersistentPerlVars[9])
#define PERLVAL_OPTS ((HV*)(PersistentPerlVars[9].ptr))
#define PERLVAR_RUN_SHUTDOWN (PersistentPerlVars[10])
#define PERLVAL_RUN_SHUTDOWN ((CV*)(PersistentPerlVars[10].ptr))
#define PERLVAR_SUB (PersistentPerlVars[11])
#define PERLVAL_SUB ((SV*)(PersistentPerlVars[11].ptr))
#define PERLVAR_I_AM_PERPERL (PersistentPerlVars[12])
#define PERLVAL_I_AM_PERPERL ((SV*)(PersistentPerlVars[12].ptr))
#define PERLVAR_RUN_CLEANUP (PersistentPerlVars[13])
#define PERLVAL_RUN_CLEANUP ((CV*)(PersistentPerlVars[13].ptr))
#define PERLVAR_FORK (PersistentPerlVars[14])
#define PERLVAL_FORK ((CV*)(PersistentPerlVars[14].ptr))
#define PERLVAR_COUNT 15
static PersistentPerlVar PersistentPerlVars[] = {
{NULL, SVt_PVHV , "ENV"},
{NULL, SVt_PVAV , "ARGV"},
{NULL, SVt_PVIO , "STDIN"},
{NULL, SVt_PVIO , "STDOUT"},
{NULL, SVt_PVIO , "STDERR"},
{NULL, SVt_PV , "0"},
{NULL, SVt_PV , "@"},
{NULL, SVt_PVCV , "CGI::_reset_globals"},
{NULL, SVt_IV , PERPERL_PKG("_opts_changed")},
{NULL, SVt_PVHV , PERPERL_PKG("_opts")},
{NULL, SVt_PVCV , PERPERL_PKG("_run_shutdown")},
{NULL, SVt_PV , PERPERL_PKG("_sub")},
{NULL, SVt_IV , PERPERL_PKG("i_am_perperl")},
{NULL, SVt_PVCV , PERPERL_PKG("_run_cleanup")},
{NULL, SVt_PVCV , PERPERL_PKG("_fork")},
};
/* End of generated section */
static const char *dev_null = "/dev/null";
PerlInterpreter *my_perl;
static int cwd_fd = -1;
static STRLEN junk_len;
static HV *cwd_hash, *scr_hash;
static const int caught_sigs[] = {SIGTERM, SIGHUP, SIGINT};
#define NUMSIGS (sizeof(caught_sigs) / sizeof(int))
/*
* Stuff to be stashed in cwd_hash / scr_hash
*
* %cwd{$devino_str} = PersistentCwd*
* %cwd{$path} = PersistentCwd*
* %script{$devino_str} = PersistentScript*
*/
static int devino_str(PersistentDevIno devino, char str[DEVINO_STR_SIZE]) {
char *bp = str;
perperl_ino_t i = devino.i;
perperl_dev_t d = devino.d;
HEX_CVT(i, bp)
*bp++ = '_';
HEX_CVT(d, bp)
*bp = '\0';
return bp - str;
}
/*
* Debugging code to dump out the internal hashes - cwd_hash and scr_hash
*/
#ifdef DUMP_HASH
#define PRINTABLE(s) ((s) ? (s) : "NULL")
static void dump_cwd(PersistentCwd *cwd, PerlIO *pio) {
char dino_str[DEVINO_STR_SIZE];
devino_str(cwd->devino, dino_str);
PerlIO_printf(pio, "{refcnt=%d, path=%s, devino=%s}",
cwd->refcnt, PRINTABLE(my_SvPV(cwd->path)), dino_str
);
}
static void dump_hash(HV *hv, PerlIO *pio) {
SV *sv;
char *key;
PerlIO_printf(pio, "Dump of %s_hash\n", hv == cwd_hash ? "cwd" : "script");
hv_iterinit(hv);
while ((sv = hv_iternextsv(hv, &key, &junk_len))) {
PerlIO_printf(pio, "%s=", key);
if (hv == scr_hash) {
PersistentScript *scr = (PersistentScript*)SvIV(sv);
PerlIO_printf(pio, "{handler=%x, last_cwd=", (int)(scr->handler));
if (scr->last_cwd)
dump_cwd(scr->last_cwd, pio);
else
PerlIO_printf(pio, "NULL");
PerlIO_printf(pio, "}\n");
} else {
PersistentCwd * cwd = (PersistentCwd*)SvIV(sv);
dump_cwd(cwd, pio);
PerlIO_printf(pio, "\n");
}
}
}
#endif /* DUMP_HASH */
/* Locate a devino in one of the hashes */
static SV **find_devino(PersistentDevIno devino, HV *hash, int lval) {
char key[DEVINO_STR_SIZE];
int key_len;
key_len = devino_str(devino, key);
return hv_fetch(hash, key, key_len, lval);
}
/* Find the PersistentScript structure in the hash, using a devino key
* Create a new one if not found.
*/
static PersistentScript *find_scr(PersistentDevIno devino, int *is_new) {
SV *sv;
PersistentScript *retval;
sv = find_devino(devino, scr_hash, 1)[0];
if ((*is_new = !SvOK(sv))) {
perperl_new(retval, 1, PersistentScript);
retval->handler = NULL;
retval->last_cwd = NULL;
sv_setiv(sv, (IV) retval);
} else {
retval = (PersistentScript *) SvIV(sv);
}
return retval;
}
/* Get the directory that holds the filename */
static char *fname_dir(const char *p) {
char *s;
if (p && (s = strrchr(p, '/')))
return perperl_util_strndup(p, max(1,s-p));
else
return NULL;
}
static void my_call_sv(SV *sv) {
if (sv) {
dSP;
PUSHMARK(SP);
call_sv(sv, G_DISCARD | G_NOARGS);
}
}
static void cwd_refcnt_dec(PersistentCwd *cwd) {
if (!--(cwd->refcnt)) {
char key[DEVINO_STR_SIZE];
int key_len;
key_len = devino_str(cwd->devino, key);
hv_delete(cwd_hash, key, key_len, G_DISCARD);
hv_delete_ent(cwd_hash, cwd->path, G_DISCARD, 0);
SvREFCNT_dec(cwd->path);
perperl_free(cwd);
}
}
static int stat_cwd_fd(PersistentDevIno *devino) {
struct stat stbuf;
if (cwd_fd != -1) {
if (fstat(cwd_fd, &stbuf) != -1) {
*devino = perperl_util_stat_devino(&stbuf);
return 1;
}
close(cwd_fd);
cwd_fd = -1;
}
return 0;
}
static int chdir_path(const char *path, PersistentDevIno *devino) {
int retval;
if (!path || !path[0])
return 0;
if (cwd_fd != -1)
close(cwd_fd);
retval = path
? (((path[0] == '.' && path[1] == '\0')) ? 0 : chdir(path))
: -1;
cwd_fd = retval != -1
? perperl_util_pref_fd(open(".", O_RDONLY), PREF_FD_CWD)
: -1;
if (cwd_fd != -1)
fcntl(cwd_fd, F_SETFD, FD_CLOEXEC);
/* TEST - simulate unreadable "." directory */
/* close(cwd_fd); cwd_fd = -1; */
/* Get device/inode for "." */
if (retval != -1 && devino && !stat_cwd_fd(devino)) {
struct stat stbuf;
if (cwd_fd == -1) {
if (stat(".", &stbuf) == -1) {
devino->d = 0;
devino->i = 0;
}
} else {
*devino = perperl_util_stat_devino(&stbuf);
}
}
return retval;
}
static int quick_cd(PersistentDevIno dest) {
PersistentDevIno devino;
/*
* See if cwd_fd is the correct dir - if so fchdir there.
*/
if (stat_cwd_fd(&devino) && DEVINO_SAME(dest, devino) &&
fchdir(cwd_fd) != -1)
{
return 1;
}
/* Stat "." */
chdir_path(".", &devino);
/* See if "." is the right directory */
return DEVINO_SAME(dest, devino);
}
static void *get_perlvar(PersistentPerlVar *pv) {
if (!pv->ptr) {
switch(pv->type) {
case SVt_PVIO:
pv->ptr = gv_fetchpv(pv->name, 1, SVt_PVIO);
break;
case SVt_PVAV:
pv->ptr = get_av(pv->name, 1);
break;
case SVt_PVHV:
pv->ptr = get_hv(pv->name, 1);
break;
case SVt_PVCV:
pv->ptr = get_cv(pv->name, 0);
break;
default:
pv->ptr = get_sv(pv->name, 1);
break;
}
if (pv->type != SVt_PVCV && !pv->ptr)
DIE_QUIET("Cannot create perl variable %s", pv->name);
}
return pv->ptr;
}
/* Shutdown and exit. */
static void all_done(void) {
perperl_file_set_state(FS_CLOSED);
/* Destroy the interpreter */
if (my_perl) {
/* Call any shutdown functions */
my_call_sv(get_perlvar(&PERLVAR_RUN_SHUTDOWN));
perl_destruct(my_perl);
}
perperl_util_exit(0,0);
}
/* Wait for a connection from a frontend */
static void backend_accept(void) {
SigList sl;
int ok;
/* Set up caught/unblocked signals to exit on */
perperl_sig_init(&sl, caught_sigs, NUMSIGS, SIG_UNBLOCK);
/* Wait for an accept or timeout */
ok = perperl_ipc_accept(OPTVAL_TIMEOUT*1000);
/* Put signals back to original settings */
perperl_sig_free(&sl);
/* If timed out or signal, then finish up */
if (!ok)
all_done();
}
/* Read in a string on stdin. */
static char *get_string(register PerlIO *pio_in, int *sz_ret) {
int sz;
register char *buf;
/* Read length of string */
sz = PerlIO_getc(pio_in);
switch(sz) {
case -1:
DIE_QUIET("protocol error");
case 0:
buf = NULL;
break;
case MAX_SHORT_STR:
PerlIO_read(pio_in, &sz, sizeof(int));
/* Fall through */
default:
/* Allocate space */
perperl_new(buf, sz+1, char);
/* Read string and terminate */
PerlIO_read(pio_in, buf, sz);
buf[sz] = '\0';
break;
}
if (sz_ret)
*sz_ret = sz;
return buf;
}
static void do_proto2(char **cwd_path) {
char c;
/* Tell the frontend what we need */
c = cwd_path ? 1 : 0;
write(PREF_FD_ACCEPT_O, &c, 1);
if (cwd_path) {
PerlIO *pio_file = PerlIO_fdopen(dup(PREF_FD_ACCEPT_E), "r");
/* Get cwd */
*cwd_path = get_string(pio_file, NULL);
PerlIO_close(pio_file);
}
}
static PersistentCwd *cwd_new(const char *path) {
char key[DEVINO_STR_SIZE];
int key_len;
SV *sv;
PersistentCwd *cwd;
perperl_new(cwd, 1, PersistentCwd);
/* Chdir to the given path */
if (!path || chdir_path(path, &(cwd->devino)) == -1) {
perperl_free(cwd);
return NULL;
}
/* Make a new cwd structure */
cwd->refcnt = 0;
cwd->path = newSVpv(path, 0);
/* Store in the hash */
sv = newSViv((IV)cwd);
SvREFCNT_inc(sv);
key_len = devino_str(cwd->devino, key);
my_hv_store(cwd_hash, key, key_len, sv);
if (!hv_store_ent(cwd_hash, cwd->path, sv, 0))
SvREFCNT_dec(sv);
return cwd;
}
static void store_last_cwd(PersistentCwd **last_cwd, PersistentCwd *cwd) {
PersistentCwd *prev_ptr = *last_cwd;
cwd->refcnt++;
*last_cwd = cwd;
if (prev_ptr)
cwd_refcnt_dec(prev_ptr);
}
#define PACKAGE_FMT PERPERL_PKG("_%s")
#define COLON_HANDLER "::handler"
#define PACKAGE1 "package "
#define PACKAGE2 "; sub handler { "
static void load_script(
PersistentDevIno devino, PersistentScript *scr, const char *scr_path
)
{
SV *sv;
char pkg[sizeof(PACKAGE_FMT)+DEVINO_STR_SIZE+sizeof(COLON_HANDLER)+5];
/* Get package name */
{
char hex_str[DEVINO_STR_SIZE];
devino_str(devino, hex_str);
sprintf(pkg, PACKAGE_FMT, hex_str);
}
/* Create phony package in sv with the script code in the handler func */
{
struct stat stbuf;
PersistentMapInfo *mi = NULL;
int fd;
/* Grab the contents of the file */
if ((fd = perperl_util_open_stat(scr_path, &stbuf)) != -1) {
mi = perperl_util_mapin(fd, -1, stbuf.st_size);
close(fd);
}
if (fd == -1 || mi == NULL)
perperl_util_die(scr_path);
/* Create sv to eval */
sv = newSVpvn(PACKAGE1, sizeof(PACKAGE1)-1);
sv_catpv (sv, pkg);
sv_catpvn(sv, PACKAGE2, sizeof(PACKAGE2)-1);
sv_catpvn(sv, mi->addr, mi->maplen);
sv_catpvn(sv, "; }", 3);
/* Get rid of the file contents */
perperl_util_mapout(mi);
}
/* Evaluate the sv to create the handler */
{
dSP;
PUSHMARK(SP);
eval_sv(sv, G_DISCARD | G_NOARGS | G_VOID | G_EVAL | G_KEEPERR);
}
SvREFCNT_dec(sv);
/* If there were no eval errors, then store a reference to the handler */
scr->handler = NULL;
if (!SvTRUE(PERLVAL_EVAL_ERROR)) {
CV *cv;
strcat(pkg, COLON_HANDLER);
if ((cv = get_cv(pkg, 0)))
scr->handler = newRV_inc((SV*)cv);
}
/* Die if we couldn't create the handler for whatever reason */
if (!scr->handler) {
DIE_QUIET("Could not compile code for %s: %s",
scr_path, my_SvPV(PERLVAL_EVAL_ERROR));
}
}
static void cleanup_after_perl(void) {
/* Cached time is now invalid */
perperl_util_time_invalidate();
/* Cancel any alarms */
alarm(0);
/* Terminate if a forked child returned */
if (getpid() != perperl_util_getpid()) {
perperl_util_pid_invalidate();
perperl_file_fork_child();
all_done();
}
/* Tell our file code that its fd is suspect */
perperl_file_fd_is_suspect();
}
/* One run of the perl process, do stdio using socket. */
static int onerun(int single_script) {
int sz, new_script, cwd_where, exit_val;
char *scr_path;
PersistentDevIno fe_scr;
PersistentScript *scr;
PerlIO *pio_in, *pio_out, *pio_err;
register char *s, *buf;
pio_in = PerlIO_stdin();
pio_out = PerlIO_stdout();
pio_err = PerlIO_stderr();
/* Set up perl STD* filehandles to have the PerlIO file pointers */
IoIFP(GvIOp(PERLVAL_STDIN)) = IoOFP(GvIOp(PERLVAL_STDIN)) = pio_in;
IoIFP(GvIOp(PERLVAL_STDOUT)) = IoOFP(GvIOp(PERLVAL_STDOUT)) = pio_out;
IoIFP(GvIOp(PERLVAL_STDERR)) = IoOFP(GvIOp(PERLVAL_STDERR)) = pio_err;
/* Do "select STDOUT" */
setdefout(PERLVAL_STDOUT);
/* TEST - this should cause a "protocol error" */
/* close(0); */
/* Get info from the frontend. */
/*
* %ENV
*/
/* Undef it */
hv_undef(PERLVAL_ENV);
/* Read in environment from stdin. */
while ((buf = get_string(pio_in, &sz))) {
/* Find equals. Store key/val in %ENV */
if ((s = strchr(buf, '='))) {
register int i = s - buf;
register int len = sz - (i+1);
SV *sv = newSVpvn(s+1, len);
my_hv_store(PERLVAL_ENV, buf, i, sv);
*s = '\0';
my_setenv(buf, s+1);
}
perperl_free(buf);
}
/*
* @ARGV
*/
/* Undef it. */
av_undef(PERLVAL_ARGV);
/* Read in argv from stdin. */
while ((buf = get_string(pio_in, &sz))) {
register SV *sv = newSVpvn(buf, sz);
av_push(PERLVAL_ARGV, sv);
perperl_free(buf);
}
/*
* Script filename
*/
scr_path = get_string(pio_in, NULL);
/*
* Script device/inode
*/
DEVINO_GET(pio_in, fe_scr);
/*
* Find the script structure for this script
*/
scr = find_scr(fe_scr, &new_script);
/*
* Is cwd part of the script filename?
*/
cwd_where = PerlIO_getc(pio_in);
if (cwd_where == PERPERL_CWD_IN_SCRIPT) {
char *dir;
/* Get directory from the script path */
if ((dir = fname_dir(scr_path))) {
SV **sv;
int done = 0;
PersistentCwd *cwd = NULL;
/* Look up path in hash to find PersistentCwd and device/inode */
if ((sv = hv_fetch(cwd_hash, dir, strlen(dir), 0))) {
cwd = (PersistentCwd*)SvIV(*sv);
/* Try to cd there quickly without using a path */
done = quick_cd(cwd->devino);
}
if (!done) {
/* Chdir to the path the frontend gave us and get its cwd */
cwd = cwd_new(dir);
}
/* Store the cwd struct with this script */
store_last_cwd(&(scr->last_cwd), cwd);
perperl_free(dir);
}
} else {
int did_proto2 = 0, done = 0;
PersistentCwd *cwd = NULL;
/* Is frontend passing over cwd's device/inode */
if (cwd_where == PERPERL_CWD_DEVINO) {
PersistentDevIno fe_cwd;
/* Get cwd device/inode from frontend */
DEVINO_GET(pio_in, fe_cwd);
/* Try to quickly get there without using a path */
done = quick_cd(fe_cwd);
if (!done) {
/* Try using the path in last_cwd in the script struct */
done = scr->last_cwd &&
DEVINO_SAME(fe_cwd, scr->last_cwd->devino) &&
chdir_path_sv(scr->last_cwd->path) != -1;
/* Didn't work. Try to look up device/inode in hash */
if (!done) {
SV **sv;
if ((sv = find_devino(fe_cwd, cwd_hash, 0))) {
cwd = (PersistentCwd*)SvIV(*sv);
/* If found, go to that path */
done = (chdir_path_sv(cwd->path) != -1);
}
}
}
}
if (!done) {
char *dir;
/*
* Do proto2 with frontend to get path
*/
do_proto2(&dir);
did_proto2 = 1;
/* Cd to this path and get its cwd structure back */
if (dir) {
cwd = cwd_new(dir);
perperl_free(dir);
}
}
/* If we used a cwd structure, make sure to save it */
if (cwd)
store_last_cwd(&(scr->last_cwd), cwd);
/* Must do proto2 if not already done */
if (!did_proto2)
do_proto2(NULL);
}
/* Do shutdowns so we get an error when writing/reading in the wrong
* direction
*/
shutdown(0, 1);
shutdown(1, 0);
shutdown(2, 0);
/*
* Load the script if it's new
*/
if (new_script)
load_script(fe_scr, scr, scr_path);
/* Set $0 to the script filename */
sv_setpv(PERLVAL_PROGRAM_NAME, scr_path);
perperl_free(scr_path);
/* If using groups, set the pointer to the correct handler */
if (!single_script)
sv_setsv(PERLVAL_SUB, scr->handler);
/* Run the perl code.
*/
exit_val = perl_run(my_perl);
/* Call any registered cleanup functions */
my_call_sv(get_perlvar(&PERLVAR_RUN_CLEANUP));
cleanup_after_perl();
/* Flush output, in case perl's stdio/reopen below don't */
PerlIO_flush(pio_out);
PerlIO_flush(pio_err);
/* Close down perl's STD* files (might not be the same as PerlIO files) */
do_close(PERLVAL_STDOUT, FALSE);
do_close(PERLVAL_STDERR, FALSE);
do_close(PERLVAL_STDIN, FALSE);
/* Get stdio files back in shape */
if (PerlIO_reopen(dev_null, "r", pio_in ) == NULL ||
PerlIO_reopen(dev_null, "w", pio_out) == NULL ||
PerlIO_reopen(dev_null, "w", pio_err) == NULL)
{
perperl_util_die("Cannot open /dev/null");
}
close(0); close(1); close(2);
/* Hack for CGI.pm */
my_call_sv(get_perlvar(&PERLVAR_RESET_GLOBALS));
/* Copy option values in from the perl vars */
if (SvIV(PERLVAL_OPTS_CHANGED)) {
int i;
for (i = 0; i < PERPERL_NUMOPTS; ++i) {
OptRec *o = perperl_optdefs + i;
SV **svp = hv_fetch(PERLVAL_OPTS, o->name, o->name_len, 0);
if (svp)
(void) perperl_opt_set(o, my_SvPV(*svp));
}
sv_setiv(PERLVAL_OPTS_CHANGED, 0);
}
#ifdef DUMP_HASH
{
time_t t;
PerlIO *pio = PerlIO_open("/tmp/perperl_backend_dump", "a");
t = time(NULL);
PerlIO_printf(pio, "\npid=%d time=%s\n",
perperl_util_getpid(), asctime(localtime(&t)));
dump_hash(cwd_hash, pio);
dump_hash(scr_hash, pio);
PerlIO_close(pio);
}
#endif
return exit_val;
}
/* Called from xs_init */
void perperl_xs_init(void) {
int i;
SV *sv;
/*
* Put things here that have to be done in the perl interpreter before
* a script runs its BEGIN block.
*/
/* Find/create our perl vars in the interpreter */
for (i = 0; i < PERLVAR_COUNT; ++i) {
(void) get_perlvar(PersistentPerlVars + i);
}
scr_hash = newHV();
cwd_hash = newHV();
/* Tell our module that we are persistentperl */
sv_inc(PERLVAL_I_AM_PERPERL);
/* Avoid warnings about "used only once" */
GvMULTI_on(
gv_fetchpv(PERLVAR_I_AM_PERPERL.name, 0, PERLVAR_I_AM_PERPERL.type)
);
/*
* Initialize options variables in our module.
*/
for (i = 0; i < PERPERL_NUMOPTS; ++i) {
OptRec *o = perperl_optdefs + i;
if (o->type == OTYPE_STR) {
if (!STR_OPTVAL(o))
continue;
sv = newSVpv(STR_OPTVAL(o), 0);
} else {
sv = newSViv(INT_OPTVAL(o));
}
my_hv_store(PERLVAL_OPTS, o->name, o->name_len, sv);
}
}
void perperl_perl_init(void) {
char **perl_argv;
const char *temp_script_name;
int use_devfd, is_new;
char dev_fd_name[sizeof(DEVFD)+10];
PersistentScript *scr;
int single_script = DOING_SINGLE_SCRIPT;
/* If we're exec'ing a setuid script then we must use a temporary
* script name of /dev/fd/N
*/
use_devfd = single_script &&
perperl_script_getstat()->st_mode & (S_ISUID|S_ISGID);
if (single_script) {
if (use_devfd) {
sprintf(dev_fd_name, DEVFD, perperl_script_open());
temp_script_name = dev_fd_name;
} else {
temp_script_name = NULL;
}
} else {
temp_script_name = "-e&{$" PERPERL_PKG("_sub") "}(@ARGV);";
}
/* Parse perl file. */
perl_argv = perperl_opt_perl_argv(temp_script_name);
if (perl_parse(my_perl, xs_init,
perperl_util_argc((const char * const *)perl_argv), perl_argv, NULL))
{
DIE_QUIET("perl_parse error");
}
cleanup_after_perl();
/* If we had to use /dev/fd/N, perl will close the file for us, so
* make sure our code knows it's closed. If we need it from here on out
* it'll have to be re-opened.
*/
if (use_devfd)
perperl_script_close();
/* Create a PersistentScript entry for the standard script */
scr = find_scr(perperl_util_stat_devino(perperl_script_getstat()), &is_new);
/* If using groups, try pre-loading the script to save time later */
if (!single_script && !perperl_script_open_failure()) {
load_script(
perperl_util_stat_devino(perperl_script_getstat()),
scr, perperl_opt_script_fname()
);
cleanup_after_perl();
}
/* Time to close stderr */
close(2);
}
void perperl_perl_run(slotnum_t gslotnum, slotnum_t bslotnum) {
int numrun, exit_val;
int single_script = DOING_SINGLE_SCRIPT;
/* Start listening on our socket */
perperl_ipc_listen(bslotnum);
/* Main loop */
for (numrun = 0; !OPTVAL_MAXRUNS || numrun < OPTVAL_MAXRUNS; ++numrun) {
/* Lock/mmap our temp file. If our group is invalid, exit quietly */
if (getppid() == 1 || !perperl_group_lock(gslotnum))
all_done();
/* Update our maturity level */
FILE_SLOT(be_slot, bslotnum).maturity = numrun ? 2 : 1;
/* Put ourself onto the be_wait list */
perperl_backend_be_wait_put(gslotnum, bslotnum);
/* If we were listed as starting, turn that off */
if (FILE_SLOT(gr_slot, gslotnum).be_starting == perperl_util_getpid())
FILE_SLOT(gr_slot, gslotnum).be_starting = 0;
/* Send out alarm signal to frontends */
perperl_group_sendsigs(gslotnum);
/* Fix our listener fd */
perperl_ipc_listen_fixfd(bslotnum);
/* Unlock file */
perperl_file_set_state(FS_HAVESLOTS);
/* Do an accept on our socket */
backend_accept();
/* Lock file. If our group is invalid, exit quietly */
if (!perperl_group_lock(gslotnum))
all_done();
/* If we were listed as starting, turn that off */
if (FILE_SLOT(gr_slot, gslotnum).be_starting == perperl_util_getpid())
FILE_SLOT(gr_slot, gslotnum).be_starting = 0;
/* Wake up any waiting frontends */
perperl_group_sendsigs(gslotnum);
/* Unlock the file */
perperl_file_set_state(FS_HAVESLOTS);
/* Run the perl code once */
exit_val = onerun(single_script);
/* Send the exit status to the frontend */
perperl_file_set_state(FS_CORRUPT);
perperl_backend_exited(bslotnum, 0, exit_val);
}
/* Start up a replacement backend */
if (perperl_group_lock(gslotnum))
perperl_group_start_be(gslotnum);
/* Exit out */
all_done();
}
int perperl_perl_fork(void) {
dSP;
int retval;
static int made_sub;
if (!made_sub) {
made_sub = 1;
eval_pv("sub " PERPERL_PKG("_fork") " {return fork;}", TRUE);
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
if (call_sv(get_perlvar(&PERLVAR_FORK), G_NOARGS|G_SCALAR) != 1)
DIE_QUIET("perl fork didn't return one value");
SPAGAIN;
retval = POPi;
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
/*
* Glue
*/
void perperl_abort(const char *s) {
PerlIO_puts(PerlIO_stderr(), s);
perperl_util_exit(1, 0);
}