implement C<goto &func> and other fixes (via private mail)

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

diff --git a/pp_hot.c b/pp_hot.c
index 4ca41bb..24bb4da 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -311,7 +311,7 @@ PP(pp_print)
        gv = (GV*)*++MARK;
     else
        gv = PL_defoutgv;
-    if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+    if (mg = SvTIED_mg((SV*)gv, 'q')) {
        if (MARK == ORIGMARK) {
            /* If using default handle then we need to make space to 
             * pass object as 1st arg, so move other args up ...
@@ -322,7 +322,7 @@ PP(pp_print)
            ++SP;
        }
        PUSHMARK(MARK - 1);
-       *MARK = mg->mg_obj;
+       *MARK = SvTIED_obj((SV*)gv, mg);
        PUTBACK;
        ENTER;
        perl_call_method("PRINT", G_SCALAR);
@@ -593,6 +593,7 @@ PP(pp_aassign)
      * clobber a value on the right that's used later in the list.
      */
     if (PL_op->op_private & OPpASSIGN_COMMON) {
+       EXTEND_MORTAL(lastrelem - firstrelem + 1);
         for (relem = firstrelem; relem <= lastrelem; relem++) {
             /*SUPPRESS 560*/
             if (sv = *relem) {
@@ -863,9 +864,9 @@ PP(pp_match)
            }
        }
     }
-    safebase = (((gimme == G_ARRAY) || global || !rx->nparens)
-               && !PL_sawampersand);
-    safebase = safebase ? 0  : REXEC_COPY_STR ;
+    safebase = ((gimme != G_ARRAY && !global && rx->nparens)
+               || SvTEMP(TARG) || PL_sawampersand)
+               ? REXEC_COPY_STR : 0;
     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
        SAVEINT(PL_multiline);
        PL_multiline = pm->op_pmflags & PMf_MULTILINE;
@@ -1055,9 +1056,9 @@ do_readline(void)
     I32 gimme = GIMME_V;
     MAGIC *mg;
 
-    if (SvRMAGICAL(PL_last_in_gv) && (mg = mg_find((SV*)PL_last_in_gv, 'q'))) {
+    if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) {
        PUSHMARK(SP);
-       XPUSHs(mg->mg_obj);
+       XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
        PUTBACK;
        ENTER;
        perl_call_method("READLINE", gimme);
@@ -1258,8 +1259,12 @@ do_readline(void)
                IoFLAGS(io) |= IOf_START;
            }
            else if (type == OP_GLOB) {
-               if (!do_close(PL_last_in_gv, FALSE))
-                   warn("internal error: glob failed");
+               if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) {
+                   warner(WARN_CLOSED,
+                          "glob failed (child exited with status %d%s)",
+                          STATUS_CURRENT >> 8,
+                          (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
+               }
            }
            if (gimme == G_SCALAR) {
                (void)SvOK_off(TARG);
@@ -1461,7 +1466,7 @@ PP(pp_iter)
 
     EXTEND(SP, 1);
     cx = &cxstack[cxstack_ix];
-    if (cx->cx_type != CXt_LOOP)
+    if (CxTYPE(cx) != CXt_LOOP)
        DIE("panic: pp_iter");
 
     av = cx->blk_loop.iterary;
@@ -1622,7 +1627,8 @@ PP(pp_subst)
                  && SvTYPE(rx->check_substr) == SVt_PVBM
                  && SvVALID(rx->check_substr)) 
                ? TARG : Nullsv);
-    safebase = (!rx->nparens && !PL_sawampersand) ? 0 : REXEC_COPY_STR;
+    safebase = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
+               ? REXEC_COPY_STR : 0;
     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
        SAVEINT(PL_multiline);
        PL_multiline = pm->op_pmflags & PMf_MULTILINE;
@@ -2105,7 +2111,6 @@ PP(pp_entersub)
            DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
                                  thr, sv);)
            MUTEX_UNLOCK(MgMUTEXP(mg));
-           SvREFCNT_inc(sv);   /* Keep alive until magic_mutexfree */
            save_destructor(unlock_condpair, sv);
        }
        MUTEX_LOCK(CvMUTEXP(cv));
@@ -2268,12 +2273,14 @@ PP(pp_entersub)
        PUSHBLOCK(cx, CXt_SUB, MARK);
        PUSHSUB(cx);
        CvDEPTH(cv)++;
+       /* XXX This would be a natural place to set C<PL_compcv = cv> so
+        * that eval'' ops within this sub know the correct lexical space.
+        * Owing the speed considerations, we choose to search for the cv
+        * in doeval() instead.
+        */
        if (CvDEPTH(cv) < 2)
            (void)SvREFCNT_inc(cv);
        else {  /* save temporaries on recursion? */
-           if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
-                 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
-               sub_crush_depth(cv);
            if (CvDEPTH(cv) > AvFILLp(padlist)) {
                AV *av;
                AV *newpad = newAV();
@@ -2373,6 +2380,13 @@ PP(pp_entersub)
                MARK++;
            }
        }
+       /* warning must come *after* we fully set up the context
+        * stuff so that __WARN__ handlers can safely dounwind()
+        * if they want to
+        */
+       if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
+           && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
+           sub_crush_depth(cv);
 #if 0
        DEBUG_S(PerlIO_printf(PerlIO_stderr(),
                              "%p entersub returning %p\n", thr, CvSTART(cv)));
@@ -2502,10 +2516,16 @@ PP(pp_method)
            !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
            !(ob=(SV*)GvIO(iogv)))
        {
-           if (!packname || !isIDFIRST(*packname))
+           if (!packname || 
+               ((*(U8*)packname >= 0xc0 && IN_UTF8)
+                   ? !isIDFIRST_utf8(packname)
+                   : !isIDFIRST(*packname)
+               ))
+           {
                DIE("Can't call method \"%s\" %s", name,
                    SvOK(sv)? "without a package or object reference"
                            : "on an undefined value");
+           }
            stash = gv_stashpvn(packname, packlen, TRUE);
            goto fetch;
        }