Try not to use negative values when accessing arrays in C. Yet another

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

diff --git a/perl.c b/perl.c
index 0ad1e00..8af44cc 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -360,7 +360,7 @@ perl_construct(pTHXx)
        if ((long) PL_mmap_page_size < 0) {
          if (errno) {
            SV * const error = ERRSV;
-           (void) SvUPGRADE(error, SVt_PV);
+           SvUPGRADE(error, SVt_PV);
            Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
          }
          else
@@ -389,6 +389,10 @@ perl_construct(pTHXx)
     PL_timesbase.tms_cstime = 0;
 #endif
 
+#ifdef PERL_MAD
+    PL_curforce = -1;
+#endif
+
     ENTER;
 }
 
@@ -895,7 +899,6 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_rs);       /* $/ */
     PL_rs = NULL;
 
-    PL_multiline = 0;          /* $* */
     Safefree(PL_osname);       /* $^O */
     PL_osname = NULL;
 
@@ -1036,6 +1039,8 @@ perl_destruct(pTHXx)
     if (!specialCopIO(PL_compiling.cop_io))
        SvREFCNT_dec(PL_compiling.cop_io);
     PL_compiling.cop_io = NULL;
+    Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
+    PL_compiling.cop_hints = NULL;
     CopFILE_free(&PL_compiling);
     CopSTASH_free(&PL_compiling);
 
@@ -1252,6 +1257,12 @@ perl_destruct(pTHXx)
 
     sv_free_arenas();
 
+    while (PL_regmatch_slab) {
+       regmatch_slab  *s = PL_regmatch_slab;
+       PL_regmatch_slab = PL_regmatch_slab->next;
+       Safefree(s);
+    }
+
     /* As the absolutely last thing, free the non-arena SV for mess() */
 
     if (PL_mess_sv) {
@@ -2176,6 +2187,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 +2331,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)
@@ -2576,27 +2612,11 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
     else {
        myop.op_other = (OP*)&myop;
        PL_markstack_ptr--;
-       /* we're trying to emulate pp_entertry() here */
-       {
-           register PERL_CONTEXT *cx;
-           const I32 gimme = GIMME_V;
-       
-           ENTER;
-           SAVETMPS;
-       
-           PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
-           PUSHEVAL(cx, 0, 0);
-           PL_eval_root = PL_op;             /* Only needed so that goto works right. */
-       
-           PL_in_eval = EVAL_INEVAL;
-           if (flags & G_KEEPERR)
-               PL_in_eval |= EVAL_KEEPERR;
-           else
-               sv_setpvn(ERRSV,"",0);
-       }
+       create_eval_scope(flags|G_FAKINGEVAL);
        PL_markstack_ptr++;
 
        JMPENV_PUSH(ret);
+
        switch (ret) {
        case 0:
  redo_body:
@@ -2633,21 +2653,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
            break;
        }
 
-       if (PL_scopestack_ix > oldscope) {
-           SV **newsp;
-           PMOP *newpm;
-           I32 gimme;
-           register PERL_CONTEXT *cx;
-           I32 optype;
-
-           POPBLOCK(cx,newpm);
-           POPEVAL(cx);
-           PL_curpm = newpm;
-           LEAVE;
-           PERL_UNUSED_VAR(newsp);
-           PERL_UNUSED_VAR(gimme);
-           PERL_UNUSED_VAR(optype);
-       }
+       if (PL_scopestack_ix > oldscope)
+           delete_eval_scope();
        JMPENV_POP;
     }
 
@@ -3079,13 +3086,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 * const 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() */
@@ -4778,7 +4789,8 @@ S_init_perllib(pTHX)
 #  endif
 #endif
 
-#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
+#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
+    /* Search for version-specific dirs below here */
     incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
 #endif
 
@@ -5091,14 +5103,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 +5151,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");