Further MAD changes.

p4raw-id: //depot/perl@27428

diff --git a/perl.c b/perl.c
index 0ad1e00..3cdca43 100644 (file)
--- 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 c494156..18f8606 100644 (file)
--- 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 ffc80c8..7ff4858 100644 (file)
--- 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 234dd9f..2c61424 100644 (file)
--- 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);