X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=a98314b49efeacd71f1651aec9ebd436cc69c3bc;hb=7087a21c096179886f18cec5311cc7e897850eef;hp=7b715ae209372e97161fca81e8f140691d118ed4;hpb=826955bd39254b001a9d724fb030a4ad97b21351;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perl.c b/perl.c
index 7b715ae..a98314b 100644
--- a/perl.c
+++ b/perl.c
@@ -228,7 +228,7 @@ void
 perl_construct(pTHXx)
 {
     dVAR;
-    PERL_UNUSED_ARG(my_perl);
+    PERL_UNUSED_CONTEXT;
 #ifdef MULTIPLICITY
     init_interp();
     PL_perl_destruct_level = 1;
@@ -389,6 +389,10 @@ perl_construct(pTHXx)
     PL_timesbase.tms_cstime = 0;
 #endif
 
+#ifdef PERL_MAD
+    PL_curforce = -1;
+#endif
+
     ENTER;
 }
 
@@ -404,6 +408,7 @@ no threads.
 int
 Perl_nothreadhook(pTHX)
 {
+    PERL_UNUSED_CONTEXT;
     return 0;
 }
 
@@ -523,7 +528,7 @@ perl_destruct(pTHXx)
     pid_t child;
 #endif
 
-    PERL_UNUSED_ARG(my_perl);
+    PERL_UNUSED_CONTEXT;
 
     /* wait for all pseudo-forked children to finish */
     PERL_WAIT_FOR_CHILDREN;
@@ -852,7 +857,7 @@ perl_destruct(pTHXx)
 
     if(PL_rsfp) {
 	(void)PerlIO_close(PL_rsfp);
-	PL_rsfp = Nullfp;
+	PL_rsfp = NULL;
     }
 
     /* Filters for program text */
@@ -894,7 +899,6 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_rs);	/* $/ */
     PL_rs = NULL;
 
-    PL_multiline = 0;		/* $* */
     Safefree(PL_osname);	/* $^O */
     PL_osname = NULL;
 
@@ -1288,10 +1292,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)
@@ -1790,6 +1803,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
@@ -2163,6 +2179,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 */
@@ -2234,7 +2269,7 @@ perl_run(pTHXx)
     int ret = 0;
     dJMPENV;
 
-    PERL_UNUSED_ARG(my_perl);
+    PERL_UNUSED_CONTEXT;
 
     oldscope = PL_scopestack_ix;
 #ifdef VMS
@@ -2288,6 +2323,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)
@@ -2997,8 +3038,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;
@@ -3030,7 +3070,9 @@ Perl_moreswitches(pTHX_ char *s)
 		sv_catpv(sv, start);
 	    else {
 		sv_catpvn(sv, start, s-start);
-		Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
+		/* Don't use NUL as q// delimiter here, this string goes in the
+		 * environment. */
+		Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
 	    }
 	    s += strlen(s);
 	    my_setenv("PERL5DB", SvPV_nolen_const(sv));
@@ -3065,13 +3107,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() */
@@ -3387,15 +3433,14 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
 void
 Perl_my_unexec(pTHX)
 {
+    PERL_UNUSED_CONTEXT;
 #ifdef UNEXEC
-    SV*    prog;
-    SV*    file;
+    SV *    prog = newSVpv(BIN_EXP, 0);
+    SV *    file = newSVpv(PL_origfilename, 0);
     int    status = 1;
     extern int etext;
 
-    prog = newSVpv(BIN_EXP, 0);
     sv_catpvs(prog, "/perl");
-    file = newSVpv(PL_origfilename, 0);
     sv_catpvs(file, ".perldump");
 
     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
@@ -3467,18 +3512,18 @@ S_init_main_stash(pTHX)
        of the SvREFCNT_dec, only to add it again with hv_name_set */
     SvREFCNT_dec(GvHV(gv));
     hv_name_set(PL_defstash, "main", 4, 0);
-    GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
+    GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash);
     SvREADONLY_on(gv);
     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
 					     SVt_PVAV)));
-    SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */
+    SvREFCNT_inc_simple(PL_incgv); /* Don't allow it to be freed */
     GvMULTI_on(PL_incgv);
     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
     GvMULTI_on(PL_hintgv);
     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
-    SvREFCNT_inc(PL_defgv);
+    SvREFCNT_inc_simple(PL_defgv);
     PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
-    SvREFCNT_inc(PL_errgv);
+    SvREFCNT_inc_simple(PL_errgv);
     GvMULTI_on(PL_errgv);
     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
     GvMULTI_on(PL_replgv);
@@ -4491,7 +4536,7 @@ S_init_lexer(pTHX)
     dVAR;
     PerlIO *tmpfp;
     tmpfp = PL_rsfp;
-    PL_rsfp = Nullfp;
+    PL_rsfp = NULL;
     lex_start(PL_linestr);
     PL_rsfp = tmpfp;
     PL_subname = newSVpvs("main");
@@ -4512,7 +4557,7 @@ S_init_predump_symbols(pTHX)
     IoIFP(io) = PerlIO_stdin();
     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
     GvMULTI_on(tmpgv);
-    GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
+    GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
 
     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
     GvMULTI_on(tmpgv);
@@ -4522,7 +4567,7 @@ S_init_predump_symbols(pTHX)
     setdefout(tmpgv);
     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
     GvMULTI_on(tmpgv);
-    GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
+    GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
 
     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
     GvMULTI_on(PL_stderrgv);
@@ -4531,7 +4576,7 @@ S_init_predump_symbols(pTHX)
     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
     GvMULTI_on(tmpgv);
-    GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
+    GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
 
     PL_statname = newSV(0);		/* last filename we did stat on */
 
@@ -5078,14 +5123,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);
@@ -5115,6 +5171,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");
@@ -5247,9 +5305,6 @@ STATIC void
 S_my_exit_jump(pTHX)
 {
     dVAR;
-    register PERL_CONTEXT *cx;
-    I32 gimme;
-    SV **newsp;
 
     if (PL_e_script) {
 	SvREFCNT_dec(PL_e_script);
@@ -5257,16 +5312,10 @@ S_my_exit_jump(pTHX)
     }
 
     POPSTACK_TO(PL_mainstack);
-    if (cxstack_ix >= 0) {
-	if (cxstack_ix > 0)
-	    dounwind(0);
-	POPBLOCK(cx,PL_curpm);
-	LEAVE;
-    }
+    dounwind(-1);
+    LEAVE_SCOPE(0);
 
     JMPENV_JUMP(2);
-    PERL_UNUSED_VAR(gimme);
-    PERL_UNUSED_VAR(newsp);
 }
 
 static I32