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 non-ASCII chars 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 || (( ! isASCII(u) ) && (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 non-ASCII bytes
339 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 of 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_BARE, ",BARE"}
750 const struct flag_to_name op_sort_names[] = {
751 {OPpSORT_NUMERIC, ",NUMERIC"},
752 {OPpSORT_INTEGER, ",INTEGER"},
753 {OPpSORT_REVERSE, ",REVERSE"},
754 {OPpSORT_INPLACE, ",INPLACE"},
755 {OPpSORT_DESCEND, ",DESCEND"},
756 {OPpSORT_QSORT, ",QSORT"},
757 {OPpSORT_STABLE, ",STABLE"}
760 const struct flag_to_name op_open_names[] = {
761 {OPpOPEN_IN_RAW, ",IN_RAW"},
762 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
763 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
764 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
767 const struct flag_to_name op_exit_names[] = {
768 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
769 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
772 const struct flag_to_name op_sassign_names[] = {
773 {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
774 {OPpASSIGN_CV_TO_GV, ",CV2GV"}
777 const struct flag_to_name op_leave_names[] = {
778 {OPpREFCOUNTED, ",REFCOUNTED"},
779 {OPpLVALUE, ",LVALUE"}
782 #define OP_PRIVATE_ONCE(op, flag, name) \
783 const struct flag_to_name CAT2(op, _names)[] = { \
787 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
788 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
789 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
790 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
791 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
792 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
793 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
794 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
795 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
796 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
797 OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
799 struct op_private_by_op {
802 const struct flag_to_name *start;
805 const struct op_private_by_op op_private_names[] = {
806 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
807 {OP_LEAVE, C_ARRAY_LENGTH(op_leave_names), op_leave_names },
808 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
809 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
810 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
811 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
812 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
813 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
814 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
815 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
816 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
817 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
818 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
819 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
820 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
821 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
822 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
823 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
824 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
825 {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
826 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
830 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
831 const struct op_private_by_op *start = op_private_names;
832 const struct op_private_by_op *const end
833 = op_private_names + C_ARRAY_LENGTH(op_private_names);
835 /* This is a linear search, but no worse than the code that it replaced.
836 It's debugging code - size is more important than speed. */
838 if (optype == start->op_type) {
839 S_append_flags(aTHX_ tmpsv, op_private, start->start,
840 start->start + start->len);
843 } while (++start < end);
847 #define DUMP_OP_FLAGS(o,xml,level,file) \
848 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
849 SV * const tmpsv = newSVpvs(""); \
850 switch (o->op_flags & OPf_WANT) { \
851 case OPf_WANT_VOID: \
852 sv_catpv(tmpsv, ",VOID"); \
854 case OPf_WANT_SCALAR: \
855 sv_catpv(tmpsv, ",SCALAR"); \
857 case OPf_WANT_LIST: \
858 sv_catpv(tmpsv, ",LIST"); \
861 sv_catpv(tmpsv, ",UNKNOWN"); \
864 append_flags(tmpsv, o->op_flags, op_flags_names); \
865 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
866 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
867 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
868 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \
870 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
871 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
873 PerlIO_printf(file, " flags=\"%s\"", \
874 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
875 SvREFCNT_dec_NN(tmpsv); \
878 #if !defined(PERL_MAD)
879 # define xmldump_attr1(level, file, pat, arg)
881 # define xmldump_attr1(level, file, pat, arg) \
882 S_xmldump_attr(aTHX_ level, file, pat, arg)
885 #define DUMP_OP_PRIVATE(o,xml,level,file) \
886 if (o->op_private) { \
887 U32 optype = o->op_type; \
888 U32 oppriv = o->op_private; \
889 SV * const tmpsv = newSVpvs(""); \
890 if (PL_opargs[optype] & OA_TARGLEX) { \
891 if (oppriv & OPpTARGET_MY) \
892 sv_catpv(tmpsv, ",TARGET_MY"); \
894 else if (optype == OP_ENTERSUB || \
895 optype == OP_RV2SV || \
896 optype == OP_GVSV || \
897 optype == OP_RV2AV || \
898 optype == OP_RV2HV || \
899 optype == OP_RV2GV || \
900 optype == OP_AELEM || \
901 optype == OP_HELEM ) \
903 if (optype == OP_ENTERSUB) { \
904 append_flags(tmpsv, oppriv, op_entersub_names); \
907 switch (oppriv & OPpDEREF) { \
909 sv_catpv(tmpsv, ",SV"); \
912 sv_catpv(tmpsv, ",AV"); \
915 sv_catpv(tmpsv, ",HV"); \
918 if (oppriv & OPpMAYBE_LVSUB) \
919 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
921 if (optype == OP_AELEM || optype == OP_HELEM) { \
922 if (oppriv & OPpLVAL_DEFER) \
923 sv_catpv(tmpsv, ",LVAL_DEFER"); \
925 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
926 if (oppriv & OPpMAYBE_TRUEBOOL) \
927 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
928 if (oppriv & OPpTRUEBOOL) \
929 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
932 if (oppriv & HINT_STRICT_REFS) \
933 sv_catpv(tmpsv, ",STRICT_REFS"); \
934 if (oppriv & OPpOUR_INTRO) \
935 sv_catpv(tmpsv, ",OUR_INTRO"); \
938 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
940 else if (OP_IS_FILETEST(o->op_type)) { \
941 if (oppriv & OPpFT_ACCESS) \
942 sv_catpv(tmpsv, ",FT_ACCESS"); \
943 if (oppriv & OPpFT_STACKED) \
944 sv_catpv(tmpsv, ",FT_STACKED"); \
945 if (oppriv & OPpFT_STACKING) \
946 sv_catpv(tmpsv, ",FT_STACKING"); \
947 if (oppriv & OPpFT_AFTER_t) \
948 sv_catpv(tmpsv, ",AFTER_t"); \
950 else if (o->op_type == OP_AASSIGN) { \
951 if (oppriv & OPpASSIGN_COMMON) \
952 sv_catpvs(tmpsv, ",COMMON"); \
953 if (oppriv & OPpMAYBE_LVSUB) \
954 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
956 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
957 sv_catpv(tmpsv, ",INTRO"); \
958 if (o->op_type == OP_PADRANGE) \
959 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
960 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
961 if ( (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV || \
962 o->op_type == OP_PADAV || o->op_type == OP_PADHV || \
963 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE || \
964 o->op_type == OP_KVHSLICE || o->op_type == OP_KVASLICE) \
965 && oppriv & OPpSLICEWARNING ) \
966 sv_catpvs(tmpsv, ",SLICEWARNING"); \
967 if (SvCUR(tmpsv)) { \
969 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
971 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
973 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
975 SvREFCNT_dec_NN(tmpsv); \
980 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
984 const OPCODE optype = o->op_type;
986 PERL_ARGS_ASSERT_DO_OP_DUMP;
988 Perl_dump_indent(aTHX_ level, file, "{\n");
990 seq = sequence_num(o);
992 PerlIO_printf(file, "%-4"UVuf, seq);
994 PerlIO_printf(file, "????");
996 "%*sTYPE = %s ===> ",
997 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
1000 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
1001 sequence_num(o->op_next));
1003 PerlIO_printf(file, "NULL\n");
1005 if (optype == OP_NULL) {
1006 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
1007 if (o->op_targ == OP_NEXTSTATE) {
1009 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1010 (UV)CopLINE(cCOPo));
1011 if (CopSTASHPV(cCOPo))
1012 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1014 if (CopLABEL(cCOPo))
1015 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1020 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1023 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1026 DUMP_OP_FLAGS(o,0,level,file);
1027 DUMP_OP_PRIVATE(o,0,level,file);
1030 if (PL_madskills && o->op_madprop) {
1031 SV * const tmpsv = newSVpvs("");
1032 MADPROP* mp = o->op_madprop;
1033 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1036 const char tmp = mp->mad_key;
1037 sv_setpvs(tmpsv,"'");
1039 sv_catpvn(tmpsv, &tmp, 1);
1040 sv_catpv(tmpsv, "'=");
1041 switch (mp->mad_type) {
1043 sv_catpv(tmpsv, "NULL");
1044 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1047 sv_catpv(tmpsv, "<");
1048 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1049 sv_catpv(tmpsv, ">");
1050 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1053 if ((OP*)mp->mad_val) {
1054 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1055 do_op_dump(level, file, (OP*)mp->mad_val);
1059 sv_catpv(tmpsv, "(UNK)");
1060 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1066 Perl_dump_indent(aTHX_ level, file, "}\n");
1068 SvREFCNT_dec_NN(tmpsv);
1077 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1079 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1080 if (cSVOPo->op_sv) {
1081 SV * const tmpsv = newSV(0);
1085 /* FIXME - is this making unwarranted assumptions about the
1086 UTF-8 cleanliness of the dump file handle? */
1089 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1090 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1091 SvPV_nolen_const(tmpsv));
1095 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1101 case OP_METHOD_NAMED:
1102 #ifndef USE_ITHREADS
1103 /* with ITHREADS, consts are stored in the pad, and the right pad
1104 * may not be active here, so skip */
1105 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1111 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1112 (UV)CopLINE(cCOPo));
1113 if (CopSTASHPV(cCOPo))
1114 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1116 if (CopLABEL(cCOPo))
1117 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1121 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1122 if (cLOOPo->op_redoop)
1123 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1125 PerlIO_printf(file, "DONE\n");
1126 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1127 if (cLOOPo->op_nextop)
1128 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1130 PerlIO_printf(file, "DONE\n");
1131 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1132 if (cLOOPo->op_lastop)
1133 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1135 PerlIO_printf(file, "DONE\n");
1143 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1144 if (cLOGOPo->op_other)
1145 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1147 PerlIO_printf(file, "DONE\n");
1153 do_pmop_dump(level, file, cPMOPo);
1161 if (o->op_private & OPpREFCOUNTED)
1162 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1167 if (o->op_flags & OPf_KIDS) {
1169 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1170 do_op_dump(level, file, kid);
1172 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1176 Perl_op_dump(pTHX_ const OP *o)
1178 PERL_ARGS_ASSERT_OP_DUMP;
1179 do_op_dump(0, Perl_debug_log, o);
1183 Perl_gv_dump(pTHX_ GV *gv)
1187 PERL_ARGS_ASSERT_GV_DUMP;
1190 PerlIO_printf(Perl_debug_log, "{}\n");
1193 sv = sv_newmortal();
1194 PerlIO_printf(Perl_debug_log, "{\n");
1195 gv_fullname3(sv, gv, NULL);
1196 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1197 if (gv != GvEGV(gv)) {
1198 gv_efullname3(sv, GvEGV(gv), NULL);
1199 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1201 PerlIO_putc(Perl_debug_log, '\n');
1202 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1206 /* map magic types to the symbolic names
1207 * (with the PERL_MAGIC_ prefixed stripped)
1210 static const struct { const char type; const char *name; } magic_names[] = {
1211 #include "mg_names.c"
1212 /* this null string terminates the list */
1217 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1219 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1221 for (; mg; mg = mg->mg_moremagic) {
1222 Perl_dump_indent(aTHX_ level, file,
1223 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1224 if (mg->mg_virtual) {
1225 const MGVTBL * const v = mg->mg_virtual;
1226 if (v >= PL_magic_vtables
1227 && v < PL_magic_vtables + magic_vtable_max) {
1228 const U32 i = v - PL_magic_vtables;
1229 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1232 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1235 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1238 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1242 const char *name = NULL;
1243 for (n = 0; magic_names[n].name; n++) {
1244 if (mg->mg_type == magic_names[n].type) {
1245 name = magic_names[n].name;
1250 Perl_dump_indent(aTHX_ level, file,
1251 " MG_TYPE = PERL_MAGIC_%s\n", name);
1253 Perl_dump_indent(aTHX_ level, file,
1254 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1258 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1259 if (mg->mg_type == PERL_MAGIC_envelem &&
1260 mg->mg_flags & MGf_TAINTEDDIR)
1261 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1262 if (mg->mg_type == PERL_MAGIC_regex_global &&
1263 mg->mg_flags & MGf_MINMATCH)
1264 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1265 if (mg->mg_flags & MGf_REFCOUNTED)
1266 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1267 if (mg->mg_flags & MGf_GSKIP)
1268 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1269 if (mg->mg_flags & MGf_COPY)
1270 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1271 if (mg->mg_flags & MGf_DUP)
1272 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1273 if (mg->mg_flags & MGf_LOCAL)
1274 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1275 if (mg->mg_type == PERL_MAGIC_regex_global &&
1276 mg->mg_flags & MGf_BYTES)
1277 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1280 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1281 PTR2UV(mg->mg_obj));
1282 if (mg->mg_type == PERL_MAGIC_qr) {
1283 REGEXP* const re = (REGEXP *)mg->mg_obj;
1284 SV * const dsv = sv_newmortal();
1285 const char * const s
1286 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1288 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1289 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1291 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1292 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1295 if (mg->mg_flags & MGf_REFCOUNTED)
1296 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1299 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1301 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1302 if (mg->mg_len >= 0) {
1303 if (mg->mg_type != PERL_MAGIC_utf8) {
1304 SV * const sv = newSVpvs("");
1305 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1306 SvREFCNT_dec_NN(sv);
1309 else if (mg->mg_len == HEf_SVKEY) {
1310 PerlIO_puts(file, " => HEf_SVKEY\n");
1311 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1312 maxnest, dumpops, pvlim); /* MG is already +1 */
1315 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1320 " does not know how to handle this MG_LEN"
1322 PerlIO_putc(file, '\n');
1324 if (mg->mg_type == PERL_MAGIC_utf8) {
1325 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1328 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1329 Perl_dump_indent(aTHX_ level, file,
1330 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1333 (UV)cache[i * 2 + 1]);
1340 Perl_magic_dump(pTHX_ const MAGIC *mg)
1342 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1346 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1350 PERL_ARGS_ASSERT_DO_HV_DUMP;
1352 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1353 if (sv && (hvname = HvNAME_get(sv)))
1355 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1356 name which quite legally could contain insane things like tabs, newlines, nulls or
1357 other scary crap - this should produce sane results - except maybe for unicode package
1358 names - but we will wait for someone to file a bug on that - demerphq */
1359 SV * const tmpsv = newSVpvs("");
1360 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1363 PerlIO_putc(file, '\n');
1367 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1369 PERL_ARGS_ASSERT_DO_GV_DUMP;
1371 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1372 if (sv && GvNAME(sv))
1373 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1375 PerlIO_putc(file, '\n');
1379 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1381 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1383 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1384 if (sv && GvNAME(sv)) {
1386 PerlIO_printf(file, "\t\"");
1387 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1388 PerlIO_printf(file, "%s\" :: \"", hvname);
1389 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1392 PerlIO_putc(file, '\n');
1395 const struct flag_to_name first_sv_flags_names[] = {
1396 {SVs_TEMP, "TEMP,"},
1397 {SVs_OBJECT, "OBJECT,"},
1406 const struct flag_to_name second_sv_flags_names[] = {
1408 {SVf_FAKE, "FAKE,"},
1409 {SVf_READONLY, "READONLY,"},
1410 {SVf_IsCOW, "IsCOW,"},
1411 {SVf_BREAK, "BREAK,"},
1412 {SVf_AMAGIC, "OVERLOAD,"},
1418 const struct flag_to_name cv_flags_names[] = {
1419 {CVf_ANON, "ANON,"},
1420 {CVf_UNIQUE, "UNIQUE,"},
1421 {CVf_CLONE, "CLONE,"},
1422 {CVf_CLONED, "CLONED,"},
1423 {CVf_CONST, "CONST,"},
1424 {CVf_NODEBUG, "NODEBUG,"},
1425 {CVf_LVALUE, "LVALUE,"},
1426 {CVf_METHOD, "METHOD,"},
1427 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1428 {CVf_CVGV_RC, "CVGV_RC,"},
1429 {CVf_DYNFILE, "DYNFILE,"},
1430 {CVf_AUTOLOAD, "AUTOLOAD,"},
1431 {CVf_HASEVAL, "HASEVAL"},
1432 {CVf_SLABBED, "SLABBED,"},
1433 {CVf_ISXSUB, "ISXSUB,"}
1436 const struct flag_to_name hv_flags_names[] = {
1437 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1438 {SVphv_LAZYDEL, "LAZYDEL,"},
1439 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1440 {SVphv_CLONEABLE, "CLONEABLE,"}
1443 const struct flag_to_name gp_flags_names[] = {
1444 {GVf_INTRO, "INTRO,"},
1445 {GVf_MULTI, "MULTI,"},
1446 {GVf_ASSUMECV, "ASSUMECV,"},
1447 {GVf_IN_PAD, "IN_PAD,"}
1450 const struct flag_to_name gp_flags_imported_names[] = {
1451 {GVf_IMPORTED_SV, " SV"},
1452 {GVf_IMPORTED_AV, " AV"},
1453 {GVf_IMPORTED_HV, " HV"},
1454 {GVf_IMPORTED_CV, " CV"},
1457 const struct flag_to_name regexp_flags_names[] = {
1458 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1459 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1460 {RXf_PMf_FOLD, "PMf_FOLD,"},
1461 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1462 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1463 {RXf_ANCH_BOL, "ANCH_BOL,"},
1464 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1465 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1466 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1467 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1468 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1469 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1470 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1471 {RXf_CANY_SEEN, "CANY_SEEN,"},
1472 {RXf_NOSCAN, "NOSCAN,"},
1473 {RXf_CHECK_ALL, "CHECK_ALL,"},
1474 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1475 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1476 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1477 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1478 {RXf_SPLIT, "SPLIT,"},
1479 {RXf_COPY_DONE, "COPY_DONE,"},
1480 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1481 {RXf_TAINTED, "TAINTED,"},
1482 {RXf_START_ONLY, "START_ONLY,"},
1483 {RXf_SKIPWHITE, "SKIPWHITE,"},
1484 {RXf_WHITE, "WHITE,"},
1485 {RXf_NULL, "NULL,"},
1489 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1497 PERL_ARGS_ASSERT_DO_SV_DUMP;
1500 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1504 flags = SvFLAGS(sv);
1507 /* process general SV flags */
1509 d = Perl_newSVpvf(aTHX_
1510 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1511 PTR2UV(SvANY(sv)), PTR2UV(sv),
1512 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1513 (int)(PL_dumpindent*level), "");
1515 if (!((flags & SVpad_NAME) == SVpad_NAME
1516 && (type == SVt_PVMG || type == SVt_PVNV))) {
1517 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1518 sv_catpv(d, "PADSTALE,");
1520 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1521 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1522 sv_catpv(d, "PADTMP,");
1523 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1525 append_flags(d, flags, first_sv_flags_names);
1526 if (flags & SVf_ROK) {
1527 sv_catpv(d, "ROK,");
1528 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1530 append_flags(d, flags, second_sv_flags_names);
1531 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1532 && type != SVt_PVAV) {
1533 if (SvPCS_IMPORTED(sv))
1534 sv_catpv(d, "PCS_IMPORTED,");
1536 sv_catpv(d, "SCREAM,");
1539 /* process type-specific SV flags */
1544 append_flags(d, CvFLAGS(sv), cv_flags_names);
1547 append_flags(d, flags, hv_flags_names);
1551 if (isGV_with_GP(sv)) {
1552 append_flags(d, GvFLAGS(sv), gp_flags_names);
1554 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1555 sv_catpv(d, "IMPORT");
1556 if (GvIMPORTED(sv) == GVf_IMPORTED)
1557 sv_catpv(d, "ALL,");
1560 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1567 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1568 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1571 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1572 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1573 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1574 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1577 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1580 if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1583 /* SVphv_SHAREKEYS is also 0x20000000 */
1584 if ((type != SVt_PVHV) && SvUTF8(sv))
1585 sv_catpv(d, "UTF8");
1587 if (*(SvEND(d) - 1) == ',') {
1588 SvCUR_set(d, SvCUR(d) - 1);
1589 SvPVX(d)[SvCUR(d)] = '\0';
1594 /* dump initial SV details */
1596 #ifdef DEBUG_LEAKING_SCALARS
1597 Perl_dump_indent(aTHX_ level, file,
1598 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1599 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1601 sv->sv_debug_inpad ? "for" : "by",
1602 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1603 PTR2UV(sv->sv_debug_parent),
1607 Perl_dump_indent(aTHX_ level, file, "SV = ");
1611 if (type < SVt_LAST) {
1612 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1614 if (type == SVt_NULL) {
1619 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1624 /* Dump general SV fields */
1626 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1627 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1628 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1629 || (type == SVt_IV && !SvROK(sv))) {
1631 #ifdef PERL_OLD_COPY_ON_WRITE
1635 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1637 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1638 #ifdef PERL_OLD_COPY_ON_WRITE
1639 if (SvIsCOW_shared_hash(sv))
1640 PerlIO_printf(file, " (HASH)");
1641 else if (SvIsCOW_normal(sv))
1642 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1644 PerlIO_putc(file, '\n');
1647 if ((type == SVt_PVNV || type == SVt_PVMG)
1648 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1649 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1650 (UV) COP_SEQ_RANGE_LOW(sv));
1651 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1652 (UV) COP_SEQ_RANGE_HIGH(sv));
1653 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1654 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1655 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1656 || type == SVt_NV) {
1657 STORE_NUMERIC_LOCAL_SET_STANDARD();
1658 /* %Vg doesn't work? --jhi */
1659 #ifdef USE_LONG_DOUBLE
1660 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1662 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1664 RESTORE_NUMERIC_LOCAL();
1668 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1670 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1673 if (type < SVt_PV) {
1678 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1679 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1680 const bool re = isREGEXP(sv);
1681 const char * const ptr =
1682 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1686 SvOOK_offset(sv, delta);
1687 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1692 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1694 PerlIO_printf(file, "( %s . ) ",
1695 pv_display(d, ptr - delta, delta, 0,
1698 if (type == SVt_INVLIST) {
1699 PerlIO_printf(file, "\n");
1700 /* 4 blanks indents 2 beyond the PV, etc */
1701 _invlist_dump(file, level, " ", sv);
1704 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1707 if (SvUTF8(sv)) /* the 6? \x{....} */
1708 PerlIO_printf(file, " [UTF8 \"%s\"]",
1709 sv_uni_display(d, sv, 6 * SvCUR(sv),
1711 PerlIO_printf(file, "\n");
1713 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1715 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1717 #ifdef PERL_NEW_COPY_ON_WRITE
1718 if (SvIsCOW(sv) && SvLEN(sv))
1719 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1724 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1727 if (type >= SVt_PVMG) {
1728 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1729 HV * const ost = SvOURSTASH(sv);
1731 do_hv_dump(level, file, " OURSTASH", ost);
1732 } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1733 Perl_dump_indent(aTHX_ level, file, " MAXNAMED = %"UVuf"\n",
1734 (UV)PadnamelistMAXNAMED(sv));
1737 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1740 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1742 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1743 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1747 /* Dump type-specific SV fields */
1751 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1752 if (AvARRAY(sv) != AvALLOC(sv)) {
1753 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1754 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1757 PerlIO_putc(file, '\n');
1758 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1759 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1760 /* arylen is stored in magic, and padnamelists use SvMAGIC for
1762 if (!AvPAD_NAMELIST(sv))
1763 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1764 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1766 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1767 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1768 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1769 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1770 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1772 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1773 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1775 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1777 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1782 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1783 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1784 /* Show distribution of HEs in the ARRAY */
1786 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1789 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1790 NV theoret, sum = 0;
1792 PerlIO_printf(file, " (");
1793 Zero(freq, FREQ_MAX + 1, int);
1794 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1797 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1799 if (count > FREQ_MAX)
1805 for (i = 0; i <= max; i++) {
1807 PerlIO_printf(file, "%d%s:%d", i,
1808 (i == FREQ_MAX) ? "+" : "",
1811 PerlIO_printf(file, ", ");
1814 PerlIO_putc(file, ')');
1815 /* The "quality" of a hash is defined as the total number of
1816 comparisons needed to access every element once, relative
1817 to the expected number needed for a random hash.
1819 The total number of comparisons is equal to the sum of
1820 the squares of the number of entries in each bucket.
1821 For a random hash of n keys into k buckets, the expected
1826 for (i = max; i > 0; i--) { /* Precision: count down. */
1827 sum += freq[i] * i * i;
1829 while ((keys = keys >> 1))
1831 theoret = HvUSEDKEYS(sv);
1832 theoret += theoret * (theoret-1)/pow2;
1833 PerlIO_putc(file, '\n');
1834 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1836 PerlIO_putc(file, '\n');
1837 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1840 HE **ents = HvARRAY(sv);
1843 HE *const *const last = ents + HvMAX(sv);
1844 count = last + 1 - ents;
1849 } while (++ents <= last);
1853 struct xpvhv_aux *const aux = HvAUX(sv);
1854 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1855 " (cached = %"UVuf")\n",
1856 (UV)count, (UV)aux->xhv_fill_lazy);
1858 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1862 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1864 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1865 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1866 #ifdef PERL_HASH_RANDOMIZE_KEYS
1867 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1868 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1869 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1872 PerlIO_putc(file, '\n');
1875 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1876 if (mg && mg->mg_obj) {
1877 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1881 const char * const hvname = HvNAME_get(sv);
1883 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1887 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1888 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1889 if (HvAUX(sv)->xhv_name_count)
1890 Perl_dump_indent(aTHX_
1891 level, file, " NAMECOUNT = %"IVdf"\n",
1892 (IV)HvAUX(sv)->xhv_name_count
1894 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1895 const I32 count = HvAUX(sv)->xhv_name_count;
1897 SV * const names = newSVpvs_flags("", SVs_TEMP);
1898 /* The starting point is the first element if count is
1899 positive and the second element if count is negative. */
1900 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1901 + (count < 0 ? 1 : 0);
1902 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1903 + (count < 0 ? -count : count);
1904 while (hekp < endp) {
1906 sv_catpvs(names, ", \"");
1907 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1908 sv_catpvs(names, "\"");
1910 /* This should never happen. */
1911 sv_catpvs(names, ", (null)");
1915 Perl_dump_indent(aTHX_
1916 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1920 Perl_dump_indent(aTHX_
1921 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1925 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1927 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1931 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1932 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1933 (int)meta->mro_which->length,
1934 meta->mro_which->name,
1935 PTR2UV(meta->mro_which));
1936 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1937 (UV)meta->cache_gen);
1938 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1940 if (meta->mro_linear_all) {
1941 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1942 PTR2UV(meta->mro_linear_all));
1943 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1946 if (meta->mro_linear_current) {
1947 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1948 PTR2UV(meta->mro_linear_current));
1949 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1952 if (meta->mro_nextmethod) {
1953 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1954 PTR2UV(meta->mro_nextmethod));
1955 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1959 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1961 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1966 if (nest < maxnest) {
1967 HV * const hv = MUTABLE_HV(sv);
1972 int count = maxnest - nest;
1973 for (i=0; i <= HvMAX(hv); i++) {
1974 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1981 if (count-- <= 0) goto DONEHV;
1984 keysv = hv_iterkeysv(he);
1985 keypv = SvPV_const(keysv, len);
1988 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1990 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1991 if (HvEITER_get(hv) == he)
1992 PerlIO_printf(file, "[CURRENT] ");
1993 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1994 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2003 if (CvAUTOLOAD(sv)) {
2005 const char *const name = SvPV_const(sv, len);
2006 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
2010 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
2011 (int) CvPROTOLEN(sv), CvPROTO(sv));
2015 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2016 if (!CvISXSUB(sv)) {
2018 Perl_dump_indent(aTHX_ level, file,
2019 " START = 0x%"UVxf" ===> %"IVdf"\n",
2020 PTR2UV(CvSTART(sv)),
2021 (IV)sequence_num(CvSTART(sv)));
2023 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
2024 PTR2UV(CvROOT(sv)));
2025 if (CvROOT(sv) && dumpops) {
2026 do_op_dump(level+1, file, CvROOT(sv));
2029 SV * const constant = cv_const_sv((const CV *)sv);
2031 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2034 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2036 PTR2UV(CvXSUBANY(sv).any_ptr));
2037 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2040 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2041 (IV)CvXSUBANY(sv).any_i32);
2045 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2046 HEK_KEY(CvNAME_HEK((CV *)sv)));
2047 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2048 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2049 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2050 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2051 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2052 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2053 if (nest < maxnest) {
2054 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2057 const CV * const outside = CvOUTSIDE(sv);
2058 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2061 : CvANON(outside) ? "ANON"
2062 : (outside == PL_main_cv) ? "MAIN"
2063 : CvUNIQUE(outside) ? "UNIQUE"
2064 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2066 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2067 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2072 if (type == SVt_PVLV) {
2073 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2074 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2075 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2076 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2077 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2078 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2079 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2082 if (isREGEXP(sv)) goto dumpregexp;
2083 if (!isGV_with_GP(sv))
2085 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2086 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2087 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2088 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2091 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2092 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2093 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2094 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2095 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2096 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2097 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2098 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2099 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2100 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2101 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2102 do_gv_dump (level, file, " EGV", GvEGV(sv));
2105 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2106 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2107 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2108 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2109 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2110 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2111 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2113 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2114 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2115 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2117 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2118 PTR2UV(IoTOP_GV(sv)));
2119 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2120 maxnest, dumpops, pvlim);
2122 /* Source filters hide things that are not GVs in these three, so let's
2123 be careful out there. */
2125 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2126 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2127 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2129 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2130 PTR2UV(IoFMT_GV(sv)));
2131 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2132 maxnest, dumpops, pvlim);
2134 if (IoBOTTOM_NAME(sv))
2135 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2136 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2137 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2139 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2140 PTR2UV(IoBOTTOM_GV(sv)));
2141 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2142 maxnest, dumpops, pvlim);
2144 if (isPRINT(IoTYPE(sv)))
2145 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2147 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2148 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2153 struct regexp * const r = ReANY((REGEXP*)sv);
2154 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
2156 append_flags(d, flags, regexp_flags_names); \
2157 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2158 SvCUR_set(d, SvCUR(d) - 1); \
2159 SvPVX(d)[SvCUR(d)] = '\0'; \
2162 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
2163 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2164 (UV)(r->compflags), SvPVX_const(d));
2166 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
2167 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2168 (UV)(r->extflags), SvPVX_const(d));
2169 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2171 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2173 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2175 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2176 (UV)(r->lastparen));
2177 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2178 (UV)(r->lastcloseparen));
2179 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2181 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2182 (IV)(r->minlenret));
2183 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2185 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2186 (UV)(r->pre_prefix));
2187 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2189 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2190 (IV)(r->suboffset));
2191 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2192 (IV)(r->subcoffset));
2194 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2196 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2198 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2199 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2201 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2202 PTR2UV(r->mother_re));
2203 if (nest < maxnest && r->mother_re)
2204 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2205 maxnest, dumpops, pvlim);
2206 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2207 PTR2UV(r->paren_names));
2208 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2209 PTR2UV(r->substrs));
2210 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2211 PTR2UV(r->pprivate));
2212 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2214 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2215 PTR2UV(r->qr_anoncv));
2217 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2218 PTR2UV(r->saved_copy));
2227 Perl_sv_dump(pTHX_ SV *sv)
2231 PERL_ARGS_ASSERT_SV_DUMP;
2234 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2236 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2240 Perl_runops_debug(pTHX)
2244 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2248 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2250 #ifdef PERL_TRACE_OPS
2251 ++PL_op_exec_cnt[PL_op->op_type];
2254 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2255 PerlIO_printf(Perl_debug_log,
2256 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2257 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2258 PTR2UV(*PL_watchaddr));
2259 if (DEBUG_s_TEST_) {
2260 if (DEBUG_v_TEST_) {
2261 PerlIO_printf(Perl_debug_log, "\n");
2269 if (DEBUG_t_TEST_) debop(PL_op);
2270 if (DEBUG_P_TEST_) debprof(PL_op);
2273 OP_ENTRY_PROBE(OP_NAME(PL_op));
2274 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2275 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2283 Perl_debop(pTHX_ const OP *o)
2287 PERL_ARGS_ASSERT_DEBOP;
2289 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2292 Perl_deb(aTHX_ "%s", OP_NAME(o));
2293 switch (o->op_type) {
2296 /* With ITHREADS, consts are stored in the pad, and the right pad
2297 * may not be active here, so check.
2298 * Looks like only during compiling the pads are illegal.
2301 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2303 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2308 SV * const sv = newSV(0);
2310 /* FIXME - is this making unwarranted assumptions about the
2311 UTF-8 cleanliness of the dump file handle? */
2314 gv_fullname3(sv, cGVOPo_gv, NULL);
2315 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2316 SvREFCNT_dec_NN(sv);
2319 PerlIO_printf(Perl_debug_log, "(NULL)");
2331 count = o->op_private & OPpPADRANGE_COUNTMASK;
2333 /* print the lexical's name */
2335 CV * const cv = deb_curcv(cxstack_ix);
2337 PAD * comppad = NULL;
2341 PADLIST * const padlist = CvPADLIST(cv);
2342 comppad = *PadlistARRAY(padlist);
2344 PerlIO_printf(Perl_debug_log, "(");
2345 for (i = 0; i < count; i++) {
2347 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2348 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2350 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2353 PerlIO_printf(Perl_debug_log, ",");
2355 PerlIO_printf(Perl_debug_log, ")");
2363 PerlIO_printf(Perl_debug_log, "\n");
2368 S_deb_curcv(pTHX_ const I32 ix)
2371 const PERL_CONTEXT * const cx = &cxstack[ix];
2372 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2373 return cx->blk_sub.cv;
2374 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2375 return cx->blk_eval.cv;
2376 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2381 return deb_curcv(ix - 1);
2385 Perl_watch(pTHX_ char **addr)
2389 PERL_ARGS_ASSERT_WATCH;
2391 PL_watchaddr = addr;
2393 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2394 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2398 S_debprof(pTHX_ const OP *o)
2402 PERL_ARGS_ASSERT_DEBPROF;
2404 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2406 if (!PL_profiledata)
2407 Newxz(PL_profiledata, MAXO, U32);
2408 ++PL_profiledata[o->op_type];
2412 Perl_debprofdump(pTHX)
2416 if (!PL_profiledata)
2418 for (i = 0; i < MAXO; i++) {
2419 if (PL_profiledata[i])
2420 PerlIO_printf(Perl_debug_log,
2421 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2428 * XML variants of most of the above routines
2432 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2436 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2438 PerlIO_printf(file, "\n ");
2439 va_start(args, pat);
2440 xmldump_vindent(level, file, pat, &args);
2446 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2449 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2450 va_start(args, pat);
2451 xmldump_vindent(level, file, pat, &args);
2456 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2458 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2460 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2461 PerlIO_vprintf(file, pat, *args);
2465 Perl_xmldump_all(pTHX)
2467 xmldump_all_perl(FALSE);
2471 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2473 PerlIO_setlinebuf(PL_xmlfp);
2475 op_xmldump(PL_main_root);
2476 /* someday we might call this, when it outputs XML: */
2477 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2478 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2479 PerlIO_close(PL_xmlfp);
2484 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2486 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2487 xmldump_packsubs_perl(stash, FALSE);
2491 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2496 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2498 if (!HvARRAY(stash))
2500 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2501 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2502 GV *gv = MUTABLE_GV(HeVAL(entry));
2504 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2507 xmldump_sub_perl(gv, justperl);
2510 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2511 && (hv = GvHV(gv)) && hv != PL_defstash)
2512 xmldump_packsubs_perl(hv, justperl); /* nested package */
2518 Perl_xmldump_sub(pTHX_ const GV *gv)
2520 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2521 xmldump_sub_perl(gv, FALSE);
2525 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2529 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2531 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2534 sv = sv_newmortal();
2535 gv_fullname3(sv, gv, NULL);
2536 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2537 if (CvXSUB(GvCV(gv)))
2538 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2539 PTR2UV(CvXSUB(GvCV(gv))),
2540 (int)CvXSUBANY(GvCV(gv)).any_i32);
2541 else if (CvROOT(GvCV(gv)))
2542 op_xmldump(CvROOT(GvCV(gv)));
2544 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2548 Perl_xmldump_form(pTHX_ const GV *gv)
2550 SV * const sv = sv_newmortal();
2552 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2554 gv_fullname3(sv, gv, NULL);
2555 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2556 if (CvROOT(GvFORM(gv)))
2557 op_xmldump(CvROOT(GvFORM(gv)));
2559 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2563 Perl_xmldump_eval(pTHX)
2565 op_xmldump(PL_eval_root);
2569 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2571 PERL_ARGS_ASSERT_SV_CATXMLSV;
2572 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2576 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2578 PERL_ARGS_ASSERT_SV_CATXMLPV;
2579 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2583 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2586 const char * const e = pv + len;
2587 const char * const start = pv;
2591 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2594 dsvcur = SvCUR(dsv); /* in case we have to restart */
2599 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2601 SvCUR(dsv) = dsvcur;
2614 && c != LATIN1_TO_NATIVE(0x85))
2616 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2620 sv_catpvs(dsv, "<");
2623 sv_catpvs(dsv, ">");
2626 sv_catpvs(dsv, "&");
2629 sv_catpvs(dsv, """);
2634 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2637 const char string = (char) c;
2638 sv_catpvn(dsv, &string, 1);
2642 if ((c >= 0xD800 && c <= 0xDB7F) ||
2643 (c >= 0xDC00 && c <= 0xDFFF) ||
2644 (c >= 0xFFF0 && c <= 0xFFFF) ||
2646 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2648 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2661 Perl_sv_xmlpeek(pTHX_ SV *sv)
2663 SV * const t = sv_newmortal();
2667 PERL_ARGS_ASSERT_SV_XMLPEEK;
2673 sv_catpv(t, "VOID=\"\"");
2676 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2677 sv_catpv(t, "WILD=\"\"");
2680 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2681 if (sv == &PL_sv_undef) {
2682 sv_catpv(t, "SV_UNDEF=\"1\"");
2683 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2684 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2688 else if (sv == &PL_sv_no) {
2689 sv_catpv(t, "SV_NO=\"1\"");
2690 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2691 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2692 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2693 SVp_POK|SVp_NOK)) &&
2698 else if (sv == &PL_sv_yes) {
2699 sv_catpv(t, "SV_YES=\"1\"");
2700 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2701 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2702 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2703 SVp_POK|SVp_NOK)) &&
2705 SvPVX(sv) && *SvPVX(sv) == '1' &&
2710 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2711 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2712 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2716 sv_catpv(t, " XXX=\"\" ");
2718 else if (SvREFCNT(sv) == 0) {
2719 sv_catpv(t, " refcnt=\"0\"");
2722 else if (DEBUG_R_TEST_) {
2725 /* is this SV on the tmps stack? */
2726 for (ix=PL_tmps_ix; ix>=0; ix--) {
2727 if (PL_tmps_stack[ix] == sv) {
2732 if (SvREFCNT(sv) > 1)
2733 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2736 sv_catpv(t, " DRT=\"<T>\"");
2740 sv_catpv(t, " ROK=\"\"");
2742 switch (SvTYPE(sv)) {
2744 sv_catpv(t, " FREED=\"1\"");
2748 sv_catpv(t, " UNDEF=\"1\"");
2751 sv_catpv(t, " IV=\"");
2754 sv_catpv(t, " NV=\"");
2757 sv_catpv(t, " PV=\"");
2760 sv_catpv(t, " PVIV=\"");
2763 sv_catpv(t, " PVNV=\"");
2766 sv_catpv(t, " PVMG=\"");
2769 sv_catpv(t, " PVLV=\"");
2772 sv_catpv(t, " AV=\"");
2775 sv_catpv(t, " HV=\"");
2779 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2781 sv_catpv(t, " CV=\"()\"");
2784 sv_catpv(t, " GV=\"");
2787 sv_catpv(t, " DUMMY=\"");
2790 sv_catpv(t, " REGEXP=\"");
2793 sv_catpv(t, " FM=\"");
2796 sv_catpv(t, " IO=\"");
2805 else if (SvNOKp(sv)) {
2806 STORE_NUMERIC_LOCAL_SET_STANDARD();
2807 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2808 RESTORE_NUMERIC_LOCAL();
2810 else if (SvIOKp(sv)) {
2812 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2814 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2823 return SvPV(t, n_a);
2827 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2829 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2832 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2835 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2838 REGEXP *const r = PM_GETRE(pm);
2839 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2840 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2841 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2843 SvREFCNT_dec_NN(tmpsv);
2844 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2845 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2848 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2849 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2850 SV * const tmpsv = pm_description(pm);
2851 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2852 SvREFCNT_dec_NN(tmpsv);
2856 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2857 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2858 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2859 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2860 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2861 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2864 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2868 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2870 do_pmop_xmldump(0, PL_xmlfp, pm);
2874 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2878 const OPCODE optype = o->op_type;
2880 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2884 seq = sequence_num(o);
2885 Perl_xmldump_indent(aTHX_ level, file,
2886 "<op_%s seq=\"%"UVuf" -> ",
2891 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2892 sequence_num(o->op_next));
2894 PerlIO_printf(file, "DONE\"");
2897 if (optype == OP_NULL)
2899 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2900 if (o->op_targ == OP_NEXTSTATE)
2903 PerlIO_printf(file, " line=\"%"UVuf"\"",
2904 (UV)CopLINE(cCOPo));
2905 if (CopSTASHPV(cCOPo))
2906 PerlIO_printf(file, " package=\"%s\"",
2908 if (CopLABEL(cCOPo))
2909 PerlIO_printf(file, " label=\"%s\"",
2914 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2917 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2920 DUMP_OP_FLAGS(o,1,0,file);
2921 DUMP_OP_PRIVATE(o,1,0,file);
2925 if (o->op_flags & OPf_SPECIAL) {
2931 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2933 if (cSVOPo->op_sv) {
2934 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2935 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2941 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2942 s = SvPV(tmpsv1,len);
2943 sv_catxmlpvn(tmpsv2, s, len, 1);
2944 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2948 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2953 case OP_METHOD_NAMED:
2954 #ifndef USE_ITHREADS
2955 /* with ITHREADS, consts are stored in the pad, and the right pad
2956 * may not be active here, so skip */
2957 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2963 PerlIO_printf(file, ">\n");
2965 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2970 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2971 (UV)CopLINE(cCOPo));
2972 if (CopSTASHPV(cCOPo))
2973 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2975 if (CopLABEL(cCOPo))
2976 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2980 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2981 if (cLOOPo->op_redoop)
2982 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2984 PerlIO_printf(file, "DONE\"");
2985 S_xmldump_attr(aTHX_ level, file, "next=\"");
2986 if (cLOOPo->op_nextop)
2987 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2989 PerlIO_printf(file, "DONE\"");
2990 S_xmldump_attr(aTHX_ level, file, "last=\"");
2991 if (cLOOPo->op_lastop)
2992 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2994 PerlIO_printf(file, "DONE\"");
3002 S_xmldump_attr(aTHX_ level, file, "other=\"");
3003 if (cLOGOPo->op_other)
3004 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3006 PerlIO_printf(file, "DONE\"");
3014 if (o->op_private & OPpREFCOUNTED)
3015 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3021 if (PL_madskills && o->op_madprop) {
3022 char prevkey = '\0';
3023 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3024 const MADPROP* mp = o->op_madprop;
3028 PerlIO_printf(file, ">\n");
3030 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3033 char tmp = mp->mad_key;
3034 sv_setpvs(tmpsv,"\"");
3036 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3037 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3038 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3041 sv_catpv(tmpsv, "\"");
3042 switch (mp->mad_type) {
3044 sv_catpv(tmpsv, "NULL");
3045 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3048 sv_catpv(tmpsv, " val=\"");
3049 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3050 sv_catpv(tmpsv, "\"");
3051 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3054 sv_catpv(tmpsv, " val=\"");
3055 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3056 sv_catpv(tmpsv, "\"");
3057 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3060 if ((OP*)mp->mad_val) {
3061 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3062 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3063 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3067 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3073 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3075 SvREFCNT_dec_NN(tmpsv);
3085 PerlIO_printf(file, ">\n");
3087 do_pmop_xmldump(level, file, cPMOPo);
3093 if (o->op_flags & OPf_KIDS) {
3097 PerlIO_printf(file, ">\n");
3099 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3100 do_op_xmldump(level, file, kid);
3104 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3106 PerlIO_printf(file, " />\n");
3110 Perl_op_xmldump(pTHX_ const OP *o)
3112 PERL_ARGS_ASSERT_OP_XMLDUMP;
3114 do_op_xmldump(0, PL_xmlfp, o);
3120 * c-indentation-style: bsd
3122 * indent-tabs-mode: nil
3125 * ex: set ts=8 sts=4 sw=4 et: