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
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;
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
beginav = Nullav;
endav = Nullav;
- /* pid-to-status mappings for waitpid */
- SvREFCNT_dec(pidstatus);
- pidstatus = Nullhv;
-
/* temp stack during pp_sort() */
SvREFCNT_dec(sortstack);
sortstack = Nullav;
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");
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," ");
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);
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;
{
GV* gv = gv_fetchpv(name, create, SVt_PVCV);
if (create && !GvCVu(gv))
- return newSUB(start_subparse(),
+ return newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
Nullop,
Nullop);
{
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
/* Handle first BEGIN of -d. */
&& (DBcv || (DBcv = GvCV(DBsub)))
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;
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
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
}
(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");
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);
+#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);
+}