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
Revert 27856.
[perl5.git] / dump.c
diff --git a/dump.c b/dump.c
index 8d4f063..e548585 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -365,33 +365,7 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
        op_dump(pm->op_pmreplroot);
     }
     if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
-       SV *tmpsv = newSVpvs("");
-       if (pm->op_pmdynflags & PMdf_USED)
-           sv_catpv(tmpsv, ",USED");
-       if (pm->op_pmdynflags & PMdf_TAINTED)
-           sv_catpv(tmpsv, ",TAINTED");
-       if (pm->op_pmflags & PMf_ONCE)
-           sv_catpv(tmpsv, ",ONCE");
-       if (PM_GETRE(pm) && PM_GETRE(pm)->check_substr
-           && !(PM_GETRE(pm)->reganch & ROPT_NOSCAN))
-           sv_catpv(tmpsv, ",SCANFIRST");
-       if (PM_GETRE(pm) && PM_GETRE(pm)->check_substr
-           && PM_GETRE(pm)->reganch & ROPT_CHECK_ALL)
-           sv_catpv(tmpsv, ",ALL");
-       if (pm->op_pmflags & PMf_SKIPWHITE)
-           sv_catpv(tmpsv, ",SKIPWHITE");
-       if (pm->op_pmflags & PMf_CONST)
-           sv_catpv(tmpsv, ",CONST");
-       if (pm->op_pmflags & PMf_KEEP)
-           sv_catpv(tmpsv, ",KEEP");
-       if (pm->op_pmflags & PMf_GLOBAL)
-           sv_catpv(tmpsv, ",GLOBAL");
-       if (pm->op_pmflags & PMf_CONTINUE)
-           sv_catpv(tmpsv, ",CONTINUE");
-       if (pm->op_pmflags & PMf_RETAINT)
-           sv_catpv(tmpsv, ",RETAINT");
-       if (pm->op_pmflags & PMf_EVAL)
-           sv_catpv(tmpsv, ",EVAL");
+       SV * const tmpsv = pm_description(pm);
        Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
        SvREFCNT_dec(tmpsv);
     }
@@ -399,6 +373,44 @@ Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
     Perl_dump_indent(aTHX_ level-1, file, "}\n");
 }
 
