/* 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
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
#include "proto.h"
+static const char* const svtypenames[SVt_LAST] = {
+ "NULL",
+ "BIND",
+ "IV",
+ "NV",
+ "PV",
+ "PVIV",
+ "PVNV",
+ "PVMG",
+ "REGEXP",
+ "PVGV",
+ "PVLV",
+ "PVAV",
+ "PVHV",
+ "PVCV",
+ "PVFM",
+ "PVIO"
+};
+
+
+static const char* const svshorttypenames[SVt_LAST] = {
+ "UNDEF",
+ "BIND",
+ "IV",
+ "NV",
+ "PV",
+ "PVIV",
+ "PVNV",
+ "PVMG",
+ "REGEXP",
+ "GV",
+ "PVLV",
+ "AV",
+ "HV",
+ "CV",
+ "FM",
+ "IO"
+};
+
#define Sequence PL_op_sequence
void
Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
{
va_list args;
+ PERL_ARGS_ASSERT_DUMP_INDENT;
va_start(args, pat);
dump_vindent(level, file, pat, &args);
va_end(args);
Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
{
dVAR;
+ PERL_ARGS_ASSERT_DUMP_VINDENT;
PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
PerlIO_vprintf(file, pat, *args);
}
dVAR;
I32 i;
+ PERL_ARGS_ASSERT_DUMP_PACKSUBS;
+
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
const HE *entry;
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
- const GV *gv = (GV*)HeVAL(entry);
- const HV *hv;
+ const GV * const gv = (GV*)HeVAL(entry);
if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
continue;
if (GvCVu(gv))
dump_sub(gv);
if (GvFORM(gv))
dump_form(gv);
- if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
- && (hv = GvHV(gv)) && hv != PL_defstash)
- dump_packsubs(hv); /* nested package */
+ if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
+ const HV * const hv = GvHV(gv);
+ if (hv && (hv != PL_defstash))
+ dump_packsubs(hv); /* nested package */
+ }
}
}
}
{
SV * const sv = sv_newmortal();
+ PERL_ARGS_ASSERT_DUMP_SUB;
+
gv_fullname3(sv, gv, NULL);
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
if (CvISXSUB(GvCV(gv)))
{
SV * const sv = sv_newmortal();
+ PERL_ARGS_ASSERT_DUMP_FORM;
+
gv_fullname3(sv, gv, NULL);
Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
if (CvROOT(GvFORM(gv)))
/*
-=for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const U8 const *str\
- |const STRLEN count|const STRLEN max
- |STRLEN const *escaped, const U32 flags
+=for apidoc pv_escape
Escapes at most the first "count" chars of pv and puts the results into
dsv such that the size of the escaped string will not exceed "max" chars
Normally the SV will be cleared before the escaped string is prepared,
but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
-If PERL_PV_ESCAPE_UNI is set then the input string is treated as unicode,
+If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
-using C<is_utf8_string()> to determine if it is unicode.
+using C<is_utf8_string()> to determine if it is Unicode.
If PERL_PV_ESCAPE_ALL is set then all input chars will be output
using C<\x01F1> style escapes, otherwise only chars above 255 will be
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
*/
#define PV_ESCAPE_OCTBUFSIZE 32
+
char *
-Perl_pv_escape( pTHX_ SV *dsv, U8 const * const str,
+Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
const STRLEN count, const STRLEN max,
STRLEN * const escaped, const U32 flags )
{
- U8 dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
- U8 octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
+ const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
+ const 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 U8 *pv = str;
- const U8 *end = pv + count; /* end of string */
+ bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
+ const char *pv = str;
+ const char * const end = pv + count; /* end of string */
+ octbuf[0] = esc;
+
+ PERL_ARGS_ASSERT_PV_ESCAPE;
- if (!flags & PERL_PV_ESCAPE_NOCLEAR)
- sv_setpvn(dsv, "", 0);
+ if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
+ /* This won't alter the UTF-8 flag */
+ sv_setpvs(dsv, "");
+ }
- if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string(pv, count))
+ if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
isuni = 1;
for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
- const UV u= (isuni) ? utf8_to_uvchr(pv, &readsize) : *pv;
+ const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
const U8 c = (U8)u & 0xFF;
if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
"%"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(*(pv+readsize)) )
+ 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 {
+ /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
+ 128-255 can be appended raw to the dsv. If dsv happens to be
+ UTF-8 then we need catpvf to upgrade them for us.
+ Or add a new API call sv_catpvc(). Think about that name, and
+ how to keep it clear that it's unlike the s of catpvs, which is
+ really an array octets, not a string. */
Perl_sv_catpvf( aTHX_ dsv, "%c", c);
wrote++;
}
return SvPVX(dsv);
}
/*
-=for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const U8 const *str\
- |const STRLEN count|const STRLEN max\
- |const U8 const *start_color| const U8 const *end_color\
- |const U32 flags
+=for apidoc pv_pretty
Converts a string into something presentable, handling escaping via
-pv_escape() and supporting quoting and elipses.
+pv_escape() and supporting quoting and ellipses.
If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
double quoted with any double quotes in the string escaped. Otherwise
if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
angle brackets.
-If the PERL_PV_PRETTY_ELIPSES flag is set and not all characters in
-string were output then an elipses C<...> will be appended to the
+If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
+string were output then an ellipsis C<...> will be appended to the
string. Note that this happens AFTER it has been quoted.
If start_color is non-null then it will be inserted after the opening
quote (if there is one) but before the escaped text. If end_color
is non-null then it will be inserted after the escaped text but before
-any quotes or elipses.
+any quotes or ellipses.
Returns a pointer to the prettified text as held by dsv.
*/
char *
-Perl_pv_pretty( pTHX_ SV *dsv, U8 const * const str, const STRLEN count,
- const STRLEN max, U8 const * const start_color, U8 const * const end_color,
+Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
+ const STRLEN max, char const * const start_color, char const * const end_color,
const U32 flags )
{
- U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
+ const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
STRLEN escaped;
-
+
+ PERL_ARGS_ASSERT_PV_PRETTY;
+
+ if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
+ /* This won't alter the UTF-8 flag */
+ sv_setpvs(dsv, "");
+ }
+
if ( dq == '"' )
- sv_setpvn(dsv, "\"", 1);
+ sv_catpvs(dsv, "\"");
else if ( flags & PERL_PV_PRETTY_LTGT )
- sv_setpvn(dsv, "<", 1);
- else
- sv_setpvn(dsv, "", 0);
+ sv_catpvs(dsv, "<");
if ( start_color != NULL )
- Perl_sv_catpvf( aTHX_ dsv, "%s", start_color);
+ sv_catpv(dsv, start_color);
pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
if ( end_color != NULL )
- Perl_sv_catpvf( aTHX_ dsv, "%s", end_color);
+ sv_catpv(dsv, end_color);
if ( dq == '"' )
- sv_catpvn( dsv, "\"", 1 );
+ sv_catpvs( dsv, "\"");
else if ( flags & PERL_PV_PRETTY_LTGT )
- sv_catpvn( dsv, ">", 1);
+ sv_catpvs(dsv, ">");
- if ( (flags & PERL_PV_PRETTY_ELIPSES) && ( escaped < count ) )
- sv_catpvn( dsv, "...", 3 );
+ if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
+ sv_catpvs(dsv, "...");
return SvPVX(dsv);
}
/*
=for apidoc pv_display
- char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
- STRLEN pvlim, U32 flags)
-
Similar to
pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
char *
Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
{
- pv_pretty( dsv, pv, cur, pvlim, 0, 0, PERL_PV_PRETTY_DUMP);
+ PERL_ARGS_ASSERT_PV_DISPLAY;
+
+ pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
if (len > cur && pv[cur] == '\0')
- sv_catpvn( dsv, "\\0", 2 );
+ sv_catpvs( dsv, "\\0");
return SvPVX(dsv);
}
dVAR;
SV * const t = sv_newmortal();
int unref = 0;
+ U32 type;
- sv_setpvn(t, "", 0);
+ sv_setpvs(t, "");
retry:
if (!sv) {
sv_catpv(t, "VOID");
sv = (SV*)SvRV(sv);
goto retry;
}
- switch (SvTYPE(sv)) {
- default:
- sv_catpv(t, "FREED");
+ type = SvTYPE(sv);
+ if (type == SVt_PVCV) {
+ Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
goto finish;
+ } else if (type < SVt_LAST) {
+ sv_catpv(t, svshorttypenames[type]);
- case SVt_NULL:
- sv_catpv(t, "UNDEF");
- goto finish;
- case SVt_IV:
- sv_catpv(t, "IV");
- break;
- case SVt_NV:
- sv_catpv(t, "NV");
- break;
- case SVt_RV:
- sv_catpv(t, "RV");
- break;
- case SVt_PV:
- sv_catpv(t, "PV");
- break;
- case SVt_PVIV:
- sv_catpv(t, "PVIV");
- break;
- case SVt_PVNV:
- sv_catpv(t, "PVNV");
- break;
- case SVt_PVMG:
- sv_catpv(t, "PVMG");
- break;
- case SVt_PVLV:
- sv_catpv(t, "PVLV");
- break;
- case SVt_PVAV:
- sv_catpv(t, "AV");
- break;
- case SVt_PVHV:
- sv_catpv(t, "HV");
- break;
- case SVt_PVCV:
- if (CvGV(sv))
- Perl_sv_catpvf(aTHX_ t, "CV(%s)", GvNAME(CvGV(sv)));
- else
- sv_catpv(t, "CV()");
+ if (type == SVt_NULL)
+ goto finish;
+ } else {
+ sv_catpv(t, "FREED");
goto finish;
- case SVt_PVGV:
- sv_catpv(t, "GV");
- break;
- case SVt_PVBM:
- sv_catpv(t, "BM");
- break;
- case SVt_PVFM:
- sv_catpv(t, "FM");
- break;
- case SVt_PVIO:
- sv_catpv(t, "IO");
- break;
}
if (SvPOKp(sv)) {
Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
if (SvUTF8(sv))
Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
- sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv),
+ sv_uni_display(tmp, sv, 6 * SvCUR(sv),
UNI_DISPLAY_QQ));
SvREFCNT_dec(tmp);
}
sv_catpv(t, "()");
finish:
- if (unref) {
- while (unref--)
- sv_catpv(t, ")");
- }
+ while (unref--)
+ sv_catpv(t, ")");
return SvPV_nolen(t);
}
{
char ch;
+ PERL_ARGS_ASSERT_DO_PMOP_DUMP;
+
if (!pm) {
Perl_dump_indent(aTHX_ level, file, "{}\n");
return;
ch = '/';
if (PM_GETRE(pm))
Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
- ch, PM_GETRE(pm)->precomp, ch,
+ ch, RX_PRECOMP(PM_GETRE(pm)), ch,
(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)) {
+ if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
SV * const tmpsv = pm_description(pm);
Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
SvREFCNT_dec(tmpsv);
S_pm_description(pTHX_ const PMOP *pm)
{
SV * const desc = newSVpvs("");
- const REGEXP * regex = PM_GETRE(pm);
+ const REGEXP * const 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");
+ PERL_ARGS_ASSERT_PM_DESCRIPTION;
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");
+#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 (RX_EXTFLAGS(regex) & RXf_TAINTED)
+ sv_catpv(desc, ",TAINTED");
+ if (RX_CHECK_SUBSTR(regex)) {
+ if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
+ sv_catpv(desc, ",SCANFIRST");
+ if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
+ sv_catpv(desc, ",ALL");
+ }
+ if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
+ sv_catpv(desc, ",SKIPWHITE");
+ }
+
if (pmflags & PMf_CONST)
sv_catpv(desc, ",CONST");
if (pmflags & PMf_KEEP)
switch (o->op_type) {
case OP_STUB:
if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
- hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
+ (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
break;
}
goto nothin;
nothin:
if (oldop && o->op_next)
continue;
- hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
+ (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
break;
case OP_MAPWHILE:
case OP_DORASSIGN:
case OP_COND_EXPR:
case OP_RANGE:
- hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
+ (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
sequence_tail(cLOGOPo->op_other);
break;
case OP_ENTERLOOP:
case OP_ENTERITER:
- hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
+ (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
sequence_tail(cLOOPo->op_redoop);
sequence_tail(cLOOPo->op_nextop);
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);
+ (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
+ sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
break;
+ case OP_QR:
+ case OP_MATCH:
case OP_HELEM:
break;
default:
- hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
+ (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
break;
}
oldop = o;
UV seq;
const OPCODE optype = o->op_type;
+ PERL_ARGS_ASSERT_DO_OP_DUMP;
+
sequence(o);
Perl_dump_indent(aTHX_ level, file, "{\n");
level++;
seq = sequence_num(o);
if (seq)
- PerlIO_printf(file, "%-4"UVf, seq);
+ PerlIO_printf(file, "%-4"UVuf, seq);
else
PerlIO_printf(file, " ");
PerlIO_printf(file,
"%*sTYPE = %s ===> ",
(int)(PL_dumpindent*level-4), "", OP_NAME(o));
if (o->op_next)
- PerlIO_printf(file, seq ? "%"UVf"\n" : "(%"UVf")\n",
+ PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
sequence_num(o->op_next));
else
PerlIO_printf(file, "DONE\n");
Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
if (o->op_targ == OP_NEXTSTATE) {
if (CopLINE(cCOPo))
- Perl_dump_indent(aTHX_ level, file, "LINE = %"UVf"\n",
+ Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
(UV)CopLINE(cCOPo));
if (CopSTASHPV(cCOPo))
Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
CopSTASHPV(cCOPo));
- if (cCOPo->cop_label)
+ if (CopLABEL(cCOPo))
Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
- cCOPo->cop_label);
+ CopLABEL(cCOPo));
}
}
else
#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) {
+ 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, ",MOD");
if (o->op_flags & OPf_SPECIAL)
sv_catpv(tmpsv, ",SPECIAL");
+ if (o->op_latefree)
+ 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");
sv_catpv(tmpsv, ",HUSH_VMSISH");
}
else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
- if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
+ if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
sv_catpv(tmpsv, ",FT_ACCESS");
if (o->op_private & OPpFT_STACKED)
sv_catpv(tmpsv, ",FT_STACKED");
#ifdef PERL_MAD
if (PL_madskills && o->op_madprop) {
- SV * const tmpsv = newSVpvn("", 0);
+ SV * const tmpsv = newSVpvs("");
MADPROP* mp = o->op_madprop;
Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
level++;
while (mp) {
- char tmp = mp->mad_key;
- sv_setpvn(tmpsv,"'",1);
+ const char tmp = mp->mad_key;
+ sv_setpvs(tmpsv,"'");
if (tmp)
sv_catpvn(tmpsv, &tmp, 1);
sv_catpv(tmpsv, "'=");
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
#endif
break;
case OP_CONST:
+ case OP_HINTSEVAL:
case OP_METHOD_NAMED:
#ifndef USE_ITHREADS
/* with ITHREADS, consts are stored in the pad, and the right pad
Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
#endif
break;
- case OP_SETSTATE:
case OP_NEXTSTATE:
case OP_DBSTATE:
if (CopLINE(cCOPo))
- Perl_dump_indent(aTHX_ level, file, "LINE = %"UVf"\n",
+ Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
(UV)CopLINE(cCOPo));
if (CopSTASHPV(cCOPo))
Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
CopSTASHPV(cCOPo));
- if (cCOPo->cop_label)
+ if (CopLABEL(cCOPo))
Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
- cCOPo->cop_label);
+ CopLABEL(cCOPo));
break;
case OP_ENTERLOOP:
Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
if (cLOOPo->op_redoop)
- PerlIO_printf(file, "%"UVf"\n", sequence_num(cLOOPo->op_redoop));
+ PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
else
PerlIO_printf(file, "DONE\n");
Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
if (cLOOPo->op_nextop)
- PerlIO_printf(file, "%"UVf"\n", sequence_num(cLOOPo->op_nextop));
+ PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
else
PerlIO_printf(file, "DONE\n");
Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
if (cLOOPo->op_lastop)
- PerlIO_printf(file, "%"UVf"\n", sequence_num(cLOOPo->op_lastop));
+ PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
else
PerlIO_printf(file, "DONE\n");
break;
case OP_AND:
Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
if (cLOGOPo->op_other)
- PerlIO_printf(file, "%"UVf"\n", sequence_num(cLOGOPo->op_other));
+ PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
else
PerlIO_printf(file, "DONE\n");
break;
void
Perl_op_dump(pTHX_ const OP *o)
{
+ PERL_ARGS_ASSERT_OP_DUMP;
do_op_dump(0, Perl_debug_log, o);
}
{
SV *sv;
+ PERL_ARGS_ASSERT_GV_DUMP;
+
if (!gv) {
PerlIO_printf(Perl_debug_log, "{}\n");
return;
{ PERL_MAGIC_isaelem, "isaelem(i)" },
{ PERL_MAGIC_nkeys, "nkeys(k)" },
{ PERL_MAGIC_dbline, "dbline(l)" },
- { PERL_MAGIC_mutex, "mutex(m)" },
{ PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
{ PERL_MAGIC_collxfrm, "collxfrm(o)" },
{ PERL_MAGIC_tiedelem, "tiedelem(p)" },
{ PERL_MAGIC_qr, "qr(r)" },
{ PERL_MAGIC_sigelem, "sigelem(s)" },
{ PERL_MAGIC_taint, "taint(t)" },
- { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
+ { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
{ PERL_MAGIC_vec, "vec(v)" },
{ PERL_MAGIC_vstring, "vstring(V)" },
{ PERL_MAGIC_utf8, "utf8(w)" },
void
Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
{
+ PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
+
for (; mg; mg = mg->mg_moremagic) {
Perl_dump_indent(aTHX_ level, file,
" MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
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* const re = (REGEXP *)mg->mg_obj;
+ SV * const dsv = sv_newmortal();
+ const char * const s
+ = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
+ 60, NULL, NULL,
+ ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
+ (RX_UTF8(re) ? 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)RX_REFCNT(re));
+ }
+ 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)
Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
if (mg->mg_len >= 0) {
if (mg->mg_type != PERL_MAGIC_utf8) {
- SV *sv = newSVpvs("");
+ SV * const sv = newSVpvs("");
PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
SvREFCNT_dec(sv);
}
PerlIO_putc(file, '\n');
}
if (mg->mg_type == PERL_MAGIC_utf8) {
- STRLEN *cache = (STRLEN *) mg->mg_ptr;
+ const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
if (cache) {
IV i;
for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
{
const char *hvname;
+
+ PERL_ARGS_ASSERT_DO_HV_DUMP;
+
Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
if (sv && (hvname = HvNAME_get(sv)))
PerlIO_printf(file, "\t\"%s\"\n", hvname);
void
Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
{
+ PERL_ARGS_ASSERT_DO_GV_DUMP;
+
Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
if (sv && GvNAME(sv))
PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
void
Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
{
+ PERL_ARGS_ASSERT_DO_GVGV_DUMP;
+
Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
if (sv && GvNAME(sv)) {
const char *hvname;
U32 flags;
U32 type;
+ PERL_ARGS_ASSERT_DO_SV_DUMP;
+
if (!sv) {
Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
return;
(int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
(int)(PL_dumpindent*level), "");
- if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
- if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
- if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
+ if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
+ if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
+ }
+ if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
+ if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
+ if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
+ }
if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
if (flags & SVs_GMG) sv_catpv(d, "GMG,");
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:
if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
- if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
break;
case SVt_PVHV:
if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
}
- if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
- if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
- if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
sv_catpv(d, "IMPORT");
if (GvIMPORTED(sv) == GVf_IMPORTED)
sv_catpv(d, " ),");
}
}
+ if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
+ if (SvVALID(sv)) sv_catpv(d, "VALID,");
/* FALL THROUGH */
default:
+ evaled_or_uv:
if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
break;
- case SVt_PVBM:
- if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
- if (SvVALID(sv)) sv_catpv(d, "VALID,");
- break;
case SVt_PVMG:
if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
- break;
+ if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
+ /* FALL THROUGH */
+ case SVt_PVNV:
+ if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
+ goto evaled_or_uv;
case SVt_PVAV:
break;
}
sv->sv_debug_cloned ? " (cloned)" : "");
#endif
Perl_dump_indent(aTHX_ level, file, "SV = ");
- switch (type) {
- case SVt_NULL:
- PerlIO_printf(file, "NULL%s\n", s);
- SvREFCNT_dec(d);
- return;
- case SVt_IV:
- PerlIO_printf(file, "IV%s\n", s);
- break;
- case SVt_NV:
- PerlIO_printf(file, "NV%s\n", s);
- break;
- case SVt_RV:
- PerlIO_printf(file, "RV%s\n", s);
- break;
- case SVt_PV:
- PerlIO_printf(file, "PV%s\n", s);
- break;
- case SVt_PVIV:
- PerlIO_printf(file, "PVIV%s\n", s);
- break;
- case SVt_PVNV:
- PerlIO_printf(file, "PVNV%s\n", s);
- break;
- case SVt_PVBM:
- PerlIO_printf(file, "PVBM%s\n", s);
- break;
- case SVt_PVMG:
- PerlIO_printf(file, "PVMG%s\n", s);
- break;
- case SVt_PVLV:
- PerlIO_printf(file, "PVLV%s\n", s);
- break;
- case SVt_PVAV:
- PerlIO_printf(file, "PVAV%s\n", s);
- break;
- case SVt_PVHV:
- PerlIO_printf(file, "PVHV%s\n", s);
- break;
- case SVt_PVCV:
- PerlIO_printf(file, "PVCV%s\n", s);
- break;
- case SVt_PVGV:
- PerlIO_printf(file, "PVGV%s\n", s);
- break;
- case SVt_PVFM:
- PerlIO_printf(file, "PVFM%s\n", s);
- break;
- case SVt_PVIO:
- PerlIO_printf(file, "PVIO%s\n", s);
- break;
- default:
+ if (type < SVt_LAST) {
+ PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
+
+ if (type == SVt_NULL) {
+ SvREFCNT_dec(d);
+ return;
+ }
+ } else {
PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
SvREFCNT_dec(d);
return;
}
if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
- && type != SVt_PVCV && !isGV_with_GP(sv))
- || type == SVt_IV) {
+ && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM)
+ || (type == SVt_IV && !SvROK(sv))) {
if (SvIsUV(sv)
#ifdef PERL_OLD_COPY_ON_WRITE
|| SvIsCOW(sv)
Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
else
Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
- if (SvOOK(sv))
- PerlIO_printf(file, " (OFFSET)");
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW_shared_hash(sv))
PerlIO_printf(file, " (HASH)");
#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 && type != SVt_REGEXP
+ && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
+ || type == SVt_NV) {
STORE_NUMERIC_LOCAL_SET_STANDARD();
/* %Vg doesn't work? --jhi */
#ifdef USE_LONG_DOUBLE
SvREFCNT_dec(d);
return;
}
- if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
+ if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
if (SvPVX_const(sv)) {
+ STRLEN delta;
+ if (SvOOK(sv)) {
+ SvOOK_offset(sv, delta);
+ Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
+ (UV) delta);
+ } else {
+ delta = 0;
+ }
Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
- if (SvOOK(sv))
- PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
+ if (SvOOK(sv)) {
+ PerlIO_printf(file, "( %s . ) ",
+ pv_display(d, SvPVX_const(sv) - delta, delta, 0,
+ pvlim));
+ }
PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
- if (SvUTF8(sv)) /* the 8? \x{....} */
- PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
+ 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));
else
Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
}
+ if (type == SVt_REGEXP) {
+ /* FIXME dumping
+ Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
+ PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
+ */
+ }
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 * const 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));
}
Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
- sv_setpvn(d, "", 0);
+ sv_setpvs(d, "");
if (AvREAL(sv)) sv_catpv(d, ",REAL");
if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
SvCUR(d) ? SvPVX_const(d) + 1 : "");
- if (nest < maxnest && av_len((AV*)sv) >= 0) {
+ if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
int count;
- for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
- SV** elt = av_fetch((AV*)sv,count,0);
+ for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
+ SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
if (elt)
Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
}
if (SvOOK(sv)) {
- const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
+ const AV * const backrefs
+ = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
if (backrefs) {
Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
PTR2UV(backrefs));
}
if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
HE *he;
- HV * const hv = (HV*)sv;
+ HV * const hv = MUTABLE_HV(sv);
int count = maxnest - nest;
hv_iterinit(hv);
while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
&& count--) {
- SV *elt, *keysv;
- const char *keypv;
STRLEN len;
const U32 hash = HeHASH(he);
+ SV * const keysv = hv_iterkeysv(he);
+ const char * const keypv = SvPV_const(keysv, len);
+ SV * const elt = hv_iterval(hv, he);
- keysv = hv_iterkeysv(he);
- keypv = SvPV_const(keysv, len);
- elt = hv_iterval(hv, he);
Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
if (SvUTF8(keysv))
- PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
+ PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
if (HeKREHASH(he))
PerlIO_printf(file, "[REHASH] ");
PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
do_op_dump(level+1, file, CvROOT(sv));
}
} else {
- SV *constant = cv_const_sv((CV *)sv);
+ SV * const constant = cv_const_sv((const CV *)sv);
Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
}
do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
- Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
+ if (type == SVt_PVCV)
+ 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));
if (type == SVt_PVFM)
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));
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));
else
Perl_sv_dump(pTHX_ SV *sv)
{
dVAR;
- do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
+
+ PERL_ARGS_ASSERT_SV_DUMP;
+
+ if (SvROK(sv))
+ do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
+ else
+ do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
}
int
Perl_debop(pTHX_ const OP *o)
{
dVAR;
+
+ PERL_ARGS_ASSERT_DEBOP;
+
if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
return 0;
Perl_deb(aTHX_ "%s", OP_NAME(o));
switch (o->op_type) {
case OP_CONST:
- PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
+ case OP_HINTSEVAL:
+ /* With ITHREADS, consts are stored in the pad, and the right pad
+ * may not be active here, so check.
+ * Looks like only during compiling the pads are illegal.
+ */
+#ifdef USE_ITHREADS
+ if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
+#endif
+ PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
break;
case OP_GVSV:
case OP_GV:
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
SV *sv;
if (cv) {
AV * const padlist = CvPADLIST(cv);
- AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
+ AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
sv = *av_fetch(comppad, o->op_targ, FALSE);
} else
sv = NULL;
}
STATIC CV*
-S_deb_curcv(pTHX_ I32 ix)
+S_deb_curcv(pTHX_ const I32 ix)
{
dVAR;
const PERL_CONTEXT * const cx = &cxstack[ix];
Perl_watch(pTHX_ char **addr)
{
dVAR;
+
+ PERL_ARGS_ASSERT_WATCH;
+
PL_watchaddr = addr;
PL_watchok = *addr;
PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
S_debprof(pTHX_ const OP *o)
{
dVAR;
- if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
+
+ PERL_ARGS_ASSERT_DEBPROF;
+
+ if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
return;
if (!PL_profiledata)
Newxz(PL_profiledata, MAXO, U32);
* 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;
+
+ PERL_ARGS_ASSERT_XMLDUMP_ATTR;
+
PerlIO_printf(file, "\n ");
va_start(args, pat);
xmldump_vindent(level, file, pat, &args);
Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
{
va_list args;
+ PERL_ARGS_ASSERT_XMLDUMP_INDENT;
va_start(args, pat);
xmldump_vindent(level, file, pat, &args);
va_end(args);
void
Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
{
+ PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
+
PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
PerlIO_vprintf(file, pat, *args);
}
I32 i;
HE *entry;
+ PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
+
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
void
Perl_xmldump_sub(pTHX_ const GV *gv)
{
- SV *sv = sv_newmortal();
+ SV * const sv = sv_newmortal();
+
+ PERL_ARGS_ASSERT_XMLDUMP_SUB;
- gv_fullname3(sv, gv, Nullch);
+ gv_fullname3(sv, gv, NULL);
Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
if (CvXSUB(GvCV(gv)))
Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
void
Perl_xmldump_form(pTHX_ const GV *gv)
{
- SV *sv = sv_newmortal();
+ SV * const sv = sv_newmortal();
+
+ PERL_ARGS_ASSERT_XMLDUMP_FORM;
- gv_fullname3(sv, gv, Nullch);
+ gv_fullname3(sv, gv, NULL);
Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
if (CvROOT(GvFORM(gv)))
op_xmldump(CvROOT(GvFORM(gv)));
char *
Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
{
+ PERL_ARGS_ASSERT_SV_CATXMLSV;
return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
}
char *
-Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
+Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
{
unsigned int c;
- char *e = pv + len;
- char *start = pv;
+ const char * const e = pv + len;
+ const char * const start = pv;
STRLEN dsvcur;
STRLEN cl;
- sv_catpvn(dsv,"",0);
+ PERL_ARGS_ASSERT_SV_CATXMLPVN;
+
+ sv_catpvs(dsv,"");
dsvcur = SvCUR(dsv); /* in case we have to restart */
retry:
Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
break;
case '<':
- Perl_sv_catpvf(aTHX_ dsv, "<");
+ sv_catpvs(dsv, "<");
break;
case '>':
- Perl_sv_catpvf(aTHX_ dsv, ">");
+ sv_catpvs(dsv, ">");
break;
case '&':
- Perl_sv_catpvf(aTHX_ dsv, "&");
+ sv_catpvs(dsv, "&");
break;
case '"':
- Perl_sv_catpvf(aTHX_ dsv, """);
+ sv_catpvs(dsv, """);
break;
default:
if (c < 0xD800) {
Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
}
else {
- Perl_sv_catpvf(aTHX_ dsv, "%c", c);
+ const char string = (char) c;
+ sv_catpvn(dsv, &string, 1);
}
break;
}
char *
Perl_sv_xmlpeek(pTHX_ SV *sv)
{
- SV *t = sv_newmortal();
+ SV * const t = sv_newmortal();
STRLEN n_a;
int unref = 0;
+ PERL_ARGS_ASSERT_SV_XMLPEEK;
+
sv_utf8_upgrade(t);
- sv_setpvn(t, "", 0);
+ sv_setpvs(t, "");
/* retry: */
if (!sv) {
sv_catpv(t, "VOID=\"\"");
case SVt_NV:
sv_catpv(t, " NV=\"");
break;
- case SVt_RV:
- sv_catpv(t, " RV=\"");
- break;
case SVt_PV:
sv_catpv(t, " PV=\"");
break;
case SVt_PVGV:
sv_catpv(t, " GV=\"");
break;
- case SVt_PVBM:
- sv_catpv(t, " BM=\"");
+ case SVt_BIND:
+ sv_catpv(t, " BIND=\"");
+ break;
+ case SVt_REGEXP:
+ sv_catpv(t, " ORANGE=\"");
break;
case SVt_PVFM:
sv_catpv(t, " FM=\"");
sv_catpv(t, "\"");
finish:
- if (unref) {
- while (unref--)
- sv_catpv(t, ")");
- }
+ while (unref--)
+ sv_catpv(t, ")");
return SvPV(t, n_a);
}
void
Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
{
+ PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
+
if (!pm) {
Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
return;
Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
level++;
if (PM_GETRE(pm)) {
- char *s = PM_GETRE(pm)->precomp;
- SV *tmpsv = newSV(0);
- SvUTF8_on(tmpsv);
- sv_catxmlpvn(tmpsv, s, strlen(s), 1);
+ REGEXP *const r = PM_GETRE(pm);
+ SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
+ sv_catxmlsv(tmpsv, (SV*)r);
Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
SvPVX(tmpsv));
SvREFCNT_dec(tmpsv);
}
else
Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
- if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
+ if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
SV * const tmpsv = pm_description(pm);
Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
SvREFCNT_dec(tmpsv);
}
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");
}
{
UV seq;
int contents = 0;
+
+ PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
+
if (!o)
return;
sequence(o);
if (o->op_targ == OP_NEXTSTATE)
{
if (CopLINE(cCOPo))
- PerlIO_printf(file, " line=\"%"UVf"\"",
+ PerlIO_printf(file, " line=\"%"UVuf"\"",
(UV)CopLINE(cCOPo));
if (CopSTASHPV(cCOPo))
PerlIO_printf(file, " package=\"%s\"",
CopSTASHPV(cCOPo));
- if (cCOPo->cop_label)
+ if (CopLABEL(cCOPo))
PerlIO_printf(file, " label=\"%s\"",
- cCOPo->cop_label);
+ CopLABEL(cCOPo));
}
}
else
PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
#endif
if (o->op_flags) {
- SV *tmpsv = newSVpvn("", 0);
+ SV * const tmpsv = newSVpvs("");
switch (o->op_flags & OPf_WANT) {
case OPf_WANT_VOID:
sv_catpv(tmpsv, ",VOID");
SvREFCNT_dec(tmpsv);
}
if (o->op_private) {
- SV *tmpsv = newSVpvn("", 0);
+ SV * const tmpsv = newSVpvs("");
if (PL_opargs[o->op_type] & OA_TARGLEX) {
if (o->op_private & OPpTARGET_MY)
sv_catpv(tmpsv, ",TARGET_MY");
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");
sv_catpv(tmpsv, ",HUSH_VMSISH");
}
else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
- if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
+ if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
sv_catpv(tmpsv, ",FT_ACCESS");
if (o->op_private & OPpFT_STACKED)
sv_catpv(tmpsv, ",FT_STACKED");
S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
#else
if (cSVOPo->op_sv) {
- SV *tmpsv1 = newSV(0);
- SV *tmpsv2 = newSV(0);
+ SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
+ SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
char *s;
STRLEN len;
- SvUTF8_on(tmpsv1);
- SvUTF8_on(tmpsv2);
ENTER;
SAVEFREESV(tmpsv1);
SAVEFREESV(tmpsv2);
- gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
+ gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
s = SvPV(tmpsv1,len);
sv_catxmlpvn(tmpsv2, s, len, 1);
S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
#endif
break;
case OP_CONST:
+ case OP_HINTSEVAL:
case OP_METHOD_NAMED:
#ifndef USE_ITHREADS
/* with ITHREADS, consts are stored in the pad, and the right pad
}
do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
break;
- case OP_SETSTATE:
case OP_NEXTSTATE:
case OP_DBSTATE:
if (CopLINE(cCOPo))
- S_xmldump_attr(aTHX_ level, file, "line=\"%"UVf"\"",
+ S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
(UV)CopLINE(cCOPo));
if (CopSTASHPV(cCOPo))
S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
CopSTASHPV(cCOPo));
- if (cCOPo->cop_label)
+ if (CopLABEL(cCOPo))
S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
- cCOPo->cop_label);
+ CopLABEL(cCOPo));
break;
case OP_ENTERLOOP:
S_xmldump_attr(aTHX_ level, file, "redo=\"");
}
if (PL_madskills && o->op_madprop) {
- SV *tmpsv = newSVpvn("", 0);
- MADPROP* mp = o->op_madprop;
- sv_utf8_upgrade(tmpsv);
+ char prevkey = '\0';
+ SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
+ const MADPROP* mp = o->op_madprop;
+
if (!contents) {
contents = 1;
PerlIO_printf(file, ">\n");
level++;
while (mp) {
char tmp = mp->mad_key;
- sv_setpvn(tmpsv,"\"",1);
+ sv_setpvs(tmpsv,"\"");
if (tmp)
sv_catxmlpvn(tmpsv, &tmp, 1, 0);
+ if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
+ sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
+ else
+ prevkey = tmp;
sv_catpv(tmpsv, "\"");
switch (mp->mad_type) {
case MAD_NULL:
void
Perl_op_xmldump(pTHX_ const OP *o)
{
+ PERL_ARGS_ASSERT_OP_XMLDUMP;
+
do_op_xmldump(0, PL_xmlfp, o);
}
#endif
https://perl5.git.perl.org / perl5.git / blobdiff