Avoid scribbling on the passed in command line string for -i in

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

diff --git a/perl.c b/perl.c
index d8077d6..c152a39 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1289,10 +1289,19 @@ void
 perl_free(pTHXx)
 {
 #ifdef PERL_TRACK_MEMPOOL
-    /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
-       thread at thread exit.  */
-    while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
-       safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+    {
+       /*
+        * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
+        * value as we're probably hunting memory leaks then
+        */
+       const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
+       if (!s || atoi(s) == 0) {
+           /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
+              thread at thread exit.  */
+           while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
+               safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+       }
+    }
 #endif
 
 #if defined(WIN32) || defined(NETWARE)
@@ -1791,6 +1800,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #  ifdef PERL_IMPLICIT_SYS
                             " PERL_IMPLICIT_SYS"
 #  endif
+#  ifdef PERL_MAD
+                            " PERL_MAD"
+#  endif
 #  ifdef PERL_MALLOC_WRAP
                             " PERL_MALLOC_WRAP"
 #  endif
@@ -2164,6 +2176,25 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
              Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
     }
 
+#ifdef PERL_MAD
+    if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
+       PL_madskills = 1;
+       PL_minus_c = 1;
+       if (!s || !s[0])
+           PL_xmlfp = PerlIO_stdout();
+       else {
+           PL_xmlfp = PerlIO_open(s, "w");
+           if (!PL_xmlfp)
+               Perl_croak(aTHX_ "Can't open %s", s);
+       }
+       my_setenv("PERL_XMLDUMP", Nullch);      /* hide from subprocs */
+    }
+    if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
+       PL_madskills = atoi(s);
+       my_setenv("PERL_MADSKILLS", Nullch);    /* hide from subprocs */
+    }
+#endif
+
     init_lexer();
 
     /* now parse the script */
@@ -2289,6 +2320,12 @@ S_run_body(pTHX_ I32 oldscope)
                     PL_sawampersand ? "Enabling" : "Omitting"));
 
     if (!PL_restartop) {
+#ifdef PERL_MAD
+       if (PL_xmlfp) {
+           xmldump_all();
+           exit(0);    /* less likely to core dump than my_exit(0) */
+       }
+#endif
        DEBUG_x(dump_all());
 #ifdef DEBUGGING
        if (!DEBUG_q_TEST)
@@ -2998,8 +3035,7 @@ Perl_moreswitches(pTHX_ char *s)
        PL_minus_F = TRUE;
        PL_splitstr = ++s;
        while (*s && !isSPACE(*s)) ++s;
-       *s = '\0';
-       PL_splitstr = savepv(PL_splitstr);
+       PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
        return s;
     case 'a':
        PL_minus_a = TRUE;
@@ -3068,13 +3104,17 @@ Perl_moreswitches(pTHX_ char *s)
        return s+1;
        }
 #endif /* __CYGWIN__ */
-       PL_inplace = savepv(s+1);
-       for (s = PL_inplace; *s && !isSPACE(*s); s++)
-           ;
+       {
+           const char *start = ++s;
+           while (*s && !isSPACE(*s))
+               ++s;
+
+           PL_inplace = savepvn(start, s - start);
+       }
        if (*s) {
-           *s++ = '\0';
+           ++s;
            if (*s == '-')      /* Additional switches on #! line. */
-               s++;
+               s++;
        }
        return s;
     case 'I':  /* -I handled both here and in parse_body() */
@@ -5080,14 +5120,25 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                av_push(PL_checkav_save, (SV*)cv);
            }
        } else {
-           SAVEFREESV(cv);
+           if (!PL_madskills)
+               SAVEFREESV(cv);
        }
        JMPENV_PUSH(ret);
        switch (ret) {
        case 0:
+#ifdef PERL_MAD
+           if (PL_madskills)
+               PL_madskills |= 16384;
+#endif
            call_list_body(cv);
+#ifdef PERL_MAD
+           if (PL_madskills)
+               PL_madskills &= ~16384;
+#endif
            atsv = ERRSV;
            (void)SvPV_const(atsv, len);
+           if (PL_madskills && PL_minus_c && paramList == PL_beginav)
+               break;  /* not really trying to run, so just wing it */
            if (len) {
                PL_curcop = &PL_compiling;
                CopLINE_set(PL_curcop, oldline);
@@ -5117,6 +5168,8 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
            PL_curcop = &PL_compiling;
            CopLINE_set(PL_curcop, oldline);
            JMPENV_POP;
+           if (PL_madskills && PL_minus_c && paramList == PL_beginav)
+               return; /* not really trying to run, so just wing it */
            if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
                if (paramList == PL_beginav)
                    Perl_croak(aTHX_ "BEGIN failed--compilation aborted");