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
30 static const char* const svtypenames[SVt_LAST] = {
50 static const char* const svshorttypenames[SVt_LAST] = {
75 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
76 const struct flag_to_name *const end)
79 if (flags & start->flag)
80 sv_catpv(sv, start->name);
81 } while (++start < end);
84 #define append_flags(sv, f, flags) \
85 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
90 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
93 PERL_ARGS_ASSERT_DUMP_INDENT;
95 dump_vindent(level, file, pat, &args);
100 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
103 PERL_ARGS_ASSERT_DUMP_VINDENT;
104 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
105 PerlIO_vprintf(file, pat, *args);
111 dump_all_perl(FALSE);
115 Perl_dump_all_perl(pTHX_ bool justperl)
119 PerlIO_setlinebuf(Perl_debug_log);
121 op_dump(PL_main_root);
122 dump_packsubs_perl(PL_defstash, justperl);
126 Perl_dump_packsubs(pTHX_ const HV *stash)
128 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
129 dump_packsubs_perl(stash, FALSE);
133 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
138 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
142 for (i = 0; i <= (I32) HvMAX(stash); i++) {
144 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
145 const GV * const gv = (const GV *)HeVAL(entry);
146 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
149 dump_sub_perl(gv, justperl);
152 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
153 const HV * const hv = GvHV(gv);
154 if (hv && (hv != PL_defstash))
155 dump_packsubs_perl(hv, justperl); /* nested package */
162 Perl_dump_sub(pTHX_ const GV *gv)
164 PERL_ARGS_ASSERT_DUMP_SUB;
165 dump_sub_perl(gv, FALSE);
169 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
173 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
175 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
179 gv_fullname3(sv, gv, NULL);
180 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
181 if (CvISXSUB(GvCV(gv)))
182 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
183 PTR2UV(CvXSUB(GvCV(gv))),
184 (int)CvXSUBANY(GvCV(gv)).any_i32);
185 else if (CvROOT(GvCV(gv)))
186 op_dump(CvROOT(GvCV(gv)));
188 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
192 Perl_dump_form(pTHX_ const GV *gv)
194 SV * const sv = sv_newmortal();
196 PERL_ARGS_ASSERT_DUMP_FORM;
198 gv_fullname3(sv, gv, NULL);
199 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
200 if (CvROOT(GvFORM(gv)))
201 op_dump(CvROOT(GvFORM(gv)));
203 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
210 op_dump(PL_eval_root);
215 =for apidoc pv_escape
217 Escapes at most the first "count" chars of pv and puts the results into
218 dsv such that the size of the escaped string will not exceed "max" chars
219 and will not contain any incomplete escape sequences.
221 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
222 will also be escaped.
224 Normally the SV will be cleared before the escaped string is prepared,
225 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
227 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
228 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
229 using C<is_utf8_string()> to determine if it is Unicode.
231 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
232 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
233 chars above 127 will be escaped using this style; otherwise, only chars above
234 255 will be so escaped; other non printable chars will use octal or
235 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
236 then all chars below 255 will be treated as printable and
237 will be output as literals.
239 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
240 string will be escaped, regardless of max. If the output is to be in hex,
241 then it will be returned as a plain hex
242 sequence. Thus the output will either be a single char,
243 an octal escape sequence, a special escape like C<\n> or a hex value.
245 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
246 not a '\\'. This is because regexes very often contain backslashed
247 sequences, whereas '%' is not a particularly common character in patterns.
249 Returns a pointer to the escaped text as held by dsv.
253 #define PV_ESCAPE_OCTBUFSIZE 32
256 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
257 const STRLEN count, const STRLEN max,
258 STRLEN * const escaped, const U32 flags )
260 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
261 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
262 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
263 STRLEN wrote = 0; /* chars written so far */
264 STRLEN chsize = 0; /* size of data to be written */
265 STRLEN readsize = 1; /* size of data just read */
266 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
267 const char *pv = str;
268 const char * const end = pv + count; /* end of string */
271 PERL_ARGS_ASSERT_PV_ESCAPE;
273 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
274 /* This won't alter the UTF-8 flag */
278 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
281 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
282 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
283 const U8 c = (U8)u & 0xFF;
286 || (flags & PERL_PV_ESCAPE_ALL)
287 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
289 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
290 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
293 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
294 "%cx{%"UVxf"}", esc, u);
295 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
298 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
302 case '\\' : /* fallthrough */
303 case '%' : if ( c == esc ) {
309 case '\v' : octbuf[1] = 'v'; break;
310 case '\t' : octbuf[1] = 't'; break;
311 case '\r' : octbuf[1] = 'r'; break;
312 case '\n' : octbuf[1] = 'n'; break;
313 case '\f' : octbuf[1] = 'f'; break;
321 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
322 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
325 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
332 if ( max && (wrote + chsize > max) ) {
334 } else if (chsize > 1) {
335 sv_catpvn(dsv, octbuf, chsize);
338 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
339 128-255 can be appended raw to the dsv. If dsv happens to be
340 UTF-8 then we need catpvf to upgrade them for us.
341 Or add a new API call sv_catpvc(). Think about that name, and
342 how to keep it clear that it's unlike the s of catpvs, which is
343 really an array octets, not a string. */
344 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
347 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
355 =for apidoc pv_pretty
357 Converts a string into something presentable, handling escaping via
358 pv_escape() and supporting quoting and ellipses.
360 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
361 double quoted with any double quotes in the string escaped. Otherwise
362 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
365 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
366 string were output then an ellipsis C<...> will be appended to the
367 string. Note that this happens AFTER it has been quoted.
369 If start_color is non-null then it will be inserted after the opening
370 quote (if there is one) but before the escaped text. If end_color
371 is non-null then it will be inserted after the escaped text but before
372 any quotes or ellipses.
374 Returns a pointer to the prettified text as held by dsv.
380 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
381 const STRLEN max, char const * const start_color, char const * const end_color,
384 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
387 PERL_ARGS_ASSERT_PV_PRETTY;
389 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
390 /* This won't alter the UTF-8 flag */
395 sv_catpvs(dsv, "\"");
396 else if ( flags & PERL_PV_PRETTY_LTGT )
399 if ( start_color != NULL )
400 sv_catpv(dsv, start_color);
402 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
404 if ( end_color != NULL )
405 sv_catpv(dsv, end_color);
408 sv_catpvs( dsv, "\"");
409 else if ( flags & PERL_PV_PRETTY_LTGT )
412 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
413 sv_catpvs(dsv, "...");
419 =for apidoc pv_display
423 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
425 except that an additional "\0" will be appended to the string when
426 len > cur and pv[cur] is "\0".
428 Note that the final string may be up to 7 chars longer than pvlim.
434 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
436 PERL_ARGS_ASSERT_PV_DISPLAY;
438 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
439 if (len > cur && pv[cur] == '\0')
440 sv_catpvs( dsv, "\\0");
445 Perl_sv_peek(pTHX_ SV *sv)
448 SV * const t = sv_newmortal();
458 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
459 /* detect data corruption under memory poisoning */
463 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
464 if (sv == &PL_sv_undef) {
465 sv_catpv(t, "SV_UNDEF");
466 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
467 SVs_GMG|SVs_SMG|SVs_RMG)) &&
471 else if (sv == &PL_sv_no) {
472 sv_catpv(t, "SV_NO");
473 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
474 SVs_GMG|SVs_SMG|SVs_RMG)) &&
475 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
481 else if (sv == &PL_sv_yes) {
482 sv_catpv(t, "SV_YES");
483 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
484 SVs_GMG|SVs_SMG|SVs_RMG)) &&
485 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
488 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
493 sv_catpv(t, "SV_PLACEHOLDER");
494 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
495 SVs_GMG|SVs_SMG|SVs_RMG)) &&
501 else if (SvREFCNT(sv) == 0) {
505 else if (DEBUG_R_TEST_) {
508 /* is this SV on the tmps stack? */
509 for (ix=PL_tmps_ix; ix>=0; ix--) {
510 if (PL_tmps_stack[ix] == sv) {
515 if (SvREFCNT(sv) > 1)
516 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
524 if (SvCUR(t) + unref > 10) {
525 SvCUR_set(t, unref + 3);
534 if (type == SVt_PVCV) {
535 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
537 } else if (type < SVt_LAST) {
538 sv_catpv(t, svshorttypenames[type]);
540 if (type == SVt_NULL)
543 sv_catpv(t, "FREED");
548 if (!SvPVX_const(sv))
549 sv_catpv(t, "(null)");
551 SV * const tmp = newSVpvs("");
555 SvOOK_offset(sv, delta);
556 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
558 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
560 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
561 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
563 SvREFCNT_dec_NN(tmp);
566 else if (SvNOKp(sv)) {
567 STORE_NUMERIC_LOCAL_SET_STANDARD();
568 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
569 RESTORE_NUMERIC_LOCAL();
571 else if (SvIOKp(sv)) {
573 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
575 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
583 if (TAINTING_get && SvTAINTED(sv))
584 sv_catpv(t, " [tainted]");
585 return SvPV_nolen(t);
589 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
593 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
596 Perl_dump_indent(aTHX_ level, file, "{}\n");
599 Perl_dump_indent(aTHX_ level, file, "{\n");
601 if (pm->op_pmflags & PMf_ONCE)
606 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
607 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
608 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
610 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
611 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
612 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
613 op_dump(pm->op_pmreplrootu.op_pmreplroot);
615 if (pm->op_code_list) {
616 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
617 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
618 do_op_dump(level, file, pm->op_code_list);
621 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
622 PTR2UV(pm->op_code_list));
624 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
625 SV * const tmpsv = pm_description(pm);
626 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
627 SvREFCNT_dec_NN(tmpsv);
630 Perl_dump_indent(aTHX_ level-1, file, "}\n");
633 const struct flag_to_name pmflags_flags_names[] = {
634 {PMf_CONST, ",CONST"},
636 {PMf_GLOBAL, ",GLOBAL"},
637 {PMf_CONTINUE, ",CONTINUE"},
638 {PMf_RETAINT, ",RETAINT"},
640 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
641 {PMf_HAS_CV, ",HAS_CV"},
642 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
643 {PMf_IS_QR, ",IS_QR"}
647 S_pm_description(pTHX_ const PMOP *pm)
649 SV * const desc = newSVpvs("");
650 const REGEXP * const regex = PM_GETRE(pm);
651 const U32 pmflags = pm->op_pmflags;
653 PERL_ARGS_ASSERT_PM_DESCRIPTION;
655 if (pmflags & PMf_ONCE)
656 sv_catpv(desc, ",ONCE");
658 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
659 sv_catpv(desc, ":USED");
661 if (pmflags & PMf_USED)
662 sv_catpv(desc, ":USED");
666 if (RX_ISTAINTED(regex))
667 sv_catpv(desc, ",TAINTED");
668 if (RX_CHECK_SUBSTR(regex)) {
669 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
670 sv_catpv(desc, ",SCANFIRST");
671 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
672 sv_catpv(desc, ",ALL");
674 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
675 sv_catpv(desc, ",SKIPWHITE");
678 append_flags(desc, pmflags, pmflags_flags_names);
683 Perl_pmop_dump(pTHX_ PMOP *pm)
685 do_pmop_dump(0, Perl_debug_log, pm);
688 /* Return a unique integer to represent the address of op o.
689 * If it already exists in PL_op_sequence, just return it;
691 * *** Note that this isn't thread-safe */
694 S_sequence_num(pTHX_ const OP *o)
703 op = newSVuv(PTR2UV(o));
705 key = SvPV_const(op, len);
707 PL_op_sequence = newHV();
708 seq = hv_fetch(PL_op_sequence, key, len, 0);
711 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
715 const struct flag_to_name op_flags_names[] = {
717 {OPf_PARENS, ",PARENS"},
720 {OPf_STACKED, ",STACKED"},
721 {OPf_SPECIAL, ",SPECIAL"}
724 const struct flag_to_name op_trans_names[] = {
725 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
726 {OPpTRANS_TO_UTF, ",TO_UTF"},
727 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
728 {OPpTRANS_SQUASH, ",SQUASH"},
729 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
730 {OPpTRANS_GROWS, ",GROWS"},
731 {OPpTRANS_DELETE, ",DELETE"}
734 const struct flag_to_name op_entersub_names[] = {
735 {OPpENTERSUB_DB, ",DB"},
736 {OPpENTERSUB_HASTARG, ",HASTARG"},
737 {OPpENTERSUB_AMPER, ",AMPER"},
738 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
739 {OPpENTERSUB_INARGS, ",INARGS"}
742 const struct flag_to_name op_const_names[] = {
743 {OPpCONST_NOVER, ",NOVER"},
744 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
745 {OPpCONST_STRICT, ",STRICT"},
746 {OPpCONST_ENTERED, ",ENTERED"},
747 {OPpCONST_FOLDED, ",FOLDED"},
748 {OPpCONST_BARE, ",BARE"}
751 const struct flag_to_name op_sort_names[] = {
752 {OPpSORT_NUMERIC, ",NUMERIC"},
753 {OPpSORT_INTEGER, ",INTEGER"},
754 {OPpSORT_REVERSE, ",REVERSE"},
755 {OPpSORT_INPLACE, ",INPLACE"},
756 {OPpSORT_DESCEND, ",DESCEND"},
757 {OPpSORT_QSORT, ",QSORT"},
758 {OPpSORT_STABLE, ",STABLE"}
761 const struct flag_to_name op_open_names[] = {
762 {OPpOPEN_IN_RAW, ",IN_RAW"},
763 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
764 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
765 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
768 const struct flag_to_name op_exit_names[] = {
769 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
770 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
773 const struct flag_to_name op_sassign_names[] = {
774 {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
775 {OPpASSIGN_CV_TO_GV, ",CV2GV"}
778 #define OP_PRIVATE_ONCE(op, flag, name) \
779 const struct flag_to_name CAT2(op, _names)[] = { \
783 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
784 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
785 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
786 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
787 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
788 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
789 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
790 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
791 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
792 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
793 OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
795 struct op_private_by_op {
798 const struct flag_to_name *start;
801 const struct op_private_by_op op_private_names[] = {
802 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
804 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
805 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
806 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
807 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
808 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
809 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
810 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
811 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
812 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
813 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
814 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
815 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
816 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
817 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
818 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
819 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
820 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
821 {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
822 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
826 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
827 const struct op_private_by_op *start = op_private_names;
828 const struct op_private_by_op *const end
829 = op_private_names + C_ARRAY_LENGTH(op_private_names);
831 /* This is a linear search, but no worse than the code that it replaced.
832 It's debugging code - size is more important than speed. */
834 if (optype == start->op_type) {
835 S_append_flags(aTHX_ tmpsv, op_private, start->start,
836 start->start + start->len);
839 } while (++start < end);
843 #define DUMP_OP_FLAGS(o,xml,level,file) \
844 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
845 SV * const tmpsv = newSVpvs(""); \
846 switch (o->op_flags & OPf_WANT) { \
847 case OPf_WANT_VOID: \
848 sv_catpv(tmpsv, ",VOID"); \
850 case OPf_WANT_SCALAR: \
851 sv_catpv(tmpsv, ",SCALAR"); \
853 case OPf_WANT_LIST: \
854 sv_catpv(tmpsv, ",LIST"); \
857 sv_catpv(tmpsv, ",UNKNOWN"); \
860 append_flags(tmpsv, o->op_flags, op_flags_names); \
861 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
862 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
863 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
864 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \
866 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
867 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
869 PerlIO_printf(file, " flags=\"%s\"", \
870 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
871 SvREFCNT_dec_NN(tmpsv); \
874 #if !defined(PERL_MAD)
875 # define xmldump_attr1(level, file, pat, arg)
877 # define xmldump_attr1(level, file, pat, arg) \
878 S_xmldump_attr(aTHX_ level, file, pat, arg)
881 #define DUMP_OP_PRIVATE(o,xml,level,file) \
882 if (o->op_private) { \
883 U32 optype = o->op_type; \
884 U32 oppriv = o->op_private; \
885 SV * const tmpsv = newSVpvs(""); \
886 if (PL_opargs[optype] & OA_TARGLEX) { \
887 if (oppriv & OPpTARGET_MY) \
888 sv_catpv(tmpsv, ",TARGET_MY"); \
890 else if (optype == OP_ENTERSUB || \
891 optype == OP_RV2SV || \
892 optype == OP_GVSV || \
893 optype == OP_RV2AV || \
894 optype == OP_RV2HV || \
895 optype == OP_RV2GV || \
896 optype == OP_AELEM || \
897 optype == OP_HELEM ) \
899 if (optype == OP_ENTERSUB) { \
900 append_flags(tmpsv, oppriv, op_entersub_names); \
903 switch (oppriv & OPpDEREF) { \
905 sv_catpv(tmpsv, ",SV"); \
908 sv_catpv(tmpsv, ",AV"); \
911 sv_catpv(tmpsv, ",HV"); \
914 if (oppriv & OPpMAYBE_LVSUB) \
915 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
917 if (optype == OP_AELEM || optype == OP_HELEM) { \
918 if (oppriv & OPpLVAL_DEFER) \
919 sv_catpv(tmpsv, ",LVAL_DEFER"); \
921 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
922 if (oppriv & OPpMAYBE_TRUEBOOL) \
923 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
924 if (oppriv & OPpTRUEBOOL) \
925 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
928 if (oppriv & HINT_STRICT_REFS) \
929 sv_catpv(tmpsv, ",STRICT_REFS"); \
930 if (oppriv & OPpOUR_INTRO) \
931 sv_catpv(tmpsv, ",OUR_INTRO"); \
934 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
936 else if (OP_IS_FILETEST(o->op_type)) { \
937 if (oppriv & OPpFT_ACCESS) \
938 sv_catpv(tmpsv, ",FT_ACCESS"); \
939 if (oppriv & OPpFT_STACKED) \
940 sv_catpv(tmpsv, ",FT_STACKED"); \
941 if (oppriv & OPpFT_STACKING) \
942 sv_catpv(tmpsv, ",FT_STACKING"); \
943 if (oppriv & OPpFT_AFTER_t) \
944 sv_catpv(tmpsv, ",AFTER_t"); \
946 else if (o->op_type == OP_AASSIGN) { \
947 if (oppriv & OPpASSIGN_COMMON) \
948 sv_catpvs(tmpsv, ",COMMON"); \
949 if (oppriv & OPpMAYBE_LVSUB) \
950 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
952 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
953 sv_catpv(tmpsv, ",INTRO"); \
954 if (o->op_type == OP_PADRANGE) \
955 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
956 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
957 if (SvCUR(tmpsv)) { \
959 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
961 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
963 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
965 SvREFCNT_dec_NN(tmpsv); \
970 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
974 const OPCODE optype = o->op_type;
976 PERL_ARGS_ASSERT_DO_OP_DUMP;
978 Perl_dump_indent(aTHX_ level, file, "{\n");
980 seq = sequence_num(o);
982 PerlIO_printf(file, "%-4"UVuf, seq);
984 PerlIO_printf(file, "????");
986 "%*sTYPE = %s ===> ",
987 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
990 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
991 sequence_num(o->op_next));
993 PerlIO_printf(file, "NULL\n");
995 if (optype == OP_NULL) {
996 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
997 if (o->op_targ == OP_NEXTSTATE) {
999 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1000 (UV)CopLINE(cCOPo));
1001 if (CopSTASHPV(cCOPo))
1002 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1004 if (CopLABEL(cCOPo))
1005 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1010 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1013 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1016 DUMP_OP_FLAGS(o,0,level,file);
1017 DUMP_OP_PRIVATE(o,0,level,file);
1020 if (PL_madskills && o->op_madprop) {
1021 SV * const tmpsv = newSVpvs("");
1022 MADPROP* mp = o->op_madprop;
1023 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1026 const char tmp = mp->mad_key;
1027 sv_setpvs(tmpsv,"'");
1029 sv_catpvn(tmpsv, &tmp, 1);
1030 sv_catpv(tmpsv, "'=");
1031 switch (mp->mad_type) {
1033 sv_catpv(tmpsv, "NULL");
1034 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1037 sv_catpv(tmpsv, "<");
1038 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1039 sv_catpv(tmpsv, ">");
1040 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1043 if ((OP*)mp->mad_val) {
1044 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1045 do_op_dump(level, file, (OP*)mp->mad_val);
1049 sv_catpv(tmpsv, "(UNK)");
1050 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1056 Perl_dump_indent(aTHX_ level, file, "}\n");
1058 SvREFCNT_dec_NN(tmpsv);
1067 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1069 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1070 if (cSVOPo->op_sv) {
1071 SV * const tmpsv = newSV(0);
1075 /* FIXME - is this making unwarranted assumptions about the
1076 UTF-8 cleanliness of the dump file handle? */
1079 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1080 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1081 SvPV_nolen_const(tmpsv));
1085 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1091 case OP_METHOD_NAMED:
1092 #ifndef USE_ITHREADS
1093 /* with ITHREADS, consts are stored in the pad, and the right pad
1094 * may not be active here, so skip */
1095 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1101 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1102 (UV)CopLINE(cCOPo));
1103 if (CopSTASHPV(cCOPo))
1104 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1106 if (CopLABEL(cCOPo))
1107 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1111 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1112 if (cLOOPo->op_redoop)
1113 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1115 PerlIO_printf(file, "DONE\n");
1116 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1117 if (cLOOPo->op_nextop)
1118 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1120 PerlIO_printf(file, "DONE\n");
1121 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1122 if (cLOOPo->op_lastop)
1123 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1125 PerlIO_printf(file, "DONE\n");
1133 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1134 if (cLOGOPo->op_other)
1135 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1137 PerlIO_printf(file, "DONE\n");
1143 do_pmop_dump(level, file, cPMOPo);
1151 if (o->op_private & OPpREFCOUNTED)
1152 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1157 if (o->op_flags & OPf_KIDS) {
1159 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1160 do_op_dump(level, file, kid);
1162 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1166 Perl_op_dump(pTHX_ const OP *o)
1168 PERL_ARGS_ASSERT_OP_DUMP;
1169 do_op_dump(0, Perl_debug_log, o);
1173 Perl_gv_dump(pTHX_ GV *gv)
1177 PERL_ARGS_ASSERT_GV_DUMP;
1180 PerlIO_printf(Perl_debug_log, "{}\n");
1183 sv = sv_newmortal();
1184 PerlIO_printf(Perl_debug_log, "{\n");
1185 gv_fullname3(sv, gv, NULL);
1186 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1187 if (gv != GvEGV(gv)) {
1188 gv_efullname3(sv, GvEGV(gv), NULL);
1189 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1191 PerlIO_putc(Perl_debug_log, '\n');
1192 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1196 /* map magic types to the symbolic names
1197 * (with the PERL_MAGIC_ prefixed stripped)
1200 static const struct { const char type; const char *name; } magic_names[] = {
1201 #include "mg_names.c"
1202 /* this null string terminates the list */
1207 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1209 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1211 for (; mg; mg = mg->mg_moremagic) {
1212 Perl_dump_indent(aTHX_ level, file,
1213 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1214 if (mg->mg_virtual) {
1215 const MGVTBL * const v = mg->mg_virtual;
1216 if (v >= PL_magic_vtables
1217 && v < PL_magic_vtables + magic_vtable_max) {
1218 const U32 i = v - PL_magic_vtables;
1219 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1222 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1225 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1228 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1232 const char *name = NULL;
1233 for (n = 0; magic_names[n].name; n++) {
1234 if (mg->mg_type == magic_names[n].type) {
1235 name = magic_names[n].name;
1240 Perl_dump_indent(aTHX_ level, file,
1241 " MG_TYPE = PERL_MAGIC_%s\n", name);
1243 Perl_dump_indent(aTHX_ level, file,
1244 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1248 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1249 if (mg->mg_type == PERL_MAGIC_envelem &&
1250 mg->mg_flags & MGf_TAINTEDDIR)
1251 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1252 if (mg->mg_type == PERL_MAGIC_regex_global &&
1253 mg->mg_flags & MGf_MINMATCH)
1254 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1255 if (mg->mg_flags & MGf_REFCOUNTED)
1256 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1257 if (mg->mg_flags & MGf_GSKIP)
1258 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1259 if (mg->mg_flags & MGf_COPY)
1260 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1261 if (mg->mg_flags & MGf_DUP)
1262 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1263 if (mg->mg_flags & MGf_LOCAL)
1264 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1267 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1268 PTR2UV(mg->mg_obj));
1269 if (mg->mg_type == PERL_MAGIC_qr) {
1270 REGEXP* const re = (REGEXP *)mg->mg_obj;
1271 SV * const dsv = sv_newmortal();
1272 const char * const s
1273 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1275 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1276 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1278 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1279 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1282 if (mg->mg_flags & MGf_REFCOUNTED)
1283 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1286 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1288 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1289 if (mg->mg_len >= 0) {
1290 if (mg->mg_type != PERL_MAGIC_utf8) {
1291 SV * const sv = newSVpvs("");
1292 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1293 SvREFCNT_dec_NN(sv);
1296 else if (mg->mg_len == HEf_SVKEY) {
1297 PerlIO_puts(file, " => HEf_SVKEY\n");
1298 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1299 maxnest, dumpops, pvlim); /* MG is already +1 */
1302 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1307 " does not know how to handle this MG_LEN"
1309 PerlIO_putc(file, '\n');
1311 if (mg->mg_type == PERL_MAGIC_utf8) {
1312 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1315 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1316 Perl_dump_indent(aTHX_ level, file,
1317 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1320 (UV)cache[i * 2 + 1]);
1327 Perl_magic_dump(pTHX_ const MAGIC *mg)
1329 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1333 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1337 PERL_ARGS_ASSERT_DO_HV_DUMP;
1339 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1340 if (sv && (hvname = HvNAME_get(sv)))
1342 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1343 name which quite legally could contain insane things like tabs, newlines, nulls or
1344 other scary crap - this should produce sane results - except maybe for unicode package
1345 names - but we will wait for someone to file a bug on that - demerphq */
1346 SV * const tmpsv = newSVpvs("");
1347 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1350 PerlIO_putc(file, '\n');
1354 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1356 PERL_ARGS_ASSERT_DO_GV_DUMP;
1358 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1359 if (sv && GvNAME(sv))
1360 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1362 PerlIO_putc(file, '\n');
1366 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1368 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1370 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1371 if (sv && GvNAME(sv)) {
1373 PerlIO_printf(file, "\t\"");
1374 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1375 PerlIO_printf(file, "%s\" :: \"", hvname);
1376 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1379 PerlIO_putc(file, '\n');
1382 const struct flag_to_name first_sv_flags_names[] = {
1383 {SVs_TEMP, "TEMP,"},
1384 {SVs_OBJECT, "OBJECT,"},
1393 const struct flag_to_name second_sv_flags_names[] = {
1395 {SVf_FAKE, "FAKE,"},
1396 {SVf_READONLY, "READONLY,"},
1397 {SVf_IsCOW, "IsCOW,"},
1398 {SVf_BREAK, "BREAK,"},
1399 {SVf_AMAGIC, "OVERLOAD,"},
1405 const struct flag_to_name cv_flags_names[] = {
1406 {CVf_ANON, "ANON,"},
1407 {CVf_UNIQUE, "UNIQUE,"},
1408 {CVf_CLONE, "CLONE,"},
1409 {CVf_CLONED, "CLONED,"},
1410 {CVf_CONST, "CONST,"},
1411 {CVf_NODEBUG, "NODEBUG,"},
1412 {CVf_LVALUE, "LVALUE,"},
1413 {CVf_METHOD, "METHOD,"},
1414 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1415 {CVf_CVGV_RC, "CVGV_RC,"},
1416 {CVf_DYNFILE, "DYNFILE,"},
1417 {CVf_AUTOLOAD, "AUTOLOAD,"},
1418 {CVf_HASEVAL, "HASEVAL"},
1419 {CVf_SLABBED, "SLABBED,"},
1420 {CVf_ISXSUB, "ISXSUB,"}
1423 const struct flag_to_name hv_flags_names[] = {
1424 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1425 {SVphv_LAZYDEL, "LAZYDEL,"},
1426 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1427 {SVphv_CLONEABLE, "CLONEABLE,"}
1430 const struct flag_to_name gp_flags_names[] = {
1431 {GVf_INTRO, "INTRO,"},
1432 {GVf_MULTI, "MULTI,"},
1433 {GVf_ASSUMECV, "ASSUMECV,"},
1434 {GVf_IN_PAD, "IN_PAD,"}
1437 const struct flag_to_name gp_flags_imported_names[] = {
1438 {GVf_IMPORTED_SV, " SV"},
1439 {GVf_IMPORTED_AV, " AV"},
1440 {GVf_IMPORTED_HV, " HV"},
1441 {GVf_IMPORTED_CV, " CV"},
1444 const struct flag_to_name regexp_flags_names[] = {
1445 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1446 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1447 {RXf_PMf_FOLD, "PMf_FOLD,"},
1448 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1449 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1450 {RXf_ANCH_BOL, "ANCH_BOL,"},
1451 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1452 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1453 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1454 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1455 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1456 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1457 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1458 {RXf_CANY_SEEN, "CANY_SEEN,"},
1459 {RXf_NOSCAN, "NOSCAN,"},
1460 {RXf_CHECK_ALL, "CHECK_ALL,"},
1461 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1462 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1463 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1464 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1465 {RXf_SPLIT, "SPLIT,"},
1466 {RXf_COPY_DONE, "COPY_DONE,"},
1467 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1468 {RXf_TAINTED, "TAINTED,"},
1469 {RXf_START_ONLY, "START_ONLY,"},
1470 {RXf_SKIPWHITE, "SKIPWHITE,"},
1471 {RXf_WHITE, "WHITE,"},
1472 {RXf_NULL, "NULL,"},
1476 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1484 PERL_ARGS_ASSERT_DO_SV_DUMP;
1487 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1491 flags = SvFLAGS(sv);
1494 /* process general SV flags */
1496 d = Perl_newSVpvf(aTHX_
1497 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1498 PTR2UV(SvANY(sv)), PTR2UV(sv),
1499 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1500 (int)(PL_dumpindent*level), "");
1502 if (!((flags & SVpad_NAME) == SVpad_NAME
1503 && (type == SVt_PVMG || type == SVt_PVNV))) {
1504 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1505 sv_catpv(d, "PADSTALE,");
1507 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1508 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1509 sv_catpv(d, "PADTMP,");
1510 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1512 append_flags(d, flags, first_sv_flags_names);
1513 if (flags & SVf_ROK) {
1514 sv_catpv(d, "ROK,");
1515 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1517 append_flags(d, flags, second_sv_flags_names);
1518 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1519 && type != SVt_PVAV) {
1520 if (SvPCS_IMPORTED(sv))
1521 sv_catpv(d, "PCS_IMPORTED,");
1523 sv_catpv(d, "SCREAM,");
1526 /* process type-specific SV flags */
1531 append_flags(d, CvFLAGS(sv), cv_flags_names);
1534 append_flags(d, flags, hv_flags_names);
1538 if (isGV_with_GP(sv)) {
1539 append_flags(d, GvFLAGS(sv), gp_flags_names);
1541 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1542 sv_catpv(d, "IMPORT");
1543 if (GvIMPORTED(sv) == GVf_IMPORTED)
1544 sv_catpv(d, "ALL,");
1547 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1554 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1555 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1558 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1559 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1560 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1561 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1564 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1567 if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1570 /* SVphv_SHAREKEYS is also 0x20000000 */
1571 if ((type != SVt_PVHV) && SvUTF8(sv))
1572 sv_catpv(d, "UTF8");
1574 if (*(SvEND(d) - 1) == ',') {
1575 SvCUR_set(d, SvCUR(d) - 1);
1576 SvPVX(d)[SvCUR(d)] = '\0';
1581 /* dump initial SV details */
1583 #ifdef DEBUG_LEAKING_SCALARS
1584 Perl_dump_indent(aTHX_ level, file,
1585 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1586 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1588 sv->sv_debug_inpad ? "for" : "by",
1589 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1590 PTR2UV(sv->sv_debug_parent),
1594 Perl_dump_indent(aTHX_ level, file, "SV = ");
1598 if (type < SVt_LAST) {
1599 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1601 if (type == SVt_NULL) {
1606 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1611 /* Dump general SV fields */
1613 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1614 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1615 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1616 || (type == SVt_IV && !SvROK(sv))) {
1618 #ifdef PERL_OLD_COPY_ON_WRITE
1622 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1624 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1625 #ifdef PERL_OLD_COPY_ON_WRITE
1626 if (SvIsCOW_shared_hash(sv))
1627 PerlIO_printf(file, " (HASH)");
1628 else if (SvIsCOW_normal(sv))
1629 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1631 PerlIO_putc(file, '\n');
1634 if ((type == SVt_PVNV || type == SVt_PVMG)
1635 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1636 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1637 (UV) COP_SEQ_RANGE_LOW(sv));
1638 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1639 (UV) COP_SEQ_RANGE_HIGH(sv));
1640 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1641 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1642 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1643 || type == SVt_NV) {
1644 STORE_NUMERIC_LOCAL_SET_STANDARD();
1645 /* %Vg doesn't work? --jhi */
1646 #ifdef USE_LONG_DOUBLE
1647 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1649 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1651 RESTORE_NUMERIC_LOCAL();
1655 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1657 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1660 if (type < SVt_PV) {
1665 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1666 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1667 const bool re = isREGEXP(sv);
1668 const char * const ptr =
1669 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1673 SvOOK_offset(sv, delta);
1674 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1679 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1681 PerlIO_printf(file, "( %s . ) ",
1682 pv_display(d, ptr - delta, delta, 0,
1685 if (type == SVt_INVLIST) {
1686 PerlIO_printf(file, "\n");
1687 /* 4 blanks indents 2 beyond the PV, etc */
1688 _invlist_dump(file, level, " ", sv);
1691 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1694 if (SvUTF8(sv)) /* the 6? \x{....} */
1695 PerlIO_printf(file, " [UTF8 \"%s\"]",
1696 sv_uni_display(d, sv, 6 * SvCUR(sv),
1698 PerlIO_printf(file, "\n");
1700 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1702 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1704 #ifdef PERL_NEW_COPY_ON_WRITE
1705 if (SvIsCOW(sv) && SvLEN(sv))
1706 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1711 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1714 if (type >= SVt_PVMG) {
1715 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1716 HV * const ost = SvOURSTASH(sv);
1718 do_hv_dump(level, file, " OURSTASH", ost);
1719 } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1720 Perl_dump_indent(aTHX_ level, file, " MAXNAMED = %"UVuf"\n",
1721 (UV)PadnamelistMAXNAMED(sv));
1724 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1727 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1729 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1730 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1734 /* Dump type-specific SV fields */
1738 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1739 if (AvARRAY(sv) != AvALLOC(sv)) {
1740 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1741 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1744 PerlIO_putc(file, '\n');
1745 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1746 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1747 /* arylen is stored in magic, and padnamelists use SvMAGIC for
1749 if (!AvPAD_NAMELIST(sv))
1750 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1751 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1753 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1754 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1755 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1756 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1757 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1759 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1760 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1762 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1764 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1769 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1770 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1771 /* Show distribution of HEs in the ARRAY */
1773 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1776 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1777 NV theoret, sum = 0;
1779 PerlIO_printf(file, " (");
1780 Zero(freq, FREQ_MAX + 1, int);
1781 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1784 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1786 if (count > FREQ_MAX)
1792 for (i = 0; i <= max; i++) {
1794 PerlIO_printf(file, "%d%s:%d", i,
1795 (i == FREQ_MAX) ? "+" : "",
1798 PerlIO_printf(file, ", ");
1801 PerlIO_putc(file, ')');
1802 /* The "quality" of a hash is defined as the total number of
1803 comparisons needed to access every element once, relative
1804 to the expected number needed for a random hash.
1806 The total number of comparisons is equal to the sum of
1807 the squares of the number of entries in each bucket.
1808 For a random hash of n keys into k buckets, the expected
1813 for (i = max; i > 0; i--) { /* Precision: count down. */
1814 sum += freq[i] * i * i;
1816 while ((keys = keys >> 1))
1818 theoret = HvUSEDKEYS(sv);
1819 theoret += theoret * (theoret-1)/pow2;
1820 PerlIO_putc(file, '\n');
1821 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1823 PerlIO_putc(file, '\n');
1824 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1827 HE **ents = HvARRAY(sv);
1830 HE *const *const last = ents + HvMAX(sv);
1831 count = last + 1 - ents;
1836 } while (++ents <= last);
1840 struct xpvhv_aux *const aux = HvAUX(sv);
1841 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1842 " (cached = %"UVuf")\n",
1843 (UV)count, (UV)aux->xhv_fill_lazy);
1845 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1849 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1851 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1852 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1853 #ifdef PERL_HASH_RANDOMIZE_KEYS
1854 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1855 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1856 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1859 PerlIO_putc(file, '\n');
1862 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1863 if (mg && mg->mg_obj) {
1864 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1868 const char * const hvname = HvNAME_get(sv);
1870 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1874 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1875 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1876 if (HvAUX(sv)->xhv_name_count)
1877 Perl_dump_indent(aTHX_
1878 level, file, " NAMECOUNT = %"IVdf"\n",
1879 (IV)HvAUX(sv)->xhv_name_count
1881 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1882 const I32 count = HvAUX(sv)->xhv_name_count;
1884 SV * const names = newSVpvs_flags("", SVs_TEMP);
1885 /* The starting point is the first element if count is
1886 positive and the second element if count is negative. */
1887 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1888 + (count < 0 ? 1 : 0);
1889 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1890 + (count < 0 ? -count : count);
1891 while (hekp < endp) {
1893 sv_catpvs(names, ", \"");
1894 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1895 sv_catpvs(names, "\"");
1897 /* This should never happen. */
1898 sv_catpvs(names, ", (null)");
1902 Perl_dump_indent(aTHX_
1903 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1907 Perl_dump_indent(aTHX_
1908 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1912 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1914 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1918 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1919 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1920 (int)meta->mro_which->length,
1921 meta->mro_which->name,
1922 PTR2UV(meta->mro_which));
1923 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1924 (UV)meta->cache_gen);
1925 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1927 if (meta->mro_linear_all) {
1928 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1929 PTR2UV(meta->mro_linear_all));
1930 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1933 if (meta->mro_linear_current) {
1934 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1935 PTR2UV(meta->mro_linear_current));
1936 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1939 if (meta->mro_nextmethod) {
1940 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1941 PTR2UV(meta->mro_nextmethod));
1942 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1946 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1948 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1953 if (nest < maxnest) {
1954 HV * const hv = MUTABLE_HV(sv);
1959 int count = maxnest - nest;
1960 for (i=0; i <= HvMAX(hv); i++) {
1961 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1968 if (count-- <= 0) goto DONEHV;
1971 keysv = hv_iterkeysv(he);
1972 keypv = SvPV_const(keysv, len);
1975 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1977 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1978 if (HvEITER_get(hv) == he)
1979 PerlIO_printf(file, "[CURRENT] ");
1980 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1981 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1990 if (CvAUTOLOAD(sv)) {
1992 const char *const name = SvPV_const(sv, len);
1993 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1997 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1998 (int) CvPROTOLEN(sv), CvPROTO(sv));
2002 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2003 if (!CvISXSUB(sv)) {
2005 Perl_dump_indent(aTHX_ level, file,
2006 " START = 0x%"UVxf" ===> %"IVdf"\n",
2007 PTR2UV(CvSTART(sv)),
2008 (IV)sequence_num(CvSTART(sv)));
2010 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
2011 PTR2UV(CvROOT(sv)));
2012 if (CvROOT(sv) && dumpops) {
2013 do_op_dump(level+1, file, CvROOT(sv));
2016 SV * const constant = cv_const_sv((const CV *)sv);
2018 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2021 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2023 PTR2UV(CvXSUBANY(sv).any_ptr));
2024 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2027 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2028 (IV)CvXSUBANY(sv).any_i32);
2032 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2033 HEK_KEY(CvNAME_HEK((CV *)sv)));
2034 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2035 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2036 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2037 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2038 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2039 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2040 if (nest < maxnest) {
2041 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2044 const CV * const outside = CvOUTSIDE(sv);
2045 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2048 : CvANON(outside) ? "ANON"
2049 : (outside == PL_main_cv) ? "MAIN"
2050 : CvUNIQUE(outside) ? "UNIQUE"
2051 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2053 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2054 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2059 if (type == SVt_PVLV) {
2060 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2061 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2062 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2063 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2064 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2065 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2066 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2069 if (isREGEXP(sv)) goto dumpregexp;
2070 if (!isGV_with_GP(sv))
2072 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2073 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2074 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2075 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2078 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2079 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2080 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2081 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2082 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2083 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2084 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2085 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2086 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2087 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2088 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2089 do_gv_dump (level, file, " EGV", GvEGV(sv));
2092 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2093 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2094 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2095 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2096 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2097 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2098 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2100 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2101 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2102 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2104 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2105 PTR2UV(IoTOP_GV(sv)));
2106 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2107 maxnest, dumpops, pvlim);
2109 /* Source filters hide things that are not GVs in these three, so let's
2110 be careful out there. */
2112 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2113 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2114 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2116 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2117 PTR2UV(IoFMT_GV(sv)));
2118 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2119 maxnest, dumpops, pvlim);
2121 if (IoBOTTOM_NAME(sv))
2122 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2123 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2124 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2126 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2127 PTR2UV(IoBOTTOM_GV(sv)));
2128 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2129 maxnest, dumpops, pvlim);
2131 if (isPRINT(IoTYPE(sv)))
2132 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2134 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2135 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2140 struct regexp * const r = ReANY((REGEXP*)sv);
2141 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
2143 append_flags(d, flags, regexp_flags_names); \
2144 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2145 SvCUR_set(d, SvCUR(d) - 1); \
2146 SvPVX(d)[SvCUR(d)] = '\0'; \
2149 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
2150 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2151 (UV)(r->compflags), SvPVX_const(d));
2153 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
2154 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2155 (UV)(r->extflags), SvPVX_const(d));
2156 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2158 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2160 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2162 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2163 (UV)(r->lastparen));
2164 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2165 (UV)(r->lastcloseparen));
2166 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2168 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2169 (IV)(r->minlenret));
2170 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2172 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2173 (UV)(r->pre_prefix));
2174 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2176 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2177 (IV)(r->suboffset));
2178 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2179 (IV)(r->subcoffset));
2181 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2183 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2185 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2186 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2188 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2189 PTR2UV(r->mother_re));
2190 if (nest < maxnest && r->mother_re)
2191 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2192 maxnest, dumpops, pvlim);
2193 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2194 PTR2UV(r->paren_names));
2195 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2196 PTR2UV(r->substrs));
2197 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2198 PTR2UV(r->pprivate));
2199 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2201 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2202 PTR2UV(r->qr_anoncv));
2204 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2205 PTR2UV(r->saved_copy));
2214 Perl_sv_dump(pTHX_ SV *sv)
2218 PERL_ARGS_ASSERT_SV_DUMP;
2221 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2223 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2227 Perl_runops_debug(pTHX)
2231 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2235 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2237 #ifdef PERL_TRACE_OPS
2238 ++PL_op_exec_cnt[PL_op->op_type];
2241 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2242 PerlIO_printf(Perl_debug_log,
2243 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2244 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2245 PTR2UV(*PL_watchaddr));
2246 if (DEBUG_s_TEST_) {
2247 if (DEBUG_v_TEST_) {
2248 PerlIO_printf(Perl_debug_log, "\n");
2256 if (DEBUG_t_TEST_) debop(PL_op);
2257 if (DEBUG_P_TEST_) debprof(PL_op);
2260 OP_ENTRY_PROBE(OP_NAME(PL_op));
2261 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2262 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2270 Perl_debop(pTHX_ const OP *o)
2274 PERL_ARGS_ASSERT_DEBOP;
2276 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2279 Perl_deb(aTHX_ "%s", OP_NAME(o));
2280 switch (o->op_type) {
2283 /* With ITHREADS, consts are stored in the pad, and the right pad
2284 * may not be active here, so check.
2285 * Looks like only during compiling the pads are illegal.
2288 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2290 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2295 SV * const sv = newSV(0);
2297 /* FIXME - is this making unwarranted assumptions about the
2298 UTF-8 cleanliness of the dump file handle? */
2301 gv_fullname3(sv, cGVOPo_gv, NULL);
2302 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2303 SvREFCNT_dec_NN(sv);
2306 PerlIO_printf(Perl_debug_log, "(NULL)");
2318 count = o->op_private & OPpPADRANGE_COUNTMASK;
2320 /* print the lexical's name */
2322 CV * const cv = deb_curcv(cxstack_ix);
2324 PAD * comppad = NULL;
2328 PADLIST * const padlist = CvPADLIST(cv);
2329 comppad = *PadlistARRAY(padlist);
2331 PerlIO_printf(Perl_debug_log, "(");
2332 for (i = 0; i < count; i++) {
2334 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2335 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2337 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2340 PerlIO_printf(Perl_debug_log, ",");
2342 PerlIO_printf(Perl_debug_log, ")");
2350 PerlIO_printf(Perl_debug_log, "\n");
2355 S_deb_curcv(pTHX_ const I32 ix)
2358 const PERL_CONTEXT * const cx = &cxstack[ix];
2359 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2360 return cx->blk_sub.cv;
2361 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2362 return cx->blk_eval.cv;
2363 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2368 return deb_curcv(ix - 1);
2372 Perl_watch(pTHX_ char **addr)
2376 PERL_ARGS_ASSERT_WATCH;
2378 PL_watchaddr = addr;
2380 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2381 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2385 S_debprof(pTHX_ const OP *o)
2389 PERL_ARGS_ASSERT_DEBPROF;
2391 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2393 if (!PL_profiledata)
2394 Newxz(PL_profiledata, MAXO, U32);
2395 ++PL_profiledata[o->op_type];
2399 Perl_debprofdump(pTHX)
2403 if (!PL_profiledata)
2405 for (i = 0; i < MAXO; i++) {
2406 if (PL_profiledata[i])
2407 PerlIO_printf(Perl_debug_log,
2408 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2415 * XML variants of most of the above routines
2419 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2423 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2425 PerlIO_printf(file, "\n ");
2426 va_start(args, pat);
2427 xmldump_vindent(level, file, pat, &args);
2433 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2436 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2437 va_start(args, pat);
2438 xmldump_vindent(level, file, pat, &args);
2443 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2445 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2447 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2448 PerlIO_vprintf(file, pat, *args);
2452 Perl_xmldump_all(pTHX)
2454 xmldump_all_perl(FALSE);
2458 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2460 PerlIO_setlinebuf(PL_xmlfp);
2462 op_xmldump(PL_main_root);
2463 /* someday we might call this, when it outputs XML: */
2464 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2465 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2466 PerlIO_close(PL_xmlfp);
2471 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2473 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2474 xmldump_packsubs_perl(stash, FALSE);
2478 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2483 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2485 if (!HvARRAY(stash))
2487 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2488 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2489 GV *gv = MUTABLE_GV(HeVAL(entry));
2491 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2494 xmldump_sub_perl(gv, justperl);
2497 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2498 && (hv = GvHV(gv)) && hv != PL_defstash)
2499 xmldump_packsubs_perl(hv, justperl); /* nested package */
2505 Perl_xmldump_sub(pTHX_ const GV *gv)
2507 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2508 xmldump_sub_perl(gv, FALSE);
2512 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2516 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2518 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2521 sv = sv_newmortal();
2522 gv_fullname3(sv, gv, NULL);
2523 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2524 if (CvXSUB(GvCV(gv)))
2525 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2526 PTR2UV(CvXSUB(GvCV(gv))),
2527 (int)CvXSUBANY(GvCV(gv)).any_i32);
2528 else if (CvROOT(GvCV(gv)))
2529 op_xmldump(CvROOT(GvCV(gv)));
2531 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2535 Perl_xmldump_form(pTHX_ const GV *gv)
2537 SV * const sv = sv_newmortal();
2539 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2541 gv_fullname3(sv, gv, NULL);
2542 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2543 if (CvROOT(GvFORM(gv)))
2544 op_xmldump(CvROOT(GvFORM(gv)));
2546 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2550 Perl_xmldump_eval(pTHX)
2552 op_xmldump(PL_eval_root);
2556 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2558 PERL_ARGS_ASSERT_SV_CATXMLSV;
2559 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2563 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2565 PERL_ARGS_ASSERT_SV_CATXMLPV;
2566 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2570 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2573 const char * const e = pv + len;
2574 const char * const start = pv;
2578 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2581 dsvcur = SvCUR(dsv); /* in case we have to restart */
2586 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2588 SvCUR(dsv) = dsvcur;
2653 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2656 sv_catpvs(dsv, "<");
2659 sv_catpvs(dsv, ">");
2662 sv_catpvs(dsv, "&");
2665 sv_catpvs(dsv, """);
2669 if (c < 32 || c > 127) {
2670 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2673 const char string = (char) c;
2674 sv_catpvn(dsv, &string, 1);
2678 if ((c >= 0xD800 && c <= 0xDB7F) ||
2679 (c >= 0xDC00 && c <= 0xDFFF) ||
2680 (c >= 0xFFF0 && c <= 0xFFFF) ||
2682 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2684 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2697 Perl_sv_xmlpeek(pTHX_ SV *sv)
2699 SV * const t = sv_newmortal();
2703 PERL_ARGS_ASSERT_SV_XMLPEEK;
2709 sv_catpv(t, "VOID=\"\"");
2712 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2713 sv_catpv(t, "WILD=\"\"");
2716 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2717 if (sv == &PL_sv_undef) {
2718 sv_catpv(t, "SV_UNDEF=\"1\"");
2719 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2720 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2724 else if (sv == &PL_sv_no) {
2725 sv_catpv(t, "SV_NO=\"1\"");
2726 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2727 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2728 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2729 SVp_POK|SVp_NOK)) &&
2734 else if (sv == &PL_sv_yes) {
2735 sv_catpv(t, "SV_YES=\"1\"");
2736 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2737 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2738 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2739 SVp_POK|SVp_NOK)) &&
2741 SvPVX(sv) && *SvPVX(sv) == '1' &&
2746 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2747 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2748 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2752 sv_catpv(t, " XXX=\"\" ");
2754 else if (SvREFCNT(sv) == 0) {
2755 sv_catpv(t, " refcnt=\"0\"");
2758 else if (DEBUG_R_TEST_) {
2761 /* is this SV on the tmps stack? */
2762 for (ix=PL_tmps_ix; ix>=0; ix--) {
2763 if (PL_tmps_stack[ix] == sv) {
2768 if (SvREFCNT(sv) > 1)
2769 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2772 sv_catpv(t, " DRT=\"<T>\"");
2776 sv_catpv(t, " ROK=\"\"");
2778 switch (SvTYPE(sv)) {
2780 sv_catpv(t, " FREED=\"1\"");
2784 sv_catpv(t, " UNDEF=\"1\"");
2787 sv_catpv(t, " IV=\"");
2790 sv_catpv(t, " NV=\"");
2793 sv_catpv(t, " PV=\"");
2796 sv_catpv(t, " PVIV=\"");
2799 sv_catpv(t, " PVNV=\"");
2802 sv_catpv(t, " PVMG=\"");
2805 sv_catpv(t, " PVLV=\"");
2808 sv_catpv(t, " AV=\"");
2811 sv_catpv(t, " HV=\"");
2815 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2817 sv_catpv(t, " CV=\"()\"");
2820 sv_catpv(t, " GV=\"");
2823 sv_catpv(t, " DUMMY=\"");
2826 sv_catpv(t, " REGEXP=\"");
2829 sv_catpv(t, " FM=\"");
2832 sv_catpv(t, " IO=\"");
2841 else if (SvNOKp(sv)) {
2842 STORE_NUMERIC_LOCAL_SET_STANDARD();
2843 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2844 RESTORE_NUMERIC_LOCAL();
2846 else if (SvIOKp(sv)) {
2848 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2850 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2859 return SvPV(t, n_a);
2863 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2865 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2868 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2871 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2874 REGEXP *const r = PM_GETRE(pm);
2875 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2876 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2877 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2879 SvREFCNT_dec_NN(tmpsv);
2880 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2881 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2884 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2885 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2886 SV * const tmpsv = pm_description(pm);
2887 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2888 SvREFCNT_dec_NN(tmpsv);
2892 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2893 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2894 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2895 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2896 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2897 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2900 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2904 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2906 do_pmop_xmldump(0, PL_xmlfp, pm);
2910 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2914 const OPCODE optype = o->op_type;
2916 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2920 seq = sequence_num(o);
2921 Perl_xmldump_indent(aTHX_ level, file,
2922 "<op_%s seq=\"%"UVuf" -> ",
2927 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2928 sequence_num(o->op_next));
2930 PerlIO_printf(file, "DONE\"");
2933 if (optype == OP_NULL)
2935 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2936 if (o->op_targ == OP_NEXTSTATE)
2939 PerlIO_printf(file, " line=\"%"UVuf"\"",
2940 (UV)CopLINE(cCOPo));
2941 if (CopSTASHPV(cCOPo))
2942 PerlIO_printf(file, " package=\"%s\"",
2944 if (CopLABEL(cCOPo))
2945 PerlIO_printf(file, " label=\"%s\"",
2950 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2953 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2956 DUMP_OP_FLAGS(o,1,0,file);
2957 DUMP_OP_PRIVATE(o,1,0,file);
2961 if (o->op_flags & OPf_SPECIAL) {
2967 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2969 if (cSVOPo->op_sv) {
2970 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2971 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2977 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2978 s = SvPV(tmpsv1,len);
2979 sv_catxmlpvn(tmpsv2, s, len, 1);
2980 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2984 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2989 case OP_METHOD_NAMED:
2990 #ifndef USE_ITHREADS
2991 /* with ITHREADS, consts are stored in the pad, and the right pad
2992 * may not be active here, so skip */
2993 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2999 PerlIO_printf(file, ">\n");
3001 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3006 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3007 (UV)CopLINE(cCOPo));
3008 if (CopSTASHPV(cCOPo))
3009 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3011 if (CopLABEL(cCOPo))
3012 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3016 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3017 if (cLOOPo->op_redoop)
3018 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3020 PerlIO_printf(file, "DONE\"");
3021 S_xmldump_attr(aTHX_ level, file, "next=\"");
3022 if (cLOOPo->op_nextop)
3023 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3025 PerlIO_printf(file, "DONE\"");
3026 S_xmldump_attr(aTHX_ level, file, "last=\"");
3027 if (cLOOPo->op_lastop)
3028 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3030 PerlIO_printf(file, "DONE\"");
3038 S_xmldump_attr(aTHX_ level, file, "other=\"");
3039 if (cLOGOPo->op_other)
3040 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3042 PerlIO_printf(file, "DONE\"");
3050 if (o->op_private & OPpREFCOUNTED)
3051 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3057 if (PL_madskills && o->op_madprop) {
3058 char prevkey = '\0';
3059 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3060 const MADPROP* mp = o->op_madprop;
3064 PerlIO_printf(file, ">\n");
3066 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3069 char tmp = mp->mad_key;
3070 sv_setpvs(tmpsv,"\"");
3072 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3073 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3074 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3077 sv_catpv(tmpsv, "\"");
3078 switch (mp->mad_type) {
3080 sv_catpv(tmpsv, "NULL");
3081 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3084 sv_catpv(tmpsv, " val=\"");
3085 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3086 sv_catpv(tmpsv, "\"");
3087 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3090 sv_catpv(tmpsv, " val=\"");
3091 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3092 sv_catpv(tmpsv, "\"");
3093 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3096 if ((OP*)mp->mad_val) {
3097 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3098 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3099 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3103 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3109 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3111 SvREFCNT_dec_NN(tmpsv);
3121 PerlIO_printf(file, ">\n");
3123 do_pmop_xmldump(level, file, cPMOPo);
3129 if (o->op_flags & OPf_KIDS) {
3133 PerlIO_printf(file, ">\n");
3135 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3136 do_op_xmldump(level, file, kid);
3140 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3142 PerlIO_printf(file, " />\n");
3146 Perl_op_xmldump(pTHX_ const OP *o)
3148 PERL_ARGS_ASSERT_OP_XMLDUMP;
3150 do_op_xmldump(0, PL_xmlfp, o);
3156 * c-indentation-style: bsd
3158 * indent-tabs-mode: nil
3161 * ex: set ts=8 sts=4 sw=4 et: