mess_sv = Nullsv; \
} STMT_END
+#ifdef PERL_OBJECT
+static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
+#else
static void find_beginning _((void));
static void forbid_setid _((char *));
static void incpush _((char *, int));
static void init_predump_symbols _((void));
static void my_exit_jump _((void)) __attribute__((noreturn));
static void nuke_stacks _((void));
-static void open_script _((char *, bool, SV *));
+static void open_script _((char *, bool, SV *, int *fd));
static void usage _((char *));
-static void validate_suid _((char *, char*));
+static void validate_suid _((char *, char*, int));
+static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
+#endif
-static int fdscript = -1;
+#ifdef PERL_OBJECT
+CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
+ IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
+{
+ CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
+ if(pPerl != NULL)
+ pPerl->Init();
+ return pPerl;
+}
+#else
PerlInterpreter *
perl_alloc(void)
{
New(53, sv_interp, 1, PerlInterpreter);
return sv_interp;
}
+#endif /* PERL_OBJECT */
void
+#ifdef PERL_OBJECT
+CPerlObj::perl_construct(void)
+#else
perl_construct(register PerlInterpreter *sv_interp)
+#endif
{
#ifdef USE_THREADS
int i;
#endif /* FAKE_THREADS */
#endif /* USE_THREADS */
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return;
+#endif
#ifdef MULTIPLICITY
Zero(sv_interp, 1, PerlInterpreter);
nrs = newSVpv("\n", 1);
rs = SvREFCNT_inc(nrs);
+#ifdef PERL_OBJECT
+ /* TODO: */
+ /* sighandlerp = sighandler; */
+#else
sighandlerp = sighandler;
+#endif
pidstatus = newHV();
#ifdef MSDOS
}
void
+#ifdef PERL_OBJECT
+CPerlObj::perl_destruct(void)
+#else
perl_destruct(register PerlInterpreter *sv_interp)
+#endif
{
dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
Thread t;
#endif /* USE_THREADS */
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return;
+#endif
#ifdef USE_THREADS
#ifndef FAKE_THREADS
/* call exit list functions */
while (exitlistlen-- > 0)
- exitlist[exitlistlen].fn(exitlist[exitlistlen].ptr);
+ exitlist[exitlistlen].fn(THIS_ exitlist[exitlistlen].ptr);
Safefree(exitlist);
Safefree(inplace);
inplace = Nullch;
- Safefree(e_tmpname);
- e_tmpname = Nullch;
-
- if (e_fp) {
- PerlIO_close(e_fp);
- e_fp = Nullfp;
+ if (e_script) {
+ SvREFCNT_dec(e_script);
+ e_script = Nullsv;
}
/* magical thingies */
if (hent) {
warn("Unbalanced string table refcount: (%d) for \"%s\"",
HeVAL(hent) - Nullsv, HeKEY(hent));
- HeVAL(hent) = &sv_undef;
+ HeVAL(hent) = Nullsv;
hent = HeNEXT(hent);
}
if (!hent) {
}
void
+#ifdef PERL_OBJECT
+CPerlObj::perl_free(void)
+#else
perl_free(PerlInterpreter *sv_interp)
+#endif
{
+#ifdef PERL_OBJECT
+ Safefree(this);
+#else
if (!(curinterp = sv_interp))
return;
Safefree(sv_interp);
+#endif
}
void
+#ifdef PERL_OBJECT
+CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
+#else
perl_atexit(void (*fn) (void *), void *ptr)
+#endif
{
Renew(exitlist, exitlistlen+1, PerlExitListEntry);
exitlist[exitlistlen].fn = fn;
}
int
+#ifdef PERL_OBJECT
+CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
+#else
perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
+#endif
{
dTHR;
register SV *sv;
char *validarg = "";
I32 oldscope;
AV* comppadlist;
- int e_tmpfd = -1;
dJMPENV;
int ret;
+ int fdscript = -1;
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
#endif
#endif
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return 255;
+#endif
#if defined(NeXT) && defined(__DYNAMIC__)
_dyld_lookup_and_bind
#ifndef VMS /* VMS doesn't have environ array */
origenviron = environ;
#endif
- e_tmpname = Nullch;
if (do_undump) {
case 'e':
if (euid != uid || egid != gid)
croak("No -e allowed in setuid scripts");
- if (!e_fp) {
-#if defined(HAS_UMASK) && !defined(VMS)
- int oldumask = PerlLIO_umask(0177);
-#endif
- e_tmpname = savepv(TMPPATH);
-#ifdef HAS_MKSTEMP
- e_tmpfd = PerlLIO_mkstemp(e_tmpname);
-#else /* use mktemp() */
- (void)PerlLIO_mktemp(e_tmpname);
- if (!*e_tmpname)
- croak("Cannot generate temporary filename");
-# if defined(HAS_OPEN3) && defined(O_EXCL)
- e_tmpfd = open(e_tmpname,
- O_WRONLY | O_CREAT | O_EXCL,
- 0600);
-# else
- (void)UNLINK(e_tmpname);
- /* Yes, potential race. But at least we can say we tried. */
- e_fp = PerlIO_open(e_tmpname,"w");
-# endif
-#endif /* ifdef HAS_MKSTEMP */
-#if defined(HAS_MKSTEMP) || (defined(HAS_OPEN3) && defined(O_EXCL))
- if (e_tmpfd < 0)
- croak("Cannot create temporary file \"%s\"", e_tmpname);
- e_fp = PerlIO_fdopen(e_tmpfd,"w");
-#endif
- if (!e_fp)
- croak("Cannot create temporary file \"%s\"", e_tmpname);
-#if defined(HAS_UMASK) && !defined(VMS)
- (void)PerlLIO_umask(oldumask);
-#endif
+ if (!e_script) {
+ e_script = newSVpv("",0);
+ filter_add(read_e_script, NULL);
}
if (*++s)
- PerlIO_puts(e_fp,s);
+ sv_catpv(e_script, s);
else if (argv[1]) {
- PerlIO_puts(e_fp,argv[1]);
+ sv_catpv(e_script, argv[1]);
argc--,argv++;
}
else
croak("No code specified for -e");
- (void)PerlIO_putc(e_fp,'\n');
+ sv_catpv(e_script, "\n");
break;
+
case 'I': /* -I handled both here and in moreswitches() */
forbid_setid("-I");
if (!*++s && (s=argv[1]) != Nullch) {
if (!scriptname)
scriptname = argv[0];
- if (e_fp) {
- if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
-#ifndef MULTIPLICITY
- warn("Did you forget to compile with -DMULTIPLICITY?");
-#endif
- croak("Can't write to temp file for -e: %s", Strerror(errno));
- }
- e_fp = Nullfp;
+ if (e_script) {
argc++,argv--;
- scriptname = e_tmpname;
+ scriptname = BIT_BUCKET; /* don't look for script or read stdin */
}
else if (scriptname == Nullch) {
#ifdef MSDOS
init_perllib();
- open_script(scriptname,dosearch,sv);
+ open_script(scriptname,dosearch,sv,&fdscript);
- validate_suid(validarg, scriptname);
+ validate_suid(validarg, scriptname,fdscript);
if (doextract)
find_beginning();
CvPADLIST(compcv) = comppadlist;
boot_core_UNIVERSAL();
+
if (xsinit)
- (*xsinit)(); /* in case linked C routines want magical variables */
+ (*xsinit)(THIS); /* in case linked C routines want magical variables */
#if defined(VMS) || defined(WIN32) || defined(DJGPP)
init_os_extras();
#endif
init_predump_symbols();
+ /* init_postdump_symbols not currently designed to be called */
+ /* more than once (ENV isn't cleared first, for example) */
+ /* But running with -u leaves %ENV & @ARGV undefined! XXX */
if (!do_undump)
init_postdump_symbols(argc,argv,env);
curcop->cop_line = 0;
curstash = defstash;
preprocess = FALSE;
- if (e_tmpname) {
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
- e_tmpfd = -1;
+ if (e_script) {
+ SvREFCNT_dec(e_script);
+ e_script = Nullsv;
}
/* now that script is parsed, we can modify record separator */
}
int
+#ifdef PERL_OBJECT
+CPerlObj::perl_run(void)
+#else
perl_run(PerlInterpreter *sv_interp)
+#endif
{
dSP;
I32 oldscope;
dJMPENV;
int ret;
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return 255;
+#endif
oldscope = scopestack_ix;
if (restartop) {
op = restartop;
restartop = 0;
- runops();
+ CALLRUNOPS();
}
else if (main_start) {
CvDEPTH(main_cv) = 1;
op = main_start;
- runops();
+ CALLRUNOPS();
}
my_exit(0);
I32 oldmark;
I32 retval;
I32 oldscope;
- static CV *DBcv;
bool oldcatch = CATCH_GET;
dJMPENV;
int ret;
if (op == (OP*)&myop)
op = pp_entersub(ARGS);
if (op)
- runops();
+ CALLRUNOPS();
retval = stack_sp - (stack_base + oldmark);
if ((flags & G_EVAL) && !(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
if (op == (OP*)&myop)
op = pp_entereval(ARGS);
if (op)
- runops();
+ CALLRUNOPS();
retval = stack_sp - (stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
-static void
+STATIC void
usage(char *name) /* XXX move this out into a module ? */
{
/* This message really ought to be max 23 lines.
* Removed -h because the user already knows that opton. Others? */
- static char *usage[] = {
+ static char *usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
"-a autosplit mode with -n or -p (splits $_ into @F)",
"-c check syntax only (runs BEGIN and END blocks)",
"\n",
NULL
};
- char **p = usage;
+ char **p = usage_msg;
printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
while (*p)
#endif
}
-static void
+STATIC void
init_main_stash(void)
{
dTHR;
sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
}
-static void
-open_script(char *scriptname, bool dosearch, SV *sv)
+STATIC void
+open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
{
dTHR;
register char *s;
if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
char *s = scriptname + 8;
- fdscript = atoi(s);
+ *fdscript = atoi(s);
while (isDIGIT(*s))
s++;
if (*s)
scriptname = s + 1;
}
else
- fdscript = -1;
- origfilename = savepv(e_tmpname ? "-e" : scriptname);
+ *fdscript = -1;
+ origfilename = savepv(e_script ? "-e" : scriptname);
curcop->cop_filegv = gv_fetchfile(origfilename);
if (strEQ(origfilename,"-"))
scriptname = "";
- if (fdscript >= 0) {
- rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
+ if (*fdscript >= 0) {
+ rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
#if defined(HAS_FCNTL) && defined(F_SETFD)
if (rsfp)
fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
#else
- setuid(uid);
+ PerlProc_setuid(uid);
#endif
#endif
#endif
- if (geteuid() != uid)
+ if (PerlProc_geteuid() != uid)
croak("Can't do seteuid!\n");
}
#endif /* IAMSUID */
fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
#endif
}
- if (e_tmpname) {
- e_fp = rsfp;
- }
if (!rsfp) {
#ifdef DOSUID
#ifndef IAMSUID /* in case script is not readable before setuid */
}
}
-static void
-validate_suid(char *validarg, char *scriptname)
+STATIC void
+validate_suid(char *validarg, char *scriptname, int fdscript)
{
int which;
setresuid(euid,uid,(Uid_t)-1) < 0
# endif
#endif
- || getuid() != euid || geteuid() != uid)
+ || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
croak("Can't swap uid and euid"); /* really paranoid */
if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
croak("Permission denied"); /* testing full pathname here */
setresuid(uid,euid,(Uid_t)-1) < 0
# endif
#endif
- || getuid() != uid || geteuid() != euid)
+ || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
croak("Can't reswap uid and euid");
if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
croak("Permission denied\n");
#ifdef HAS_SETRESGID
(void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
#else
- setgid(statbuf.st_gid);
+ PerlProc_setgid(statbuf.st_gid);
#endif
#endif
#endif
- if (getegid() != statbuf.st_gid)
+ if (PerlProc_getegid() != statbuf.st_gid)
croak("Can't do setegid!\n");
}
if (statbuf.st_mode & S_ISUID) {
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
#else
- setuid(statbuf.st_uid);
+ PerlProc_setuid(statbuf.st_uid);
#endif
#endif
#endif
- if (geteuid() != statbuf.st_uid)
+ if (PerlProc_geteuid() != statbuf.st_uid)
croak("Can't do seteuid!\n");
}
else if (uid) { /* oops, mustn't run as root */
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
#else
- setuid((Uid_t)uid);
+ PerlProc_setuid((Uid_t)uid);
#endif
#endif
#endif
- if (geteuid() != uid)
+ if (PerlProc_geteuid() != uid)
croak("Can't do seteuid!\n");
}
init_ids();
#endif /* DOSUID */
}
-static void
+STATIC void
find_beginning(void)
{
register char *s, *s2;
}
}
-static void
+
+STATIC void
init_ids(void)
{
- uid = (int)getuid();
- euid = (int)geteuid();
- gid = (int)getgid();
- egid = (int)getegid();
+ uid = (int)PerlProc_getuid();
+ euid = (int)PerlProc_geteuid();
+ gid = (int)PerlProc_getgid();
+ egid = (int)PerlProc_getegid();
#ifdef VMS
uid |= gid << 16;
euid |= egid << 16;
tainting |= (uid && (euid != uid || egid != gid));
}
-static void
+STATIC void
forbid_setid(char *s)
{
if (euid != uid)
croak("No %s allowed while running setgid", s);
}
-static void
+STATIC void
init_debugger(void)
{
dTHR;
#undef REASONABLE
-static void
+STATIC void
nuke_stacks(void)
{
dTHR;
} )
}
+#ifndef PERL_OBJECT
static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
+#endif
-static void
+STATIC void
init_lexer(void)
{
+#ifdef PERL_OBJECT
+ PerlIO *tmpfp;
+#endif
tmpfp = rsfp;
rsfp = Nullfp;
lex_start(linestr);
subname = newSVpv("main",4);
}
-static void
+STATIC void
init_predump_symbols(void)
{
dTHR;
osname = savepv(OSNAME);
}
-static void
+STATIC void
init_postdump_symbols(register int argc, register char **argv, register char **env)
{
dTHR;
if (!(s = strchr(*env,'=')))
continue;
*s++ = '\0';
-#if defined(WIN32) || defined(MSDOS)
+#if defined(MSDOS)
(void)strupr(*env);
#endif
sv = newSVpv(s--,0);
sv_setiv(GvSV(tmpgv), (IV)getpid());
}
-static void
+STATIC void
init_perllib(void)
{
char *s;
#ifndef PRIVLIB_EXP
#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
+#if defined(WIN32)
+ incpush(PRIVLIB_EXP, TRUE);
+#else
incpush(PRIVLIB_EXP, FALSE);
+#endif
#ifdef SITEARCH_EXP
incpush(SITEARCH_EXP, FALSE);
#endif
#ifdef SITELIB_EXP
+#if defined(WIN32)
+ incpush(SITELIB_EXP, TRUE);
+#else
incpush(SITELIB_EXP, FALSE);
#endif
+#endif
if (!tainting)
incpush(".", FALSE);
}
# define PERLLIB_MANGLE(s,n) (s)
#endif
-static void
+STATIC void
incpush(char *p, int addsubdirs)
{
SV *subdir = Nullsv;
- static char *archpat_auto;
if (!p)
return;
}
#ifdef USE_THREADS
-static struct perl_thread *
+STATIC struct perl_thread *
init_main_thread()
{
struct perl_thread *thr;
#endif /* USE_THREADS */
void
-call_list(I32 oldscope, AV *list)
+call_list(I32 oldscope, AV *paramList)
{
dTHR;
line_t oldline = curcop->cop_line;
dJMPENV;
int ret;
- while (AvFILL(list) >= 0) {
- CV *cv = (CV*)av_shift(list);
+ while (AvFILL(paramList) >= 0) {
+ CV *cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
JMPENV_POP;
curcop = &compiling;
curcop->cop_line = oldline;
- if (list == beginav)
+ if (paramList == beginav)
sv_catpv(atsv, "BEGIN failed--compilation aborted");
else
sv_catpv(atsv, "END failed--cleanup aborted");
curcop = &compiling;
curcop->cop_line = oldline;
if (statusvalue) {
- if (list == beginav)
+ if (paramList == beginav)
croak("BEGIN failed--compilation aborted");
else
croak("END failed--cleanup aborted");
my_exit_jump();
}
-static void
+STATIC void
my_exit_jump(void)
{
dSP;
I32 gimme;
SV **newsp;
- if (e_tmpname) {
- if (e_fp) {
- PerlIO_close(e_fp);
- e_fp = Nullfp;
- }
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
+ if (e_script) {
+ SvREFCNT_dec(e_script);
+ e_script = Nullsv;
}
POPSTACK_TO(mainstack);
}
+#include "XSUB.h"
+
+static I32
+#ifdef PERL_OBJECT
+read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
+#else
+read_e_script(int idx, SV *buf_sv, int maxlen)
+#endif
+{
+ char *p, *nl;
+ p = SvPVX(e_script);
+ nl = strchr(p, '\n');
+ nl = (nl) ? nl+1 : SvEND(e_script);
+ if (nl-p == 0)
+ return 0;
+ sv_catpvn(buf_sv, p, nl-p);
+ sv_chop(e_script, nl);
+ return 1;
+}
+