This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_do_sv_dump: dump REGEXP body
authorDavid Mitchell <davem@iabyn.com>
Sun, 30 Jan 2011 23:56:01 +0000 (23:56 +0000)
committerDavid Mitchell <davem@iabyn.com>
Sun, 30 Jan 2011 23:58:26 +0000 (23:58 +0000)
Now that a regexp is a first-class SV, dump all the fields
of the 'struct regexp': it's just another SV body type

dump.c
ext/Devel-Peek/t/Peek.t

diff --git a/dump.c b/dump.c
index c278ad4..15a788f 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1543,6 +1543,37 @@ const struct flag_to_name gp_flags_imported_names[] = {
     {GVf_IMPORTED_CV, " CV"},
 };
 
+const struct flag_to_name regexp_flags_names[] = {
+    {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
+    {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
+    {RXf_PMf_FOLD,        "PMf_FOLD,"},
+    {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
+    {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
+    {RXf_ANCH_BOL,        "ANCH_BOL,"},
+    {RXf_ANCH_MBOL,       "ANCH_MBOL,"},
+    {RXf_ANCH_SBOL,       "ANCH_SBOL,"},
+    {RXf_ANCH_GPOS,       "ANCH_GPOS,"},
+    {RXf_GPOS_SEEN,       "GPOS_SEEN,"},
+    {RXf_GPOS_FLOAT,      "GPOS_FLOAT,"},
+    {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
+    {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
+    {RXf_CANY_SEEN,       "CANY_SEEN,"},
+    {RXf_NOSCAN,          "NOSCAN,"},
+    {RXf_CHECK_ALL,       "CHECK_ALL,"},
+    {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
+    {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,"},
+};
+
 void
 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
 {
@@ -2131,10 +2162,60 @@ 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:
-       /* FIXME dumping
-           Perl_dump_indent(aTHX_ level, file, "  REGEXP = 0x%"UVxf"\n",
-                            PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
-       */
+       {
+           struct regexp * const r = (struct regexp *)SvANY(sv);
+           flags = RX_EXTFLAGS((REGEXP*)sv);
+           sv_setpv(d,"");
+           append_flags(d, flags, regexp_flags_names);
+           if (*(SvEND(d) - 1) == ',') {
+               SvCUR_set(d, SvCUR(d) - 1);
+               SvPVX(d)[SvCUR(d)] = '\0';
+           }
+           Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
+                               (UV)flags, SvPVX_const(d));
+           Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
+                               (UV)(r->intflags));
+           Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
+                               (UV)(r->nparens));
+           Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
+                               (UV)(r->lastparen));
+           Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
+                               (UV)(r->lastcloseparen));
+           Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
+                               (IV)(r->minlen));
+           Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
+                               (IV)(r->minlenret));
+           Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
+                               (UV)(r->gofs));
+           Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
+                               (UV)(r->pre_prefix));
+           Perl_dump_indent(aTHX_ level, file, "  SEEN_EVALS = %"UVuf"\n",
+                               (UV)(r->seen_evals));
+           Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
+                               (IV)(r->sublen));
+           if (r->subbeg)
+               Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
+                           PTR2UV(r->subbeg),
+                           pv_display(d, r->subbeg, r->sublen, 50, pvlim));
+           else
+               Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
+           Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf"\n",
+                               PTR2UV(r->engine));
+           Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
+                               PTR2UV(r->mother_re));
+           Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
+                               PTR2UV(r->paren_names));
+           Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
+                               PTR2UV(r->substrs));
+           Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
+                               PTR2UV(r->pprivate));
+           Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
+                               PTR2UV(r->offs));
+#ifdef PERL_OLD_COPY_ON_WRITE
+           Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
+                               PTR2UV(r->saved_copy));
+#endif
+       }
        break;
     }
     SvREFCNT_dec(d);
index ee0faa2..5c6b315 100644 (file)
@@ -332,7 +332,28 @@ do_test('reference to regexp',
     PV = $ADDR "\\(\\?\\^:tic\\)"
     CUR = 8
     LEN = 0
-    STASH = $ADDR\\t"Regexp"');
+    STASH = $ADDR\\t"Regexp"'
+. ($] < 5.013 ? '' :
+'
+    EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
+    INTFLAGS = 0x0
+    NPARENS = 0
+    LASTPAREN = 0
+    LASTCLOSEPAREN = 0
+    MINLEN = 3
+    MINLENRET = 3
+    GOFS = 0
+    PRE_PREFIX = 4
+    SEEN_EVALS = 0
+    SUBLEN = 0
+    SUBBEG = 0x0
+    ENGINE = $ADDR
+    MOTHER_RE = $ADDR
+    PAREN_NAMES = 0x0
+    SUBSTRS = $ADDR
+    PPRIVATE = $ADDR
+    OFFS = $ADDR'
+));
 } else {
 do_test('reference to regexp',
         qr(tic),