+static
+SV *
+S_pm_description(pTHX_ const PMOP *pm)
+{
+    SV * const desc = newSVpvs("");
+    const REGEXP * regex = PM_GETRE(pm);
+    const U32 pmflags = pm->op_pmflags;
+
+    if (pm->op_pmdynflags & PMdf_USED)
+       sv_catpv(desc, ",USED");
+    if (pm->op_pmdynflags & PMdf_TAINTED)
+       sv_catpv(desc, ",TAINTED");
+
+    if (pmflags & PMf_ONCE)
+       sv_catpv(desc, ",ONCE");
+    if (regex && regex->check_substr) {
+       if (!(regex->reganch & ROPT_NOSCAN))
+           sv_catpv(desc, ",SCANFIRST");
+       if (regex->reganch & ROPT_CHECK_ALL)
+           sv_catpv(desc, ",ALL");
+    }
+    if (pmflags & PMf_SKIPWHITE)
+       sv_catpv(desc, ",SKIPWHITE");
+    if (pmflags & PMf_CONST)
+       sv_catpv(desc, ",CONST");
+    if (pmflags & PMf_KEEP)
+       sv_catpv(desc, ",KEEP");
+    if (pmflags & PMf_GLOBAL)
+       sv_catpv(desc, ",GLOBAL");
+    if (pmflags & PMf_CONTINUE)
+       sv_catpv(desc, ",CONTINUE");
+    if (pmflags & PMf_RETAINT)
+       sv_catpv(desc, ",RETAINT");
+    if (pmflags & PMf_EVAL)
+       sv_catpv(desc, ",EVAL");
+    return desc;
+}
+
 void
 Perl_pmop_dump(pTHX_ PMOP *pm)
 {
@@ -771,7 +783,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 
 #ifdef PERL_MAD
     if (PL_madskills && o->op_madprop) {
-       SV *tmpsv = newSVpvn("", 0);
+       SV * const tmpsv = newSVpvn("", 0);
        MADPROP* mp = o->op_madprop;
        Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
        level++;
@@ -821,7 +833,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 #else
        if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
            if (cSVOPo->op_sv) {
-               SV *tmpsv = newSV(0);
+               SV * const tmpsv = newSV(0);
                ENTER;
                SAVEFREESV(tmpsv);
 #ifdef PERL_MAD
@@ -959,6 +971,7 @@ static const struct { const char type; const char *name; } magic_names[] = {
        { PERL_MAGIC_bm,             "bm(B)" },
        { PERL_MAGIC_regdata,        "regdata(D)" },
        { PERL_MAGIC_env,            "env(E)" },
+       { PERL_MAGIC_hints,          "hints(H)" },
        { PERL_MAGIC_isa,            "isa(I)" },
        { PERL_MAGIC_dbfile,         "dbfile(L)" },
        { PERL_MAGIC_shared,         "shared(N)" },
@@ -971,6 +984,7 @@ static const struct { const char type; const char *name; } magic_names[] = {
        { PERL_MAGIC_envelem,        "envelem(e)" },
        { PERL_MAGIC_fm,             "fm(f)" },
        { PERL_MAGIC_regex_global,   "regex_global(g)" },
+       { PERL_MAGIC_hintselem,      "hintselem(h)" },
        { PERL_MAGIC_isaelem,        "isaelem(i)" },
        { PERL_MAGIC_nkeys,          "nkeys(k)" },
        { PERL_MAGIC_dbline,         "dbline(l)" },
@@ -1030,6 +1044,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
            else if (v == &PL_vtbl_backref)    s = "backref";
            else if (v == &PL_vtbl_utf8)       s = "utf8";
             else if (v == &PL_vtbl_arylen_p)   s = "arylen_p";
+            else if (v == &PL_vtbl_hintselem)  s = "hintselem";
            if (s)
                Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
            else
@@ -1635,13 +1650,36 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
         if (IoTOP_NAME(sv))
             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
-       do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
+       if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
+           do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
+       else {
+           Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
+                            PTR2UV(IoTOP_GV(sv)));
+           do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
+                       dumpops, pvlim);
+       }
+       /* Source filters hide things that are not GVs in these three, so let's
+          be careful out there.  */
         if (IoFMT_NAME(sv))
             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
-       do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
+       if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
+           do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
+       else {
+           Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
+                            PTR2UV(IoFMT_GV(sv)));
+           do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
+                       dumpops, pvlim);
+       }
         if (IoBOTTOM_NAME(sv))
             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
-       do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
+       if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
+           do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
+       else {
+           Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
+                            PTR2UV(IoBOTTOM_GV(sv)));
+           do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
+                       dumpops, pvlim);
+       }
        Perl_dump_indent(aTHX_ level, file, "  SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
        if (isPRINT(IoTYPE(sv)))
             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
@@ -2230,33 +2268,7 @@ Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
     else
        Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
     if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
-       SV *tmpsv = newSVpvn("", 0);
-       if (pm->op_pmdynflags & PMdf_USED)
-           sv_catpv(tmpsv, ",USED");
-       if (pm->op_pmdynflags & PMdf_TAINTED)
-           sv_catpv(tmpsv, ",TAINTED");
-       if (pm->op_pmflags & PMf_ONCE)
-           sv_catpv(tmpsv, ",ONCE");
-       if (PM_GETRE(pm) && PM_GETRE(pm)->check_substr
-           && !(PM_GETRE(pm)->reganch & ROPT_NOSCAN))
-           sv_catpv(tmpsv, ",SCANFIRST");
-       if (PM_GETRE(pm) && PM_GETRE(pm)->check_substr
-           && PM_GETRE(pm)->reganch & ROPT_CHECK_ALL)
-           sv_catpv(tmpsv, ",ALL");
-       if (pm->op_pmflags & PMf_SKIPWHITE)
-           sv_catpv(tmpsv, ",SKIPWHITE");
-       if (pm->op_pmflags & PMf_CONST)
-           sv_catpv(tmpsv, ",CONST");
-       if (pm->op_pmflags & PMf_KEEP)
-           sv_catpv(tmpsv, ",KEEP");
-       if (pm->op_pmflags & PMf_GLOBAL)
-           sv_catpv(tmpsv, ",GLOBAL");
-       if (pm->op_pmflags & PMf_CONTINUE)
-           sv_catpv(tmpsv, ",CONTINUE");
-       if (pm->op_pmflags & PMf_RETAINT)
-           sv_catpv(tmpsv, ",RETAINT");
-       if (pm->op_pmflags & PMf_EVAL)
-           sv_catpv(tmpsv, ",EVAL");
+       SV * const tmpsv = pmflags_description(pm);
        Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
        SvREFCNT_dec(tmpsv);
     }
Unnamed repository; edit this file 'description' to name the repository.