/* 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.
*/
/*
- * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
- * it has not been hard for me to read your mind and memory.'"
+ * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
+ * it has not been hard for me to read your mind and memory.'
+ *
+ * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
*/
/* This file contains utility routines to dump the contents of SV and OP
"IO"
};
+struct flag_to_name {
+ U32 flag;
+ const char *name;
+};
+
+static void
+S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
+ const struct flag_to_name *const end)
+{
+ do {
+ if (flags & start->flag)
+ sv_catpv(sv, start->name);
+ } while (++start < end);
+}
+
+#define append_flags(sv, f, flags) \
+ S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
+
+
#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);
}
void
Perl_dump_all(pTHX)
{
+ dump_all_perl(FALSE);
+}
+
+void
+Perl_dump_all_perl(pTHX_ bool justperl)
+{
+
dVAR;
PerlIO_setlinebuf(Perl_debug_log);
if (PL_main_root)
op_dump(PL_main_root);
- dump_packsubs(PL_defstash);
+ dump_packsubs_perl(PL_defstash, justperl);
}
void
Perl_dump_packsubs(pTHX_ const HV *stash)
{
+ PERL_ARGS_ASSERT_DUMP_PACKSUBS;
+ dump_packsubs_perl(stash, FALSE);
+}
+
+void
+Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
+{
dVAR;
I32 i;
+ PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
+
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 * const gv = (GV*)HeVAL(entry);
+ const GV * const gv = (const GV *)HeVAL(entry);
if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
continue;
if (GvCVu(gv))
- dump_sub(gv);
+ dump_sub_perl(gv, justperl);
if (GvFORM(gv))
dump_form(gv);
if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
const HV * const hv = GvHV(gv);
if (hv && (hv != PL_defstash))
- dump_packsubs(hv); /* nested package */
+ dump_packsubs_perl(hv, justperl); /* nested package */
}
}
}
void
Perl_dump_sub(pTHX_ const GV *gv)
{
- SV * const sv = sv_newmortal();
+ PERL_ARGS_ASSERT_DUMP_SUB;
+ dump_sub_perl(gv, FALSE);
+}
+
+void
+Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
+{
+ SV * sv;
+ PERL_ARGS_ASSERT_DUMP_SUB_PERL;
+
+ if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
+ return;
+
+ sv = sv_newmortal();
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);
+ sv_setpvs(dsv, "");
}
if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
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);
+ sv_setpvs(dsv, "");
}
if ( dq == '"' )
- sv_catpvn(dsv, "\"", 1);
+ sv_catpvs(dsv, "\"");
else if ( flags & PERL_PV_PRETTY_LTGT )
- sv_catpvn(dsv, "<", 1);
+ sv_catpvs(dsv, "<");
if ( start_color != NULL )
- Perl_sv_catpv( aTHX_ dsv, 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_catpv( aTHX_ dsv, 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_ELLIPSES) && ( escaped < count ) )
- sv_catpvn( dsv, "...", 3 );
+ 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)
{
+ 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);
}
int unref = 0;
U32 type;
- sv_setpvn(t, "", 0);
+ sv_setpvs(t, "");
retry:
if (!sv) {
sv_catpv(t, "VOID");
goto finish;
}
- else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
+ else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
sv_catpv(t, "WILD");
goto finish;
}
sv_catpv(t, "...");
goto finish;
}
- sv = (SV*)SvRV(sv);
+ sv = SvRV(sv);
goto retry;
}
type = SvTYPE(sv);
else {
SV * const tmp = newSVpvs("");
sv_catpv(t, "(");
- if (SvOOK(sv))
- Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
+ if (SvOOK(sv)) {
+ STRLEN delta;
+ SvOOK_offset(sv, delta);
+ Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
+ }
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\"]",
finish:
while (unref--)
sv_catpv(t, ")");
+ if (PL_tainting && SvTAINTED(sv))
+ sv_catpv(t, " [tainted]");
return SvPV_nolen(t);
}
{
char ch;
+ PERL_ARGS_ASSERT_DO_PMOP_DUMP;
+
if (!pm) {
Perl_dump_indent(aTHX_ level, file, "{}\n");
return;
Perl_dump_indent(aTHX_ level-1, file, "}\n");
}
+const struct flag_to_name pmflags_flags_names[] = {
+ {PMf_CONST, ",CONST"},
+ {PMf_KEEP, ",KEEP"},
+ {PMf_GLOBAL, ",GLOBAL"},
+ {PMf_CONTINUE, ",CONTINUE"},
+ {PMf_RETAINT, ",RETAINT"},
+ {PMf_EVAL, ",EVAL"},
+ {PMf_NONDESTRUCT, ",NONDESTRUCT"},
+};
+
static SV *
S_pm_description(pTHX_ const PMOP *pm)
{
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
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");
+ append_flags(desc, pmflags, pmflags_flags_names);
return desc;
}
return seq ? SvUV(*seq): 0;
}
+const struct flag_to_name op_flags_names[] = {
+ {OPf_KIDS, ",KIDS"},
+ {OPf_PARENS, ",PARENS"},
+ {OPf_REF, ",REF"},
+ {OPf_MOD, ",MOD"},
+ {OPf_STACKED, ",STACKED"},
+ {OPf_SPECIAL, ",SPECIAL"}
+};
+
+const struct flag_to_name op_trans_names[] = {
+ {OPpTRANS_FROM_UTF, ",FROM_UTF"},
+ {OPpTRANS_TO_UTF, ",TO_UTF"},
+ {OPpTRANS_IDENTICAL, ",IDENTICAL"},
+ {OPpTRANS_SQUASH, ",SQUASH"},
+ {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
+ {OPpTRANS_GROWS, ",GROWS"},
+ {OPpTRANS_DELETE, ",DELETE"}
+};
+
+const struct flag_to_name op_entersub_names[] = {
+ {OPpENTERSUB_DB, ",DB"},
+ {OPpENTERSUB_HASTARG, ",HASTARG"},
+ {OPpENTERSUB_NOMOD, ",NOMOD"},
+ {OPpENTERSUB_AMPER, ",AMPER"},
+ {OPpENTERSUB_NOPAREN, ",NOPAREN"},
+ {OPpENTERSUB_INARGS, ",INARGS"}
+};
+
+const struct flag_to_name op_const_names[] = {
+ {OPpCONST_NOVER, ",NOVER"},
+ {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
+ {OPpCONST_STRICT, ",STRICT"},
+ {OPpCONST_ENTERED, ",ENTERED"},
+ {OPpCONST_ARYBASE, ",ARYBASE"},
+ {OPpCONST_BARE, ",BARE"},
+ {OPpCONST_WARNING, ",WARNING"}
+};
+
+const struct flag_to_name op_sort_names[] = {
+ {OPpSORT_NUMERIC, ",NUMERIC"},
+ {OPpSORT_INTEGER, ",INTEGER"},
+ {OPpSORT_REVERSE, ",REVERSE"},
+ {OPpSORT_INPLACE, ",INPLACE"},
+ {OPpSORT_DESCEND, ",DESCEND"},
+ {OPpSORT_QSORT, ",QSORT"},
+ {OPpSORT_STABLE, ",STABLE"}
+};
+
+const struct flag_to_name op_open_names[] = {
+ {OPpOPEN_IN_RAW, ",IN_RAW"},
+ {OPpOPEN_IN_CRLF, ",IN_CRLF"},
+ {OPpOPEN_OUT_RAW, ",OUT_RAW"},
+ {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
+};
+
+const struct flag_to_name op_exit_names[] = {
+ {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
+ {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
+};
+
+#define OP_PRIVATE_ONCE(op, flag, name) \
+ const struct flag_to_name CAT2(op, _names)[] = { \
+ {(flag), (name)} \
+ }
+
+OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
+OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
+OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
+OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
+OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
+OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
+OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
+OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
+OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
+OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
+OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
+OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
+
+struct op_private_by_op {
+ U16 op_type;
+ U16 len;
+ const struct flag_to_name *start;
+};
+
+const struct op_private_by_op op_private_names[] = {
+ {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
+ {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
+ {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
+ {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
+ {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
+ {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
+ {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
+ {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
+ {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
+ {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
+ {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
+ {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
+ {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
+ {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
+ {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
+ {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
+ {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
+ {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
+ {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
+ {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
+ {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
+};
+
+static bool
+S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
+ const struct op_private_by_op *start = op_private_names;
+ const struct op_private_by_op *const end
+ = op_private_names + C_ARRAY_LENGTH(op_private_names);
+
+ /* This is a linear search, but no worse than the code that it replaced.
+ It's debugging code - size is more important than speed. */
+ do {
+ if (optype == start->op_type) {
+ S_append_flags(aTHX_ tmpsv, op_private, start->start,
+ start->start + start->len);
+ return TRUE;
+ }
+ } while (++start < end);
+ return FALSE;
+}
+
void
Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *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++;
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, ",UNKNOWN");
break;
}
- if (o->op_flags & OPf_KIDS)
- sv_catpv(tmpsv, ",KIDS");
- if (o->op_flags & OPf_PARENS)
- sv_catpv(tmpsv, ",PARENS");
- if (o->op_flags & OPf_STACKED)
- sv_catpv(tmpsv, ",STACKED");
- if (o->op_flags & OPf_REF)
- sv_catpv(tmpsv, ",REF");
- if (o->op_flags & OPf_MOD)
- sv_catpv(tmpsv, ",MOD");
- if (o->op_flags & OPf_SPECIAL)
- sv_catpv(tmpsv, ",SPECIAL");
+ append_flags(tmpsv, o->op_flags, op_flags_names);
if (o->op_latefree)
sv_catpv(tmpsv, ",LATEFREE");
if (o->op_latefreed)
if (o->op_private & OPpTARGET_MY)
sv_catpv(tmpsv, ",TARGET_MY");
}
- else if (optype == OP_LEAVESUB ||
- optype == OP_LEAVE ||
- optype == OP_LEAVESUBLV ||
- optype == OP_LEAVEWRITE) {
- if (o->op_private & OPpREFCOUNTED)
- sv_catpv(tmpsv, ",REFCOUNTED");
- }
- else if (optype == OP_AASSIGN) {
- if (o->op_private & OPpASSIGN_COMMON)
- sv_catpv(tmpsv, ",COMMON");
- }
- else if (optype == OP_SASSIGN) {
- if (o->op_private & OPpASSIGN_BACKWARDS)
- sv_catpv(tmpsv, ",BACKWARDS");
- }
- else if (optype == OP_TRANS) {
- if (o->op_private & OPpTRANS_SQUASH)
- sv_catpv(tmpsv, ",SQUASH");
- if (o->op_private & OPpTRANS_DELETE)
- sv_catpv(tmpsv, ",DELETE");
- if (o->op_private & OPpTRANS_COMPLEMENT)
- sv_catpv(tmpsv, ",COMPLEMENT");
- if (o->op_private & OPpTRANS_IDENTICAL)
- sv_catpv(tmpsv, ",IDENTICAL");
- if (o->op_private & OPpTRANS_GROWS)
- sv_catpv(tmpsv, ",GROWS");
- }
- else if (optype == OP_REPEAT) {
- if (o->op_private & OPpREPEAT_DOLIST)
- sv_catpv(tmpsv, ",DOLIST");
- }
else if (optype == OP_ENTERSUB ||
- optype == OP_RV2SV ||
- optype == OP_GVSV ||
- optype == OP_RV2AV ||
- optype == OP_RV2HV ||
- optype == OP_RV2GV ||
- optype == OP_AELEM ||
- optype == OP_HELEM )
+ optype == OP_RV2SV ||
+ optype == OP_GVSV ||
+ optype == OP_RV2AV ||
+ optype == OP_RV2HV ||
+ optype == OP_RV2GV ||
+ optype == OP_AELEM ||
+ optype == OP_HELEM )
{
if (optype == OP_ENTERSUB) {
- if (o->op_private & OPpENTERSUB_AMPER)
- sv_catpv(tmpsv, ",AMPER");
- if (o->op_private & OPpENTERSUB_DB)
- sv_catpv(tmpsv, ",DB");
- if (o->op_private & OPpENTERSUB_HASTARG)
- sv_catpv(tmpsv, ",HASTARG");
- if (o->op_private & OPpENTERSUB_NOPAREN)
- sv_catpv(tmpsv, ",NOPAREN");
- if (o->op_private & OPpENTERSUB_INARGS)
- sv_catpv(tmpsv, ",INARGS");
- if (o->op_private & OPpENTERSUB_NOMOD)
- sv_catpv(tmpsv, ",NOMOD");
+ append_flags(tmpsv, o->op_private, op_entersub_names);
}
else {
switch (o->op_private & OPpDEREF) {
if (o->op_private & OPpMAYBE_LVSUB)
sv_catpv(tmpsv, ",MAYBE_LVSUB");
}
+
+ if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
+ && (o->op_private & OPpDEREFed))
+ sv_catpv(tmpsv, ",DEREFed");
+
if (optype == OP_AELEM || optype == OP_HELEM) {
if (o->op_private & OPpLVAL_DEFER)
sv_catpv(tmpsv, ",LVAL_DEFER");
sv_catpv(tmpsv, ",OUR_INTRO");
}
}
- else if (optype == OP_CONST) {
- if (o->op_private & OPpCONST_BARE)
- sv_catpv(tmpsv, ",BARE");
- if (o->op_private & OPpCONST_STRICT)
- sv_catpv(tmpsv, ",STRICT");
- if (o->op_private & OPpCONST_ARYBASE)
- sv_catpv(tmpsv, ",ARYBASE");
- if (o->op_private & OPpCONST_WARNING)
- sv_catpv(tmpsv, ",WARNING");
- if (o->op_private & OPpCONST_ENTERED)
- sv_catpv(tmpsv, ",ENTERED");
- }
- else if (optype == OP_FLIP) {
- if (o->op_private & OPpFLIP_LINENUM)
- sv_catpv(tmpsv, ",LINENUM");
- }
- else if (optype == OP_FLOP) {
- if (o->op_private & OPpFLIP_LINENUM)
- sv_catpv(tmpsv, ",LINENUM");
+ else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
}
- else if (optype == OP_RV2CV) {
- if (o->op_private & OPpLVAL_INTRO)
- sv_catpv(tmpsv, ",INTRO");
- }
- else if (optype == OP_GV) {
- if (o->op_private & OPpEARLY_CV)
- sv_catpv(tmpsv, ",EARLY_CV");
- }
- else if (optype == OP_LIST) {
- if (o->op_private & OPpLIST_GUESSED)
- sv_catpv(tmpsv, ",GUESSED");
- }
- else if (optype == OP_DELETE) {
- if (o->op_private & OPpSLICE)
- sv_catpv(tmpsv, ",SLICE");
- }
- else if (optype == OP_EXISTS) {
- if (o->op_private & OPpEXISTS_SUB)
- sv_catpv(tmpsv, ",EXISTS_SUB");
- }
- else if (optype == OP_SORT) {
- if (o->op_private & OPpSORT_NUMERIC)
- sv_catpv(tmpsv, ",NUMERIC");
- if (o->op_private & OPpSORT_INTEGER)
- sv_catpv(tmpsv, ",INTEGER");
- if (o->op_private & OPpSORT_REVERSE)
- sv_catpv(tmpsv, ",REVERSE");
- }
- else if (optype == OP_OPEN || optype == OP_BACKTICK) {
- if (o->op_private & OPpOPEN_IN_RAW)
- sv_catpv(tmpsv, ",IN_RAW");
- if (o->op_private & OPpOPEN_IN_CRLF)
- sv_catpv(tmpsv, ",IN_CRLF");
- if (o->op_private & OPpOPEN_OUT_RAW)
- sv_catpv(tmpsv, ",OUT_RAW");
- if (o->op_private & OPpOPEN_OUT_CRLF)
- sv_catpv(tmpsv, ",OUT_CRLF");
- }
- else if (optype == OP_EXIT) {
- if (o->op_private & OPpEXIT_VMSISH)
- sv_catpv(tmpsv, ",EXIT_VMSISH");
- if (o->op_private & OPpHUSH_VMSISH)
- sv_catpv(tmpsv, ",HUSH_VMSISH");
- }
- else if (optype == OP_DIE) {
- if (o->op_private & OPpHUSH_VMSISH)
- 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)
+ else if (PL_check[optype] != Perl_ck_ftst) {
+ 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) {
const char tmp = mp->mad_key;
- sv_setpvn(tmpsv,"'",1);
+ sv_setpvs(tmpsv,"'");
if (tmp)
sv_catpvn(tmpsv, &tmp, 1);
sv_catpv(tmpsv, "'=");
#ifdef USE_ITHREADS
Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
#else
- if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
+ if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
if (cSVOPo->op_sv) {
SV * const tmpsv = newSV(0);
ENTER;
UTF-8 cleanliness of the dump file handle? */
SvUTF8_on(tmpsv);
#endif
- gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
+ gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
SvPV_nolen_const(tmpsv));
LEAVE;
#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))
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_tied, "tied(P)" },
{ PERL_MAGIC_sig, "sig(S)" },
{ PERL_MAGIC_uvar, "uvar(U)" },
+ { PERL_MAGIC_checkcall, "checkcall(])" },
{ PERL_MAGIC_overload_elem, "overload_elem(a)" },
{ PERL_MAGIC_overload_table, "overload_table(c)" },
{ PERL_MAGIC_regdatum, "regdatum(d)" },
{ 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));
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";
+ else if (v == &PL_vtbl_hints) s = "hints";
else s = NULL;
if (s)
Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
if (mg->mg_type == PERL_MAGIC_envelem &&
mg->mg_flags & MGf_TAINTEDDIR)
Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
+ if (mg->mg_type == PERL_MAGIC_regex_global &&
+ mg->mg_flags & MGf_MINMATCH)
+ Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
if (mg->mg_flags & MGf_REFCOUNTED)
Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
if (mg->mg_flags & MGf_GSKIP)
Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
- if (mg->mg_type == PERL_MAGIC_regex_global &&
- mg->mg_flags & MGf_MINMATCH)
- Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
+ if (mg->mg_flags & MGf_COPY)
+ Perl_dump_indent(aTHX_ level, file, " COPY\n");
+ if (mg->mg_flags & MGf_DUP)
+ Perl_dump_indent(aTHX_ level, file, " DUP\n");
+ if (mg->mg_flags & MGf_LOCAL)
+ Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
}
if (mg->mg_obj) {
- Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
+ 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),
+ = 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_EXTFLAGS(re) & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0))
+ (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",
}
else if (mg->mg_len == HEf_SVKEY) {
PerlIO_puts(file, " => HEf_SVKEY\n");
- do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
+ do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
+ maxnest, dumpops, pvlim); /* MG is already +1 */
continue;
}
+ else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
else
- PerlIO_puts(file, " ???? - please notify IZ");
+ PerlIO_puts(
+ file,
+ " ???? - " __FILE__
+ " does not know how to handle this MG_LEN"
+ );
PerlIO_putc(file, '\n');
}
if (mg->mg_type == PERL_MAGIC_utf8) {
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);
+ {
+ /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
+ name which quite legally could contain insane things like tabs, newlines, nulls or
+ other scary crap - this should produce sane results - except maybe for unicode package
+ names - but we will wait for someone to file a bug on that - demerphq */
+ SV * const tmpsv = newSVpvs("");
+ PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
+ }
else
PerlIO_putc(file, '\n');
}
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;
PerlIO_putc(file, '\n');
}
+const struct flag_to_name first_sv_flags_names[] = {
+ {SVs_TEMP, "TEMP,"},
+ {SVs_OBJECT, "OBJECT,"},
+ {SVs_GMG, "GMG,"},
+ {SVs_SMG, "SMG,"},
+ {SVs_RMG, "RMG,"},
+ {SVf_IOK, "IOK,"},
+ {SVf_NOK, "NOK,"},
+ {SVf_POK, "POK,"}
+};
+
+const struct flag_to_name second_sv_flags_names[] = {
+ {SVf_OOK, "OOK,"},
+ {SVf_FAKE, "FAKE,"},
+ {SVf_READONLY, "READONLY,"},
+ {SVf_BREAK, "BREAK,"},
+ {SVf_AMAGIC, "OVERLOAD,"},
+ {SVp_IOK, "pIOK,"},
+ {SVp_NOK, "pNOK,"},
+ {SVp_POK, "pPOK,"}
+};
+
+const struct flag_to_name cv_flags_names[] = {
+ {CVf_ANON, "ANON,"},
+ {CVf_UNIQUE, "UNIQUE,"},
+ {CVf_CLONE, "CLONE,"},
+ {CVf_CLONED, "CLONED,"},
+ {CVf_CONST, "CONST,"},
+ {CVf_NODEBUG, "NODEBUG,"},
+ {CVf_LVALUE, "LVALUE,"},
+ {CVf_METHOD, "METHOD,"},
+ {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
+ {CVf_CVGV_RC, "CVGV_RC,"},
+ {CVf_ISXSUB, "ISXSUB,"}
+};
+
+const struct flag_to_name hv_flags_names[] = {
+ {SVphv_SHAREKEYS, "SHAREKEYS,"},
+ {SVphv_LAZYDEL, "LAZYDEL,"},
+ {SVphv_HASKFLAGS, "HASKFLAGS,"},
+ {SVphv_REHASH, "REHASH,"},
+ {SVphv_CLONEABLE, "CLONEABLE,"}
+};
+
+const struct flag_to_name gp_flags_names[] = {
+ {GVf_INTRO, "INTRO,"},
+ {GVf_MULTI, "MULTI,"},
+ {GVf_ASSUMECV, "ASSUMECV,"},
+ {GVf_IN_PAD, "IN_PAD,"}
+};
+
+const struct flag_to_name gp_flags_imported_names[] = {
+ {GVf_IMPORTED_SV, " SV"},
+ {GVf_IMPORTED_AV, " AV"},
+ {GVf_IMPORTED_HV, " HV"},
+ {GVf_IMPORTED_CV, " CV"},
+};
+
void
Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
{
U32 flags;
U32 type;
+ PERL_ARGS_ASSERT_DO_SV_DUMP;
+
if (!sv) {
Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
return;
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 & SVs_SMG) sv_catpv(d, "SMG,");
- if (flags & SVs_RMG) sv_catpv(d, "RMG,");
-
- if (flags & SVf_IOK) sv_catpv(d, "IOK,");
- if (flags & SVf_NOK) sv_catpv(d, "NOK,");
- if (flags & SVf_POK) sv_catpv(d, "POK,");
+ append_flags(d, flags, first_sv_flags_names);
if (flags & SVf_ROK) {
sv_catpv(d, "ROK,");
if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
}
- 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,");
+ append_flags(d, flags, second_sv_flags_names);
if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
if (SvPCS_IMPORTED(sv))
sv_catpv(d, "PCS_IMPORTED,");
switch (type) {
case SVt_PVCV:
case SVt_PVFM:
- if (CvANON(sv)) sv_catpv(d, "ANON,");
- if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
- if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
- if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
- if (CvCONST(sv)) sv_catpv(d, "CONST,");
- if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
+ append_flags(d, CvFLAGS(sv), cv_flags_names);
if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
- if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
- if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
- if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
- if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
break;
case SVt_PVHV:
- if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
- if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
- if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
- if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
- if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
+ append_flags(d, flags, hv_flags_names);
break;
case SVt_PVGV:
case SVt_PVLV:
if (isGV_with_GP(sv)) {
- if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
- if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
- if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
- if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
- if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
+ append_flags(d, GvFLAGS(sv), gp_flags_names);
}
if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
sv_catpv(d, "IMPORT");
sv_catpv(d, "ALL,");
else {
sv_catpv(d, "(");
- if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
- if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
- if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
- if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
+ append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
sv_catpv(d, " ),");
}
}
s = SvPVX_const(d);
#ifdef DEBUG_LEAKING_SCALARS
- Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
+ Perl_dump_indent(aTHX_ level, file,
+ "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
sv->sv_debug_line,
sv->sv_debug_inpad ? "for" : "by",
sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
- sv->sv_debug_cloned ? " (cloned)" : "");
+ PTR2UV(sv->sv_debug_parent),
+ sv->sv_debug_serial
+ );
#endif
Perl_dump_indent(aTHX_ level, file, "SV = ");
if (type < SVt_LAST) {
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_PVIO && type != SVt_REGEXP)
|| (type == SVt_IV && !SvROK(sv))) {
if (SvIsUV(sv)
#ifdef PERL_OLD_COPY_ON_WRITE
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)");
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_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 */
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 6? \x{....} */
PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
do_hv_dump(level, file, " OURSTASH", ost);
} else {
if (SvMAGIC(sv))
- do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
+ do_magic_dump(level, file, SvMAGIC(sv), nest+1, 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** 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);
+ AV * const backrefs
+ = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
+ struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
+ if (HvAUX(sv)->xhv_name_count)
+ Perl_dump_indent(aTHX_
+ level, file, " NAMECOUNT = %"IVdf"\n",
+ (IV)HvAUX(sv)->xhv_name_count
+ );
+ if (HvAUX(sv)->xhv_name && HvENAME_HEK_NN(sv)) {
+ if (HvAUX(sv)->xhv_name_count) {
+ SV * const names = sv_newmortal();
+ HEK ** const namep = (HEK **)HvAUX(sv)->xhv_name;
+ const I32 count = HvAUX(sv)->xhv_name_count;
+ /* This line sets hekp to one element before the first
+ name, so the ++hekp below will put us at the start-
+ ing point.
+ That starting point is the first element if count
+ is positive and the second element if count
+ is negative.
+ */
+ HEK **hekp = namep - (count > 0);
+ sv_setpv(names, "");
+ while (++hekp < namep + (count < 0 ? -count : count))
+ if (*hekp) {
+ sv_catpvs(names, ", \"");
+ sv_catpvn(
+ names, HEK_KEY(*hekp), HEK_LEN(*hekp)
+ );
+ sv_catpvs(names, "\"");
+ }
+ /* This should never happen. */
+ else sv_catpvs(names, ", (null)");
+ Perl_dump_indent(aTHX_
+ level, file, " ENAME = %s\n", SvPV_nolen(names)+2
+ );
+ }
+ else
+ Perl_dump_indent(aTHX_
+ level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
+ );
+ }
if (backrefs) {
Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
PTR2UV(backrefs));
- do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
+ do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
dumpops, pvlim);
}
+ if (meta) {
+ /* FIXME - mro_algs kflags can signal a UTF-8 name. */
+ Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
+ (int)meta->mro_which->length,
+ meta->mro_which->name,
+ PTR2UV(meta->mro_which));
+ Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
+ (UV)meta->cache_gen);
+ Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
+ (UV)meta->pkg_gen);
+ if (meta->mro_linear_all) {
+ Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
+ PTR2UV(meta->mro_linear_all));
+ do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
+ dumpops, pvlim);
+ }
+ if (meta->mro_linear_current) {
+ Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
+ PTR2UV(meta->mro_linear_current));
+ do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
+ dumpops, pvlim);
+ }
+ if (meta->mro_nextmethod) {
+ Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
+ PTR2UV(meta->mro_nextmethod));
+ do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
+ dumpops, pvlim);
+ }
+ if (meta->isa) {
+ Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
+ PTR2UV(meta->isa));
+ do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
+ dumpops, pvlim);
+ }
+ }
}
- if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
- HE *he;
- HV * const hv = (HV*)sv;
- int count = maxnest - nest;
-
- hv_iterinit(hv);
- while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
- && count--) {
- 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);
-
- 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, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
- if (HeKREHASH(he))
- PerlIO_printf(file, "[REHASH] ");
- PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
- do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
+ if (nest < maxnest) {
+ if (HvEITER_get(sv)) /* preserve iterator */
+ Perl_dump_indent(aTHX_ level, file,
+ " (*** Active iterator; skipping element dump ***)\n");
+ else {
+ HE *he;
+ HV * const hv = MUTABLE_HV(sv);
+ int count = maxnest - nest;
+
+ hv_iterinit(hv);
+ while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
+ && count--) {
+ 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);
+
+ 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, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
+ if (HeKREHASH(he))
+ PerlIO_printf(file, "[REHASH] ");
+ PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
+ do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
+ }
+ hv_iterinit(hv); /* Return to status quo */
}
- hv_iterinit(hv); /* Return to status quo */
}
break;
case SVt_PVCV:
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)
: CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
}
if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
- do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
+ do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
break;
case SVt_PVGV:
case SVt_PVLV:
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);
+ do_sv_dump (level+1, file, MUTABLE_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. */
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);
+ do_sv_dump (level+1, file, MUTABLE_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));
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);
+ do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
+ maxnest, dumpops, pvlim);
}
if (isPRINT(IoTYPE(sv)))
Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
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
{
dVAR;
if (!PL_op) {
- if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
return 0;
}
DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
do {
- PERL_ASYNC_CHECK();
if (PL_debug) {
if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
PerlIO_printf(Perl_debug_log,
if (DEBUG_t_TEST_) debop(PL_op);
if (DEBUG_P_TEST_) debprof(PL_op);
}
- } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
+ } while ((PL_op = PL_op->op_ppaddr(aTHX)));
DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
TAINT_NOT;
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);
}
void
Perl_xmldump_all(pTHX)
{
+ xmldump_all_perl(FALSE);
+}
+
+void
+Perl_xmldump_all_perl(pTHX_ bool justperl)
+{
PerlIO_setlinebuf(PL_xmlfp);
if (PL_main_root)
op_xmldump(PL_main_root);
+ xmldump_packsubs_perl(PL_defstash, justperl);
if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
PerlIO_close(PL_xmlfp);
PL_xmlfp = 0;
void
Perl_xmldump_packsubs(pTHX_ const HV *stash)
{
+ PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
+ xmldump_packsubs_perl(stash, FALSE);
+}
+
+void
+Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
+{
I32 i;
HE *entry;
+ PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
+
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
- GV *gv = (GV*)HeVAL(entry);
+ GV *gv = MUTABLE_GV(HeVAL(entry));
HV *hv;
if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
continue;
if (GvCVu(gv))
- xmldump_sub(gv);
+ xmldump_sub_perl(gv, justperl);
if (GvFORM(gv))
xmldump_form(gv);
if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
&& (hv = GvHV(gv)) && hv != PL_defstash)
- xmldump_packsubs(hv); /* nested package */
+ xmldump_packsubs_perl(hv, justperl); /* nested package */
}
}
}
void
Perl_xmldump_sub(pTHX_ const GV *gv)
{
- SV * const sv = sv_newmortal();
+ PERL_ARGS_ASSERT_XMLDUMP_SUB;
+ xmldump_sub_perl(gv, FALSE);
+}
+
+void
+Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
+{
+ SV * sv;
+
+ PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
+
+ if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
+ return;
+ sv = sv_newmortal();
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));
}
char *
+Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
+{
+ PERL_ARGS_ASSERT_SV_CATXMLPV;
+ return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
+}
+
+char *
Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
{
unsigned int c;
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:
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=\"\"");
goto finish;
}
- else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
+ else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
sv_catpv(t, "WILD=\"\"");
goto finish;
}
case SVt_BIND:
sv_catpv(t, " BIND=\"");
break;
- case SVt_ORANGE:
+ case SVt_REGEXP:
sv_catpv(t, " ORANGE=\"");
break;
case SVt_PVFM:
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)) {
- const regexp *const r = PM_GETRE(pm);
- SV * const tmpsv = newSVpvn(RX_PRECOMP(r),r->prelen);
- SvUTF8_on(tmpsv);
+ REGEXP *const r = PM_GETRE(pm);
+ SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
+ sv_catxmlsv(tmpsv, MUTABLE_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);
{
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
PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
#endif
if (o->op_flags) {
- SV * const 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 * const 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 & OPpHUSH_VMSISH)
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)
+ else if (PL_check[o->op_type] != Perl_ck_ftst) {
+ 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 * const tmpsv1 = newSV(0);
- SV * const tmpsv2 = newSVpvn("",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, NULL);
+ gv_fullname3(tmpsv1, MUTABLE_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))
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) {
char prevkey = '\0';
- SV * const tmpsv = newSVpvn("", 0);
+ SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
const MADPROP* mp = o->op_madprop;
- sv_utf8_upgrade(tmpsv);
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. */
break;
case MAD_SV:
sv_catpv(tmpsv, " val=\"");
- sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
+ sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
sv_catpv(tmpsv, "\"");
Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
break;
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