#include <unistd.h>
#endif
-dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
+dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
#ifdef IAMSUID
#ifndef DOSUID
#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; \
+ } STMT_END
+
static void find_beginning _((void));
-static void incpush _((char *));
+static void forbid_setid _((char *));
+static void incpush _((char *, int));
static void init_ids _((void));
static void init_debugger _((void));
static void init_lexer _((void));
static void init_postdump_symbols _((int, char **, char **));
static void init_predump_symbols _((void));
static void init_stacks _((void));
+static void my_exit_jump _((void)) __attribute__((noreturn));
static void nuke_stacks _((void));
static void open_script _((char *, bool, SV *));
static void usage _((char *));
nrs = newSVpv("\n", 1);
rs = SvREFCNT_inc(nrs);
+ pidstatus = newHV();
+
#ifdef MSDOS
/*
* There is no way we can refer to them from Perl so close them to save
}
#ifdef MULTIPLICITY
- chopset = " \n-";
- copline = NOLINE;
- curcop = &compiling;
- dbargs = 0;
- dlmax = 128;
- laststatval = -1;
- laststype = OP_STAT;
- maxscream = -1;
- maxsysfd = MAXSYSFD;
- rsfp = Nullfp;
- statname = Nullsv;
- tmps_floor = -1;
+ I_REINIT;
+ perl_destruct_level = 1;
+#else
+ if(perl_destruct_level > 0)
+ I_REINIT;
#endif
init_ids();
+ STATUS_ALL_SUCCESS;
+
+ SET_NUMERIC_STANDARD();
#if defined(SUBVERSION) && SUBVERSION > 0
sprintf(patchlevel, "%7.5f", (double) 5
+ ((double) PATCHLEVEL / (double) 1000)
PerlIO_init(); /* Hook to IO system */
fdpid = newAV(); /* for remembering popen pids by fd */
- pidstatus = newHV();/* for remembering status of dead pids */
init_stacks();
ENTER;
#ifdef DEBUGGING
{
char *s;
- if (s = getenv("PERL_DESTRUCT_LEVEL"))
- destruct_level = atoi(s);
+ if (s = getenv("PERL_DESTRUCT_LEVEL")) {
+ int i = atoi(s);
+ if (destruct_level < i)
+ destruct_level = i;
+ }
}
#endif
+ /* unhook hooks which will soon be, or use, destroyed data */
+ SvREFCNT_dec(warnhook);
+ warnhook = Nullsv;
+ SvREFCNT_dec(diehook);
+ diehook = Nullsv;
+ SvREFCNT_dec(parsehook);
+ parsehook = Nullsv;
+
LEAVE;
FREETMPS;
- /* We must account for everything. First the syntax tree. */
+ /* We must account for everything. */
+
+ /* Destroy the main CV and syntax tree */
if (main_root) {
curpad = AvARRAY(comppad);
op_free(main_root);
- main_root = 0;
+ main_root = Nullop;
}
+ main_start = Nullop;
+ SvREFCNT_dec(main_cv);
+ main_cv = Nullcv;
+
if (sv_objcount) {
/*
* Try to destruct global references. We do this first so that the
return;
}
- /* unhook hooks which may now point to, or use, broken code */
- if (warnhook && SvREFCNT(warnhook))
- SvREFCNT_dec(warnhook);
- if (diehook && SvREFCNT(diehook))
- SvREFCNT_dec(diehook);
- if (parsehook && SvREFCNT(parsehook))
- SvREFCNT_dec(parsehook);
-
+ /* loosen bonds of global variables */
+
+ if(rsfp) {
+ (void)PerlIO_close(rsfp);
+ rsfp = Nullfp;
+ }
+
+ /* Filters for program text */
+ SvREFCNT_dec(rsfp_filters);
+ rsfp_filters = Nullav;
+
+ /* switches */
+ preprocess = FALSE;
+ minus_n = FALSE;
+ minus_p = FALSE;
+ minus_l = FALSE;
+ minus_a = FALSE;
+ minus_F = FALSE;
+ doswitches = FALSE;
+ dowarn = FALSE;
+ doextract = FALSE;
+ sawampersand = FALSE; /* must save all match strings */
+ sawstudy = FALSE; /* do fbm_instr on all strings */
+ sawvec = FALSE;
+ unsafe = FALSE;
+
+ Safefree(inplace);
+ inplace = Nullch;
+
+ Safefree(e_tmpname);
+ e_tmpname = Nullch;
+
+ if (e_fp) {
+ PerlIO_close(e_fp);
+ e_fp = Nullfp;
+ }
+
+ /* magical thingies */
+
+ Safefree(ofs); /* $, */
+ ofs = Nullch;
+
+ Safefree(ors); /* $\ */
+ ors = Nullch;
+
+ SvREFCNT_dec(nrs); /* $\ helper */
+ nrs = Nullsv;
+
+ multiline = 0; /* $* */
+
+ SvREFCNT_dec(statname);
+ statname = Nullsv;
+ statgv = Nullgv;
+
+ /* defgv, aka *_ should be taken care of elsewhere */
+
+#if 0 /* just about all regexp stuff, seems to be ok */
+
+ /* shortcuts to regexp stuff */
+ leftgv = Nullgv;
+ ampergv = Nullgv;
+
+ SAVEFREEOP(curpm);
+ SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
+
+ regprecomp = NULL; /* uncompiled string. */
+ regparse = NULL; /* Input-scan pointer. */
+ regxend = NULL; /* End of input for compile */
+ regnpar = 0; /* () count. */
+ regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
+ regsize = 0; /* Code size. */
+ regnaughty = 0; /* How bad is this pattern? */
+ regsawback = 0; /* Did we see \1, ...? */
+
+ reginput = NULL; /* String-input pointer. */
+ regbol = NULL; /* Beginning of input, for ^ check. */
+ regeol = NULL; /* End of input, for $ check. */
+ regstartp = (char **)NULL; /* Pointer to startp array. */
+ regendp = (char **)NULL; /* Ditto for endp. */
+ reglastparen = 0; /* Similarly for lastparen. */
+ regtill = NULL; /* How far we are required to go. */
+ regflags = 0; /* are we folding, multilining? */
+ regprev = (char)NULL; /* char before regbol, \n if none */
+
+#endif /* if 0 */
+
+ /* clean up after study() */
+ SvREFCNT_dec(lastscream);
+ lastscream = Nullsv;
+ Safefree(screamfirst);
+ screamfirst = 0;
+ Safefree(screamnext);
+ screamnext = 0;
+
+ /* startup and shutdown function lists */
+ SvREFCNT_dec(beginav);
+ SvREFCNT_dec(endav);
+ beginav = Nullav;
+ endav = Nullav;
+
+ /* temp stack during pp_sort() */
+ SvREFCNT_dec(sortstack);
+ sortstack = Nullav;
+
+ /* shortcuts just get cleared */
+ envgv = Nullgv;
+ siggv = Nullgv;
+ incgv = Nullgv;
+ errgv = Nullgv;
+ argvgv = Nullgv;
+ argvoutgv = Nullgv;
+ stdingv = Nullgv;
+ last_in_gv = Nullgv;
+
+ /* reset so print() ends up where we expect */
+ setdefout(Nullgv);
+
/* Prepare to destruct main symbol table. */
+
hv = defstash;
defstash = 0;
SvREFCNT_dec(hv);
FREETMPS;
if (destruct_level >= 2) {
if (scopestack_ix != 0)
- warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
+ warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
+ (long)scopestack_ix);
if (savestack_ix != 0)
- warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
+ warn("Unbalanced saves: %ld more saves than restores\n",
+ (long)savestack_ix);
if (tmps_floor != -1)
- warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
+ warn("Unbalanced tmps: %ld more allocs than frees\n",
+ (long)tmps_floor + 1);
if (cxstack_ix != -1)
- warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
+ warn("Unbalanced context: %ld more PUSHes than POPs\n",
+ (long)cxstack_ix + 1);
}
/* Now absolutely destruct everything, somehow or other, loops or no. */
SvREFCNT_dec(strtab);
if (sv_count != 0)
- warn("Scalars leaked: %d\n", sv_count);
+ warn("Scalars leaked: %ld\n", (long)sv_count);
sv_free_arenas();
-
- linestr = NULL; /* No SVs have survived, need to clean out */
+
+ /* No SVs have survived, need to clean out */
+ linestr = NULL;
+ pidstatus = Nullhv;
if (origfilename)
Safefree(origfilename);
nuke_stacks();
return 0;
}
- if (main_root)
+ if (main_root) {
+ curpad = AvARRAY(comppad);
op_free(main_root);
- main_root = 0;
+ main_root = Nullop;
+ }
+ main_start = Nullop;
+ SvREFCNT_dec(main_cv);
+ main_cv = Nullcv;
+
+ time(&basetime);
+ mustcatch = FALSE;
switch (Sigsetjmp(top_env,1)) {
case 1:
-#ifdef VMS
- statusvalue = 255;
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
+ /* FALL THROUGH */
case 2:
+ /* my_exit() was called */
curstash = defstash;
if (endav)
calllist(endav);
- return(statusvalue); /* my_exit() was called */
+ return STATUS_NATIVE_EXPORT;
case 3:
PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
return 1;
case 'n':
case 'p':
case 's':
- case 'T':
case 'u':
case 'U':
case 'v':
goto reswitch;
break;
+ case 'T':
+ tainting = TRUE;
+ s++;
+ goto reswitch;
+
case 'e':
if (euid != uid || egid != gid)
croak("No -e allowed in setuid scripts");
(void)PerlIO_putc(e_fp,'\n');
break;
case 'I':
- taint_not("-I");
+ forbid_setid("-I");
sv_catpv(sv,"-");
sv_catpv(sv,s);
sv_catpv(sv," ");
if (*++s) {
- av_push(GvAVn(incgv),newSVpv(s,0));
+ incpush(s, TRUE);
}
else if (argv[1]) {
- av_push(GvAVn(incgv),newSVpv(argv[1],0));
+ incpush(argv[1], TRUE);
sv_catpv(sv,argv[1]);
argc--,argv++;
sv_catpv(sv," ");
}
break;
case 'P':
- taint_not("-P");
+ forbid_setid("-P");
preprocess = TRUE;
s++;
goto reswitch;
case 'S':
- taint_not("-S");
+ forbid_setid("-S");
dosearch = TRUE;
s++;
goto reswitch;
else if (scriptname == Nullch) {
#ifdef MSDOS
if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
- moreswitches("v");
+ moreswitches("h");
#endif
scriptname = "-";
}
if (doextract)
find_beginning();
- compcv = (CV*)NEWSV(1104,0);
+ main_cv = compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)compcv, SVt_PVCV);
+ CvUNIQUE_on(compcv);
comppad = newAV();
av_push(comppad, Nullsv);
cxstack_ix = -1; /* start context stack again */
break;
case 2:
+ /* my_exit() was called */
curstash = defstash;
if (endav)
calllist(endav);
if (getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- return(statusvalue); /* my_exit() was called */
+ return STATUS_NATIVE_EXPORT;
case 3:
if (!restartop) {
PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
runops();
}
else if (main_start) {
+ CvDEPTH(main_cv) = 1;
op = main_start;
runops();
}
return 0;
}
-void
-my_exit(status)
-U32 status;
-{
- register CONTEXT *cx;
- I32 gimme;
- SV **newsp;
-
- statusvalue = FIXSTATUS(status);
- if (cxstack_ix >= 0) {
- if (cxstack_ix > 0)
- dounwind(0);
- POPBLOCK(cx,curpm);
- LEAVE;
- }
- Siglongjmp(top_env, 2);
-}
-
SV*
perl_get_sv(name, create)
char* name;
I32 create;
{
GV* gv = gv_fetchpv(name, create, SVt_PVCV);
- if (create && !GvCV(gv))
- return newSUB(start_subparse(),
+ if (create && !GvCVu(gv))
+ return newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
Nullop,
Nullop);
if (gv)
- return GvCV(gv);
+ return GvCVu(gv);
return Nullcv;
}
{
LOGOP myop; /* fake syntax tree node */
SV** sp = stack_sp;
- I32 oldmark = TOPMARK;
+ I32 oldmark;
I32 retval;
Sigjmp_buf oldtop;
I32 oldscope;
static CV *DBcv;
-
+ bool oldmustcatch = mustcatch;
+
if (flags & G_DISCARD) {
ENTER;
SAVETMPS;
}
+ Zero(&myop, 1, LOGOP);
+ if (flags & G_NOARGS) {
+ PUSHMARK(sp);
+ }
+ else
+ myop.op_flags |= OPf_STACKED;
+ myop.op_next = Nullop;
+ myop.op_flags |= OPf_KNOW;
+ if (flags & G_ARRAY)
+ myop.op_flags |= OPf_LIST;
SAVESPTR(op);
op = (OP*)&myop;
- Zero(op, 1, LOGOP);
+
EXTEND(stack_sp, 1);
*++stack_sp = sv;
+ oldmark = TOPMARK;
oldscope = scopestack_ix;
- if (!(flags & G_NOARGS))
- myop.op_flags = OPf_STACKED;
- myop.op_next = Nullop;
- myop.op_flags |= OPf_KNOW;
- if (flags & G_ARRAY)
- myop.op_flags |= OPf_LIST;
-
- if (perldb && curstash != debstash
- && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */
+ if (perldb && curstash != debstash
+ /* Handle first BEGIN of -d. */
+ && (DBcv || (DBcv = GvCV(DBsub)))
+ /* Try harder, since this may have been a sighandler, thus
+ * curstash may be meaningless. */
+ && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
op->op_private |= OPpENTERSUB_DB;
if (flags & G_EVAL) {
case 0:
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
Copy(oldtop, top_env, 1, Sigjmp_buf);
if (statusvalue)
croak("Callback called exit");
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
case 3:
if (restartop) {
goto cleanup;
}
}
+ else
+ mustcatch = TRUE;
if (op == (OP*)&myop)
op = pp_entersub();
}
Copy(oldtop, top_env, 1, Sigjmp_buf);
}
+ else
+ mustcatch = oldmustcatch;
+
if (flags & G_DISCARD) {
stack_sp = stack_base + oldmark;
retval = 0;
case 0:
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
Copy(oldtop, top_env, 1, Sigjmp_buf);
if (statusvalue)
croak("Callback called exit");
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
case 3:
if (restartop) {
sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
-#if defined(DOSISH)
-# define PERLLIB_SEP ';'
-#else
-# if defined(VMS)
-# define PERLLIB_SEP '|'
-# else
-# define PERLLIB_SEP ':'
-# endif
-#endif
-#ifndef PERLLIB_MANGLE
-# define PERLLIB_MANGLE(s,n) (s)
-#endif
-
-static void
-incpush(p)
-char *p;
-{
- char *s;
-
- if (!p)
- return;
-
- /* Break at all separators */
- while (*p) {
- /* First, skip any consecutive separators */
- while ( *p == PERLLIB_SEP ) {
- /* Uncomment the next line for PATH semantics */
- /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
- p++;
- }
- if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
- av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
- (STRLEN)(s - p)));
- p = s + 1;
- } else {
- av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
- break;
- }
- }
-}
-
static void
usage(name) /* XXX move this out into a module ? */
char *name;
s++;
return s;
case 'd':
- taint_not("-d");
+ forbid_setid("-d");
s++;
if (*s == ':' || *s == '=') {
sprintf(buf, "use Devel::%s;", ++s);
return s;
case 'D':
#ifdef DEBUGGING
- taint_not("-D");
+ forbid_setid("-D");
if (isALPHA(s[1])) {
static char debopts[] = "psltocPmfrxuLHXD";
char *d;
*s = '\0';
break;
case 'I':
- taint_not("-I");
+ forbid_setid("-I");
if (*++s) {
- char *e;
+ char *e, *p;
for (e = s; *e && !isSPACE(*e); e++) ;
- av_push(GvAVn(incgv),newSVpv(s,e-s));
+ p = savepvn(s, e-s);
+ incpush(p, TRUE);
+ Safefree(p);
if (*e)
return e;
}
}
return s;
case 'M':
- taint_not("-M"); /* XXX ? */
+ forbid_setid("-M"); /* XXX ? */
/* FALL THROUGH */
case 'm':
- taint_not("-m"); /* XXX ? */
+ forbid_setid("-m"); /* XXX ? */
if (*++s) {
char *start;
char *use = "use ";
s++;
return s;
case 's':
- taint_not("-s");
+ forbid_setid("-s");
doswitches = TRUE;
s++;
return s;
case 'T':
- tainting = TRUE;
+ if (!tainting)
+ croak("Too late for \"-T\" option (try putting it first)");
s++;
return s;
case 'u':
printf("\nThis is perl, version %s",patchlevel);
#endif
- printf("\n\nCopyright 1987-1996, Larry Wall\n");
- printf("\n\t+ suidperl security patch");
+ printf("\n\nCopyright 1987-1997, Larry Wall\n");
#ifdef MSDOS
- printf("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
+ printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
+#endif
+#ifdef DJGPP
+ printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
#endif
#ifdef OS2
printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
printf("\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
-#ifdef MSDOS
- usage(origargv[0]);
-#endif
exit(0);
case 'w':
dowarn = TRUE;
case '\n':
case '\t':
break;
+#ifdef ALTERNATE_SHEBANG
+ case 'S': /* OS/2 needs -S on "extproc" line. */
+ break;
+#endif
case 'P':
if (preprocess)
return s+1;
# ifdef VMS
# include <lib$routines.h>
lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
-#else
+# else
ABORT(); /* for use with undump */
-#endif
+# endif
#endif
}
if (fdscript >= 0) {
rsfp = PerlIO_fdopen(fdscript,"r");
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
+ if (rsfp)
+ fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
#endif
}
else if (preprocess) {
rsfp = my_popen(buf,"r");
}
else if (!*scriptname) {
- taint_not("program input from stdin");
+ forbid_setid("program input from stdin");
rsfp = PerlIO_stdin();
}
else {
rsfp = PerlIO_open(scriptname,"r");
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
+ if (rsfp)
+ fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
#endif
}
if (e_tmpname) {
e_fp = rsfp;
}
- if ((PerlIO*)rsfp == Nullfp) {
+ if (!rsfp) {
#ifdef DOSUID
#ifndef IAMSUID /* in case script is not readable before setuid */
if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
(void)PerlIO_close(rsfp);
if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
PerlIO_printf(rsfp,
-"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
-(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
- uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
- statbuf.st_dev, statbuf.st_ino,
+"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
+(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
+ (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
+ (long)statbuf.st_dev, (long)statbuf.st_ino,
SvPVX(GvSV(curcop->cop_filegv)),
- statbuf.st_uid, statbuf.st_gid);
+ (long)statbuf.st_uid, (long)statbuf.st_gid);
(void)my_pclose(rsfp);
}
croak("Permission denied\n");
/* skip forward in input to the real script? */
- taint_not("-x");
+ forbid_setid("-x");
while (doextract) {
if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
croak("No Perl script found in input\n");
}
static void
+forbid_setid(s)
+char *s;
+{
+ if (euid != uid)
+ croak("No %s allowed while running setuid", s);
+ if (egid != gid)
+ croak("No %s allowed while running setgid", s);
+}
+
+static void
init_debugger()
{
curstash = debstash;
init_stacks()
{
curstack = newAV();
- mainstack = curstack; /* remember in case we switch stacks */
- AvREAL_off(curstack); /* not a real array */
+ mainstack = curstack; /* remember in case we switch stacks */
+ AvREAL_off(curstack); /* not a real array */
av_extend(curstack,127);
stack_base = AvARRAY(curstack);
stack_sp = stack_base;
stack_max = stack_base + 127;
- /* Shouldn't these stacks be per-interpreter? */
+ cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
+ New(50,cxstack,cxstack_max + 1,CONTEXT);
+ cxstack_ix = -1;
+
+ New(50,tmps_stack,128,SV*);
+ tmps_ix = -1;
+ tmps_max = 128;
+
+ DEBUG( {
+ New(51,debname,128,char);
+ New(52,debdelim,128,char);
+ } )
+
+ /*
+ * The following stacks almost certainly should be per-interpreter,
+ * but for now they're not. XXX
+ */
+
if (markstack) {
markstack_ptr = markstack;
} else {
New(54,retstack,16,OP*);
retstack_ix = 0;
retstack_max = 16;
- }
-
- cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
- New(50,cxstack,cxstack_max + 1,CONTEXT);
- cxstack_ix = -1;
-
- New(50,tmps_stack,128,SV*);
- tmps_ix = -1;
- tmps_max = 128;
-
- DEBUG( {
- New(51,debname,128,char);
- New(52,debdelim,128,char);
- } )
+ }
}
static void
{
Safefree(cxstack);
Safefree(tmps_stack);
+ DEBUG( {
+ Safefree(debname);
+ Safefree(debdelim);
+ } )
}
static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
+
static void
init_lexer()
{
tmpfp = rsfp;
-
lex_start(linestr);
rsfp = tmpfp;
subname = newSVpv("main",4);
sv_setpvn(bodytarget, "", 0);
formtarget = bodytarget;
- tainted = 1;
+ TAINT;
if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
sv_setpv(GvSV(tmpgv),origfilename);
magicname("0", "0", 1);
}
- if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
- time(&basetime);
if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
sv_setpv(GvSV(tmpgv),origargv[0]);
if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
#endif
hv_magic(hv, envgv, 'E');
}
- tainted = 0;
+ TAINT_NOT;
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
sv_setiv(GvSV(tmpgv),(I32)getpid());
-
}
static void
#ifndef VMS
s = getenv("PERL5LIB");
if (s)
- incpush(s);
+ incpush(s, TRUE);
else
- incpush(getenv("PERLLIB"));
+ incpush(getenv("PERLLIB"), FALSE);
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
* "natural" VMS idiom for a Unix path string. We allow each
char buf[256];
int idx = 0;
if (my_trnlnm("PERL5LIB",buf,0))
- do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
else
- while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
#endif /* VMS */
}
ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP);
+ incpush(APPLLIB_EXP, FALSE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP);
+ incpush(ARCHLIB_EXP, FALSE);
#endif
#ifndef PRIVLIB_EXP
#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
- incpush(PRIVLIB_EXP);
+ incpush(PRIVLIB_EXP, FALSE);
#ifdef SITEARCH_EXP
- incpush(SITEARCH_EXP);
+ incpush(SITEARCH_EXP, FALSE);
#endif
#ifdef SITELIB_EXP
- incpush(SITELIB_EXP);
+ incpush(SITELIB_EXP, FALSE);
#endif
#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
- incpush(OLDARCHLIB_EXP);
+ incpush(OLDARCHLIB_EXP, FALSE);
#endif
if (!tainting)
- incpush(".");
+ incpush(".", FALSE);
+}
+
+#if defined(DOSISH)
+# define PERLLIB_SEP ';'
+#else
+# if defined(VMS)
+# define PERLLIB_SEP '|'
+# else
+# define PERLLIB_SEP ':'
+# endif
+#endif
+#ifndef PERLLIB_MANGLE
+# define PERLLIB_MANGLE(s,n) (s)
+#endif
+
+static void
+incpush(p, addsubdirs)
+char *p;
+int addsubdirs;
+{
+ SV *subdir = Nullsv;
+ static char *archpat_auto;
+
+ if (!p)
+ return;
+
+ if (addsubdirs) {
+ subdir = newSV(0);
+ if (!archpat_auto) {
+ STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
+ + sizeof("//auto"));
+ New(55, archpat_auto, len, char);
+ sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
+#ifdef VMS
+ for (len = sizeof(ARCHNAME) + 2;
+ archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
+ if (archpat_auto[len] == '.') archpat_auto[len] = '_';
+#endif
+ }
+ }
+
+ /* Break at all separators */
+ while (p && *p) {
+ SV *libdir = newSV(0);
+ char *s;
+
+ /* skip any consecutive separators */
+ while ( *p == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
+ p++;
+ }
+
+ if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
+ sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
+ (STRLEN)(s - p));
+ p = s + 1;
+ }
+ else {
+ sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
+ p = Nullch; /* break out */
+ }
+
+ /*
+ * BEFORE pushing libdir onto @INC we may first push version- and
+ * archname-specific sub-directories.
+ */
+ if (addsubdirs) {
+ struct stat tmpstatbuf;
+#ifdef VMS
+ char *unix;
+ STRLEN len;
+
+ if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
+ len = strlen(unix);
+ while (unix[len-1] == '/') len--; /* Cosmetic */
+ sv_usepvn(libdir,unix,len);
+ }
+ else
+ PerlIO_printf(PerlIO_stderr(),
+ "Failed to unixify @INC element \"%s\"\n",
+ SvPV(libdir,na));
+#endif
+ /* .../archname/version if -d .../archname/version/auto */
+ sv_setsv(subdir, libdir);
+ sv_catpv(subdir, archpat_auto);
+ if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(incgv),
+ newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+
+ /* .../archname if -d .../archname/auto */
+ sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
+ strlen(patchlevel) + 1, "", 0);
+ if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(incgv),
+ newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ }
+
+ /* finally push this lib directory on the end of @INC */
+ av_push(GvAVn(incgv), libdir);
+ }
+
+ SvREFCNT_dec(subdir);
}
void
}
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
else
croak("END failed--cleanup aborted");
}
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
- return;
case 3:
if (!restartop) {
PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
Copy(oldtop, top_env, 1, Sigjmp_buf);
}
+void
+my_exit(status)
+U32 status;
+{
+ switch (status) {
+ case 0:
+ STATUS_ALL_SUCCESS;
+ break;
+ case 1:
+ STATUS_ALL_FAILURE;
+ break;
+ default:
+ STATUS_NATIVE_SET(status);
+ break;
+ }
+ my_exit_jump();
+}
+
+void
+my_failure_exit()
+{
+#ifdef VMS
+ if (vaxc$errno & 1) {
+ if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
+ STATUS_NATIVE_SET(44);
+ }
+ else {
+ if (!vaxc$errno && errno) /* unlikely */
+ STATUS_NATIVE_SET(44);
+ else
+ STATUS_NATIVE_SET(vaxc$errno);
+ }
+#else
+ if (errno & 255)
+ STATUS_POSIX_SET(errno);
+ else if (STATUS_POSIX == 0)
+ STATUS_POSIX_SET(255);
+#endif
+ my_exit_jump();
+}
+
+static void
+my_exit_jump()
+{
+ register CONTEXT *cx;
+ 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 (cxstack_ix >= 0) {
+ if (cxstack_ix > 0)
+ dounwind(0);
+ POPBLOCK(cx,curpm);
+ LEAVE;
+ }
+
+ Siglongjmp(top_env, 2);
+}