Fix comments about @INC ordering

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

diff --git a/pp_hot.c b/pp_hot.c
index a78f022..3371e88 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -157,7 +157,7 @@ PP(pp_sassign)
            /* We've been returned a constant rather than a full subroutine,
               but they expect a subroutine reference to apply.  */
            if (SvROK(cv)) {
-               ENTER;
+               ENTER_with_name("sassign_coderef");
                SvREFCNT_inc_void(SvRV(cv));
                /* newCONSTSUB takes a reference count on the passed in SV
                   from us.  We set the name to NULL, otherwise we get into
@@ -167,7 +167,7 @@ PP(pp_sassign)
                SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
                                                      SvRV(cv))));
                SvREFCNT_dec(cv);
-               LEAVE;
+               LEAVE_with_name("sassign_coderef");
            } else {
                /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
                   is that
@@ -719,14 +719,14 @@ PP(pp_print)
        PUSHMARK(MARK - 1);
        *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
        PUTBACK;
-       ENTER;
+       ENTER_with_name("call_PRINT");
        if( PL_op->op_type == OP_SAY ) {
                /* local $\ = "\n" */
                SAVEGENERICSV(PL_ors_sv);
                PL_ors_sv = newSVpvs("\n");
        }
        call_method("PRINT", G_SCALAR);
-       LEAVE;
+       LEAVE_with_name("call_PRINT");
        SPAGAIN;
        MARK = ORIGMARK + 1;
        *MARK = *SP;
@@ -1209,10 +1209,13 @@ PP(pp_qr)
     SV * const rv = sv_newmortal();
 
     SvUPGRADE(rv, SVt_IV);
-    /* This RV is about to own a reference to the regexp. (In addition to the
-       reference already owned by the PMOP.  */
-    ReREFCNT_inc(rx);
-    SvRV_set(rv, MUTABLE_SV(rx));
+    /* For a subroutine describing itself as "This is a hacky workaround" I'm
+       loathe to use it here, but it seems to be the right fix. Or close.
+       The key part appears to be that it's essential for pp_qr to return a new
+       object (SV), which implies that there needs to be an effective way to
+       generate a new SV from the existing SV that is pre-compiled in the
+       optree.  */
+    SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
     SvROK_on(rv);
 
     if (pkg) {
@@ -1258,7 +1261,11 @@ PP(pp_match)
     }
 
     PUTBACK;                           /* EVAL blocks need stack_sp. */
-    s = SvPV_const(TARG, len);
+    /* Skip get-magic if this is a qr// clone, because regcomp has
+       already done it. */
+    s = ((struct regexp *)SvANY(rx))->mother_re
+        ? SvPV_nomg_const(TARG, len)
+        : SvPV_const(TARG, len);
     if (!s)
        DIE(aTHX_ "panic: pp_match");
     strend = s + len;
@@ -1554,9 +1561,9 @@ Perl_do_readline(pTHX)
            PUSHMARK(SP);
            XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
            PUTBACK;
-           ENTER;
+           ENTER_with_name("call_READLINE");
            call_method("READLINE", gimme);
-           LEAVE;
+           LEAVE_with_name("call_READLINE");
            SPAGAIN;
            if (gimme == G_SCALAR) {
                SV* const result = POPs;
@@ -1675,11 +1682,11 @@ Perl_do_readline(pTHX)
                (void)do_close(PL_last_in_gv, FALSE);
            }
            else if (type == OP_GLOB) {
-               if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
-                   Perl_warner(aTHX_ packWARN(WARN_GLOB),
-                          "glob failed (child exited with status %d%s)",
-                          (int)(STATUS_CURRENT >> 8),
-                          (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
+               if (!do_close(PL_last_in_gv, FALSE)) {
+                   Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
+                                  "glob failed (child exited with status %d%s)",
+                                  (int)(STATUS_CURRENT >> 8),
+                                  (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
                }
            }
            if (gimme == G_SCALAR) {
@@ -1764,7 +1771,7 @@ PP(pp_enter)
            gimme = G_SCALAR;
     }
 
-    ENTER;
+    ENTER_with_name("block");
 
     SAVETMPS;
     PUSHBLOCK(cx, CXt_BLOCK, SP);
@@ -1891,7 +1898,7 @@ PP(pp_leave)
     }
     PL_curpm = newpm;  /* Don't pop $1 et al till now */
 
-    LEAVE;
+    LEAVE_with_name("block");
 
     RETURN;
 }
@@ -2378,14 +2385,14 @@ PP(pp_grepwhile)
     if (SvTRUEx(POPs))
        PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
     ++*PL_markstack_ptr;
-    LEAVE;                                     /* exit inner scope */
+    LEAVE_with_name("grep_item");                                      /* exit inner scope */
 
     /* All done yet? */
     if (PL_stack_base + *PL_markstack_ptr > SP) {
        I32 items;
        const I32 gimme = GIMME_V;
 
-       LEAVE;                                  /* exit outer scope */
+       LEAVE_with_name("grep");                                        /* exit outer scope */
        (void)POPMARK;                          /* pop src */
        items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
        (void)POPMARK;                          /* pop dst */
@@ -2408,7 +2415,7 @@ PP(pp_grepwhile)
     else {
        SV *src;
 
-       ENTER;                                  /* enter inner scope */
+       ENTER_with_name("grep_item");                                   /* enter inner scope */
        SAVEVPTR(PL_curpm);
 
        src = PL_stack_base[*PL_markstack_ptr];
@@ -2700,7 +2707,7 @@ PP(pp_entersub)
            if (!sym)
                DIE(aTHX_ PL_no_usym, "a subroutine");
            if (PL_op->op_private & HINT_STRICT_REFS)
-               DIE(aTHX_ PL_no_symref, sym, "a subroutine");
+               DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
            cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
            break;
        }
@@ -2869,8 +2876,10 @@ try_autoload:
            PL_curcopdb = NULL;
        }
        /* Do we need to open block here? XXXX */
-       if (CvXSUB(cv)) /* XXX this is supposed to be true */
-           (void)(*CvXSUB(cv))(aTHX_ cv);
+
+       /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
+       assert(CvXSUB(cv));
+       CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
 
        /* Enforce some sanity in scalar context. */
        if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {