add Perl_dup_warnings() and fix leak

[perl5.git] / op.c

diff --git a/op.c b/op.c
index 35414be..2b162e1 100644 (file)
--- a/op.c
+++ b/op.c
@@ -190,6 +190,22 @@ static const char array_passed_to_stat[] = "Array passed to stat will be coerced
     } \
     defer_stack[++defer_ix] = o; \
   } STMT_END
+#define DEFER_REVERSE(count)                            \
+    STMT_START {                                        \
+        UV cnt = (count);                               \
+        if (cnt > 1) {                                  \
+            OP **top = defer_stack + defer_ix;          \
+            /* top - (cnt) + 1 isn't safe here */       \
+            OP **bottom = top - (cnt - 1);              \
+            OP *tmp;                                    \
+            assert(bottom >= defer_stack);              \
+            while (top > bottom) {                      \
+                tmp = *top;                             \
+                *top-- = *bottom;                       \
+                *bottom++ = tmp;                        \
+            }                                           \
+        }                                               \
+    } STMT_END;
 
 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 
@@ -1426,8 +1442,7 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
         OpMAYBESIB_set(start, insert, NULL);
     }
     else {
-        if (!parent)
-            goto no_parent;
+        assert(parent);
         cLISTOPx(parent)->op_first = insert;
         if (insert)
             parent->op_flags |= OPf_KIDS;
@@ -2634,6 +2649,7 @@ S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
 STATIC void
 S_maybe_multiconcat(pTHX_ OP *o)
 {
+    dVAR;
     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
     OP *topop;       /* the top-most op in the concat tree (often equals o,
                         unless there are assign/stringify ops above it */
@@ -3490,8 +3506,12 @@ S_optimize_op(pTHX_ OP* o)
 
         if (o->op_flags & OPf_KIDS) {
             OP *kid;
-            for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
+            IV child_count = 0;
+            for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
                 DEFER_OP(kid);
+                ++child_count;
+            }
+            DEFER_REVERSE(child_count);
         }
     } while ( ( o = POP_DEFERRED_OP() ) );
 
@@ -3556,7 +3576,7 @@ For now it's static, but it may be exposed to the API in the future.
 */
 
 STATIC OP*
-S_traverse_op_tree(OP *top, OP *o) {
+S_traverse_op_tree(pTHX_ OP *top, OP *o) {
     OP *sib;
 
     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
@@ -7802,6 +7822,7 @@ S_assignment_type(pTHX_ const OP *o)
 static OP *
 S_newONCEOP(pTHX_ OP *initop, OP *padop)
 {
+    dVAR;
     const PADOFFSET target = padop->op_targ;
     OP *const other = newOP(OP_PADSV,
                            padop->op_flags
@@ -17021,6 +17042,26 @@ const_av_xsub(pTHX_ CV* cv)
     XSRETURN(AvFILLp(av)+1);
 }
 
+/* Copy an existing cop->cop_warnings field.
+ * If it's one of the standard addresses, just re-use the address.
+ * This is the e implementation for the DUP_WARNINGS() macro
+ */
+
+STRLEN*
+Perl_dup_warnings(pTHX_ STRLEN* warnings)
+{
+    Size_t size;
+    STRLEN *new_warnings;
+
+    if (specialWARN(warnings))
+        return warnings;
+
+    size = sizeof(*warnings) + *warnings;
+
+    new_warnings = (STRLEN*)PerlMemShared_malloc(size);
+    Copy(warnings, new_warnings, size, char);
+    return new_warnings;
+}
 
 /*
  * ex: set ts=8 sts=4 sw=4 et: