[win32] protect sortcop from C<sort { sort { ... } ... } ...>

[p5sagit/p5-mst-13.2.git] / perl.c

diff --git a/perl.c b/perl.c
index a4d3ac0..52ad7ca 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -24,6 +24,13 @@
 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
@@ -169,6 +176,7 @@ perl_construct(register PerlInterpreter *sv_interp)
 #endif
     }
 
+    init_stacks(ARGS);
 #ifdef MULTIPLICITY
     I_REINIT;
     perl_destruct_level = 1; 
@@ -200,11 +208,11 @@ perl_construct(register PerlInterpreter *sv_interp)
     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);
@@ -320,6 +328,7 @@ perl_destruct(register PerlInterpreter *sv_interp)
        op_free(main_root);
        main_root = Nullop;
     }
+    curcop = &compiling;
     main_start = Nullop;
     SvREFCNT_dec(main_cv);
     main_cv = Nullcv;
@@ -343,6 +352,12 @@ perl_destruct(register PerlInterpreter *sv_interp)
     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());
@@ -544,6 +559,15 @@ perl_free(PerlInterpreter *sv_interp)
     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)
 {
@@ -675,21 +699,36 @@ setuid perl scripts securely.\n");
            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);
@@ -1854,7 +1893,7 @@ open_script(char *scriptname, bool dosearch, SV *sv)
 #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
@@ -1922,7 +1961,7 @@ open_script(char *scriptname, bool dosearch, SV *sv)
            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? */
@@ -1945,7 +1984,7 @@ open_script(char *scriptname, bool dosearch, SV *sv)
                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)
@@ -2070,7 +2109,7 @@ sed %s -e \"/^[^#]/b\" \
     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);
@@ -2148,7 +2187,7 @@ validate_suid(char *validarg, char *scriptname)
 #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) {
@@ -2469,7 +2508,7 @@ nuke_stacks(void)
        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;
@@ -2749,7 +2788,7 @@ incpush(char *p, int addsubdirs)
            /* .../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"));
@@ -2757,7 +2796,7 @@ incpush(char *p, int addsubdirs)
            /* .../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"));
@@ -2956,7 +2995,7 @@ my_failure_exit(void)
 static void
 my_exit_jump(void)
 {
-    dTHR;
+    dSP;
     register PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
@@ -2971,6 +3010,7 @@ my_exit_jump(void)
        e_tmpname = Nullch;
     }
 
+    POPSTACK_TO(mainstack);
     if (cxstack_ix >= 0) {
        if (cxstack_ix > 0)
            dounwind(0);