Remove small memory leak in newATTRSUB that manifested as a

[perl5.git] / op.c

diff --git a/op.c b/op.c
index b10eb81..5fd21bf 100644 (file)
--- a/op.c
+++ b/op.c
@@ -78,9 +78,9 @@ Perl_Slab_Free(pTHX_ void *op)
     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
     assert( *slab > 0 );
     if (--(*slab) == 0) {
-     #ifdef NETWARE
-      #define PerlMemShared PerlMem
-     #endif
+#  ifdef NETWARE
+#    define PerlMemShared PerlMem
+#  endif
        
     PerlMemShared_free(slab);
        if (slab == PL_OpSlab) {
@@ -1823,6 +1823,7 @@ Perl_newPROG(pTHX_ OP *o)
        if (o->op_type == OP_STUB) {
            PL_comppad_name = 0;
            PL_compcv = 0;
+           FreeOp(o);
            return;
        }
        PL_main_root = scope(sawparens(scalarvoid(o)));
@@ -1864,19 +1865,27 @@ Perl_localize(pTHX_ OP *o, I32 lex)
            && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
        {
            char *s = PL_bufptr;
-           int sigil = 0;
+           bool sigil = FALSE;
 
            /* some heuristics to detect a potential error */
-           while (*s && (strchr(", \t\n", *s)
-                       || (strchr("@$%*", *s) && ++sigil) ))
+           while (*s && (strchr(", \t\n", *s)))
                s++;
-           if (sigil) {
-               while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
-                           || strchr("@$%*, \t\n", *s)))
-                   s++;
 
-               if (*s == ';' || *s == '=')
-                   Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
+           while (1) {
+               if (*s && strchr("@$%*", *s) && *++s
+                      && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
+                   s++;
+                   sigil = TRUE;
+                   while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
+                       s++;
+                   while (*s && (strchr(", \t\n", *s)))
+                       s++;
+               }
+               else
+                   break;
+           }
+           if (sigil && (*s == ';' || *s == '=')) {
+               Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
                                "Parentheses missing around \"%s\" list",
                                lex ? (PL_in_my == KEY_our ? "our" : "my")
                                : "local");
@@ -3334,12 +3343,10 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
        }
     }
     if (first->op_type == OP_CONST) {
-       if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
-           if (first->op_private & OPpCONST_STRICT)
-               no_bareword_allowed(first);
-           else
+       if (first->op_private & OPpCONST_STRICT)
+           no_bareword_allowed(first);
+       else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
                Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
-       }
        if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
            op_free(first);
            *firstp = Nullop;
@@ -3351,7 +3358,9 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
            return first;
        }
     }
-    else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
+    else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
+             type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
+    {
        OP *k1 = ((UNOP*)first)->op_first;
        OP *k2 = k1->op_sibling;
        OPCODE warnop = 0;
@@ -3779,7 +3788,9 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
        op_free(label);
     }
     else {
-       if (label->op_type == OP_ENTERSUB)
+       /* Check whether it's going to be a goto &function */
+       if (label->op_type == OP_ENTERSUB
+               && !(label->op_flags & OPf_STACKED))
            label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
        o = newUNOP(type, OPf_STACKED, label);
     }
@@ -4154,6 +4165,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        /* transfer PL_compcv to cv */
        cv_undef(cv);
        CvFLAGS(cv) = CvFLAGS(PL_compcv);
+       if (!CvWEAKOUTSIDE(cv))
+           SvREFCNT_dec(CvOUTSIDE(cv));
        CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
        CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
        CvOUTSIDE(PL_compcv) = 0;
@@ -4209,6 +4222,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                             mod(scalarseq(block), OP_LEAVESUBLV));
     }
     else {
+       /* This makes sub {}; work as expected.  */
+       if (block->op_type == OP_STUB) {
+           op_free(block);
+           block = newSTATEOP(0, Nullch, 0);
+       }
        CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
     }
     CvROOT(cv)->op_private |= OPpREFCOUNTED;
@@ -4350,6 +4368,9 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
     CvCONST_on(cv);
     sv_setpv((SV*)cv, "");  /* prototype is "" */
 
+    if (stash)
+       CopSTASH_free(PL_curcop);
+
     LEAVE;
 
     return cv;
@@ -4702,7 +4723,8 @@ OP *
 Perl_ck_concat(pTHX_ OP *o)
 {
     OP *kid = cUNOPo->op_first;
-    if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
+    if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
+           !(kUNOP->op_first->op_flags & OPf_MOD))
         o->op_flags |= OPf_STACKED;
     return o;
 }
@@ -5223,8 +5245,7 @@ Perl_ck_fun(pTHX_ OP *o)
                                           
                                      }
                                      if (tmpstr) {
-                                          name = savepv(SvPVX(tmpstr));
-                                          len = strlen(name);
+                                          name = SvPV(tmpstr, len);
                                           sv_2mortal(tmpstr);
                                      }
                                 }
@@ -5319,6 +5340,7 @@ Perl_ck_glob(pTHX_ OP *o)
        o->op_ppaddr = PL_ppaddr[OP_LIST];
        cLISTOPo->op_first->op_type = OP_PUSHMARK;
        cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
+       cLISTOPo->op_first->op_targ = 0;
        o = newUNOP(OP_ENTERSUB, OPf_STACKED,
                    append_elem(OP_LIST, o,
                                scalar(newUNOP(OP_RV2CV, 0,
@@ -6178,6 +6200,18 @@ Perl_ck_trunc(pTHX_ OP *o)
 }
 
 OP *
+Perl_ck_unpack(pTHX_ OP *o)
+{
+    OP *kid = cLISTOPo->op_first;
+    if (kid->op_sibling) {
+       kid = kid->op_sibling;
+       if (!kid->op_sibling)
+           kid->op_sibling = newDEFSVOP();
+    }
+    return ck_fun(o);
+}
+
+OP *
 Perl_ck_substr(pTHX_ OP *o)
 {
     o = ck_fun(o);