This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Fix various mad eval leaks
[perl5.git] / dump.c
diff --git a/dump.c b/dump.c
index c7a40a6..c74c003 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -581,7 +581,7 @@ Perl_sv_peek(pTHX_ SV *sv)
   finish:
     while (unref--)
        sv_catpv(t, ")");
-    if (PL_tainting && SvTAINTED(sv))
+    if (TAINTING_get && SvTAINTED(sv))
        sv_catpv(t, " [tainted]");
     return SvPV_nolen(t);
 }
@@ -664,7 +664,7 @@ S_pm_description(pTHX_ const PMOP *pm)
 #endif
 
     if (regex) {
-        if (RX_EXTFLAGS(regex) & RXf_TAINTED)
+        if (RX_ISTAINTED(regex))
             sv_catpv(desc, ",TAINTED");
         if (RX_CHECK_SUBSTR(regex)) {
             if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
@@ -672,8 +672,6 @@ S_pm_description(pTHX_ const PMOP *pm)
             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
                 sv_catpv(desc, ",ALL");
         }
-        if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
-            sv_catpv(desc, ",SKIPWHITE");
     }
 
     append_flags(desc, pmflags, pmflags_flags_names);
@@ -907,6 +905,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
     }
     if (o->op_private) {
        SV * const tmpsv = newSVpvs("");
+
        if (PL_opargs[optype] & OA_TARGLEX) {
            if (o->op_private & OPpTARGET_MY)
                sv_catpv(tmpsv, ",TARGET_MY");
@@ -943,6 +942,12 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
                if (o->op_private & OPpLVAL_DEFER)
                    sv_catpv(tmpsv, ",LVAL_DEFER");
            }
+           else if (optype == OP_RV2HV || optype == OP_PADHV) {
+             if (o->op_private & OPpMAYBE_TRUEBOOL)
+               sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL");
+             if (o->op_private & OPpTRUEBOOL)
+               sv_catpvs(tmpsv, ",OPpTRUEBOOL");
+           }
            else {
                if (o->op_private & HINT_STRICT_REFS)
                    sv_catpv(tmpsv, ",STRICT_REFS");
@@ -958,10 +963,19 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
            if (o->op_private & OPpFT_STACKED)
                sv_catpv(tmpsv, ",FT_STACKED");
        }
+
        if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
            sv_catpv(tmpsv, ",INTRO");
+
+       if (o->op_type == OP_PADRANGE)
+           Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf,
+                (UV)(o->op_private & OPpPADRANGE_COUNTMASK));
+
        if (SvCUR(tmpsv))
            Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
+        else
+           Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
+                                (UV)o->op_private);
        SvREFCNT_dec(tmpsv);
     }
 
@@ -1411,12 +1425,10 @@ const struct flag_to_name regexp_flags_names[] = {
     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
-    {RXf_SPLIT,           "SPLIT,"},
     {RXf_COPY_DONE,       "COPY_DONE,"},
     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
     {RXf_TAINTED,         "TAINTED,"},
     {RXf_START_ONLY,      "START_ONLY,"},
-    {RXf_SKIPWHITE,       "SKIPWHITE,"},
     {RXf_WHITE,           "WHITE,"},
     {RXf_NULL,            "NULL,"},
 };
@@ -1609,8 +1621,11 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        return;
     }
 
-    if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
-       if (SvPVX_const(sv)) {
+    if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
+       const bool re = isREGEXP(sv);
+       const char * const ptr =
+           re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
+       if (ptr) {
            STRLEN delta;
            if (SvOOK(sv)) {
                SvOOK_offset(sv, delta);
@@ -1619,18 +1634,22 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
            } else {
                delta = 0;
            }
-           Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
+           Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
            if (SvOOK(sv)) {
                PerlIO_printf(file, "( %s . ) ",
-                             pv_display(d, SvPVX_const(sv) - delta, delta, 0,
+                             pv_display(d, ptr - delta, delta, 0,
                                         pvlim));
            }
-           PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
+           PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
+                                                re ? 0 : SvLEN(sv),
+                                                pvlim));
            if (SvUTF8(sv)) /* the 6?  \x{....} */
                PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
            PerlIO_printf(file, "\n");
            Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
-           Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
+           if (!re)
+               Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
+                                      (IV)SvLEN(sv));
        }
        else
            Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
@@ -1918,10 +1937,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                                 (IV)CvXSUBANY(sv).any_i32);
            }
        }
-       do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
+       if (CvNAMED(sv))
+           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
+                                  HEK_KEY(CvNAME_HEK((CV *)sv)));
+       else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
        Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
-       if (type == SVt_PVCV)
-           Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
+       Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
        Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
        Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
        Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
@@ -1954,6 +1975,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
                    dumpops, pvlim);
        }
+       if (isREGEXP(sv)) goto dumpregexp;
        if (!isGV_with_GP(sv))
            break;
        Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
@@ -2022,8 +2044,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
        break;
     case SVt_REGEXP:
+      dumpregexp:
        {
-           struct regexp * const r = (struct regexp *)SvANY(sv);
+           struct regexp * const r = ReANY((REGEXP*)sv);
            flags = RX_EXTFLAGS((REGEXP*)sv);
            sv_setpv(d,"");
            append_flags(d, flags, regexp_flags_names);
@@ -2051,6 +2074,10 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                                (UV)(r->pre_prefix));
            Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
                                (IV)(r->sublen));
+           Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
+                               (IV)(r->suboffset));
+           Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
+                               (IV)(r->subcoffset));
            if (r->subbeg)
                Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
                            PTR2UV(r->subbeg),
@@ -2124,6 +2151,8 @@ Perl_runops_debug(pTHX)
            if (DEBUG_t_TEST_) debop(PL_op);
            if (DEBUG_P_TEST_) debprof(PL_op);
        }
+
+        OP_ENTRY_PROBE(OP_NAME(PL_op));
     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
 
@@ -2170,25 +2199,45 @@ Perl_debop(pTHX_ const OP *o)
        else
            PerlIO_printf(Perl_debug_log, "(NULL)");
        break;
+
+    {
+        int count;
+
     case OP_PADSV:
     case OP_PADAV:
     case OP_PADHV:
-       {
+        count = 1;
+        goto dump_padop;
+    case OP_PADRANGE:
+        count = o->op_private & OPpPADRANGE_COUNTMASK;
+    dump_padop:
        /* print the lexical's name */
-       CV * const cv = deb_curcv(cxstack_ix);
-       SV *sv;
-        if (cv) {
-           AV * const padlist = CvPADLIST(cv);
-            AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
-            sv = *av_fetch(comppad, o->op_targ, FALSE);
-        } else
-            sv = NULL;
-        if (sv)
-           PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
-        else
-           PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
-       }
+        {
+            CV * const cv = deb_curcv(cxstack_ix);
+            SV *sv;
+            PAD * comppad = NULL;
+            int i;
+
+            if (cv) {
+                PADLIST * const padlist = CvPADLIST(cv);
+                comppad = *PadlistARRAY(padlist);
+            }
+            PerlIO_printf(Perl_debug_log, "(");
+            for (i = 0; i < count; i++) {
+                if (comppad &&
+                        (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
+                    PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
+                else
+                    PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
+                            (UV)o->op_targ+i);
+                if (i < count-1)
+                    PerlIO_printf(Perl_debug_log, ",");
+            }
+            PerlIO_printf(Perl_debug_log, ")");
+        }
         break;
+    }
+
     default:
        break;
     }
Unnamed repository; edit this file 'description' to name the repository.