Further MAD changes.

p4raw-id: //depot/perl@27428

4 files changed, 83 insertions, 2 deletions

diff --git a/perl.c b/perl.c
index 0ad1e00f57..3cdca43baa 100644
--- a/perl.c
+++ b/perl.c
@@ -2176,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 */
@@ -2301,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)
@@ -5091,14 +5116,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);
@@ -5128,6 +5164,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");
diff --git a/perly.c b/perly.c
index c4941563c7..18f8606bff 100644
--- a/perly.c
+++ b/perly.c
@@ -296,6 +296,11 @@ Perl_yyparse (pTHX)
 	  rule.  */
     int yylen;
 
+#ifdef PERL_MAD
+    if (PL_madskills)
+	return madparse();
+#endif
+
     YYDPRINTF ((Perl_debug_log, "Starting parse\n"));
 
     ENTER;			/* force stack free before we return */
@@ -403,7 +408,11 @@ Perl_yyparse (pTHX)
     /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol.  */
     if (yychar == YYEMPTY) {
 	YYDPRINTF ((Perl_debug_log, "Reading a token: "));
+#ifdef PERL_MAD
+	yychar = PL_madskills ? madlex() : yylex();
+#else
 	yychar = yylex();
+#endif
 #  ifdef EBCDIC
 	if (yychar >= 0 && yychar < 255) {
 	    yychar = NATIVE_TO_ASCII(yychar);
diff --git a/pp_ctl.c b/pp_ctl.c
index ffc80c8e43..7ff4858bfe 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2625,7 +2625,13 @@ PP(pp_exit)
 #endif
     }
     PL_exit_flags |= PERL_EXIT_EXPECTED;
+#ifdef PERL_MAD
+    /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
+    if (anum || !(PL_minus_c && PL_madskills))
+	my_exit(anum);
+#else
     my_exit(anum);
+#endif
     PUSHs(&PL_sv_undef);
     RETURN;
 }
@@ -2885,7 +2891,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
 
 
-    SAVEMORTALIZESV(PL_compcv);	/* must remain until end of current statement */
+    if (!PL_madskills)
+	SAVEMORTALIZESV(PL_compcv);	/* must remain until end of current statement */
 
     /* make sure we compile in the right package */
 
@@ -2898,6 +2905,11 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     SAVEFREESV(PL_beginav);
     SAVEI32(PL_error_count);
 
+#ifdef PERL_MAD
+    SAVEI32(PL_madskills);
+    PL_madskills = 0;
+#endif
+
     /* try to compile it */
 
     PL_eval_root = NULL;
diff --git a/scope.c b/scope.c
index 234dd9f8fe..2c61424240 100644
--- a/scope.c
+++ b/scope.c
@@ -165,6 +165,11 @@ S_save_scalar_at(pTHX_ SV **sptr)
     SV * const osv = *sptr;
     register SV * const sv = *sptr = newSV(0);
 
+#ifdef PERL_MAD
+    if (PL_formfeed && sv == PL_formfeed)
+	abort();
+#endif
+
     if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
 	if (SvGMAGICAL(osv)) {
 	    const bool oldtainted = PL_tainted;
@@ -182,6 +187,10 @@ Perl_save_scalar(pTHX_ GV *gv)
 {
     dVAR;
     SV ** const sptr = &GvSVn(gv);
+#ifdef PERL_MAD
+    if (PL_formfeed && *sptr == PL_formfeed)
+	abort();
+#endif
     PL_localizing = 1;
     SvGETMAGIC(*sptr);
     PL_localizing = 0;
@@ -198,6 +207,10 @@ void
 Perl_save_generic_svref(pTHX_ SV **sptr)
 {
     dVAR;
+#ifdef PERL_MAD
+    if (PL_formfeed && *sptr == PL_formfeed)
+	abort();
+#endif
     SSCHECK(3);
     SSPUSHPTR(sptr);
     SSPUSHPTR(SvREFCNT_inc(*sptr));
@@ -324,6 +337,11 @@ Perl_save_item(pTHX_ register SV *item)
     dVAR;
     register SV * const sv = newSVsv(item);
 
+#ifdef PERL_MAD
+    if (PL_formfeed && item == PL_formfeed)
+	abort();
+#endif
+
     SSCHECK(3);
     SSPUSHPTR(item);		/* remember the pointer */
     SSPUSHPTR(sv);		/* remember the value */
@@ -542,6 +560,10 @@ SV*
 Perl_save_svref(pTHX_ SV **sptr)
 {
     dVAR;
+#ifdef PERL_MAD
+    if (PL_formfeed && *sptr == PL_formfeed)
+	abort();
+#endif
     SvGETMAGIC(*sptr);
     SSCHECK(3);
     SSPUSHPTR(sptr);