Re: [perl #22719] ISA cache problem with blessed stash objects

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

diff --git a/pp_ctl.c b/pp_ctl.c
index 91fc2ca..30e7b13 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1329,8 +1329,6 @@ OP *
 Perl_die_where(pTHX_ char *message, STRLEN msglen)
 {
     STRLEN n_a;
-    IO *io;
-    MAGIC *mg;
 
     if (PL_in_eval) {
        I32 cxix;
@@ -1365,8 +1363,6 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
                sv_setpvn(ERRSV, message, msglen);
            }
        }
-       else
-           message = SvPVx(ERRSV, msglen);
 
        while ((cxix = dopoptoeval(cxstack_ix)) < 0
               && PL_curstackinfo->si_prev)
@@ -1383,6 +1379,8 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
 
            POPBLOCK(cx,PL_curpm);
            if (CxTYPE(cx) != CXt_EVAL) {
+               if (!message)
+                   message = SvPVx(ERRSV, msglen);
                PerlIO_write(Perl_error_log, "panic: die ", 11);
                PerlIO_write(Perl_error_log, message, msglen);
                my_exit(1);
@@ -1412,30 +1410,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
     if (!message)
        message = SvPVx(ERRSV, msglen);
 
-    /* if STDERR is tied, print to it instead */
-    if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
-       && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
-       dSP; ENTER;
-       PUSHMARK(SP);
-       XPUSHs(SvTIED_obj((SV*)io, mg));
-       XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
-       PUTBACK;
-       call_method("PRINT", G_SCALAR);
-       LEAVE;
-    }
-    else {
-#ifdef USE_SFIO
-       /* SFIO can really mess with your errno */
-       int e = errno;
-#endif
-       PerlIO *serr = Perl_error_log;
-
-       PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-       (void)PerlIO_flush(serr);
-#ifdef USE_SFIO
-       errno = e;
-#endif
-    }
+    write_to_stderr(message, msglen);
     my_failure_exit();
     /* NOTREACHED */
     return 0;
@@ -2402,7 +2377,7 @@ PP(pp_goto)
            switch (CxTYPE(cx)) {
            case CXt_EVAL:
                leaving_eval = TRUE;
-                if (CxREALEVAL(cx)) {
+                if (!CxTRYBLOCK(cx)) {
                    gotoprobe = (last_eval_cx ?
                                last_eval_cx->blk_eval.old_eval_root :
                                PL_eval_root);
@@ -2898,13 +2873,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
        *startop = PL_eval_root;
     } else
        SAVEFREEOP(PL_eval_root);
-    if (gimme & G_VOID && ! PL_in_eval & EVAL_INREQUIRE)
-       /*
-        * EVAL_INREQUIRE (the code is being required) is special-cased :
-        * in this case we want scalar context to be forced, instead
-        * of void context, so a proper return value is returned from
-        * C<require> via this leaveeval op.
-        */
+    if (gimme & G_VOID)
        scalarvoid(PL_eval_root);
     else if (gimme & G_ARRAY)
        list(PL_eval_root);
@@ -2936,8 +2905,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 }
 
 STATIC PerlIO *
-S_doopen_pmc(pTHX_ const char *name, const char *mode)
+S_doopen_pm(pTHX_ const char *name, const char *mode)
 {
+#ifndef PERL_DISABLE_PMC
     STRLEN namelen = strlen(name);
     PerlIO *fp;
 
@@ -2965,6 +2935,9 @@ S_doopen_pmc(pTHX_ const char *name, const char *mode)
        fp = PerlIO_open(name, mode);
     }
     return fp;
+#else
+    return PerlIO_open(name, mode);
+#endif /* !PERL_DISABLE_PMC */
 }
 
 PP(pp_require)
@@ -3063,7 +3036,7 @@ PP(pp_require)
 
     if (path_is_absolute(name)) {
        tryname = name;
-       tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
+       tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
     }
 #ifdef MACOS_TRADITIONAL
     if (!tryrsfp) {
@@ -3072,7 +3045,7 @@ PP(pp_require)
        MacPerl_CanonDir(name, newname, 1);
        if (path_is_absolute(newname)) {
            tryname = newname;
-           tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
+           tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
        }
     }
 #endif
@@ -3227,7 +3200,7 @@ PP(pp_require)
 #endif
                    TAINT_PROPER("require");
                    tryname = SvPVX(namesv);
-                   tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
+                   tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
                    if (tryrsfp) {
                        if (tryname[0] == '.' && tryname[1] == '/')
                            tryname += 2;
@@ -3573,11 +3546,20 @@ S_doparseform(pTHX_ SV *sv)
     U16 *linepc = 0;
     register I32 arg;
     bool ischop;
+    int maxops = 2; /* FF_LINEMARK + FF_END) */
 
     if (len == 0)
        Perl_croak(aTHX_ "Null picture in formline");
 
-    New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
+    /* estimate the buffer size needed */
+    for (base = s; s <= send; s++) {
+       if (*s == '\n' || *s == '@' || *s == '^')
+           maxops += 10;
+    }
+    s = base;
+    base = Nullch;
+
+    New(804, fops, maxops, U16);
     fpc = fops;
 
     if (s < send) {
@@ -3740,6 +3722,7 @@ S_doparseform(pTHX_ SV *sv)
     }
     *fpc++ = FF_END;
 
+    assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
     arg = fpc - fops;
     { /* need to jump to the next word */
         int z;