This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Sarathy's clear_pmop patch with Radu Greab's fix,
[perl5.git] / op.c
diff --git a/op.c b/op.c
index 4c5dd13..25e7aa5 100644 (file)
--- a/op.c
+++ b/op.c
@@ -125,7 +125,7 @@ S_trlist_upgrade(pTHX_ U8** sp, U8** ep)
     *ep = d;
     return *sp;
 }
-  
+
 
 /* "register" allocation */
 
@@ -843,6 +843,29 @@ S_op_clear(pTHX_ OP *o)
     case OP_MATCH:
     case OP_QR:
 clear_pmop:
+       {
+           HV *pmstash = PmopSTASH(cPMOPo);
+           if (pmstash && SvREFCNT(pmstash)) {
+               PMOP *pmop = HvPMROOT(pmstash);
+               PMOP *lastpmop = NULL;
+               while (pmop) {
+                   if (cPMOPo == pmop) {
+                       if (lastpmop)
+                           lastpmop->op_pmnext = pmop->op_pmnext;
+                       else
+                           HvPMROOT(pmstash) = pmop->op_pmnext;
+                       break;
+                   }
+                   lastpmop = pmop;
+                   pmop = pmop->op_pmnext;
+               }
+#ifdef USE_ITHREADS
+               Safefree(PmopSTASHPV(cPMOPo));
+#else
+               /* NOTE: PMOP.op_pmstash is not refcounted */
+#endif
+           }
+       }
        cPMOPo->op_pmreplroot = Nullop;
        ReREFCNT_dec(cPMOPo->op_pmregexp);
        cPMOPo->op_pmregexp = (REGEXP*)NULL;
@@ -1361,7 +1384,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
        PL_modcount++;
        return o;
     case OP_CONST:
-        if (o->op_private & (OPpCONST_BARE) && 
+        if (o->op_private & (OPpCONST_BARE) &&
                 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
             SV *sv = ((SVOP*)o)->op_sv;
             GV *gv;
@@ -1376,8 +1399,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
                 OP* enter;
                 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
 
-                enter = newUNOP(OP_ENTERSUB,0, 
-                        newUNOP(OP_RV2CV, 0, 
+                enter = newUNOP(OP_ENTERSUB,0,
+                        newUNOP(OP_RV2CV, 0,
                             newGVOP(OP_GV, 0, gv)
                         ));
                 enter->op_private |= OPpLVAL_INTRO;
@@ -2708,26 +2731,27 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            for (j = 0; j < i; j++) {
                U8 *s = cp[j];
                I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
-               UV  val = utf8_to_uv(s, cur, &ulen, 0);
+               /* CHECKME: Use unicode code points for ranges - needs more thought ... NI-S */
+               UV  val = utf8n_to_uvuni(s, cur, &ulen, 0);
                s += ulen;
                diff = val - nextmin;
                if (diff > 0) {
-                   t = uv_to_utf8(tmpbuf,nextmin);
+                   t = uvuni_to_utf8(tmpbuf,nextmin);
                    sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
                    if (diff > 1) {
-                       t = uv_to_utf8(tmpbuf, val - 1);
+                       t = uvuni_to_utf8(tmpbuf, val - 1);
                        sv_catpvn(transv, "\377", 1);
                        sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
                    }
                }
                if (s < tend && *s == 0xff)
-                   val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
+                   val = utf8n_to_uvuni(s+1, cur - 1, &ulen, 0);
                if (val >= nextmin)
                    nextmin = val + 1;
            }
-           t = uv_to_utf8(tmpbuf,nextmin);
+           t = uvuni_to_utf8(tmpbuf,nextmin);
            sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
-           t = uv_to_utf8(tmpbuf, 0x7fffffff);
+           t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
            sv_catpvn(transv, "\377", 1);
            sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
            t = (U8*)SvPVX(transv);
@@ -2739,7 +2763,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            r = t; rlen = tlen; rend = tend;
        }
        if (!squash) {
-               if (t == r ||
+               if ((!rlen && !del) || t == r ||
                    (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
                {
                    o->op_private |= OPpTRANS_IDENTICAL;
@@ -2749,11 +2773,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        while (t < tend || tfirst <= tlast) {
            /* see if we need more "t" chars */
            if (tfirst > tlast) {
-               tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
+               tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
                t += ulen;
                if (t < tend && *t == 0xff) {   /* illegal utf8 val indicates range */
                    t++;
-                   tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
+                   tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
                    t += ulen;
                }
                else
@@ -2763,11 +2787,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            /* now see if we need more "r" chars */
            if (rfirst > rlast) {
                if (r < rend) {
-                   rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
+                   rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
                    r += ulen;
                    if (r < rend && *r == 0xff) {       /* illegal utf8 val indicates range */
                        r++;
-                       rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
+                       rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
                        r += ulen;
                    }
                    else
@@ -2872,7 +2896,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            }
        }
        if (!del) {
-           if (j >= rlen)
+           if (!rlen) {
+               j = rlen;
+               if (!squash)
+                   o->op_private |= OPpTRANS_IDENTICAL;
+           }
+           else if (j >= rlen)
                j = rlen - 1;
            else
                cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
@@ -2934,6 +2963,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags)
     if (type != OP_TRANS && PL_curstash) {
        pmop->op_pmnext = HvPMROOT(PL_curstash);
        HvPMROOT(PL_curstash) = pmop;
+       PmopSTASH_set(pmop,PL_curstash);
     }
 
     return (OP*)pmop;
@@ -4157,14 +4187,19 @@ Perl_cv_undef(pTHX_ CV *cv)
        SAVEVPTR(PL_curpad);
        PL_curpad = 0;
 
-       if (!CvCLONED(cv))
-           op_free(CvROOT(cv));
+       op_free(CvROOT(cv));
        CvROOT(cv) = Nullop;
        LEAVE;
     }
     SvPOK_off((SV*)cv);                /* forget prototype */
     CvGV(cv) = Nullgv;
-    SvREFCNT_dec(CvOUTSIDE(cv));
+    /* Since closure prototypes have the same lifetime as the containing
+     * CV, they don't hold a refcount on the outside CV.  This avoids
+     * the refcount loop between the outer CV (which keeps a refcount to
+     * the closure prototype in the pad entry for pp_anoncode()) and the
+     * closure prototype, and the ensuing memory leak.  --GSAR */
+    if (!CvANON(cv) || CvCLONED(cv))
+       SvREFCNT_dec(CvOUTSIDE(cv));
     CvOUTSIDE(cv) = Nullcv;
     if (CvCONST(cv)) {
        SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
@@ -4278,7 +4313,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
     CvFILE(cv)         = CvFILE(proto);
     CvGV(cv)           = CvGV(proto);
     CvSTASH(cv)                = CvSTASH(proto);
-    CvROOT(cv)         = CvROOT(proto);
+    CvROOT(cv)         = OpREFCNT_inc(CvROOT(proto));
     CvSTART(cv)                = CvSTART(proto);
     if (outside)
        CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
@@ -4674,8 +4709,30 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        CvOUTSIDE(PL_compcv) = 0;
        CvPADLIST(cv) = CvPADLIST(PL_compcv);
        CvPADLIST(PL_compcv) = 0;
-       if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
-           CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
+       /* inner references to PL_compcv must be fixed up ... */
+       {
+           AV *padlist = CvPADLIST(cv);
+           AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+           AV *comppad = (AV*)AvARRAY(padlist)[1];
+           SV **namepad = AvARRAY(comppad_name);
+           SV **curpad = AvARRAY(comppad);
+           for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+               SV *namesv = namepad[ix];
+               if (namesv && namesv != &PL_sv_undef
+                   && *SvPVX(namesv) == '&')
+               {
+                   CV *innercv = (CV*)curpad[ix];
+                   if (CvOUTSIDE(innercv) == PL_compcv) {
+                       CvOUTSIDE(innercv) = cv;
+                       if (!CvANON(innercv) || CvCLONED(innercv)) {
+                           (void)SvREFCNT_inc(cv);
+                           SvREFCNT_dec(PL_compcv);
+                       }
+                   }
+               }
+           }
+       }
+       /* ... before we throw it away */
        SvREFCNT_dec(PL_compcv);
     }
     else {
@@ -4778,6 +4835,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        }
     }
 
+    /* If a potential closure prototype, don't keep a refcount on outer CV.
+     * This is okay as the lifetime of the prototype is tied to the
+     * lifetime of the outer CV.  Avoids memory leak due to reference
+     * loop. --GSAR */
+    if (!name)
+       SvREFCNT_dec(CvOUTSIDE(cv));
+
     if (name || aname) {
        char *s;
        char *tname = (name ? name : aname);
@@ -6796,7 +6860,7 @@ Perl_peep(pTHX_ register OP *o)
        case OP_MATCH:
        case OP_SUBST:
            o->op_seq = PL_op_seqmax++;
-           while (cPMOP->op_pmreplstart && 
+           while (cPMOP->op_pmreplstart &&
                   cPMOP->op_pmreplstart->op_type == OP_NULL)
                cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
            peep(cPMOP->op_pmreplstart);