#endif
#endif
-#define I_REINIT \
- STMT_START { \
- chopset = " \n-"; \
- copline = NOLINE; \
- curcop = &compiling; \
- curcopdb = NULL; \
- cxstack_ix = -1; \
- cxstack_max = 128; \
- dbargs = 0; \
- dlmax = 128; \
- laststatval = -1; \
- laststype = OP_STAT; \
- maxscream = -1; \
- maxsysfd = MAXSYSFD; \
- statname = Nullsv; \
- tmps_floor = -1; \
- tmps_ix = -1; \
- op_mask = NULL; \
- dlmax = 128; \
- laststatval = -1; \
- laststype = OP_STAT; \
- 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_interp _((void));
static void init_ids _((void));
static void init_debugger _((void));
static void init_lexer _((void));
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
+ ++ninterps;
Zero(sv_interp, 1, PerlInterpreter);
#endif
thr = init_main_thread();
#endif /* USE_THREADS */
- linestr = NEWSV(65,80);
+ linestr = NEWSV(65,79);
sv_upgrade(linestr,SVt_PVIV);
if (!SvREADONLY(&sv_undef)) {
nrs = newSVpv("\n", 1);
rs = SvREFCNT_inc(nrs);
+#ifdef PERL_OBJECT
+ /* TODO: */
+ /* sighandlerp = sighandler; */
+#else
sighandlerp = sighandler;
+#endif
pidstatus = newHV();
#ifdef MSDOS
init_stacks(ARGS);
#ifdef MULTIPLICITY
- I_REINIT;
+ init_interp();
perl_destruct_level = 1;
#else
- if(perl_destruct_level > 0)
- I_REINIT;
+ if (perl_destruct_level > 0)
+ init_interp();
#endif
init_ids();
}
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
LEAVE;
FREETMPS;
+#ifdef MULTIPLICITY
+ --ninterps;
+#endif
+
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
/* call exit list functions */
while (exitlistlen-- > 0)
- exitlist[exitlistlen].fn(exitlist[exitlistlen].ptr);
+ exitlist[exitlistlen].fn(PERL_OBJECT_THIS_ exitlist[exitlistlen].ptr);
Safefree(exitlist);
argvoutgv = Nullgv;
stdingv = Nullgv;
last_in_gv = Nullgv;
+ replgv = Nullgv;
/* reset so print() ends up where we expect */
setdefout(Nullgv);
/* No SVs have survived, need to clean out */
linestr = NULL;
pidstatus = Nullhv;
- if (origfilename)
- Safefree(origfilename);
+ Safefree(origfilename);
+ Safefree(archpat_auto);
+ Safefree(reg_start_tmp);
+ Safefree(HeKEY_hek(&hv_fetch_ent_mh));
+ Safefree(op_mask);
nuke_stacks();
hints = 0; /* Reset hints. Should hints be per-interpreter ? */
}
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;
AV* comppadlist;
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
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)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
#if defined(VMS) || defined(WIN32) || defined(DJGPP)
init_os_extras();
#endif
}
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
+/* initialize curinterp */
+STATIC void
+init_interp(void)
+{
+
+#ifdef PERL_OBJECT /* XXX kludge */
+#define I_REINIT \
+ STMT_START { \
+ chopset = " \n-"; \
+ copline = NOLINE; \
+ curcop = &compiling; \
+ curcopdb = NULL; \
+ dbargs = 0; \
+ dlmax = 128; \
+ laststatval = -1; \
+ laststype = OP_STAT; \
+ maxscream = -1; \
+ maxsysfd = MAXSYSFD; \
+ statname = Nullsv; \
+ tmps_floor = -1; \
+ tmps_ix = -1; \
+ op_mask = NULL; \
+ dlmax = 128; \
+ laststatval = -1; \
+ laststype = OP_STAT; \
+ mess_sv = Nullsv; \
+ splitstr = " "; \
+ generation = 100; \
+ exitlist = NULL; \
+ exitlistlen = 0; \
+ regindent = 0; \
+ in_clean_objs = FALSE; \
+ in_clean_all= FALSE; \
+ profiledata = NULL; \
+ rsfp = Nullfp; \
+ rsfp_filters= Nullav; \
+ } STMT_END
+ I_REINIT;
+#else
+# ifdef MULTIPLICITY
+# define PERLVAR(var,type)
+# define PERLVARI(var,type,init) curinterp->var = init;
+# define PERLVARIC(var,type,init) curinterp->var = init;
+# include "intrpvar.h"
+# ifndef USE_THREADS
+# include "thrdvar.h"
+# endif
+# undef PERLVAR
+# undef PERLVARI
+# undef PERLVARIC
+# else
+# define PERLVAR(var,type)
+# define PERLVARI(var,type,init) var = init;
+# define PERLVARIC(var,type,init) var = init;
+# include "intrpvar.h"
+# ifndef USE_THREADS
+# include "thrdvar.h"
+# endif
+# undef PERLVAR
+# undef PERLVARI
+# undef PERLVARIC
+# endif
+#endif
+
+}
+
+STATIC void
init_main_stash(void)
{
dTHR;
defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
GvMULTI_on(errgv);
+ replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
+ GvMULTI_on(replgv);
(void)form("%240s",""); /* Preallocate temp - for immediate signals. */
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
sv_setpvn(ERRSV, "", 0);
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;
- scriptname = find_script(scriptname, dosearch, NULL, 0);
+ /* scriptname will be non-NULL if find_script() returns */
+ scriptname = find_script(scriptname, dosearch, NULL, 1);
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_script ? "-e" : scriptname);
+ *fdscript = -1;
+ origfilename = (e_script ? savepv("-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 */
}
else if (preprocess) {
char *cpp_cfg = CPPSTDIN;
- SV *cpp = NEWSV(0,0);
+ SV *cpp = newSVpv("",0);
SV *cmd = NEWSV(0,0);
if (strEQ(cpp_cfg, "cppstdin"))
#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 */
}
}
-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 I32
-read_e_script(int idx, SV *buf_sv, int maxlen)
-{
- char *p, *nl;
- FILTER_READ(idx+1, buf_sv, maxlen);
- 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;
-}
-
-
-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;
tmps_ix = -1;
tmps_max = REASONABLE(128);
- /*
- * The following stacks almost certainly should be per-interpreter,
- * but for now they're not. XXX
- */
-
- if (markstack) {
- markstack_ptr = markstack;
- } else {
- New(54,markstack,REASONABLE(32),I32);
- markstack_ptr = markstack;
- markstack_max = markstack + REASONABLE(32);
- }
+ New(54,markstack,REASONABLE(32),I32);
+ markstack_ptr = markstack;
+ markstack_max = markstack + REASONABLE(32);
SET_MARKBASE;
- if (scopestack) {
- scopestack_ix = 0;
- } else {
- New(54,scopestack,REASONABLE(32),I32);
- scopestack_ix = 0;
- scopestack_max = REASONABLE(32);
- }
+ New(54,scopestack,REASONABLE(32),I32);
+ scopestack_ix = 0;
+ scopestack_max = REASONABLE(32);
- if (savestack) {
- savestack_ix = 0;
- } else {
- New(54,savestack,REASONABLE(128),ANY);
- savestack_ix = 0;
- savestack_max = REASONABLE(128);
- }
+ New(54,savestack,REASONABLE(128),ANY);
+ savestack_ix = 0;
+ savestack_max = REASONABLE(128);
- if (retstack) {
- retstack_ix = 0;
- } else {
- New(54,retstack,REASONABLE(16),OP*);
- retstack_ix = 0;
- retstack_max = REASONABLE(16);
- }
+ New(54,retstack,REASONABLE(16),OP*);
+ retstack_ix = 0;
+ retstack_max = REASONABLE(16);
}
#undef REASONABLE
-static void
+STATIC void
nuke_stacks(void)
{
dTHR;
curstackinfo = p;
}
Safefree(tmps_stack);
+ Safefree(markstack);
+ Safefree(scopestack);
+ Safefree(savestack);
+ Safefree(retstack);
DEBUG( {
Safefree(debname);
Safefree(debdelim);
} )
}
+#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;
if (addsubdirs) {
- subdir = NEWSV(55,0);
+ subdir = sv_newmortal();
if (!archpat_auto) {
STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
+ sizeof("//auto"));
/* finally push this lib directory on the end of @INC */
av_push(GvAVn(incgv), libdir);
}
-
- SvREFCNT_dec(subdir);
}
#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;
JMPENV_JUMP(2);
}
+
+
+#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;
+}
+
+
https://perl5.git.perl.org / perl5.git / blobdiff