3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'
15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
18 /* This file contains utility routines to dump the contents of SV and OP
19 * structures, as used by command-line options like -Dt and -Dx, and
22 * It also holds the debugging version of the runops function.
26 #define PERL_IN_DUMP_C
32 static const char* const svtypenames[SVt_LAST] = {
52 static const char* const svshorttypenames[SVt_LAST] = {
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78 const struct flag_to_name *const end)
81 if (flags & start->flag)
82 sv_catpv(sv, start->name);
83 } while (++start < end);
86 #define append_flags(sv, f, flags) \
87 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
92 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
95 PERL_ARGS_ASSERT_DUMP_INDENT;
97 dump_vindent(level, file, pat, &args);
102 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
105 PERL_ARGS_ASSERT_DUMP_VINDENT;
106 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
107 PerlIO_vprintf(file, pat, *args);
113 dump_all_perl(FALSE);
117 Perl_dump_all_perl(pTHX_ bool justperl)
121 PerlIO_setlinebuf(Perl_debug_log);
123 op_dump(PL_main_root);
124 dump_packsubs_perl(PL_defstash, justperl);
128 Perl_dump_packsubs(pTHX_ const HV *stash)
130 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
131 dump_packsubs_perl(stash, FALSE);
135 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
140 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
144 for (i = 0; i <= (I32) HvMAX(stash); i++) {
146 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
147 const GV * const gv = (const GV *)HeVAL(entry);
148 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
151 dump_sub_perl(gv, justperl);
154 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
155 const HV * const hv = GvHV(gv);
156 if (hv && (hv != PL_defstash))
157 dump_packsubs_perl(hv, justperl); /* nested package */
164 Perl_dump_sub(pTHX_ const GV *gv)
166 PERL_ARGS_ASSERT_DUMP_SUB;
167 dump_sub_perl(gv, FALSE);
171 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
175 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
177 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
181 gv_fullname3(sv, gv, NULL);
182 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
183 if (CvISXSUB(GvCV(gv)))
184 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
185 PTR2UV(CvXSUB(GvCV(gv))),
186 (int)CvXSUBANY(GvCV(gv)).any_i32);
187 else if (CvROOT(GvCV(gv)))
188 op_dump(CvROOT(GvCV(gv)));
190 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
194 Perl_dump_form(pTHX_ const GV *gv)
196 SV * const sv = sv_newmortal();
198 PERL_ARGS_ASSERT_DUMP_FORM;
200 gv_fullname3(sv, gv, NULL);
201 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
202 if (CvROOT(GvFORM(gv)))
203 op_dump(CvROOT(GvFORM(gv)));
205 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
212 op_dump(PL_eval_root);
217 =for apidoc pv_escape
219 Escapes at most the first "count" chars of pv and puts the results into
220 dsv such that the size of the escaped string will not exceed "max" chars
221 and will not contain any incomplete escape sequences.
223 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
224 will also be escaped.
226 Normally the SV will be cleared before the escaped string is prepared,
227 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
229 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
230 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
231 using C<is_utf8_string()> to determine if it is Unicode.
233 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
234 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
235 chars above 127 will be escaped using this style; otherwise, only chars above
236 255 will be so escaped; other non printable chars will use octal or
237 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
238 then all chars below 255 will be treated as printable and
239 will be output as literals.
241 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
242 string will be escaped, regardless of max. If the output is to be in hex,
243 then it will be returned as a plain hex
244 sequence. Thus the output will either be a single char,
245 an octal escape sequence, a special escape like C<\n> or a hex value.
247 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
248 not a '\\'. This is because regexes very often contain backslashed
249 sequences, whereas '%' is not a particularly common character in patterns.
251 Returns a pointer to the escaped text as held by dsv.
255 #define PV_ESCAPE_OCTBUFSIZE 32
258 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
259 const STRLEN count, const STRLEN max,
260 STRLEN * const escaped, const U32 flags )
262 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
263 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
264 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
265 STRLEN wrote = 0; /* chars written so far */
266 STRLEN chsize = 0; /* size of data to be written */
267 STRLEN readsize = 1; /* size of data just read */
268 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
269 const char *pv = str;
270 const char * const end = pv + count; /* end of string */
273 PERL_ARGS_ASSERT_PV_ESCAPE;
275 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
276 /* This won't alter the UTF-8 flag */
280 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
283 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
284 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
285 const U8 c = (U8)u & 0xFF;
288 || (flags & PERL_PV_ESCAPE_ALL)
289 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
291 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
292 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
295 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
296 "%cx{%"UVxf"}", esc, u);
297 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
300 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
304 case '\\' : /* fallthrough */
305 case '%' : if ( c == esc ) {
311 case '\v' : octbuf[1] = 'v'; break;
312 case '\t' : octbuf[1] = 't'; break;
313 case '\r' : octbuf[1] = 'r'; break;
314 case '\n' : octbuf[1] = 'n'; break;
315 case '\f' : octbuf[1] = 'f'; break;
323 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
324 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
327 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
334 if ( max && (wrote + chsize > max) ) {
336 } else if (chsize > 1) {
337 sv_catpvn(dsv, octbuf, chsize);
340 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
341 128-255 can be appended raw to the dsv. If dsv happens to be
342 UTF-8 then we need catpvf to upgrade them for us.
343 Or add a new API call sv_catpvc(). Think about that name, and
344 how to keep it clear that it's unlike the s of catpvs, which is
345 really an array octets, not a string. */
346 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
349 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
357 =for apidoc pv_pretty
359 Converts a string into something presentable, handling escaping via
360 pv_escape() and supporting quoting and ellipses.
362 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
363 double quoted with any double quotes in the string escaped. Otherwise
364 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
367 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
368 string were output then an ellipsis C<...> will be appended to the
369 string. Note that this happens AFTER it has been quoted.
371 If start_color is non-null then it will be inserted after the opening
372 quote (if there is one) but before the escaped text. If end_color
373 is non-null then it will be inserted after the escaped text but before
374 any quotes or ellipses.
376 Returns a pointer to the prettified text as held by dsv.
382 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
383 const STRLEN max, char const * const start_color, char const * const end_color,
386 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
389 PERL_ARGS_ASSERT_PV_PRETTY;
391 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
392 /* This won't alter the UTF-8 flag */
397 sv_catpvs(dsv, "\"");
398 else if ( flags & PERL_PV_PRETTY_LTGT )
401 if ( start_color != NULL )
402 sv_catpv(dsv, start_color);
404 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
406 if ( end_color != NULL )
407 sv_catpv(dsv, end_color);
410 sv_catpvs( dsv, "\"");
411 else if ( flags & PERL_PV_PRETTY_LTGT )
414 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
415 sv_catpvs(dsv, "...");
421 =for apidoc pv_display
425 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
427 except that an additional "\0" will be appended to the string when
428 len > cur and pv[cur] is "\0".
430 Note that the final string may be up to 7 chars longer than pvlim.
436 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
438 PERL_ARGS_ASSERT_PV_DISPLAY;
440 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
441 if (len > cur && pv[cur] == '\0')
442 sv_catpvs( dsv, "\\0");
447 Perl_sv_peek(pTHX_ SV *sv)
450 SV * const t = sv_newmortal();
460 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
464 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
465 if (sv == &PL_sv_undef) {
466 sv_catpv(t, "SV_UNDEF");
467 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
468 SVs_GMG|SVs_SMG|SVs_RMG)) &&
472 else if (sv == &PL_sv_no) {
473 sv_catpv(t, "SV_NO");
474 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
475 SVs_GMG|SVs_SMG|SVs_RMG)) &&
476 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
482 else if (sv == &PL_sv_yes) {
483 sv_catpv(t, "SV_YES");
484 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
485 SVs_GMG|SVs_SMG|SVs_RMG)) &&
486 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
489 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
494 sv_catpv(t, "SV_PLACEHOLDER");
495 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
496 SVs_GMG|SVs_SMG|SVs_RMG)) &&
502 else if (SvREFCNT(sv) == 0) {
506 else if (DEBUG_R_TEST_) {
509 /* is this SV on the tmps stack? */
510 for (ix=PL_tmps_ix; ix>=0; ix--) {
511 if (PL_tmps_stack[ix] == sv) {
516 if (SvREFCNT(sv) > 1)
517 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
525 if (SvCUR(t) + unref > 10) {
526 SvCUR_set(t, unref + 3);
535 if (type == SVt_PVCV) {
536 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
538 } else if (type < SVt_LAST) {
539 sv_catpv(t, svshorttypenames[type]);
541 if (type == SVt_NULL)
544 sv_catpv(t, "FREED");
549 if (!SvPVX_const(sv))
550 sv_catpv(t, "(null)");
552 SV * const tmp = newSVpvs("");
556 SvOOK_offset(sv, delta);
557 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
559 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
561 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
562 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
567 else if (SvNOKp(sv)) {
568 STORE_NUMERIC_LOCAL_SET_STANDARD();
569 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
570 RESTORE_NUMERIC_LOCAL();
572 else if (SvIOKp(sv)) {
574 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
576 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
584 if (PL_tainting && SvTAINTED(sv))
585 sv_catpv(t, " [tainted]");
586 return SvPV_nolen(t);
590 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
594 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
597 Perl_dump_indent(aTHX_ level, file, "{}\n");
600 Perl_dump_indent(aTHX_ level, file, "{\n");
602 if (pm->op_pmflags & PMf_ONCE)
607 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
608 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
609 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
611 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
612 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
613 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
614 op_dump(pm->op_pmreplrootu.op_pmreplroot);
616 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
617 SV * const tmpsv = pm_description(pm);
618 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
622 Perl_dump_indent(aTHX_ level-1, file, "}\n");
625 const struct flag_to_name pmflags_flags_names[] = {
626 {PMf_CONST, ",CONST"},
628 {PMf_GLOBAL, ",GLOBAL"},
629 {PMf_CONTINUE, ",CONTINUE"},
630 {PMf_RETAINT, ",RETAINT"},
632 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
636 S_pm_description(pTHX_ const PMOP *pm)
638 SV * const desc = newSVpvs("");
639 const REGEXP * const regex = PM_GETRE(pm);
640 const U32 pmflags = pm->op_pmflags;
642 PERL_ARGS_ASSERT_PM_DESCRIPTION;
644 if (pmflags & PMf_ONCE)
645 sv_catpv(desc, ",ONCE");
647 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
648 sv_catpv(desc, ":USED");
650 if (pmflags & PMf_USED)
651 sv_catpv(desc, ":USED");
655 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
656 sv_catpv(desc, ",TAINTED");
657 if (RX_CHECK_SUBSTR(regex)) {
658 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
659 sv_catpv(desc, ",SCANFIRST");
660 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
661 sv_catpv(desc, ",ALL");
663 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
664 sv_catpv(desc, ",SKIPWHITE");
667 append_flags(desc, pmflags, pmflags_flags_names);
672 Perl_pmop_dump(pTHX_ PMOP *pm)
674 do_pmop_dump(0, Perl_debug_log, pm);
677 /* Return a unique integer to represent the address of op o.
678 * If it already exists in PL_op_sequence, just return it;
680 * *** Note that this isn't thread-safe */
683 S_sequence_num(pTHX_ const OP *o)
692 op = newSVuv(PTR2UV(o));
694 key = SvPV_const(op, len);
696 PL_op_sequence = newHV();
697 seq = hv_fetch(PL_op_sequence, key, len, 0);
700 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
704 const struct flag_to_name op_flags_names[] = {
706 {OPf_PARENS, ",PARENS"},
709 {OPf_STACKED, ",STACKED"},
710 {OPf_SPECIAL, ",SPECIAL"}
713 const struct flag_to_name op_trans_names[] = {
714 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
715 {OPpTRANS_TO_UTF, ",TO_UTF"},
716 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
717 {OPpTRANS_SQUASH, ",SQUASH"},
718 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
719 {OPpTRANS_GROWS, ",GROWS"},
720 {OPpTRANS_DELETE, ",DELETE"}
723 const struct flag_to_name op_entersub_names[] = {
724 {OPpENTERSUB_DB, ",DB"},
725 {OPpENTERSUB_HASTARG, ",HASTARG"},
726 {OPpENTERSUB_AMPER, ",AMPER"},
727 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
728 {OPpENTERSUB_INARGS, ",INARGS"}
731 const struct flag_to_name op_const_names[] = {
732 {OPpCONST_NOVER, ",NOVER"},
733 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
734 {OPpCONST_STRICT, ",STRICT"},
735 {OPpCONST_ENTERED, ",ENTERED"},
736 {OPpCONST_BARE, ",BARE"},
737 {OPpCONST_WARNING, ",WARNING"}
740 const struct flag_to_name op_sort_names[] = {
741 {OPpSORT_NUMERIC, ",NUMERIC"},
742 {OPpSORT_INTEGER, ",INTEGER"},
743 {OPpSORT_REVERSE, ",REVERSE"},
744 {OPpSORT_INPLACE, ",INPLACE"},
745 {OPpSORT_DESCEND, ",DESCEND"},
746 {OPpSORT_QSORT, ",QSORT"},
747 {OPpSORT_STABLE, ",STABLE"}
750 const struct flag_to_name op_open_names[] = {
751 {OPpOPEN_IN_RAW, ",IN_RAW"},
752 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
753 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
754 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
757 const struct flag_to_name op_exit_names[] = {
758 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
759 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
762 #define OP_PRIVATE_ONCE(op, flag, name) \
763 const struct flag_to_name CAT2(op, _names)[] = { \
767 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
768 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
769 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
770 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
771 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
772 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
773 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
774 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
775 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
776 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
777 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
778 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
780 struct op_private_by_op {
783 const struct flag_to_name *start;
786 const struct op_private_by_op op_private_names[] = {
787 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
788 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
789 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
790 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
791 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
792 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
793 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
794 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
795 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
796 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
797 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
798 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
799 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
800 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
801 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
802 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
803 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
804 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
805 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
806 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
807 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
811 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
812 const struct op_private_by_op *start = op_private_names;
813 const struct op_private_by_op *const end
814 = op_private_names + C_ARRAY_LENGTH(op_private_names);
816 /* This is a linear search, but no worse than the code that it replaced.
817 It's debugging code - size is more important than speed. */
819 if (optype == start->op_type) {
820 S_append_flags(aTHX_ tmpsv, op_private, start->start,
821 start->start + start->len);
824 } while (++start < end);
829 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
833 const OPCODE optype = o->op_type;
835 PERL_ARGS_ASSERT_DO_OP_DUMP;
837 Perl_dump_indent(aTHX_ level, file, "{\n");
839 seq = sequence_num(o);
841 PerlIO_printf(file, "%-4"UVuf, seq);
843 PerlIO_printf(file, "????");
845 "%*sTYPE = %s ===> ",
846 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
849 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
850 sequence_num(o->op_next));
852 PerlIO_printf(file, "NULL\n");
854 if (optype == OP_NULL) {
855 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
856 if (o->op_targ == OP_NEXTSTATE) {
858 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
860 if (CopSTASHPV(cCOPo))
861 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
864 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
869 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
872 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
874 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
875 SV * const tmpsv = newSVpvs("");
876 switch (o->op_flags & OPf_WANT) {
878 sv_catpv(tmpsv, ",VOID");
880 case OPf_WANT_SCALAR:
881 sv_catpv(tmpsv, ",SCALAR");
884 sv_catpv(tmpsv, ",LIST");
887 sv_catpv(tmpsv, ",UNKNOWN");
890 append_flags(tmpsv, o->op_flags, op_flags_names);
892 sv_catpv(tmpsv, ",LATEFREE");
894 sv_catpv(tmpsv, ",LATEFREED");
896 sv_catpv(tmpsv, ",ATTACHED");
897 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
901 SV * const tmpsv = newSVpvs("");
902 if (PL_opargs[optype] & OA_TARGLEX) {
903 if (o->op_private & OPpTARGET_MY)
904 sv_catpv(tmpsv, ",TARGET_MY");
906 else if (optype == OP_ENTERSUB ||
907 optype == OP_RV2SV ||
909 optype == OP_RV2AV ||
910 optype == OP_RV2HV ||
911 optype == OP_RV2GV ||
912 optype == OP_AELEM ||
915 if (optype == OP_ENTERSUB) {
916 append_flags(tmpsv, o->op_private, op_entersub_names);
919 switch (o->op_private & OPpDEREF) {
921 sv_catpv(tmpsv, ",SV");
924 sv_catpv(tmpsv, ",AV");
927 sv_catpv(tmpsv, ",HV");
930 if (o->op_private & OPpMAYBE_LVSUB)
931 sv_catpv(tmpsv, ",MAYBE_LVSUB");
934 if (optype == OP_AELEM || optype == OP_HELEM) {
935 if (o->op_private & OPpLVAL_DEFER)
936 sv_catpv(tmpsv, ",LVAL_DEFER");
939 if (o->op_private & HINT_STRICT_REFS)
940 sv_catpv(tmpsv, ",STRICT_REFS");
941 if (o->op_private & OPpOUR_INTRO)
942 sv_catpv(tmpsv, ",OUR_INTRO");
945 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
947 else if (PL_check[optype] != Perl_ck_ftst) {
948 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
949 sv_catpv(tmpsv, ",FT_ACCESS");
950 if (o->op_private & OPpFT_STACKED)
951 sv_catpv(tmpsv, ",FT_STACKED");
953 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
954 sv_catpv(tmpsv, ",INTRO");
956 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
961 if (PL_madskills && o->op_madprop) {
962 SV * const tmpsv = newSVpvs("");
963 MADPROP* mp = o->op_madprop;
964 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
967 const char tmp = mp->mad_key;
968 sv_setpvs(tmpsv,"'");
970 sv_catpvn(tmpsv, &tmp, 1);
971 sv_catpv(tmpsv, "'=");
972 switch (mp->mad_type) {
974 sv_catpv(tmpsv, "NULL");
975 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
978 sv_catpv(tmpsv, "<");
979 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
980 sv_catpv(tmpsv, ">");
981 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
984 if ((OP*)mp->mad_val) {
985 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
986 do_op_dump(level, file, (OP*)mp->mad_val);
990 sv_catpv(tmpsv, "(UNK)");
991 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
997 Perl_dump_indent(aTHX_ level, file, "}\n");
1008 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1010 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1011 if (cSVOPo->op_sv) {
1012 SV * const tmpsv = newSV(0);
1016 /* FIXME - is this making unwarranted assumptions about the
1017 UTF-8 cleanliness of the dump file handle? */
1020 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1021 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1022 SvPV_nolen_const(tmpsv));
1026 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1032 case OP_METHOD_NAMED:
1033 #ifndef USE_ITHREADS
1034 /* with ITHREADS, consts are stored in the pad, and the right pad
1035 * may not be active here, so skip */
1036 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1042 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1043 (UV)CopLINE(cCOPo));
1044 if (CopSTASHPV(cCOPo))
1045 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1047 if (CopLABEL(cCOPo))
1048 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1052 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1053 if (cLOOPo->op_redoop)
1054 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1056 PerlIO_printf(file, "DONE\n");
1057 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1058 if (cLOOPo->op_nextop)
1059 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1061 PerlIO_printf(file, "DONE\n");
1062 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1063 if (cLOOPo->op_lastop)
1064 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1066 PerlIO_printf(file, "DONE\n");
1074 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1075 if (cLOGOPo->op_other)
1076 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1078 PerlIO_printf(file, "DONE\n");
1084 do_pmop_dump(level, file, cPMOPo);
1092 if (o->op_private & OPpREFCOUNTED)
1093 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1098 if (o->op_flags & OPf_KIDS) {
1100 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1101 do_op_dump(level, file, kid);
1103 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1107 Perl_op_dump(pTHX_ const OP *o)
1109 PERL_ARGS_ASSERT_OP_DUMP;
1110 do_op_dump(0, Perl_debug_log, o);
1114 Perl_gv_dump(pTHX_ GV *gv)
1118 PERL_ARGS_ASSERT_GV_DUMP;
1121 PerlIO_printf(Perl_debug_log, "{}\n");
1124 sv = sv_newmortal();
1125 PerlIO_printf(Perl_debug_log, "{\n");
1126 gv_fullname3(sv, gv, NULL);
1127 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1128 if (gv != GvEGV(gv)) {
1129 gv_efullname3(sv, GvEGV(gv), NULL);
1130 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1132 PerlIO_putc(Perl_debug_log, '\n');
1133 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1137 /* map magic types to the symbolic names
1138 * (with the PERL_MAGIC_ prefixed stripped)
1141 static const struct { const char type; const char *name; } magic_names[] = {
1142 #include "mg_names.c"
1143 /* this null string terminates the list */
1148 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1150 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1152 for (; mg; mg = mg->mg_moremagic) {
1153 Perl_dump_indent(aTHX_ level, file,
1154 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1155 if (mg->mg_virtual) {
1156 const MGVTBL * const v = mg->mg_virtual;
1157 if (v >= PL_magic_vtables
1158 && v < PL_magic_vtables + magic_vtable_max) {
1159 const U32 i = v - PL_magic_vtables;
1160 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1163 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1166 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1169 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1173 const char *name = NULL;
1174 for (n = 0; magic_names[n].name; n++) {
1175 if (mg->mg_type == magic_names[n].type) {
1176 name = magic_names[n].name;
1181 Perl_dump_indent(aTHX_ level, file,
1182 " MG_TYPE = PERL_MAGIC_%s\n", name);
1184 Perl_dump_indent(aTHX_ level, file,
1185 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1189 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1190 if (mg->mg_type == PERL_MAGIC_envelem &&
1191 mg->mg_flags & MGf_TAINTEDDIR)
1192 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1193 if (mg->mg_type == PERL_MAGIC_regex_global &&
1194 mg->mg_flags & MGf_MINMATCH)
1195 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1196 if (mg->mg_flags & MGf_REFCOUNTED)
1197 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1198 if (mg->mg_flags & MGf_GSKIP)
1199 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1200 if (mg->mg_flags & MGf_COPY)
1201 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1202 if (mg->mg_flags & MGf_DUP)
1203 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1204 if (mg->mg_flags & MGf_LOCAL)
1205 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1208 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1209 PTR2UV(mg->mg_obj));
1210 if (mg->mg_type == PERL_MAGIC_qr) {
1211 REGEXP* const re = (REGEXP *)mg->mg_obj;
1212 SV * const dsv = sv_newmortal();
1213 const char * const s
1214 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1216 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1217 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1219 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1220 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1223 if (mg->mg_flags & MGf_REFCOUNTED)
1224 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1227 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1229 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1230 if (mg->mg_len >= 0) {
1231 if (mg->mg_type != PERL_MAGIC_utf8) {
1232 SV * const sv = newSVpvs("");
1233 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1237 else if (mg->mg_len == HEf_SVKEY) {
1238 PerlIO_puts(file, " => HEf_SVKEY\n");
1239 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1240 maxnest, dumpops, pvlim); /* MG is already +1 */
1243 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1248 " does not know how to handle this MG_LEN"
1250 PerlIO_putc(file, '\n');
1252 if (mg->mg_type == PERL_MAGIC_utf8) {
1253 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1256 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1257 Perl_dump_indent(aTHX_ level, file,
1258 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1261 (UV)cache[i * 2 + 1]);
1268 Perl_magic_dump(pTHX_ const MAGIC *mg)
1270 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1274 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1278 PERL_ARGS_ASSERT_DO_HV_DUMP;
1280 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1281 if (sv && (hvname = HvNAME_get(sv)))
1283 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1284 name which quite legally could contain insane things like tabs, newlines, nulls or
1285 other scary crap - this should produce sane results - except maybe for unicode package
1286 names - but we will wait for someone to file a bug on that - demerphq */
1287 SV * const tmpsv = newSVpvs("");
1288 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1291 PerlIO_putc(file, '\n');
1295 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1297 PERL_ARGS_ASSERT_DO_GV_DUMP;
1299 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1300 if (sv && GvNAME(sv))
1301 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1303 PerlIO_putc(file, '\n');
1307 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1309 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1311 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1312 if (sv && GvNAME(sv)) {
1314 PerlIO_printf(file, "\t\"");
1315 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1316 PerlIO_printf(file, "%s\" :: \"", hvname);
1317 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1320 PerlIO_putc(file, '\n');
1323 const struct flag_to_name first_sv_flags_names[] = {
1324 {SVs_TEMP, "TEMP,"},
1325 {SVs_OBJECT, "OBJECT,"},
1334 const struct flag_to_name second_sv_flags_names[] = {
1336 {SVf_FAKE, "FAKE,"},
1337 {SVf_READONLY, "READONLY,"},
1338 {SVf_BREAK, "BREAK,"},
1339 {SVf_AMAGIC, "OVERLOAD,"},
1345 const struct flag_to_name cv_flags_names[] = {
1346 {CVf_ANON, "ANON,"},
1347 {CVf_UNIQUE, "UNIQUE,"},
1348 {CVf_CLONE, "CLONE,"},
1349 {CVf_CLONED, "CLONED,"},
1350 {CVf_CONST, "CONST,"},
1351 {CVf_NODEBUG, "NODEBUG,"},
1352 {CVf_LVALUE, "LVALUE,"},
1353 {CVf_METHOD, "METHOD,"},
1354 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1355 {CVf_CVGV_RC, "CVGV_RC,"},
1356 {CVf_DYNFILE, "DYNFILE,"},
1357 {CVf_AUTOLOAD, "AUTOLOAD,"},
1358 {CVf_ISXSUB, "ISXSUB,"}
1361 const struct flag_to_name hv_flags_names[] = {
1362 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1363 {SVphv_LAZYDEL, "LAZYDEL,"},
1364 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1365 {SVphv_REHASH, "REHASH,"},
1366 {SVphv_CLONEABLE, "CLONEABLE,"}
1369 const struct flag_to_name gp_flags_names[] = {
1370 {GVf_INTRO, "INTRO,"},
1371 {GVf_MULTI, "MULTI,"},
1372 {GVf_ASSUMECV, "ASSUMECV,"},
1373 {GVf_IN_PAD, "IN_PAD,"}
1376 const struct flag_to_name gp_flags_imported_names[] = {
1377 {GVf_IMPORTED_SV, " SV"},
1378 {GVf_IMPORTED_AV, " AV"},
1379 {GVf_IMPORTED_HV, " HV"},
1380 {GVf_IMPORTED_CV, " CV"},
1383 const struct flag_to_name regexp_flags_names[] = {
1384 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1385 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1386 {RXf_PMf_FOLD, "PMf_FOLD,"},
1387 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1388 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1389 {RXf_ANCH_BOL, "ANCH_BOL,"},
1390 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1391 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1392 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1393 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1394 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1395 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1396 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1397 {RXf_CANY_SEEN, "CANY_SEEN,"},
1398 {RXf_NOSCAN, "NOSCAN,"},
1399 {RXf_CHECK_ALL, "CHECK_ALL,"},
1400 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1401 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1402 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1403 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1404 {RXf_SPLIT, "SPLIT,"},
1405 {RXf_COPY_DONE, "COPY_DONE,"},
1406 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1407 {RXf_TAINTED, "TAINTED,"},
1408 {RXf_START_ONLY, "START_ONLY,"},
1409 {RXf_SKIPWHITE, "SKIPWHITE,"},
1410 {RXf_WHITE, "WHITE,"},
1411 {RXf_NULL, "NULL,"},
1415 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1423 PERL_ARGS_ASSERT_DO_SV_DUMP;
1426 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1430 flags = SvFLAGS(sv);
1433 /* process general SV flags */
1435 d = Perl_newSVpvf(aTHX_
1436 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1437 PTR2UV(SvANY(sv)), PTR2UV(sv),
1438 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1439 (int)(PL_dumpindent*level), "");
1441 if (!((flags & SVpad_NAME) == SVpad_NAME
1442 && (type == SVt_PVMG || type == SVt_PVNV))) {
1443 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1444 sv_catpv(d, "PADSTALE,");
1446 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1447 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1448 sv_catpv(d, "PADTMP,");
1449 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1451 append_flags(d, flags, first_sv_flags_names);
1452 if (flags & SVf_ROK) {
1453 sv_catpv(d, "ROK,");
1454 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1456 append_flags(d, flags, second_sv_flags_names);
1457 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1458 if (SvPCS_IMPORTED(sv))
1459 sv_catpv(d, "PCS_IMPORTED,");
1461 sv_catpv(d, "SCREAM,");
1464 /* process type-specific SV flags */
1469 append_flags(d, CvFLAGS(sv), cv_flags_names);
1472 append_flags(d, flags, hv_flags_names);
1476 if (isGV_with_GP(sv)) {
1477 append_flags(d, GvFLAGS(sv), gp_flags_names);
1479 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1480 sv_catpv(d, "IMPORT");
1481 if (GvIMPORTED(sv) == GVf_IMPORTED)
1482 sv_catpv(d, "ALL,");
1485 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1492 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1493 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1496 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1497 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1498 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1499 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1502 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1507 /* SVphv_SHAREKEYS is also 0x20000000 */
1508 if ((type != SVt_PVHV) && SvUTF8(sv))
1509 sv_catpv(d, "UTF8");
1511 if (*(SvEND(d) - 1) == ',') {
1512 SvCUR_set(d, SvCUR(d) - 1);
1513 SvPVX(d)[SvCUR(d)] = '\0';
1518 /* dump initial SV details */
1520 #ifdef DEBUG_LEAKING_SCALARS
1521 Perl_dump_indent(aTHX_ level, file,
1522 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1523 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1525 sv->sv_debug_inpad ? "for" : "by",
1526 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1527 PTR2UV(sv->sv_debug_parent),
1531 Perl_dump_indent(aTHX_ level, file, "SV = ");
1535 if (type < SVt_LAST) {
1536 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1538 if (type == SVt_NULL) {
1543 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1548 /* Dump general SV fields */
1550 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1551 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1552 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1553 || (type == SVt_IV && !SvROK(sv))) {
1555 #ifdef PERL_OLD_COPY_ON_WRITE
1559 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1561 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1562 #ifdef PERL_OLD_COPY_ON_WRITE
1563 if (SvIsCOW_shared_hash(sv))
1564 PerlIO_printf(file, " (HASH)");
1565 else if (SvIsCOW_normal(sv))
1566 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1568 PerlIO_putc(file, '\n');
1571 if ((type == SVt_PVNV || type == SVt_PVMG)
1572 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1573 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1574 (UV) COP_SEQ_RANGE_LOW(sv));
1575 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1576 (UV) COP_SEQ_RANGE_HIGH(sv));
1577 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1578 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1579 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1580 || type == SVt_NV) {
1581 STORE_NUMERIC_LOCAL_SET_STANDARD();
1582 /* %Vg doesn't work? --jhi */
1583 #ifdef USE_LONG_DOUBLE
1584 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1586 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1588 RESTORE_NUMERIC_LOCAL();
1592 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1594 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1597 if (type < SVt_PV) {
1602 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1603 if (SvPVX_const(sv)) {
1606 SvOOK_offset(sv, delta);
1607 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1612 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1614 PerlIO_printf(file, "( %s . ) ",
1615 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1618 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1619 if (SvUTF8(sv)) /* the 6? \x{....} */
1620 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1621 PerlIO_printf(file, "\n");
1622 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1623 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1626 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1629 if (type >= SVt_PVMG) {
1630 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1631 HV * const ost = SvOURSTASH(sv);
1633 do_hv_dump(level, file, " OURSTASH", ost);
1636 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1639 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1641 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1642 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1643 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1644 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1648 /* Dump type-specific SV fields */
1652 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1653 if (AvARRAY(sv) != AvALLOC(sv)) {
1654 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1655 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1658 PerlIO_putc(file, '\n');
1659 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1660 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1661 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1663 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1664 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1665 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1666 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1667 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1669 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1670 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1672 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1674 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1679 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1680 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1681 /* Show distribution of HEs in the ARRAY */
1683 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1686 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1687 NV theoret, sum = 0;
1689 PerlIO_printf(file, " (");
1690 Zero(freq, FREQ_MAX + 1, int);
1691 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1694 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1696 if (count > FREQ_MAX)
1702 for (i = 0; i <= max; i++) {
1704 PerlIO_printf(file, "%d%s:%d", i,
1705 (i == FREQ_MAX) ? "+" : "",
1708 PerlIO_printf(file, ", ");
1711 PerlIO_putc(file, ')');
1712 /* The "quality" of a hash is defined as the total number of
1713 comparisons needed to access every element once, relative
1714 to the expected number needed for a random hash.
1716 The total number of comparisons is equal to the sum of
1717 the squares of the number of entries in each bucket.
1718 For a random hash of n keys into k buckets, the expected
1723 for (i = max; i > 0; i--) { /* Precision: count down. */
1724 sum += freq[i] * i * i;
1726 while ((keys = keys >> 1))
1728 theoret = HvUSEDKEYS(sv);
1729 theoret += theoret * (theoret-1)/pow2;
1730 PerlIO_putc(file, '\n');
1731 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1733 PerlIO_putc(file, '\n');
1734 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1735 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1736 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1737 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1738 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1740 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1741 if (mg && mg->mg_obj) {
1742 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1746 const char * const hvname = HvNAME_get(sv);
1748 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1752 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1753 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1754 if (HvAUX(sv)->xhv_name_count)
1755 Perl_dump_indent(aTHX_
1756 level, file, " NAMECOUNT = %"IVdf"\n",
1757 (IV)HvAUX(sv)->xhv_name_count
1759 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1760 const I32 count = HvAUX(sv)->xhv_name_count;
1762 SV * const names = newSVpvs_flags("", SVs_TEMP);
1763 /* The starting point is the first element if count is
1764 positive and the second element if count is negative. */
1765 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1766 + (count < 0 ? 1 : 0);
1767 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1768 + (count < 0 ? -count : count);
1769 while (hekp < endp) {
1771 sv_catpvs(names, ", \"");
1772 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1773 sv_catpvs(names, "\"");
1775 /* This should never happen. */
1776 sv_catpvs(names, ", (null)");
1780 Perl_dump_indent(aTHX_
1781 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1785 Perl_dump_indent(aTHX_
1786 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1790 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1792 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1796 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1797 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1798 (int)meta->mro_which->length,
1799 meta->mro_which->name,
1800 PTR2UV(meta->mro_which));
1801 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1802 (UV)meta->cache_gen);
1803 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1805 if (meta->mro_linear_all) {
1806 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1807 PTR2UV(meta->mro_linear_all));
1808 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1811 if (meta->mro_linear_current) {
1812 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1813 PTR2UV(meta->mro_linear_current));
1814 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1817 if (meta->mro_nextmethod) {
1818 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1819 PTR2UV(meta->mro_nextmethod));
1820 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1824 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1826 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1831 if (nest < maxnest) {
1832 HV * const hv = MUTABLE_HV(sv);
1837 int count = maxnest - nest;
1838 for (i=0; i <= HvMAX(hv); i++) {
1839 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1846 if (count-- <= 0) goto DONEHV;
1849 keysv = hv_iterkeysv(he);
1850 keypv = SvPV_const(keysv, len);
1853 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1855 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1856 if (HvEITER_get(hv) == he)
1857 PerlIO_printf(file, "[CURRENT] ");
1859 PerlIO_printf(file, "[REHASH] ");
1860 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1861 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1870 if (CvAUTOLOAD(sv)) {
1872 const char *const name = SvPV_const(sv, len);
1873 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1877 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1878 (int) CvPROTOLEN(sv), CvPROTO(sv));
1882 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1883 if (!CvISXSUB(sv)) {
1885 Perl_dump_indent(aTHX_ level, file,
1886 " START = 0x%"UVxf" ===> %"IVdf"\n",
1887 PTR2UV(CvSTART(sv)),
1888 (IV)sequence_num(CvSTART(sv)));
1890 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1891 PTR2UV(CvROOT(sv)));
1892 if (CvROOT(sv) && dumpops) {
1893 do_op_dump(level+1, file, CvROOT(sv));
1896 SV * const constant = cv_const_sv((const CV *)sv);
1898 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1901 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1903 PTR2UV(CvXSUBANY(sv).any_ptr));
1904 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1907 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1908 (IV)CvXSUBANY(sv).any_i32);
1911 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1912 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1913 if (type == SVt_PVCV)
1914 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1915 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1916 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1917 if (type == SVt_PVFM)
1918 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1919 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1920 if (nest < maxnest) {
1921 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1924 const CV * const outside = CvOUTSIDE(sv);
1925 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1928 : CvANON(outside) ? "ANON"
1929 : (outside == PL_main_cv) ? "MAIN"
1930 : CvUNIQUE(outside) ? "UNIQUE"
1931 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1933 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1934 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1939 if (type == SVt_PVLV) {
1940 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1941 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1942 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1943 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1944 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1945 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1948 if (!isGV_with_GP(sv))
1950 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1951 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1952 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1953 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1956 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1957 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1958 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1959 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1960 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1961 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1962 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1963 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1964 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1965 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1966 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1967 do_gv_dump (level, file, " EGV", GvEGV(sv));
1970 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1971 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1972 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1973 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1974 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1975 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1976 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1978 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1979 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1980 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1982 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1983 PTR2UV(IoTOP_GV(sv)));
1984 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1985 maxnest, dumpops, pvlim);
1987 /* Source filters hide things that are not GVs in these three, so let's
1988 be careful out there. */
1990 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1991 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1992 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1994 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1995 PTR2UV(IoFMT_GV(sv)));
1996 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1997 maxnest, dumpops, pvlim);
1999 if (IoBOTTOM_NAME(sv))
2000 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2001 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2002 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2004 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2005 PTR2UV(IoBOTTOM_GV(sv)));
2006 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2007 maxnest, dumpops, pvlim);
2009 if (isPRINT(IoTYPE(sv)))
2010 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2012 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2013 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2017 struct regexp * const r = (struct regexp *)SvANY(sv);
2018 flags = RX_EXTFLAGS((REGEXP*)sv);
2020 append_flags(d, flags, regexp_flags_names);
2021 if (*(SvEND(d) - 1) == ',') {
2022 SvCUR_set(d, SvCUR(d) - 1);
2023 SvPVX(d)[SvCUR(d)] = '\0';
2025 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2026 (UV)flags, SvPVX_const(d));
2027 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2029 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2031 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2032 (UV)(r->lastparen));
2033 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2034 (UV)(r->lastcloseparen));
2035 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2037 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2038 (IV)(r->minlenret));
2039 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2041 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2042 (UV)(r->pre_prefix));
2043 Perl_dump_indent(aTHX_ level, file, " SEEN_EVALS = %"UVuf"\n",
2044 (UV)(r->seen_evals));
2045 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2048 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2050 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2052 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2053 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2055 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2056 PTR2UV(r->mother_re));
2057 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2058 PTR2UV(r->paren_names));
2059 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2060 PTR2UV(r->substrs));
2061 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2062 PTR2UV(r->pprivate));
2063 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2065 #ifdef PERL_OLD_COPY_ON_WRITE
2066 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2067 PTR2UV(r->saved_copy));
2076 Perl_sv_dump(pTHX_ SV *sv)
2080 PERL_ARGS_ASSERT_SV_DUMP;
2083 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2085 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2089 Perl_runops_debug(pTHX)
2093 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2097 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2100 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2101 PerlIO_printf(Perl_debug_log,
2102 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2103 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2104 PTR2UV(*PL_watchaddr));
2105 if (DEBUG_s_TEST_) {
2106 if (DEBUG_v_TEST_) {
2107 PerlIO_printf(Perl_debug_log, "\n");
2115 if (DEBUG_t_TEST_) debop(PL_op);
2116 if (DEBUG_P_TEST_) debprof(PL_op);
2118 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2119 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2126 Perl_debop(pTHX_ const OP *o)
2130 PERL_ARGS_ASSERT_DEBOP;
2132 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2135 Perl_deb(aTHX_ "%s", OP_NAME(o));
2136 switch (o->op_type) {
2139 /* With ITHREADS, consts are stored in the pad, and the right pad
2140 * may not be active here, so check.
2141 * Looks like only during compiling the pads are illegal.
2144 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2146 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2151 SV * const sv = newSV(0);
2153 /* FIXME - is this making unwarranted assumptions about the
2154 UTF-8 cleanliness of the dump file handle? */
2157 gv_fullname3(sv, cGVOPo_gv, NULL);
2158 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2162 PerlIO_printf(Perl_debug_log, "(NULL)");
2168 /* print the lexical's name */
2169 CV * const cv = deb_curcv(cxstack_ix);
2172 AV * const padlist = CvPADLIST(cv);
2173 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2174 sv = *av_fetch(comppad, o->op_targ, FALSE);
2178 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2180 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2186 PerlIO_printf(Perl_debug_log, "\n");
2191 S_deb_curcv(pTHX_ const I32 ix)
2194 const PERL_CONTEXT * const cx = &cxstack[ix];
2195 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2196 return cx->blk_sub.cv;
2197 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2198 return cx->blk_eval.cv;
2199 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2204 return deb_curcv(ix - 1);
2208 Perl_watch(pTHX_ char **addr)
2212 PERL_ARGS_ASSERT_WATCH;
2214 PL_watchaddr = addr;
2216 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2217 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2221 S_debprof(pTHX_ const OP *o)
2225 PERL_ARGS_ASSERT_DEBPROF;
2227 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2229 if (!PL_profiledata)
2230 Newxz(PL_profiledata, MAXO, U32);
2231 ++PL_profiledata[o->op_type];
2235 Perl_debprofdump(pTHX)
2239 if (!PL_profiledata)
2241 for (i = 0; i < MAXO; i++) {
2242 if (PL_profiledata[i])
2243 PerlIO_printf(Perl_debug_log,
2244 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2251 * XML variants of most of the above routines
2255 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2259 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2261 PerlIO_printf(file, "\n ");
2262 va_start(args, pat);
2263 xmldump_vindent(level, file, pat, &args);
2269 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2272 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2273 va_start(args, pat);
2274 xmldump_vindent(level, file, pat, &args);
2279 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2281 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2283 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2284 PerlIO_vprintf(file, pat, *args);
2288 Perl_xmldump_all(pTHX)
2290 xmldump_all_perl(FALSE);
2294 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2296 PerlIO_setlinebuf(PL_xmlfp);
2298 op_xmldump(PL_main_root);
2299 /* someday we might call this, when it outputs XML: */
2300 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2301 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2302 PerlIO_close(PL_xmlfp);
2307 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2309 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2310 xmldump_packsubs_perl(stash, FALSE);
2314 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2319 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2321 if (!HvARRAY(stash))
2323 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2324 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2325 GV *gv = MUTABLE_GV(HeVAL(entry));
2327 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2330 xmldump_sub_perl(gv, justperl);
2333 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2334 && (hv = GvHV(gv)) && hv != PL_defstash)
2335 xmldump_packsubs_perl(hv, justperl); /* nested package */
2341 Perl_xmldump_sub(pTHX_ const GV *gv)
2343 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2344 xmldump_sub_perl(gv, FALSE);
2348 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2352 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2354 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2357 sv = sv_newmortal();
2358 gv_fullname3(sv, gv, NULL);
2359 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2360 if (CvXSUB(GvCV(gv)))
2361 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2362 PTR2UV(CvXSUB(GvCV(gv))),
2363 (int)CvXSUBANY(GvCV(gv)).any_i32);
2364 else if (CvROOT(GvCV(gv)))
2365 op_xmldump(CvROOT(GvCV(gv)));
2367 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2371 Perl_xmldump_form(pTHX_ const GV *gv)
2373 SV * const sv = sv_newmortal();
2375 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2377 gv_fullname3(sv, gv, NULL);
2378 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2379 if (CvROOT(GvFORM(gv)))
2380 op_xmldump(CvROOT(GvFORM(gv)));
2382 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2386 Perl_xmldump_eval(pTHX)
2388 op_xmldump(PL_eval_root);
2392 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2394 PERL_ARGS_ASSERT_SV_CATXMLSV;
2395 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2399 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2401 PERL_ARGS_ASSERT_SV_CATXMLPV;
2402 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2406 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2409 const char * const e = pv + len;
2410 const char * const start = pv;
2414 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2417 dsvcur = SvCUR(dsv); /* in case we have to restart */
2422 c = utf8_to_uvchr((U8*)pv, &cl);
2424 SvCUR(dsv) = dsvcur;
2489 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2492 sv_catpvs(dsv, "<");
2495 sv_catpvs(dsv, ">");
2498 sv_catpvs(dsv, "&");
2501 sv_catpvs(dsv, """);
2505 if (c < 32 || c > 127) {
2506 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2509 const char string = (char) c;
2510 sv_catpvn(dsv, &string, 1);
2514 if ((c >= 0xD800 && c <= 0xDB7F) ||
2515 (c >= 0xDC00 && c <= 0xDFFF) ||
2516 (c >= 0xFFF0 && c <= 0xFFFF) ||
2518 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2520 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2533 Perl_sv_xmlpeek(pTHX_ SV *sv)
2535 SV * const t = sv_newmortal();
2539 PERL_ARGS_ASSERT_SV_XMLPEEK;
2545 sv_catpv(t, "VOID=\"\"");
2548 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2549 sv_catpv(t, "WILD=\"\"");
2552 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2553 if (sv == &PL_sv_undef) {
2554 sv_catpv(t, "SV_UNDEF=\"1\"");
2555 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2556 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2560 else if (sv == &PL_sv_no) {
2561 sv_catpv(t, "SV_NO=\"1\"");
2562 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2563 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2564 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2565 SVp_POK|SVp_NOK)) &&
2570 else if (sv == &PL_sv_yes) {
2571 sv_catpv(t, "SV_YES=\"1\"");
2572 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2573 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2574 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2575 SVp_POK|SVp_NOK)) &&
2577 SvPVX(sv) && *SvPVX(sv) == '1' &&
2582 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2583 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2584 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2588 sv_catpv(t, " XXX=\"\" ");
2590 else if (SvREFCNT(sv) == 0) {
2591 sv_catpv(t, " refcnt=\"0\"");
2594 else if (DEBUG_R_TEST_) {
2597 /* is this SV on the tmps stack? */
2598 for (ix=PL_tmps_ix; ix>=0; ix--) {
2599 if (PL_tmps_stack[ix] == sv) {
2604 if (SvREFCNT(sv) > 1)
2605 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2608 sv_catpv(t, " DRT=\"<T>\"");
2612 sv_catpv(t, " ROK=\"\"");
2614 switch (SvTYPE(sv)) {
2616 sv_catpv(t, " FREED=\"1\"");
2620 sv_catpv(t, " UNDEF=\"1\"");
2623 sv_catpv(t, " IV=\"");
2626 sv_catpv(t, " NV=\"");
2629 sv_catpv(t, " PV=\"");
2632 sv_catpv(t, " PVIV=\"");
2635 sv_catpv(t, " PVNV=\"");
2638 sv_catpv(t, " PVMG=\"");
2641 sv_catpv(t, " PVLV=\"");
2644 sv_catpv(t, " AV=\"");
2647 sv_catpv(t, " HV=\"");
2651 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2653 sv_catpv(t, " CV=\"()\"");
2656 sv_catpv(t, " GV=\"");
2659 sv_catpv(t, " BIND=\"");
2662 sv_catpv(t, " REGEXP=\"");
2665 sv_catpv(t, " FM=\"");
2668 sv_catpv(t, " IO=\"");
2677 else if (SvNOKp(sv)) {
2678 STORE_NUMERIC_LOCAL_SET_STANDARD();
2679 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2680 RESTORE_NUMERIC_LOCAL();
2682 else if (SvIOKp(sv)) {
2684 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2686 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2695 return SvPV(t, n_a);
2699 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2701 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2704 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2707 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2710 REGEXP *const r = PM_GETRE(pm);
2711 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2712 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2713 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2715 SvREFCNT_dec(tmpsv);
2716 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2717 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2720 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2721 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2722 SV * const tmpsv = pm_description(pm);
2723 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2724 SvREFCNT_dec(tmpsv);
2728 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2729 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2730 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2731 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2732 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2733 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2736 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2740 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2742 do_pmop_xmldump(0, PL_xmlfp, pm);
2746 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2751 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2755 seq = sequence_num(o);
2756 Perl_xmldump_indent(aTHX_ level, file,
2757 "<op_%s seq=\"%"UVuf" -> ",
2762 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2763 sequence_num(o->op_next));
2765 PerlIO_printf(file, "DONE\"");
2768 if (o->op_type == OP_NULL)
2770 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2771 if (o->op_targ == OP_NEXTSTATE)
2774 PerlIO_printf(file, " line=\"%"UVuf"\"",
2775 (UV)CopLINE(cCOPo));
2776 if (CopSTASHPV(cCOPo))
2777 PerlIO_printf(file, " package=\"%s\"",
2779 if (CopLABEL(cCOPo))
2780 PerlIO_printf(file, " label=\"%s\"",
2785 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2788 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2791 SV * const tmpsv = newSVpvs("");
2792 switch (o->op_flags & OPf_WANT) {
2794 sv_catpv(tmpsv, ",VOID");
2796 case OPf_WANT_SCALAR:
2797 sv_catpv(tmpsv, ",SCALAR");
2800 sv_catpv(tmpsv, ",LIST");
2803 sv_catpv(tmpsv, ",UNKNOWN");
2806 if (o->op_flags & OPf_KIDS)
2807 sv_catpv(tmpsv, ",KIDS");
2808 if (o->op_flags & OPf_PARENS)
2809 sv_catpv(tmpsv, ",PARENS");
2810 if (o->op_flags & OPf_STACKED)
2811 sv_catpv(tmpsv, ",STACKED");
2812 if (o->op_flags & OPf_REF)
2813 sv_catpv(tmpsv, ",REF");
2814 if (o->op_flags & OPf_MOD)
2815 sv_catpv(tmpsv, ",MOD");
2816 if (o->op_flags & OPf_SPECIAL)
2817 sv_catpv(tmpsv, ",SPECIAL");
2818 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2819 SvREFCNT_dec(tmpsv);
2821 if (o->op_private) {
2822 SV * const tmpsv = newSVpvs("");
2823 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2824 if (o->op_private & OPpTARGET_MY)
2825 sv_catpv(tmpsv, ",TARGET_MY");
2827 else if (o->op_type == OP_LEAVESUB ||
2828 o->op_type == OP_LEAVE ||
2829 o->op_type == OP_LEAVESUBLV ||
2830 o->op_type == OP_LEAVEWRITE) {
2831 if (o->op_private & OPpREFCOUNTED)
2832 sv_catpv(tmpsv, ",REFCOUNTED");
2834 else if (o->op_type == OP_AASSIGN) {
2835 if (o->op_private & OPpASSIGN_COMMON)
2836 sv_catpv(tmpsv, ",COMMON");
2838 else if (o->op_type == OP_SASSIGN) {
2839 if (o->op_private & OPpASSIGN_BACKWARDS)
2840 sv_catpv(tmpsv, ",BACKWARDS");
2842 else if (o->op_type == OP_TRANS) {
2843 if (o->op_private & OPpTRANS_SQUASH)
2844 sv_catpv(tmpsv, ",SQUASH");
2845 if (o->op_private & OPpTRANS_DELETE)
2846 sv_catpv(tmpsv, ",DELETE");
2847 if (o->op_private & OPpTRANS_COMPLEMENT)
2848 sv_catpv(tmpsv, ",COMPLEMENT");
2849 if (o->op_private & OPpTRANS_IDENTICAL)
2850 sv_catpv(tmpsv, ",IDENTICAL");
2851 if (o->op_private & OPpTRANS_GROWS)
2852 sv_catpv(tmpsv, ",GROWS");
2854 else if (o->op_type == OP_REPEAT) {
2855 if (o->op_private & OPpREPEAT_DOLIST)
2856 sv_catpv(tmpsv, ",DOLIST");
2858 else if (o->op_type == OP_ENTERSUB ||
2859 o->op_type == OP_RV2SV ||
2860 o->op_type == OP_GVSV ||
2861 o->op_type == OP_RV2AV ||
2862 o->op_type == OP_RV2HV ||
2863 o->op_type == OP_RV2GV ||
2864 o->op_type == OP_AELEM ||
2865 o->op_type == OP_HELEM )
2867 if (o->op_type == OP_ENTERSUB) {
2868 if (o->op_private & OPpENTERSUB_AMPER)
2869 sv_catpv(tmpsv, ",AMPER");
2870 if (o->op_private & OPpENTERSUB_DB)
2871 sv_catpv(tmpsv, ",DB");
2872 if (o->op_private & OPpENTERSUB_HASTARG)
2873 sv_catpv(tmpsv, ",HASTARG");
2874 if (o->op_private & OPpENTERSUB_NOPAREN)
2875 sv_catpv(tmpsv, ",NOPAREN");
2876 if (o->op_private & OPpENTERSUB_INARGS)
2877 sv_catpv(tmpsv, ",INARGS");
2880 switch (o->op_private & OPpDEREF) {
2882 sv_catpv(tmpsv, ",SV");
2885 sv_catpv(tmpsv, ",AV");
2888 sv_catpv(tmpsv, ",HV");
2891 if (o->op_private & OPpMAYBE_LVSUB)
2892 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2894 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2895 if (o->op_private & OPpLVAL_DEFER)
2896 sv_catpv(tmpsv, ",LVAL_DEFER");
2899 if (o->op_private & HINT_STRICT_REFS)
2900 sv_catpv(tmpsv, ",STRICT_REFS");
2901 if (o->op_private & OPpOUR_INTRO)
2902 sv_catpv(tmpsv, ",OUR_INTRO");
2905 else if (o->op_type == OP_CONST) {
2906 if (o->op_private & OPpCONST_BARE)
2907 sv_catpv(tmpsv, ",BARE");
2908 if (o->op_private & OPpCONST_STRICT)
2909 sv_catpv(tmpsv, ",STRICT");
2910 if (o->op_private & OPpCONST_WARNING)
2911 sv_catpv(tmpsv, ",WARNING");
2912 if (o->op_private & OPpCONST_ENTERED)
2913 sv_catpv(tmpsv, ",ENTERED");
2915 else if (o->op_type == OP_FLIP) {
2916 if (o->op_private & OPpFLIP_LINENUM)
2917 sv_catpv(tmpsv, ",LINENUM");
2919 else if (o->op_type == OP_FLOP) {
2920 if (o->op_private & OPpFLIP_LINENUM)
2921 sv_catpv(tmpsv, ",LINENUM");
2923 else if (o->op_type == OP_RV2CV) {
2924 if (o->op_private & OPpLVAL_INTRO)
2925 sv_catpv(tmpsv, ",INTRO");
2927 else if (o->op_type == OP_GV) {
2928 if (o->op_private & OPpEARLY_CV)
2929 sv_catpv(tmpsv, ",EARLY_CV");
2931 else if (o->op_type == OP_LIST) {
2932 if (o->op_private & OPpLIST_GUESSED)
2933 sv_catpv(tmpsv, ",GUESSED");
2935 else if (o->op_type == OP_DELETE) {
2936 if (o->op_private & OPpSLICE)
2937 sv_catpv(tmpsv, ",SLICE");
2939 else if (o->op_type == OP_EXISTS) {
2940 if (o->op_private & OPpEXISTS_SUB)
2941 sv_catpv(tmpsv, ",EXISTS_SUB");
2943 else if (o->op_type == OP_SORT) {
2944 if (o->op_private & OPpSORT_NUMERIC)
2945 sv_catpv(tmpsv, ",NUMERIC");
2946 if (o->op_private & OPpSORT_INTEGER)
2947 sv_catpv(tmpsv, ",INTEGER");
2948 if (o->op_private & OPpSORT_REVERSE)
2949 sv_catpv(tmpsv, ",REVERSE");
2951 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2952 if (o->op_private & OPpOPEN_IN_RAW)
2953 sv_catpv(tmpsv, ",IN_RAW");
2954 if (o->op_private & OPpOPEN_IN_CRLF)
2955 sv_catpv(tmpsv, ",IN_CRLF");
2956 if (o->op_private & OPpOPEN_OUT_RAW)
2957 sv_catpv(tmpsv, ",OUT_RAW");
2958 if (o->op_private & OPpOPEN_OUT_CRLF)
2959 sv_catpv(tmpsv, ",OUT_CRLF");
2961 else if (o->op_type == OP_EXIT) {
2962 if (o->op_private & OPpEXIT_VMSISH)
2963 sv_catpv(tmpsv, ",EXIT_VMSISH");
2964 if (o->op_private & OPpHUSH_VMSISH)
2965 sv_catpv(tmpsv, ",HUSH_VMSISH");
2967 else if (o->op_type == OP_DIE) {
2968 if (o->op_private & OPpHUSH_VMSISH)
2969 sv_catpv(tmpsv, ",HUSH_VMSISH");
2971 else if (PL_check[o->op_type] != Perl_ck_ftst) {
2972 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2973 sv_catpv(tmpsv, ",FT_ACCESS");
2974 if (o->op_private & OPpFT_STACKED)
2975 sv_catpv(tmpsv, ",FT_STACKED");
2977 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2978 sv_catpv(tmpsv, ",INTRO");
2980 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2981 SvREFCNT_dec(tmpsv);
2984 switch (o->op_type) {
2986 if (o->op_flags & OPf_SPECIAL) {
2992 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2994 if (cSVOPo->op_sv) {
2995 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2996 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3002 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3003 s = SvPV(tmpsv1,len);
3004 sv_catxmlpvn(tmpsv2, s, len, 1);
3005 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3009 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3014 case OP_METHOD_NAMED:
3015 #ifndef USE_ITHREADS
3016 /* with ITHREADS, consts are stored in the pad, and the right pad
3017 * may not be active here, so skip */
3018 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3024 PerlIO_printf(file, ">\n");
3026 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3031 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3032 (UV)CopLINE(cCOPo));
3033 if (CopSTASHPV(cCOPo))
3034 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3036 if (CopLABEL(cCOPo))
3037 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3041 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3042 if (cLOOPo->op_redoop)
3043 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3045 PerlIO_printf(file, "DONE\"");
3046 S_xmldump_attr(aTHX_ level, file, "next=\"");
3047 if (cLOOPo->op_nextop)
3048 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3050 PerlIO_printf(file, "DONE\"");
3051 S_xmldump_attr(aTHX_ level, file, "last=\"");
3052 if (cLOOPo->op_lastop)
3053 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3055 PerlIO_printf(file, "DONE\"");
3063 S_xmldump_attr(aTHX_ level, file, "other=\"");
3064 if (cLOGOPo->op_other)
3065 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3067 PerlIO_printf(file, "DONE\"");
3075 if (o->op_private & OPpREFCOUNTED)
3076 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3082 if (PL_madskills && o->op_madprop) {
3083 char prevkey = '\0';
3084 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3085 const MADPROP* mp = o->op_madprop;
3089 PerlIO_printf(file, ">\n");
3091 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3094 char tmp = mp->mad_key;
3095 sv_setpvs(tmpsv,"\"");
3097 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3098 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3099 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3102 sv_catpv(tmpsv, "\"");
3103 switch (mp->mad_type) {
3105 sv_catpv(tmpsv, "NULL");
3106 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3109 sv_catpv(tmpsv, " val=\"");
3110 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3111 sv_catpv(tmpsv, "\"");
3112 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3115 sv_catpv(tmpsv, " val=\"");
3116 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3117 sv_catpv(tmpsv, "\"");
3118 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3121 if ((OP*)mp->mad_val) {
3122 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3123 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3124 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3128 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3134 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3136 SvREFCNT_dec(tmpsv);
3139 switch (o->op_type) {
3146 PerlIO_printf(file, ">\n");
3148 do_pmop_xmldump(level, file, cPMOPo);
3154 if (o->op_flags & OPf_KIDS) {
3158 PerlIO_printf(file, ">\n");
3160 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3161 do_op_xmldump(level, file, kid);
3165 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3167 PerlIO_printf(file, " />\n");
3171 Perl_op_xmldump(pTHX_ const OP *o)
3173 PERL_ARGS_ASSERT_OP_XMLDUMP;
3175 do_op_xmldump(0, PL_xmlfp, o);
3181 * c-indentation-style: bsd
3183 * indent-tabs-mode: t
3186 * ex: set ts=8 sts=4 sw=4 noet: