Integrate MIME::Base64 2.16 from CPAN. (Do we really want the

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

diff --git a/op.c b/op.c
index c3aee1e..abd9417 100644 (file)
--- a/op.c
+++ b/op.c
@@ -152,8 +152,8 @@ STATIC void
 S_no_bareword_allowed(pTHX_ OP *o)
 {
     qerror(Perl_mess(aTHX_
-                    "Bareword \"%s\" not allowed while \"strict subs\" in use",
-                    SvPV_nolen(cSVOPo_sv)));
+                    "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
+                    cSVOPo_sv));
 }
 
 /* "register" allocation */
@@ -3108,7 +3108,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
                             curop->op_type == OP_PADANY)
                    {
                        if (PAD_COMPNAME_GEN(curop->op_targ)
-                                                   == PL_generation)
+                                                   == (STRLEN)PL_generation)
                            break;
                        PAD_COMPNAME_GEN(curop->op_targ)
                                                        = PL_generation;
@@ -3753,12 +3753,20 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
     return o;
 }
 
+/*
+=for apidoc cv_undef
+
+Clear out all the active components of a CV. This can happen either
+by an explicit C<undef &foo>, or by the reference count going to zero.
+In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
+children can still follow the full lexical scope chain.
+
+=cut
+*/
+
 void
 Perl_cv_undef(pTHX_ CV *cv)
 {
-    CV *outsidecv;
-    CV *freecv = Nullcv;
-
 #ifdef USE_ITHREADS
     if (CvFILE(cv) && !CvXSUB(cv)) {
        /* for XSUBs CvFILE point directly to static memory; __FILE__ */
@@ -3780,26 +3788,24 @@ Perl_cv_undef(pTHX_ CV *cv)
     }
     SvPOK_off((SV*)cv);                /* forget prototype */
     CvGV(cv) = Nullgv;
-    outsidecv = 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))
-        freecv = outsidecv;
-    CvOUTSIDE(cv) = Nullcv;
+
+    pad_undef(cv);
+
+    /* remove CvOUTSIDE unless this is an undef rather than a free */
+    if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
+       if (!CvWEAKOUTSIDE(cv))
+           SvREFCNT_dec(CvOUTSIDE(cv));
+       CvOUTSIDE(cv) = Nullcv;
+    }
     if (CvCONST(cv)) {
        SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
        CvCONST_off(cv);
     }
-    pad_undef(cv, outsidecv);
-    if (freecv)
-       SvREFCNT_dec(freecv);
     if (CvXSUB(cv)) {
         CvXSUB(cv) = 0;
     }
-    CvFLAGS(cv) = 0;
+    /* delete all flags except WEAKOUTSIDE */
+    CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
 }
 
 void
@@ -3815,7 +3821,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
        if (name)
            Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
        if (SvPOK(cv))
-           Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
+           Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
        sv_catpv(msg, " vs ");
        if (p)
            Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
@@ -4086,9 +4092,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            SAVEFREESV(PL_compcv);
            goto done;
        }
+       /* transfer PL_compcv to cv */
        cv_undef(cv);
        CvFLAGS(cv) = CvFLAGS(PL_compcv);
        CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
+       CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
        CvOUTSIDE(PL_compcv) = 0;
        CvPADLIST(cv) = CvPADLIST(PL_compcv);
        CvPADLIST(PL_compcv) = 0;
@@ -4128,7 +4136,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                else {
                    /* force display of errors found but not reported */
                    sv_catpv(ERRSV, not_safe);
-                   Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
+                   Perl_croak(aTHX_ "%"SVf, ERRSV);
                }
            }
        }
@@ -4159,13 +4167,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            CvCONST_on(cv);
     }
 
-    /* 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);
@@ -5990,8 +5991,8 @@ Perl_ck_subr(pTHX_ OP *o)
                continue;
            default:
              oops:
-               Perl_croak(aTHX_ "Malformed prototype for %s: %s",
-                          gv_ename(namegv), SvPV((SV*)cv, n_a));
+               Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
+                          gv_ename(namegv), cv);
            }
        }
        else
@@ -6062,8 +6063,10 @@ Perl_peep(pTHX_ register OP *o)
     for (; o; o = o->op_next) {
        if (o->op_seq)
            break;
-       if (!PL_op_seqmax)
-           PL_op_seqmax++;
+        /* The special value -1 is used by the B::C compiler backend to indicate
+         * that an op is statically defined and should not be freed */
+       if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
+           PL_op_seqmax = 1;
        PL_op = o;
        switch (o->op_type) {
        case OP_SETSTATE:
@@ -6077,12 +6080,13 @@ Perl_peep(pTHX_ register OP *o)
            if (cSVOPo->op_private & OPpCONST_STRICT)
                no_bareword_allowed(o);
 #ifdef USE_ITHREADS
+       case OP_METHOD_NAMED:
            /* Relocate sv to the pad for thread safety.
             * Despite being a "constant", the SV is written to,
             * for reference counts, sv_upgrade() etc. */
            if (cSVOP->op_sv) {
                PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
-               if (SvPADTMP(cSVOPo->op_sv)) {
+               if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
                    /* If op_sv is already a PADTMP then it is being used by
                     * some pad, so make a copy. */
                    sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
@@ -6196,8 +6200,8 @@ Perl_peep(pTHX_ register OP *o)
                    SV *sv = sv_newmortal();
                    gv_efullname3(sv, gv, Nullch);
                    Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
-                               "%s() called too early to check prototype",
-                               SvPV_nolen(sv));
+                               "%"SVf"() called too early to check prototype",
+                               sv);
                }
            }
            else if (o->op_next->op_type == OP_READLINE