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 #define OP_PRIVATE_ONCE(op, flag, name) \
778 const struct flag_to_name CAT2(op, _names)[] = { \
782 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
783 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
784 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
785 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
786 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
787 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
788 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
789 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
790 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
791 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
792 OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
794 struct op_private_by_op {
797 const struct flag_to_name *start;
800 const struct op_private_by_op op_private_names[] = {
801 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
802 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
804 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
805 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
806 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
807 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
808 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
809 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
810 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
811 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
812 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
813 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
814 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
815 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
816 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
817 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
818 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
819 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
820 {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
821 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
825 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
826 const struct op_private_by_op *start = op_private_names;
827 const struct op_private_by_op *const end
828 = op_private_names + C_ARRAY_LENGTH(op_private_names);
830 /* This is a linear search, but no worse than the code that it replaced.
831 It's debugging code - size is more important than speed. */
833 if (optype == start->op_type) {
834 S_append_flags(aTHX_ tmpsv, op_private, start->start,
835 start->start + start->len);
838 } while (++start < end);
842 #define DUMP_OP_FLAGS(o,xml,level,file) \
843 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
844 SV * const tmpsv = newSVpvs(""); \
845 switch (o->op_flags & OPf_WANT) { \
846 case OPf_WANT_VOID: \
847 sv_catpv(tmpsv, ",VOID"); \
849 case OPf_WANT_SCALAR: \
850 sv_catpv(tmpsv, ",SCALAR"); \
852 case OPf_WANT_LIST: \
853 sv_catpv(tmpsv, ",LIST"); \
856 sv_catpv(tmpsv, ",UNKNOWN"); \
859 append_flags(tmpsv, o->op_flags, op_flags_names); \
860 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
861 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
862 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
863 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \
865 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
866 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
868 PerlIO_printf(file, " flags=\"%s\"", \
869 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
870 SvREFCNT_dec_NN(tmpsv); \
873 #if !defined(PERL_MAD)
874 # define xmldump_attr1(level, file, pat, arg)
876 # define xmldump_attr1(level, file, pat, arg) \
877 S_xmldump_attr(aTHX_ level, file, pat, arg)
880 #define DUMP_OP_PRIVATE(o,xml,level,file) \
881 if (o->op_private) { \
882 U32 optype = o->op_type; \
883 U32 oppriv = o->op_private; \
884 SV * const tmpsv = newSVpvs(""); \
885 if (PL_opargs[optype] & OA_TARGLEX) { \
886 if (oppriv & OPpTARGET_MY) \
887 sv_catpv(tmpsv, ",TARGET_MY"); \
889 else if (optype == OP_ENTERSUB || \
890 optype == OP_RV2SV || \
891 optype == OP_GVSV || \
892 optype == OP_RV2AV || \
893 optype == OP_RV2HV || \
894 optype == OP_RV2GV || \
895 optype == OP_AELEM || \
896 optype == OP_HELEM ) \
898 if (optype == OP_ENTERSUB) { \
899 append_flags(tmpsv, oppriv, op_entersub_names); \
902 switch (oppriv & OPpDEREF) { \
904 sv_catpv(tmpsv, ",SV"); \
907 sv_catpv(tmpsv, ",AV"); \
910 sv_catpv(tmpsv, ",HV"); \
913 if (oppriv & OPpMAYBE_LVSUB) \
914 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
916 if (optype == OP_AELEM || optype == OP_HELEM) { \
917 if (oppriv & OPpLVAL_DEFER) \
918 sv_catpv(tmpsv, ",LVAL_DEFER"); \
920 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
921 if (oppriv & OPpMAYBE_TRUEBOOL) \
922 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
923 if (oppriv & OPpTRUEBOOL) \
924 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
927 if (oppriv & HINT_STRICT_REFS) \
928 sv_catpv(tmpsv, ",STRICT_REFS"); \
929 if (oppriv & OPpOUR_INTRO) \
930 sv_catpv(tmpsv, ",OUR_INTRO"); \
933 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
935 else if (OP_IS_FILETEST(o->op_type)) { \
936 if (oppriv & OPpFT_ACCESS) \
937 sv_catpv(tmpsv, ",FT_ACCESS"); \
938 if (oppriv & OPpFT_STACKED) \
939 sv_catpv(tmpsv, ",FT_STACKED"); \
940 if (oppriv & OPpFT_STACKING) \
941 sv_catpv(tmpsv, ",FT_STACKING"); \
942 if (oppriv & OPpFT_AFTER_t) \
943 sv_catpv(tmpsv, ",AFTER_t"); \
945 else if (o->op_type == OP_AASSIGN) { \
946 if (oppriv & OPpASSIGN_COMMON) \
947 sv_catpvs(tmpsv, ",COMMON"); \
948 if (oppriv & OPpMAYBE_LVSUB) \
949 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
951 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
952 sv_catpv(tmpsv, ",INTRO"); \
953 if (o->op_type == OP_PADRANGE) \
954 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
955 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
956 if ( (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV || \
957 o->op_type == OP_PADAV || o->op_type == OP_PADHV || \
958 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE || \
959 o->op_type == OP_KVHSLICE || o->op_type == OP_KVASLICE) \
960 && oppriv & OPpSLICEWARNING ) \
961 sv_catpvs(tmpsv, ",SLICEWARNING"); \
962 if (SvCUR(tmpsv)) { \
964 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
966 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
968 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
970 SvREFCNT_dec_NN(tmpsv); \
975 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
979 const OPCODE optype = o->op_type;
981 PERL_ARGS_ASSERT_DO_OP_DUMP;
983 Perl_dump_indent(aTHX_ level, file, "{\n");
985 seq = sequence_num(o);
987 PerlIO_printf(file, "%-4"UVuf, seq);
989 PerlIO_printf(file, "????");
991 "%*sTYPE = %s ===> ",
992 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
995 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
996 sequence_num(o->op_next));
998 PerlIO_printf(file, "NULL\n");
1000 if (optype == OP_NULL) {
1001 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
1002 if (o->op_targ == OP_NEXTSTATE) {
1004 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1005 (UV)CopLINE(cCOPo));
1006 if (CopSTASHPV(cCOPo))
1007 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1009 if (CopLABEL(cCOPo))
1010 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1015 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1018 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1021 DUMP_OP_FLAGS(o,0,level,file);
1022 DUMP_OP_PRIVATE(o,0,level,file);
1025 if (PL_madskills && o->op_madprop) {
1026 SV * const tmpsv = newSVpvs("");
1027 MADPROP* mp = o->op_madprop;
1028 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1031 const char tmp = mp->mad_key;
1032 sv_setpvs(tmpsv,"'");
1034 sv_catpvn(tmpsv, &tmp, 1);
1035 sv_catpv(tmpsv, "'=");
1036 switch (mp->mad_type) {
1038 sv_catpv(tmpsv, "NULL");
1039 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1042 sv_catpv(tmpsv, "<");
1043 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1044 sv_catpv(tmpsv, ">");
1045 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1048 if ((OP*)mp->mad_val) {
1049 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1050 do_op_dump(level, file, (OP*)mp->mad_val);
1054 sv_catpv(tmpsv, "(UNK)");
1055 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1061 Perl_dump_indent(aTHX_ level, file, "}\n");
1063 SvREFCNT_dec_NN(tmpsv);
1072 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1074 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1075 if (cSVOPo->op_sv) {
1076 SV * const tmpsv = newSV(0);
1080 /* FIXME - is this making unwarranted assumptions about the
1081 UTF-8 cleanliness of the dump file handle? */
1084 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1085 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1086 SvPV_nolen_const(tmpsv));
1090 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1096 case OP_METHOD_NAMED:
1097 #ifndef USE_ITHREADS
1098 /* with ITHREADS, consts are stored in the pad, and the right pad
1099 * may not be active here, so skip */
1100 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1106 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1107 (UV)CopLINE(cCOPo));
1108 if (CopSTASHPV(cCOPo))
1109 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1111 if (CopLABEL(cCOPo))
1112 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1116 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1117 if (cLOOPo->op_redoop)
1118 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1120 PerlIO_printf(file, "DONE\n");
1121 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1122 if (cLOOPo->op_nextop)
1123 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1125 PerlIO_printf(file, "DONE\n");
1126 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1127 if (cLOOPo->op_lastop)
1128 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1130 PerlIO_printf(file, "DONE\n");
1138 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1139 if (cLOGOPo->op_other)
1140 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1142 PerlIO_printf(file, "DONE\n");
1148 do_pmop_dump(level, file, cPMOPo);
1156 if (o->op_private & OPpREFCOUNTED)
1157 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1162 if (o->op_flags & OPf_KIDS) {
1164 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1165 do_op_dump(level, file, kid);
1167 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1171 Perl_op_dump(pTHX_ const OP *o)
1173 PERL_ARGS_ASSERT_OP_DUMP;
1174 do_op_dump(0, Perl_debug_log, o);
1178 Perl_gv_dump(pTHX_ GV *gv)
1182 PERL_ARGS_ASSERT_GV_DUMP;
1185 PerlIO_printf(Perl_debug_log, "{}\n");
1188 sv = sv_newmortal();
1189 PerlIO_printf(Perl_debug_log, "{\n");
1190 gv_fullname3(sv, gv, NULL);
1191 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1192 if (gv != GvEGV(gv)) {
1193 gv_efullname3(sv, GvEGV(gv), NULL);
1194 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1196 PerlIO_putc(Perl_debug_log, '\n');
1197 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1201 /* map magic types to the symbolic names
1202 * (with the PERL_MAGIC_ prefixed stripped)
1205 static const struct { const char type; const char *name; } magic_names[] = {
1206 #include "mg_names.c"
1207 /* this null string terminates the list */
1212 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1214 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1216 for (; mg; mg = mg->mg_moremagic) {
1217 Perl_dump_indent(aTHX_ level, file,
1218 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1219 if (mg->mg_virtual) {
1220 const MGVTBL * const v = mg->mg_virtual;
1221 if (v >= PL_magic_vtables
1222 && v < PL_magic_vtables + magic_vtable_max) {
1223 const U32 i = v - PL_magic_vtables;
1224 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1227 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1230 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1233 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1237 const char *name = NULL;
1238 for (n = 0; magic_names[n].name; n++) {
1239 if (mg->mg_type == magic_names[n].type) {
1240 name = magic_names[n].name;
1245 Perl_dump_indent(aTHX_ level, file,
1246 " MG_TYPE = PERL_MAGIC_%s\n", name);
1248 Perl_dump_indent(aTHX_ level, file,
1249 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1253 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1254 if (mg->mg_type == PERL_MAGIC_envelem &&
1255 mg->mg_flags & MGf_TAINTEDDIR)
1256 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1257 if (mg->mg_type == PERL_MAGIC_regex_global &&
1258 mg->mg_flags & MGf_MINMATCH)
1259 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1260 if (mg->mg_flags & MGf_REFCOUNTED)
1261 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1262 if (mg->mg_flags & MGf_GSKIP)
1263 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1264 if (mg->mg_flags & MGf_COPY)
1265 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1266 if (mg->mg_flags & MGf_DUP)
1267 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1268 if (mg->mg_flags & MGf_LOCAL)
1269 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1270 if (mg->mg_type == PERL_MAGIC_regex_global &&
1271 mg->mg_flags & MGf_BYTES)
1272 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1275 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1276 PTR2UV(mg->mg_obj));
1277 if (mg->mg_type == PERL_MAGIC_qr) {
1278 REGEXP* const re = (REGEXP *)mg->mg_obj;
1279 SV * const dsv = sv_newmortal();
1280 const char * const s
1281 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1283 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1284 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1286 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1287 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1290 if (mg->mg_flags & MGf_REFCOUNTED)
1291 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1294 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1296 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1297 if (mg->mg_len >= 0) {
1298 if (mg->mg_type != PERL_MAGIC_utf8) {
1299 SV * const sv = newSVpvs("");
1300 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1301 SvREFCNT_dec_NN(sv);
1304 else if (mg->mg_len == HEf_SVKEY) {
1305 PerlIO_puts(file, " => HEf_SVKEY\n");
1306 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1307 maxnest, dumpops, pvlim); /* MG is already +1 */
1310 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1315 " does not know how to handle this MG_LEN"
1317 PerlIO_putc(file, '\n');
1319 if (mg->mg_type == PERL_MAGIC_utf8) {
1320 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1323 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1324 Perl_dump_indent(aTHX_ level, file,
1325 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1328 (UV)cache[i * 2 + 1]);
1335 Perl_magic_dump(pTHX_ const MAGIC *mg)
1337 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1341 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1345 PERL_ARGS_ASSERT_DO_HV_DUMP;
1347 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1348 if (sv && (hvname = HvNAME_get(sv)))
1350 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1351 name which quite legally could contain insane things like tabs, newlines, nulls or
1352 other scary crap - this should produce sane results - except maybe for unicode package
1353 names - but we will wait for someone to file a bug on that - demerphq */
1354 SV * const tmpsv = newSVpvs("");
1355 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1358 PerlIO_putc(file, '\n');
1362 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1364 PERL_ARGS_ASSERT_DO_GV_DUMP;
1366 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1367 if (sv && GvNAME(sv))
1368 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1370 PerlIO_putc(file, '\n');
1374 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1376 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1378 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1379 if (sv && GvNAME(sv)) {
1381 PerlIO_printf(file, "\t\"");
1382 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1383 PerlIO_printf(file, "%s\" :: \"", hvname);
1384 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1387 PerlIO_putc(file, '\n');
1390 const struct flag_to_name first_sv_flags_names[] = {
1391 {SVs_TEMP, "TEMP,"},
1392 {SVs_OBJECT, "OBJECT,"},
1401 const struct flag_to_name second_sv_flags_names[] = {
1403 {SVf_FAKE, "FAKE,"},
1404 {SVf_READONLY, "READONLY,"},
1405 {SVf_IsCOW, "IsCOW,"},
1406 {SVf_BREAK, "BREAK,"},
1407 {SVf_AMAGIC, "OVERLOAD,"},
1413 const struct flag_to_name cv_flags_names[] = {
1414 {CVf_ANON, "ANON,"},
1415 {CVf_UNIQUE, "UNIQUE,"},
1416 {CVf_CLONE, "CLONE,"},
1417 {CVf_CLONED, "CLONED,"},
1418 {CVf_CONST, "CONST,"},
1419 {CVf_NODEBUG, "NODEBUG,"},
1420 {CVf_LVALUE, "LVALUE,"},
1421 {CVf_METHOD, "METHOD,"},
1422 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1423 {CVf_CVGV_RC, "CVGV_RC,"},
1424 {CVf_DYNFILE, "DYNFILE,"},
1425 {CVf_AUTOLOAD, "AUTOLOAD,"},
1426 {CVf_HASEVAL, "HASEVAL"},
1427 {CVf_SLABBED, "SLABBED,"},
1428 {CVf_ISXSUB, "ISXSUB,"}
1431 const struct flag_to_name hv_flags_names[] = {
1432 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1433 {SVphv_LAZYDEL, "LAZYDEL,"},
1434 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1435 {SVphv_CLONEABLE, "CLONEABLE,"}
1438 const struct flag_to_name gp_flags_names[] = {
1439 {GVf_INTRO, "INTRO,"},
1440 {GVf_MULTI, "MULTI,"},
1441 {GVf_ASSUMECV, "ASSUMECV,"},
1442 {GVf_IN_PAD, "IN_PAD,"}
1445 const struct flag_to_name gp_flags_imported_names[] = {
1446 {GVf_IMPORTED_SV, " SV"},
1447 {GVf_IMPORTED_AV, " AV"},
1448 {GVf_IMPORTED_HV, " HV"},
1449 {GVf_IMPORTED_CV, " CV"},
1452 const struct flag_to_name regexp_flags_names[] = {
1453 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1454 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1455 {RXf_PMf_FOLD, "PMf_FOLD,"},
1456 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1457 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1458 {RXf_ANCH_BOL, "ANCH_BOL,"},
1459 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1460 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1461 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1462 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1463 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1464 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1465 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1466 {RXf_CANY_SEEN, "CANY_SEEN,"},
1467 {RXf_NOSCAN, "NOSCAN,"},
1468 {RXf_CHECK_ALL, "CHECK_ALL,"},
1469 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1470 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1471 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1472 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1473 {RXf_SPLIT, "SPLIT,"},
1474 {RXf_COPY_DONE, "COPY_DONE,"},
1475 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1476 {RXf_TAINTED, "TAINTED,"},
1477 {RXf_START_ONLY, "START_ONLY,"},
1478 {RXf_SKIPWHITE, "SKIPWHITE,"},
1479 {RXf_WHITE, "WHITE,"},
1480 {RXf_NULL, "NULL,"},
1484 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1492 PERL_ARGS_ASSERT_DO_SV_DUMP;
1495 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1499 flags = SvFLAGS(sv);
1502 /* process general SV flags */
1504 d = Perl_newSVpvf(aTHX_
1505 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1506 PTR2UV(SvANY(sv)), PTR2UV(sv),
1507 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1508 (int)(PL_dumpindent*level), "");
1510 if (!((flags & SVpad_NAME) == SVpad_NAME
1511 && (type == SVt_PVMG || type == SVt_PVNV))) {
1512 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1513 sv_catpv(d, "PADSTALE,");
1515 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1516 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1517 sv_catpv(d, "PADTMP,");
1518 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1520 append_flags(d, flags, first_sv_flags_names);
1521 if (flags & SVf_ROK) {
1522 sv_catpv(d, "ROK,");
1523 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1525 append_flags(d, flags, second_sv_flags_names);
1526 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1527 && type != SVt_PVAV) {
1528 if (SvPCS_IMPORTED(sv))
1529 sv_catpv(d, "PCS_IMPORTED,");
1531 sv_catpv(d, "SCREAM,");
1534 /* process type-specific SV flags */
1539 append_flags(d, CvFLAGS(sv), cv_flags_names);
1542 append_flags(d, flags, hv_flags_names);
1546 if (isGV_with_GP(sv)) {
1547 append_flags(d, GvFLAGS(sv), gp_flags_names);
1549 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1550 sv_catpv(d, "IMPORT");
1551 if (GvIMPORTED(sv) == GVf_IMPORTED)
1552 sv_catpv(d, "ALL,");
1555 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1562 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1563 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1566 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1567 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1568 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1569 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1572 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1575 if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1578 /* SVphv_SHAREKEYS is also 0x20000000 */
1579 if ((type != SVt_PVHV) && SvUTF8(sv))
1580 sv_catpv(d, "UTF8");
1582 if (*(SvEND(d) - 1) == ',') {
1583 SvCUR_set(d, SvCUR(d) - 1);
1584 SvPVX(d)[SvCUR(d)] = '\0';
1589 /* dump initial SV details */
1591 #ifdef DEBUG_LEAKING_SCALARS
1592 Perl_dump_indent(aTHX_ level, file,
1593 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1594 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1596 sv->sv_debug_inpad ? "for" : "by",
1597 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1598 PTR2UV(sv->sv_debug_parent),
1602 Perl_dump_indent(aTHX_ level, file, "SV = ");
1606 if (type < SVt_LAST) {
1607 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1609 if (type == SVt_NULL) {
1614 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1619 /* Dump general SV fields */
1621 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1622 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1623 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1624 || (type == SVt_IV && !SvROK(sv))) {
1626 #ifdef PERL_OLD_COPY_ON_WRITE
1630 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1632 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1633 #ifdef PERL_OLD_COPY_ON_WRITE
1634 if (SvIsCOW_shared_hash(sv))
1635 PerlIO_printf(file, " (HASH)");
1636 else if (SvIsCOW_normal(sv))
1637 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1639 PerlIO_putc(file, '\n');
1642 if ((type == SVt_PVNV || type == SVt_PVMG)
1643 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1644 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1645 (UV) COP_SEQ_RANGE_LOW(sv));
1646 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1647 (UV) COP_SEQ_RANGE_HIGH(sv));
1648 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1649 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1650 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1651 || type == SVt_NV) {
1652 STORE_NUMERIC_LOCAL_SET_STANDARD();
1653 /* %Vg doesn't work? --jhi */
1654 #ifdef USE_LONG_DOUBLE
1655 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1657 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1659 RESTORE_NUMERIC_LOCAL();
1663 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1665 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1668 if (type < SVt_PV) {
1673 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1674 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1675 const bool re = isREGEXP(sv);
1676 const char * const ptr =
1677 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1681 SvOOK_offset(sv, delta);
1682 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1687 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1689 PerlIO_printf(file, "( %s . ) ",
1690 pv_display(d, ptr - delta, delta, 0,
1693 if (type == SVt_INVLIST) {
1694 PerlIO_printf(file, "\n");
1695 /* 4 blanks indents 2 beyond the PV, etc */
1696 _invlist_dump(file, level, " ", sv);
1699 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1702 if (SvUTF8(sv)) /* the 6? \x{....} */
1703 PerlIO_printf(file, " [UTF8 \"%s\"]",
1704 sv_uni_display(d, sv, 6 * SvCUR(sv),
1706 PerlIO_printf(file, "\n");
1708 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1710 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1712 #ifdef PERL_NEW_COPY_ON_WRITE
1713 if (SvIsCOW(sv) && SvLEN(sv))
1714 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1719 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1722 if (type >= SVt_PVMG) {
1723 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1724 HV * const ost = SvOURSTASH(sv);
1726 do_hv_dump(level, file, " OURSTASH", ost);
1727 } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1728 Perl_dump_indent(aTHX_ level, file, " MAXNAMED = %"UVuf"\n",
1729 (UV)PadnamelistMAXNAMED(sv));
1732 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1735 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1737 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1738 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1742 /* Dump type-specific SV fields */
1746 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1747 if (AvARRAY(sv) != AvALLOC(sv)) {
1748 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1749 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1752 PerlIO_putc(file, '\n');
1753 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1754 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1755 /* arylen is stored in magic, and padnamelists use SvMAGIC for
1757 if (!AvPAD_NAMELIST(sv))
1758 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1759 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1761 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1762 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1763 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1764 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1765 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1767 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1768 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1770 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1772 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1777 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1778 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1779 /* Show distribution of HEs in the ARRAY */
1781 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1784 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1785 NV theoret, sum = 0;
1787 PerlIO_printf(file, " (");
1788 Zero(freq, FREQ_MAX + 1, int);
1789 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1792 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1794 if (count > FREQ_MAX)
1800 for (i = 0; i <= max; i++) {
1802 PerlIO_printf(file, "%d%s:%d", i,
1803 (i == FREQ_MAX) ? "+" : "",
1806 PerlIO_printf(file, ", ");
1809 PerlIO_putc(file, ')');
1810 /* The "quality" of a hash is defined as the total number of
1811 comparisons needed to access every element once, relative
1812 to the expected number needed for a random hash.
1814 The total number of comparisons is equal to the sum of
1815 the squares of the number of entries in each bucket.
1816 For a random hash of n keys into k buckets, the expected
1821 for (i = max; i > 0; i--) { /* Precision: count down. */
1822 sum += freq[i] * i * i;
1824 while ((keys = keys >> 1))
1826 theoret = HvUSEDKEYS(sv);
1827 theoret += theoret * (theoret-1)/pow2;
1828 PerlIO_putc(file, '\n');
1829 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1831 PerlIO_putc(file, '\n');
1832 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1835 HE **ents = HvARRAY(sv);
1838 HE *const *const last = ents + HvMAX(sv);
1839 count = last + 1 - ents;
1844 } while (++ents <= last);
1848 struct xpvhv_aux *const aux = HvAUX(sv);
1849 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1850 " (cached = %"UVuf")\n",
1851 (UV)count, (UV)aux->xhv_fill_lazy);
1853 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1857 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1859 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1860 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1861 #ifdef PERL_HASH_RANDOMIZE_KEYS
1862 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1863 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1864 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1867 PerlIO_putc(file, '\n');
1870 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1871 if (mg && mg->mg_obj) {
1872 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1876 const char * const hvname = HvNAME_get(sv);
1878 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1882 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1883 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1884 if (HvAUX(sv)->xhv_name_count)
1885 Perl_dump_indent(aTHX_
1886 level, file, " NAMECOUNT = %"IVdf"\n",
1887 (IV)HvAUX(sv)->xhv_name_count
1889 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1890 const I32 count = HvAUX(sv)->xhv_name_count;
1892 SV * const names = newSVpvs_flags("", SVs_TEMP);
1893 /* The starting point is the first element if count is
1894 positive and the second element if count is negative. */
1895 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1896 + (count < 0 ? 1 : 0);
1897 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1898 + (count < 0 ? -count : count);
1899 while (hekp < endp) {
1901 sv_catpvs(names, ", \"");
1902 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1903 sv_catpvs(names, "\"");
1905 /* This should never happen. */
1906 sv_catpvs(names, ", (null)");
1910 Perl_dump_indent(aTHX_
1911 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1915 Perl_dump_indent(aTHX_
1916 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1920 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1922 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1926 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1927 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1928 (int)meta->mro_which->length,
1929 meta->mro_which->name,
1930 PTR2UV(meta->mro_which));
1931 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1932 (UV)meta->cache_gen);
1933 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1935 if (meta->mro_linear_all) {
1936 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1937 PTR2UV(meta->mro_linear_all));
1938 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1941 if (meta->mro_linear_current) {
1942 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1943 PTR2UV(meta->mro_linear_current));
1944 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1947 if (meta->mro_nextmethod) {
1948 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1949 PTR2UV(meta->mro_nextmethod));
1950 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1954 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1956 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1961 if (nest < maxnest) {
1962 HV * const hv = MUTABLE_HV(sv);
1967 int count = maxnest - nest;
1968 for (i=0; i <= HvMAX(hv); i++) {
1969 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1976 if (count-- <= 0) goto DONEHV;
1979 keysv = hv_iterkeysv(he);
1980 keypv = SvPV_const(keysv, len);
1983 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1985 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1986 if (HvEITER_get(hv) == he)
1987 PerlIO_printf(file, "[CURRENT] ");
1988 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1989 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1998 if (CvAUTOLOAD(sv)) {
2000 const char *const name = SvPV_const(sv, len);
2001 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
2005 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
2006 (int) CvPROTOLEN(sv), CvPROTO(sv));
2010 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2011 if (!CvISXSUB(sv)) {
2013 Perl_dump_indent(aTHX_ level, file,
2014 " START = 0x%"UVxf" ===> %"IVdf"\n",
2015 PTR2UV(CvSTART(sv)),
2016 (IV)sequence_num(CvSTART(sv)));
2018 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
2019 PTR2UV(CvROOT(sv)));
2020 if (CvROOT(sv) && dumpops) {
2021 do_op_dump(level+1, file, CvROOT(sv));
2024 SV * const constant = cv_const_sv((const CV *)sv);
2026 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2029 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2031 PTR2UV(CvXSUBANY(sv).any_ptr));
2032 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2035 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2036 (IV)CvXSUBANY(sv).any_i32);
2040 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2041 HEK_KEY(CvNAME_HEK((CV *)sv)));
2042 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2043 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2044 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2045 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2046 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2047 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2048 if (nest < maxnest) {
2049 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2052 const CV * const outside = CvOUTSIDE(sv);
2053 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2056 : CvANON(outside) ? "ANON"
2057 : (outside == PL_main_cv) ? "MAIN"
2058 : CvUNIQUE(outside) ? "UNIQUE"
2059 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2061 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2062 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2067 if (type == SVt_PVLV) {
2068 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2069 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2070 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2071 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2072 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2073 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2074 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2077 if (isREGEXP(sv)) goto dumpregexp;
2078 if (!isGV_with_GP(sv))
2080 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2081 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2082 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2083 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2086 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2087 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2088 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2089 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2090 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2091 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2092 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2093 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2094 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2095 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2096 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2097 do_gv_dump (level, file, " EGV", GvEGV(sv));
2100 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2101 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2102 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2103 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2104 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2105 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2106 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2108 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2109 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2110 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2112 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2113 PTR2UV(IoTOP_GV(sv)));
2114 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2115 maxnest, dumpops, pvlim);
2117 /* Source filters hide things that are not GVs in these three, so let's
2118 be careful out there. */
2120 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2121 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2122 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2124 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2125 PTR2UV(IoFMT_GV(sv)));
2126 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2127 maxnest, dumpops, pvlim);
2129 if (IoBOTTOM_NAME(sv))
2130 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2131 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2132 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2134 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2135 PTR2UV(IoBOTTOM_GV(sv)));
2136 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2137 maxnest, dumpops, pvlim);
2139 if (isPRINT(IoTYPE(sv)))
2140 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2142 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2143 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2148 struct regexp * const r = ReANY((REGEXP*)sv);
2149 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
2151 append_flags(d, flags, regexp_flags_names); \
2152 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2153 SvCUR_set(d, SvCUR(d) - 1); \
2154 SvPVX(d)[SvCUR(d)] = '\0'; \
2157 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
2158 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2159 (UV)(r->compflags), SvPVX_const(d));
2161 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
2162 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2163 (UV)(r->extflags), SvPVX_const(d));
2164 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2166 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2168 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2170 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2171 (UV)(r->lastparen));
2172 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2173 (UV)(r->lastcloseparen));
2174 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2176 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2177 (IV)(r->minlenret));
2178 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2180 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2181 (UV)(r->pre_prefix));
2182 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2184 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2185 (IV)(r->suboffset));
2186 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2187 (IV)(r->subcoffset));
2189 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2191 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2193 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2194 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2196 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2197 PTR2UV(r->mother_re));
2198 if (nest < maxnest && r->mother_re)
2199 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2200 maxnest, dumpops, pvlim);
2201 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2202 PTR2UV(r->paren_names));
2203 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2204 PTR2UV(r->substrs));
2205 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2206 PTR2UV(r->pprivate));
2207 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2209 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2210 PTR2UV(r->qr_anoncv));
2212 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2213 PTR2UV(r->saved_copy));
2222 Perl_sv_dump(pTHX_ SV *sv)
2226 PERL_ARGS_ASSERT_SV_DUMP;
2229 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2231 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2235 Perl_runops_debug(pTHX)
2239 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2243 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2245 #ifdef PERL_TRACE_OPS
2246 ++PL_op_exec_cnt[PL_op->op_type];
2249 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2250 PerlIO_printf(Perl_debug_log,
2251 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2252 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2253 PTR2UV(*PL_watchaddr));
2254 if (DEBUG_s_TEST_) {
2255 if (DEBUG_v_TEST_) {
2256 PerlIO_printf(Perl_debug_log, "\n");
2264 if (DEBUG_t_TEST_) debop(PL_op);
2265 if (DEBUG_P_TEST_) debprof(PL_op);
2268 OP_ENTRY_PROBE(OP_NAME(PL_op));
2269 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2270 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2278 Perl_debop(pTHX_ const OP *o)
2282 PERL_ARGS_ASSERT_DEBOP;
2284 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2287 Perl_deb(aTHX_ "%s", OP_NAME(o));
2288 switch (o->op_type) {
2291 /* With ITHREADS, consts are stored in the pad, and the right pad
2292 * may not be active here, so check.
2293 * Looks like only during compiling the pads are illegal.
2296 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2298 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2303 SV * const sv = newSV(0);
2305 /* FIXME - is this making unwarranted assumptions about the
2306 UTF-8 cleanliness of the dump file handle? */
2309 gv_fullname3(sv, cGVOPo_gv, NULL);
2310 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2311 SvREFCNT_dec_NN(sv);
2314 PerlIO_printf(Perl_debug_log, "(NULL)");
2326 count = o->op_private & OPpPADRANGE_COUNTMASK;
2328 /* print the lexical's name */
2330 CV * const cv = deb_curcv(cxstack_ix);
2332 PAD * comppad = NULL;
2336 PADLIST * const padlist = CvPADLIST(cv);
2337 comppad = *PadlistARRAY(padlist);
2339 PerlIO_printf(Perl_debug_log, "(");
2340 for (i = 0; i < count; i++) {
2342 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2343 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2345 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2348 PerlIO_printf(Perl_debug_log, ",");
2350 PerlIO_printf(Perl_debug_log, ")");
2358 PerlIO_printf(Perl_debug_log, "\n");
2363 S_deb_curcv(pTHX_ const I32 ix)
2366 const PERL_CONTEXT * const cx = &cxstack[ix];
2367 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2368 return cx->blk_sub.cv;
2369 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2370 return cx->blk_eval.cv;
2371 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2376 return deb_curcv(ix - 1);
2380 Perl_watch(pTHX_ char **addr)
2384 PERL_ARGS_ASSERT_WATCH;
2386 PL_watchaddr = addr;
2388 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2389 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2393 S_debprof(pTHX_ const OP *o)
2397 PERL_ARGS_ASSERT_DEBPROF;
2399 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2401 if (!PL_profiledata)
2402 Newxz(PL_profiledata, MAXO, U32);
2403 ++PL_profiledata[o->op_type];
2407 Perl_debprofdump(pTHX)
2411 if (!PL_profiledata)
2413 for (i = 0; i < MAXO; i++) {
2414 if (PL_profiledata[i])
2415 PerlIO_printf(Perl_debug_log,
2416 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2423 * XML variants of most of the above routines
2427 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2431 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2433 PerlIO_printf(file, "\n ");
2434 va_start(args, pat);
2435 xmldump_vindent(level, file, pat, &args);
2441 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2444 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2445 va_start(args, pat);
2446 xmldump_vindent(level, file, pat, &args);
2451 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2453 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2455 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2456 PerlIO_vprintf(file, pat, *args);
2460 Perl_xmldump_all(pTHX)
2462 xmldump_all_perl(FALSE);
2466 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2468 PerlIO_setlinebuf(PL_xmlfp);
2470 op_xmldump(PL_main_root);
2471 /* someday we might call this, when it outputs XML: */
2472 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2473 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2474 PerlIO_close(PL_xmlfp);
2479 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2481 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2482 xmldump_packsubs_perl(stash, FALSE);
2486 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2491 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2493 if (!HvARRAY(stash))
2495 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2496 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2497 GV *gv = MUTABLE_GV(HeVAL(entry));
2499 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2502 xmldump_sub_perl(gv, justperl);
2505 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2506 && (hv = GvHV(gv)) && hv != PL_defstash)
2507 xmldump_packsubs_perl(hv, justperl); /* nested package */
2513 Perl_xmldump_sub(pTHX_ const GV *gv)
2515 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2516 xmldump_sub_perl(gv, FALSE);
2520 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2524 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2526 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2529 sv = sv_newmortal();
2530 gv_fullname3(sv, gv, NULL);
2531 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2532 if (CvXSUB(GvCV(gv)))
2533 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2534 PTR2UV(CvXSUB(GvCV(gv))),
2535 (int)CvXSUBANY(GvCV(gv)).any_i32);
2536 else if (CvROOT(GvCV(gv)))
2537 op_xmldump(CvROOT(GvCV(gv)));
2539 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2543 Perl_xmldump_form(pTHX_ const GV *gv)
2545 SV * const sv = sv_newmortal();
2547 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2549 gv_fullname3(sv, gv, NULL);
2550 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2551 if (CvROOT(GvFORM(gv)))
2552 op_xmldump(CvROOT(GvFORM(gv)));
2554 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2558 Perl_xmldump_eval(pTHX)
2560 op_xmldump(PL_eval_root);
2564 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2566 PERL_ARGS_ASSERT_SV_CATXMLSV;
2567 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2571 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2573 PERL_ARGS_ASSERT_SV_CATXMLPV;
2574 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2578 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2581 const char * const e = pv + len;
2582 const char * const start = pv;
2586 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2589 dsvcur = SvCUR(dsv); /* in case we have to restart */
2594 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2596 SvCUR(dsv) = dsvcur;
2609 && c != LATIN1_TO_NATIVE(0x85))
2611 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2615 sv_catpvs(dsv, "<");
2618 sv_catpvs(dsv, ">");
2621 sv_catpvs(dsv, "&");
2624 sv_catpvs(dsv, """);
2629 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2632 const char string = (char) c;
2633 sv_catpvn(dsv, &string, 1);
2637 if ((c >= 0xD800 && c <= 0xDB7F) ||
2638 (c >= 0xDC00 && c <= 0xDFFF) ||
2639 (c >= 0xFFF0 && c <= 0xFFFF) ||
2641 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2643 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2656 Perl_sv_xmlpeek(pTHX_ SV *sv)
2658 SV * const t = sv_newmortal();
2662 PERL_ARGS_ASSERT_SV_XMLPEEK;
2668 sv_catpv(t, "VOID=\"\"");
2671 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2672 sv_catpv(t, "WILD=\"\"");
2675 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2676 if (sv == &PL_sv_undef) {
2677 sv_catpv(t, "SV_UNDEF=\"1\"");
2678 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2679 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2683 else if (sv == &PL_sv_no) {
2684 sv_catpv(t, "SV_NO=\"1\"");
2685 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2686 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2687 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2688 SVp_POK|SVp_NOK)) &&
2693 else if (sv == &PL_sv_yes) {
2694 sv_catpv(t, "SV_YES=\"1\"");
2695 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2696 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2697 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2698 SVp_POK|SVp_NOK)) &&
2700 SvPVX(sv) && *SvPVX(sv) == '1' &&
2705 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2706 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2707 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2711 sv_catpv(t, " XXX=\"\" ");
2713 else if (SvREFCNT(sv) == 0) {
2714 sv_catpv(t, " refcnt=\"0\"");
2717 else if (DEBUG_R_TEST_) {
2720 /* is this SV on the tmps stack? */
2721 for (ix=PL_tmps_ix; ix>=0; ix--) {
2722 if (PL_tmps_stack[ix] == sv) {
2727 if (SvREFCNT(sv) > 1)
2728 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2731 sv_catpv(t, " DRT=\"<T>\"");
2735 sv_catpv(t, " ROK=\"\"");
2737 switch (SvTYPE(sv)) {
2739 sv_catpv(t, " FREED=\"1\"");
2743 sv_catpv(t, " UNDEF=\"1\"");
2746 sv_catpv(t, " IV=\"");
2749 sv_catpv(t, " NV=\"");
2752 sv_catpv(t, " PV=\"");
2755 sv_catpv(t, " PVIV=\"");
2758 sv_catpv(t, " PVNV=\"");
2761 sv_catpv(t, " PVMG=\"");
2764 sv_catpv(t, " PVLV=\"");
2767 sv_catpv(t, " AV=\"");
2770 sv_catpv(t, " HV=\"");
2774 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2776 sv_catpv(t, " CV=\"()\"");
2779 sv_catpv(t, " GV=\"");
2782 sv_catpv(t, " DUMMY=\"");
2785 sv_catpv(t, " REGEXP=\"");
2788 sv_catpv(t, " FM=\"");
2791 sv_catpv(t, " IO=\"");
2800 else if (SvNOKp(sv)) {
2801 STORE_NUMERIC_LOCAL_SET_STANDARD();
2802 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2803 RESTORE_NUMERIC_LOCAL();
2805 else if (SvIOKp(sv)) {
2807 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2809 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2818 return SvPV(t, n_a);
2822 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2824 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2827 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2830 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2833 REGEXP *const r = PM_GETRE(pm);
2834 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2835 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2836 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2838 SvREFCNT_dec_NN(tmpsv);
2839 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2840 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2843 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2844 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2845 SV * const tmpsv = pm_description(pm);
2846 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2847 SvREFCNT_dec_NN(tmpsv);
2851 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2852 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2853 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2854 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2855 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2856 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2859 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2863 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2865 do_pmop_xmldump(0, PL_xmlfp, pm);
2869 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2873 const OPCODE optype = o->op_type;
2875 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2879 seq = sequence_num(o);
2880 Perl_xmldump_indent(aTHX_ level, file,
2881 "<op_%s seq=\"%"UVuf" -> ",
2886 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2887 sequence_num(o->op_next));
2889 PerlIO_printf(file, "DONE\"");
2892 if (optype == OP_NULL)
2894 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2895 if (o->op_targ == OP_NEXTSTATE)
2898 PerlIO_printf(file, " line=\"%"UVuf"\"",
2899 (UV)CopLINE(cCOPo));
2900 if (CopSTASHPV(cCOPo))
2901 PerlIO_printf(file, " package=\"%s\"",
2903 if (CopLABEL(cCOPo))
2904 PerlIO_printf(file, " label=\"%s\"",
2909 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2912 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2915 DUMP_OP_FLAGS(o,1,0,file);
2916 DUMP_OP_PRIVATE(o,1,0,file);
2920 if (o->op_flags & OPf_SPECIAL) {
2926 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2928 if (cSVOPo->op_sv) {
2929 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2930 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2936 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2937 s = SvPV(tmpsv1,len);
2938 sv_catxmlpvn(tmpsv2, s, len, 1);
2939 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2943 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2948 case OP_METHOD_NAMED:
2949 #ifndef USE_ITHREADS
2950 /* with ITHREADS, consts are stored in the pad, and the right pad
2951 * may not be active here, so skip */
2952 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2958 PerlIO_printf(file, ">\n");
2960 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2965 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2966 (UV)CopLINE(cCOPo));
2967 if (CopSTASHPV(cCOPo))
2968 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2970 if (CopLABEL(cCOPo))
2971 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2975 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2976 if (cLOOPo->op_redoop)
2977 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2979 PerlIO_printf(file, "DONE\"");
2980 S_xmldump_attr(aTHX_ level, file, "next=\"");
2981 if (cLOOPo->op_nextop)
2982 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2984 PerlIO_printf(file, "DONE\"");
2985 S_xmldump_attr(aTHX_ level, file, "last=\"");
2986 if (cLOOPo->op_lastop)
2987 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2989 PerlIO_printf(file, "DONE\"");
2997 S_xmldump_attr(aTHX_ level, file, "other=\"");
2998 if (cLOGOPo->op_other)
2999 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3001 PerlIO_printf(file, "DONE\"");
3009 if (o->op_private & OPpREFCOUNTED)
3010 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3016 if (PL_madskills && o->op_madprop) {
3017 char prevkey = '\0';
3018 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3019 const MADPROP* mp = o->op_madprop;
3023 PerlIO_printf(file, ">\n");
3025 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3028 char tmp = mp->mad_key;
3029 sv_setpvs(tmpsv,"\"");
3031 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3032 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3033 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3036 sv_catpv(tmpsv, "\"");
3037 switch (mp->mad_type) {
3039 sv_catpv(tmpsv, "NULL");
3040 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3043 sv_catpv(tmpsv, " val=\"");
3044 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3045 sv_catpv(tmpsv, "\"");
3046 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3049 sv_catpv(tmpsv, " val=\"");
3050 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3051 sv_catpv(tmpsv, "\"");
3052 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3055 if ((OP*)mp->mad_val) {
3056 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3057 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3058 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3062 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3068 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3070 SvREFCNT_dec_NN(tmpsv);
3080 PerlIO_printf(file, ">\n");
3082 do_pmop_xmldump(level, file, cPMOPo);
3088 if (o->op_flags & OPf_KIDS) {
3092 PerlIO_printf(file, ">\n");
3094 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3095 do_op_xmldump(level, file, kid);
3099 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3101 PerlIO_printf(file, " />\n");
3105 Perl_op_xmldump(pTHX_ const OP *o)
3107 PERL_ARGS_ASSERT_OP_XMLDUMP;
3109 do_op_xmldump(0, PL_xmlfp, o);
3115 * c-indentation-style: bsd
3117 * indent-tabs-mode: nil
3120 * ex: set ts=8 sts=4 sw=4 et: