char *getenv _((char *)); /* Usually in <stdlib.h> */
#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
#ifdef IAMSUID
#endif
}
+ init_stacks(ARGS);
#ifdef MULTIPLICITY
I_REINIT;
perl_destruct_level = 1;
localpatches = local_patches; /* For possible -v */
#endif
- PerlIO_init(); /* Hook to IO system */
+ PerlIO_init(); /* Hook to IO system */
- fdpid = newAV(); /* for remembering popen pids by fd */
+ fdpid = newAV(); /* for remembering popen pids by fd */
+ modglobal = newHV(); /* pointers to per-interpreter module globals */
- init_stacks(ARGS);
DEBUG( {
New(51,debname,128,char);
New(52,debdelim,128,char);
op_free(main_root);
main_root = Nullop;
}
+ curcop = &compiling;
main_start = Nullop;
SvREFCNT_dec(main_cv);
main_cv = Nullcv;
SvREFCNT_dec(parsehook);
parsehook = Nullsv;
+ /* call exit list functions */
+ while (exitlistlen-- > 0)
+ exitlist[exitlistlen].fn(exitlist[exitlistlen].ptr);
+
+ Safefree(exitlist);
+
if (destruct_level == 0){
DEBUG_P(debprofdump());
Safefree(sv_interp);
}
+void
+perl_atexit(void (*fn) (void *), void *ptr)
+{
+ Renew(exitlist, exitlistlen+1, PerlExitListEntry);
+ exitlist[exitlistlen].fn = fn;
+ exitlist[exitlistlen].ptr = ptr;
+ ++exitlistlen;
+}
+
int
perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
{
if (euid != uid || egid != gid)
croak("No -e allowed in setuid scripts");
if (!e_fp) {
+#ifdef HAS_UMASK
+ int oldumask = PerlLIO_umask(0177);
+#endif
e_tmpname = savepv(TMPPATH);
#ifdef HAS_MKSTEMP
e_tmpfd = PerlLIO_mkstemp(e_tmpname);
-
- if (e_tmpfd < 0)
- croak("Can't mkstemp() temporary file \"%s\"", e_tmpname);
- e_fp = PerlIO_fdopen(e_tmpfd,"w");
#else /* use mktemp() */
(void)PerlLIO_mktemp(e_tmpname);
if (!*e_tmpname)
- croak("Can't mktemp() temporary file \"%s\"", 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 /* HAS_MKSTEMP */
+# 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 open temporary file \"%s\"", e_tmpname);
+ croak("Cannot create temporary file \"%s\"", e_tmpname);
+#ifdef HAS_UMASK
+ (void)PerlLIO_umask(oldumask);
+#endif
}
if (*++s)
PerlIO_puts(e_fp,s);
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Looking for %s\n",cur));
- if (Stat(cur,&statbuf) >= 0) {
+ if (PerlLIO_stat(cur,&statbuf) >= 0) {
dosearch = 0;
scriptname = cur;
#ifdef SEARCH_EXTS
do {
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
- retval = Stat(tokenbuf,&statbuf);
+ retval = PerlLIO_stat(tokenbuf,&statbuf);
#ifdef SEARCH_EXTS
} while ( retval < 0 /* not there */
&& extidx>=0 && ext[extidx] /* try an extension? */
xfailed = savepv(tokenbuf);
}
#ifndef DOSISH
- if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
+ if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
#endif
seen_dot = 1; /* Disable message. */
if (!xfound)
if (!rsfp) {
#ifdef DOSUID
#ifndef IAMSUID /* in case script is not readable before setuid */
- if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
+ if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
statbuf.st_mode & (S_ISUID|S_ISGID)) {
/* try again */
PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
#endif
|| getuid() != euid || geteuid() != uid)
croak("Can't swap uid and euid"); /* really paranoid */
- if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
+ if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
croak("Permission denied"); /* testing full pathname here */
if (tmpstatbuf.st_dev != statbuf.st_dev ||
tmpstatbuf.st_ino != statbuf.st_ino) {
curstackinfo = curstackinfo->si_next;
while (curstackinfo) {
PERL_SI *p = curstackinfo->si_prev;
- SvREFCNT_dec(curstackinfo->si_stack);
+ /* curstackinfo->si_stack got nuked by sv_free_arenas() */
Safefree(curstackinfo->si_cxstack);
Safefree(curstackinfo);
curstackinfo = p;
/* .../archname/version if -d .../archname/version/auto */
sv_setsv(subdir, libdir);
sv_catpv(subdir, archpat_auto);
- if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ if (PerlLIO_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 &&
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(incgv),
newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
static void
my_exit_jump(void)
{
- dTHR;
+ dSP;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
e_tmpname = Nullch;
}
+ POPSTACK_TO(mainstack);
if (cxstack_ix >= 0) {
if (cxstack_ix > 0)
dounwind(0);