/* dump.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
static const char* const svtypenames[SVt_LAST] = {
"NULL",
+ "BIND",
"IV",
"NV",
"RV",
- "BIND",
"PV",
"PVIV",
"PVNV",
static const char* const svshorttypenames[SVt_LAST] = {
"UNDEF",
+ "BIND",
"IV",
"NV",
"RV",
- "BIND",
"PV",
"PVIV",
"PVNV",
an octal escape sequence, a special escape like C<\n> or a 3 or
more digit hex value.
+If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
+not a '\\'. This is because regexes very often contain backslashed
+sequences, whereas '%' is not a particularly common character in patterns.
+
Returns a pointer to the escaped text as held by dsv.
=cut
const STRLEN count, const STRLEN max,
STRLEN * const escaped, const U32 flags )
{
- char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
- char octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
+ char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
+ char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
+ char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
STRLEN wrote = 0; /* chars written so far */
STRLEN chsize = 0; /* size of data to be written */
STRLEN readsize = 1; /* size of data just read */
bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
const char *pv = str;
const char *end = pv + count; /* end of string */
+ octbuf[0] = esc;
if (!flags & PERL_PV_ESCAPE_NOCLEAR)
sv_setpvn(dsv, "", 0);
"%"UVxf, u);
else
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- "\\x{%"UVxf"}", u);
+ "%cx{%"UVxf"}", esc, u);
} else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
chsize = 1;
} else {
- if ( (c == dq) || (c == '\\') || !isPRINT(c) ) {
- chsize = 2;
+ if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
+ chsize = 2;
switch (c) {
- case '\\' : octbuf[1] = '\\'; break;
+
+ case '\\' : /* fallthrough */
+ case '%' : if ( c == esc ) {
+ octbuf[1] = esc;
+ } else {
+ chsize = 1;
+ }
+ break;
case '\v' : octbuf[1] = 'v'; break;
case '\t' : octbuf[1] = 't'; break;
case '\r' : octbuf[1] = 'r'; break;
case '\n' : octbuf[1] = 'n'; break;
case '\f' : octbuf[1] = 'f'; break;
- case '"' :
+ case '"' :
if ( dq == '"' )
octbuf[1] = '"';
else
chsize = 1;
- break;
+ break;
default:
if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- "\\%03o", c);
- else
+ "%c%03o", esc, c);
+ else
chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
- "\\%o", c);
+ "%c%o", esc, c);
}
} else {
- chsize=1;
+ chsize = 1;
}
- }
- if ( max && (wrote + chsize > max) ) {
- break;
+ }
+ if ( max && (wrote + chsize > max) ) {
+ break;
} else if (chsize > 1) {
- sv_catpvn(dsv, octbuf, chsize);
- wrote += chsize;
+ sv_catpvn(dsv, octbuf, chsize);
+ wrote += chsize;
} else {
Perl_sv_catpvf( aTHX_ dsv, "%c", c);
wrote++;
const STRLEN max, char const * const start_color, char const * const end_color,
const U32 flags )
{
- U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
+ U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
STRLEN escaped;
if ( dq == '"' )
(pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
else
Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
- if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
+ if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
- op_dump(pm->op_pmreplroot);
+ op_dump(pm->op_pmreplrootu.op_pmreplroot);
}
if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
SV * const tmpsv = pm_description(pm);
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->extflags & RXf_NOSCAN))
- sv_catpv(desc, ",SCANFIRST");
- if (regex->extflags & RXf_CHECK_ALL)
- sv_catpv(desc, ",ALL");
- }
- if (pmflags & PMf_SKIPWHITE)
- sv_catpv(desc, ",SKIPWHITE");
+#ifdef USE_ITHREADS
+ if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
+ sv_catpv(desc, ":USED");
+#else
+ if (pmflags & PMf_USED)
+ sv_catpv(desc, ":USED");
+#endif
+
+ if (regex) {
+ if (regex->extflags & RXf_TAINTED)
+ sv_catpv(desc, ",TAINTED");
+ if (regex->check_substr) {
+ if (!(regex->extflags & RXf_NOSCAN))
+ sv_catpv(desc, ",SCANFIRST");
+ if (regex->extflags & RXf_CHECK_ALL)
+ sv_catpv(desc, ",ALL");
+ }
+ if (regex->extflags & RXf_SKIPWHITE)
+ sv_catpv(desc, ",SKIPWHITE");
+ }
+
if (pmflags & PMf_CONST)
sv_catpv(desc, ",CONST");
if (pmflags & PMf_KEEP)
sequence_tail(cLOOPo->op_lastop);
break;
- case OP_QR:
- case OP_MATCH:
case OP_SUBST:
hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
- sequence_tail(cPMOPo->op_pmreplstart);
+ sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
break;
+ case OP_QR:
+ case OP_MATCH:
case OP_HELEM:
break;
#ifdef DUMPADDR
Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
#endif
- if (o->op_flags || o->op_latefree || o->op_latefreed) {
+ if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
SV * const tmpsv = newSVpvs("");
switch (o->op_flags & OPf_WANT) {
case OPf_WANT_VOID:
sv_catpv(tmpsv, ",LATEFREE");
if (o->op_latefreed)
sv_catpv(tmpsv, ",LATEFREED");
+ if (o->op_attached)
+ sv_catpv(tmpsv, ",ATTACHED");
Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
SvREFCNT_dec(tmpsv);
}
if (o->op_private & OPpSORT_REVERSE)
sv_catpv(tmpsv, ",REVERSE");
}
- else if (optype == OP_THREADSV) {
- if (o->op_private & OPpDONE_SVREF)
- sv_catpv(tmpsv, ",SVREF");
- }
else if (optype == OP_OPEN || optype == OP_BACKTICK) {
if (o->op_private & OPpOPEN_IN_RAW)
sv_catpv(tmpsv, ",IN_RAW");
ENTER;
SAVEFREESV(tmpsv);
#ifdef PERL_MAD
- /* FIXME - it this making unwarranted assumptions about the
+ /* FIXME - is this making unwarranted assumptions about the
UTF-8 cleanliness of the dump file handle? */
SvUTF8_on(tmpsv);
#endif
{ PERL_MAGIC_sv, "sv(\\0)" },
{ PERL_MAGIC_arylen, "arylen(#)" },
{ PERL_MAGIC_rhash, "rhash(%)" },
- { PERL_MAGIC_regdata_names, "regdata_names(+)" },
{ PERL_MAGIC_pos, "pos(.)" },
{ PERL_MAGIC_symtab, "symtab(:)" },
{ PERL_MAGIC_backref, "backref(<)" },
Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
}
if (mg->mg_obj) {
- Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
- if (mg->mg_flags & MGf_REFCOUNTED)
+ Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
+ PTR2UV(mg->mg_obj));
+ if (mg->mg_type == PERL_MAGIC_qr) {
+ regexp *re=(regexp *)mg->mg_obj;
+ SV *dsv= sv_newmortal();
+ const char * const s = pv_pretty(dsv, re->wrapped, re->wraplen,
+ 60, NULL, NULL,
+ ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELIPSES |
+ ((re->extflags & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0))
+ );
+ Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
+ Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
+ (IV)re->refcnt);
+ }
+ if (mg->mg_flags & MGf_REFCOUNTED)
do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
}
if (mg->mg_len)
if (flags & SVf_OOK) sv_catpv(d, "OOK,");
if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
+ if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
if (flags & SVp_POK) sv_catpv(d, "pPOK,");
- if (flags & SVp_SCREAM && type != SVt_PVHV)
+ if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
+ if (SvPCS_IMPORTED(sv))
+ sv_catpv(d, "PCS_IMPORTED,");
+ else
sv_catpv(d, "SCREAM,");
+ }
switch (type) {
case SVt_PVCV:
case SVt_PVMG:
if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
- if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
- break;
+ /* FALL THROUGH */
case SVt_PVNV:
if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
goto evaled_or_uv;
#endif
PerlIO_putc(file, '\n');
}
- if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
- && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
- || type == SVt_NV) {
+ if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
+ Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
+ (UV) COP_SEQ_RANGE_LOW(sv));
+ Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
+ (UV) COP_SEQ_RANGE_HIGH(sv));
+ } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
+ && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)
+ && !SvVALID(sv))
+ || type == SVt_NV) {
STORE_NUMERIC_LOCAL_SET_STANDARD();
/* %Vg doesn't work? --jhi */
#ifdef USE_LONG_DOUBLE
Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
}
if (type >= SVt_PVMG) {
- if (SvMAGIC(sv))
- do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
+ if (type == SVt_PVMG && SvPAD_OUR(sv)) {
+ HV *ost = SvOURSTASH(sv);
+ if (ost)
+ do_hv_dump(level, file, " OURSTASH", ost);
+ } else {
+ if (SvMAGIC(sv))
+ do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
+ }
if (SvSTASH(sv))
do_hv_dump(level, file, " STASH", SvSTASH(sv));
}
do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
dumpops, pvlim);
}
+ if (SvVALID(sv)) {
+ Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
+ Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
+ Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
+ Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
+ }
if (!isGV_with_GP(sv))
break;
Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
if (cGVOPo_gv) {
SV * const sv = newSV(0);
#ifdef PERL_MAD
- /* FIXME - it this making unwarranted assumptions about the
+ /* FIXME - is this making unwarranted assumptions about the
UTF-8 cleanliness of the dump file handle? */
SvUTF8_on(sv);
#endif
* XML variants of most of the above routines
*/
-STATIC
-void
+STATIC void
S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
{
va_list args;
}
level--;
- if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
+ if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
Perl_xmldump_indent(aTHX_ level, file, ">\n");
Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
- do_op_xmldump(level+2, file, pm->op_pmreplroot);
+ do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
}
if (o->op_private & OPpSORT_REVERSE)
sv_catpv(tmpsv, ",REVERSE");
}
- else if (o->op_type == OP_THREADSV) {
- if (o->op_private & OPpDONE_SVREF)
- sv_catpv(tmpsv, ",SVREF");
- }
else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
if (o->op_private & OPpOPEN_IN_RAW)
sv_catpv(tmpsv, ",IN_RAW");
projects / p5sagit/p5-mst-13.2.git / blobdiff