Add '=cut' to silence POD formatting warning

[perl5.git] / op.c

diff --git a/op.c b/op.c
index bf10dd3..666ef26 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1316,6 +1316,24 @@ S_cop_free(pTHX_ COP* cop)
 {
     PERL_ARGS_ASSERT_COP_FREE;
 
+    /* If called during global destruction PL_defstash might be NULL and there
+       shouldn't be any code running that will trip over the bad cop address.
+       This also avoids uselessly creating the AV after it's been destroyed.
+    */
+    if (cop->op_type == OP_DBSTATE && PL_phase != PERL_PHASE_DESTRUCT) {
+        /* Remove the now invalid op from the line number information.
+           This could cause a freed memory overwrite if the debugger tried to
+           set a breakpoint on this line.
+        */
+        AV *av = CopFILEAVn(cop);
+        if (av) {
+            SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
+            if (svp && *svp != &PL_sv_undef && SvIVX(*svp) == PTR2IV(cop) ) {
+                (void)SvIOK_off(*svp);
+                SvIV_set(*svp, 0);
+            }
+        }
+    }
     CopFILE_free(cop);
     if (! specialWARN(cop->cop_warnings))
         PerlMemShared_free(cop->cop_warnings);
@@ -10675,7 +10693,8 @@ Constructs and returns a deferred-block statement that implements the
 C<defer> semantics.  The C<block> optree is consumed by this function and
 becomes part of the returned optree.
 
-The C<flags> argument is currently ignored.
+The C<flags> argument carries additional flags to set on the returned op,
+including the C<op_private> field.
 
 =cut
  */
@@ -10686,7 +10705,6 @@ Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
     OP *o, *start, *blockfirst;
 
     PERL_ARGS_ASSERT_NEWDEFEROP;
-    PERL_UNUSED_ARG(flags);
 
     start = LINKLIST(block);
 
@@ -10695,7 +10713,8 @@ Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
     block->op_next = block;
 
     o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start);
-    o->op_flags |= OPf_WANT_VOID;
+    o->op_flags |= OPf_WANT_VOID | (U8)(flags);
+    o->op_private = (U8)(flags >> 8);
 
     /* Terminate the block */
     blockfirst = cUNOPx(block)->op_first;
@@ -10705,6 +10724,33 @@ Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
     return o;
 }
 
+/*
+=for apidoc op_wrap_finally
+
+Wraps the given C<block> optree fragment in its own scoped block, arranging
+for the C<finally> optree fragment to be invoked when leaving that block for
+any reason. Both optree fragments are consumed and the combined result is
+returned.
+
+=cut
+*/
+
+OP *
+Perl_op_wrap_finally(pTHX_ OP *block, OP *finally)
+{
+    PERL_ARGS_ASSERT_OP_WRAP_FINALLY;
+
+    /* TODO: If block is already an ENTER/LEAVE-wrapped line sequence we can
+     * just splice the DEFEROP in at the top, for efficiency.
+     */
+
+    OP *o = newLISTOP(OP_LINESEQ, 0, newDEFEROP((OPpDEFER_FINALLY << 8), finally), block);
+    o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
+    OpTYPE_set(o, OP_LEAVE);
+
+    return o;
+}
+
 /* must not conflict with SVf_UTF8 */
 #define CV_CKPROTO_CURSTASH    0x1
 
@@ -10916,9 +10962,9 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
         const line_t oldline = CopLINE(PL_curcop);
         SV *namesv = o
             ? cSVOPo->op_sv
-            : sv_2mortal(newSVpvn_utf8(
-                PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
-              ));
+            : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1,
+               (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP
+              );
         if (PL_parser && PL_parser->copline != NOLINE)
             /* This ensures that warnings are reported at the first
                line of a redefinition, not the last.  */
@@ -14201,6 +14247,9 @@ Perl_ck_sort(pTHX_ OP *o)
         simplify_sort(o);
     firstkid = OpSIBLING(cLISTOPo->op_first);          /* get past pushmark */
 
+    if (!firstkid)
+        return too_few_arguments_pv(o,OP_DESC(o), 0);
+
     if ((stacked = o->op_flags & OPf_STACKED)) {       /* may have been cleared */
         OP *kid = cUNOPx(firstkid)->op_first;          /* get past null */
 
@@ -17903,6 +17952,12 @@ Perl_rpeep(pTHX_ OP *o)
             DEFER(cLOGOPo->op_other);
             break;
 
+        case OP_ENTERTRYCATCH:
+            assert(cLOGOPo->op_other->op_type == OP_CATCH);
+            /* catch body is the ->op_other of the OP_CATCH */
+            DEFER(cLOGOPx(cLOGOPo->op_other)->op_other);
+            break;
+
         case OP_SUBST:
             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
@@ -18245,7 +18300,10 @@ Perl_rpeep(pTHX_ OP *o)
         }
 
         case OP_REF:
-            /* see if ref() is used in boolean context */
+        case OP_BLESSED:
+            /* if the op is used in boolean context, set the TRUEBOOL flag
+             * which enables an optimisation at runtime which avoids creating
+             * a stack temporary for known-true package names */
             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
             break;