#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 forbid_setid _((char *));
-static void incpush _((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;
- perl_destruct_level = 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
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;
/* loosen bonds of global variables */
- setdefout(Nullgv);
+ 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 */
- sv_free(nrs);
+ Safefree(ofs); /* $, */
+ ofs = Nullch;
+
+ Safefree(ors); /* $\ */
+ ors = Nullch;
+
+ SvREFCNT_dec(nrs); /* $\ helper */
nrs = Nullsv;
- sv_free(lastscream);
- lastscream = Nullsv;
+ multiline = 0; /* $* */
- sv_free(statname);
+ SvREFCNT_dec(statname);
statname = Nullsv;
statgv = Nullgv;
- laststatval = -1;
+
+ /* 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. */
warn("Scalars leaked: %d\n", 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();
op_free(main_root);
main_root = 0;
+ time(&basetime);
+
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");
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," ");
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");
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;
}
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) {
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;
case '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;
}
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("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
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)) {
#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);
+ }
+ }
+
+ /* 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;
+
+ /* .../archname/version if -d .../archname/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/version if -d .../archname/version/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 (GETSTATUS_NATIVE & 1) /* fortuitiously includes "-1" */
+ SETSTATUS_NATIVE(44);
+ }
+ else {
+ if (!vaxc$errno && errno) /* someone must have set $^E = 0 */
+ SETSTATUS_NATIVE(44);
+ else
+ SETSTATUS_NATIVE(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);
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff