/* dump.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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.
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++) {
{
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 char 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
const char * const end = pv + count; /* end of string */
octbuf[0] = esc;
+ PERL_ARGS_ASSERT_PV_ESCAPE;
+
if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
/* This won't alter the UTF-8 flag */
sv_setpvn(dsv, "", 0);
return SvPVX(dsv);
}
/*
-=for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
- |const STRLEN count|const STRLEN max\
- |const char const *start_color| const char 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 ellipses.
{
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_setpvn(dsv, "", 0);
/*
=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)
{
+ 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 );
{
char ch;
+ PERL_ARGS_ASSERT_DO_PMOP_DUMP;
+
if (!pm) {
Perl_dump_indent(aTHX_ level, file, "{}\n");
return;
const REGEXP * const regex = PM_GETRE(pm);
const U32 pmflags = pm->op_pmflags;
+ PERL_ARGS_ASSERT_PM_DESCRIPTION;
+
if (pmflags & PMf_ONCE)
sv_catpv(desc, ",ONCE");
#ifdef USE_ITHREADS
UV seq;
const OPCODE optype = o->op_type;
+ PERL_ARGS_ASSERT_DO_OP_DUMP;
+
sequence(o);
Perl_dump_indent(aTHX_ level, file, "{\n");
level++;
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
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");
#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
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 ===> ");
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_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_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;
return;
}
if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
- && type != SVt_PVCV && !isGV_with_GP(sv))
+ && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM)
|| (type == SVt_IV && !SvROK(sv))) {
if (SvIsUV(sv)
#ifdef PERL_OLD_COPY_ON_WRITE
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)) {
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** const 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);
do_op_dump(level+1, file, CvROOT(sv));
}
} else {
- SV * const 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)
Perl_sv_dump(pTHX_ SV *sv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_DUMP;
+
if (SvROK(sv))
do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
else
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:
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;
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;
+
+ PERL_ARGS_ASSERT_DEBPROF;
+
if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
return;
if (!PL_profiledata)
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++) {
{
SV * const sv = sv_newmortal();
+ PERL_ARGS_ASSERT_XMLDUMP_SUB;
+
gv_fullname3(sv, gv, NULL);
Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
if (CvXSUB(GvCV(gv)))
{
SV * const sv = sv_newmortal();
+ PERL_ARGS_ASSERT_XMLDUMP_FORM;
+
gv_fullname3(sv, gv, NULL);
Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
if (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));
}
STRLEN dsvcur;
STRLEN cl;
+ PERL_ARGS_ASSERT_SV_CATXMLPVN;
+
sv_catpvn(dsv,"",0);
dsvcur = SvCUR(dsv); /* in case we have to restart */
STRLEN n_a;
int unref = 0;
+ PERL_ARGS_ASSERT_SV_XMLPEEK;
+
sv_utf8_upgrade(t);
sv_setpvn(t, "", 0);
/* retry: */
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;
level++;
if (PM_GETRE(pm)) {
REGEXP *const r = PM_GETRE(pm);
- SV * const tmpsv = newSVsv((SV*)r);
- sv_utf8_upgrade(tmpsv);
+ 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);
{
UV seq;
int contents = 0;
+
+ PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
+
if (!o)
return;
sequence(o);
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
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");
#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
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=\"");
void
Perl_op_xmldump(pTHX_ const OP *o)
{
+ PERL_ARGS_ASSERT_OP_XMLDUMP;
+
do_op_xmldump(0, PL_xmlfp, o);
}
#endif
projects / p5sagit/p5-mst-13.2.git / blobdiff