Add Porting/check-cpan-pollution to MANIFEST

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

diff --git a/pp_ctl.c b/pp_ctl.c
index e69107e..8c638ac 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -149,6 +149,27 @@ PP(pp_regcomp)
        re = (REGEXP*) tmpstr;
 
     if (re) {
+       /* The match's LHS's get-magic might need to access this op's reg-
+          exp (as is sometimes the case with $';  see bug 70764).  So we
+          must call get-magic now before we replace the regexp. Hopeful-
+          ly this hack can be replaced with the approach described at
+          http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
+          /msg122415.html some day. */
+       if(pm->op_type == OP_MATCH) {
+        SV *lhs;
+        const bool was_tainted = PL_tainted;
+        if (pm->op_flags & OPf_STACKED)
+           lhs = TOPs;
+        else if (pm->op_private & OPpTARGET_MY)
+           lhs = PAD_SV(pm->op_targ);
+        else lhs = DEFSV;
+        SvGETMAGIC(lhs);
+        /* Restore the previous value of PL_tainted (which may have been
+           modified by get-magic), to avoid incorrectly setting the
+           RXf_TAINTED flag further down. */
+        PL_tainted = was_tainted;
+       }
+
        re = reg_temp_copy(NULL, re);
        ReREFCNT_dec(PM_GETRE(pm));
        PM_SETRE(pm, re);
@@ -1313,13 +1334,16 @@ S_dopoptolabel(pTHX_ const char *label)
        case CXt_LOOP_LAZYSV:
        case CXt_LOOP_FOR:
        case CXt_LOOP_PLAIN:
-           if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
+         {
+           const char *cx_label = CxLABEL(cx);
+           if (!cx_label || strNE(label, cx_label) ) {
                DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
-                       (long)i, CxLABEL(cx)));
+                       (long)i, cx_label));
                continue;
            }
            DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
            return i;
+         }
        }
     }
     return i;
@@ -1858,7 +1882,7 @@ PP(pp_dbstate)
            /* don't do recursive DB::DB call */
            return NORMAL;
 
-       ENTER_with_name("sub");
+       ENTER;
        SAVETMPS;
 
        SAVEI32(PL_debug);
@@ -1873,7 +1897,7 @@ PP(pp_dbstate)
            (void)(*CvXSUB(cv))(aTHX_ cv);
            CvDEPTH(cv)--;
            FREETMPS;
-           LEAVE_with_name("sub");
+           LEAVE;
            return NORMAL;
        }
        else {
@@ -2393,9 +2417,11 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
        OP *kid;
        /* First try all the kids at this level, since that's likeliest. */
        for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
-           if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
-                   CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
-               return kid;
+           if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
+               const char *kid_label = CopLABEL(kCOP);
+               if (kid_label && strEQ(kid_label, label))
+                   return kid;
+           }
        }
        for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
            if (kid == PL_lastgotoprobe)
@@ -2534,7 +2560,7 @@ PP(pp_goto)
                PUSHMARK(mark);
                PUTBACK;
                (void)(*CvXSUB(cv))(aTHX_ cv);
-               LEAVE_with_name("sub");
+               LEAVE;
                return retop;
            }
            else {
@@ -3250,21 +3276,21 @@ PP(pp_require)
                        SVfARG(vnormal(PL_patchlevel)));
                }
                else { /* probably 'use 5.10' or 'use 5.8' */
-                   SV * hintsv = newSV(0);
+                   SV *hintsv;
                    I32 second = 0;
 
                    if (av_len(lav)>=1) 
                        second = SvIV(*av_fetch(lav,1,0));
 
                    second /= second >= 600  ? 100 : 10;
-                   hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
-                       (int)first, (int)second,0);
+                   hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
+                                          (int)first, (int)second);
                    upg_version(hintsv, TRUE);
 
                    DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
                        "--this is only %"SVf", stopped",
                        SVfARG(vnormal(req)),
-                       SVfARG(vnormal(hintsv)),
+                       SVfARG(vnormal(sv_2mortal(hintsv))),
                        SVfARG(vnormal(PL_patchlevel)));
                }
            }
@@ -4313,7 +4339,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                    (void) sv_2mortal(MUTABLE_SV(seen_this));
                }
                if (NULL == seen_other) {
-                   seen_this = newHV();
+                   seen_other = newHV();
                    (void) sv_2mortal(MUTABLE_SV(seen_other));
                }
                for(i = 0; i <= other_len; ++i) {
@@ -4321,7 +4347,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                    SV * const * const other_elem = av_fetch(other_av, i, FALSE);
 
                    if (!this_elem || !other_elem) {
-                       if (this_elem || other_elem)
+                       if ((this_elem && SvOK(*this_elem))
+                               || (other_elem && SvOK(*other_elem)))
                            RETPUSHNO;
                    }
                    else if (hv_exists_ent(seen_this,