3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'
15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
18 /* This file contains utility routines to dump the contents of SV and OP
19 * structures, as used by command-line options like -Dt and -Dx, and
22 * It also holds the debugging version of the runops function.
26 #define PERL_IN_DUMP_C
30 static const char* const svtypenames[SVt_LAST] = {
50 static const char* const svshorttypenames[SVt_LAST] = {
75 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
76 const struct flag_to_name *const end)
79 if (flags & start->flag)
80 sv_catpv(sv, start->name);
81 } while (++start < end);
84 #define append_flags(sv, f, flags) \
85 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
90 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
93 PERL_ARGS_ASSERT_DUMP_INDENT;
95 dump_vindent(level, file, pat, &args);
100 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
103 PERL_ARGS_ASSERT_DUMP_VINDENT;
104 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
105 PerlIO_vprintf(file, pat, *args);
111 dump_all_perl(FALSE);
115 Perl_dump_all_perl(pTHX_ bool justperl)
119 PerlIO_setlinebuf(Perl_debug_log);
121 op_dump(PL_main_root);
122 dump_packsubs_perl(PL_defstash, justperl);
126 Perl_dump_packsubs(pTHX_ const HV *stash)
128 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
129 dump_packsubs_perl(stash, FALSE);
133 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
138 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
142 for (i = 0; i <= (I32) HvMAX(stash); i++) {
144 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
145 const GV * const gv = (const GV *)HeVAL(entry);
146 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
149 dump_sub_perl(gv, justperl);
152 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
153 const HV * const hv = GvHV(gv);
154 if (hv && (hv != PL_defstash))
155 dump_packsubs_perl(hv, justperl); /* nested package */
162 Perl_dump_sub(pTHX_ const GV *gv)
164 PERL_ARGS_ASSERT_DUMP_SUB;
165 dump_sub_perl(gv, FALSE);
169 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
173 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
175 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
179 gv_fullname3(sv, gv, NULL);
180 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
181 if (CvISXSUB(GvCV(gv)))
182 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
183 PTR2UV(CvXSUB(GvCV(gv))),
184 (int)CvXSUBANY(GvCV(gv)).any_i32);
185 else if (CvROOT(GvCV(gv)))
186 op_dump(CvROOT(GvCV(gv)));
188 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
192 Perl_dump_form(pTHX_ const GV *gv)
194 SV * const sv = sv_newmortal();
196 PERL_ARGS_ASSERT_DUMP_FORM;
198 gv_fullname3(sv, gv, NULL);
199 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
200 if (CvROOT(GvFORM(gv)))
201 op_dump(CvROOT(GvFORM(gv)));
203 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
210 op_dump(PL_eval_root);
215 =for apidoc pv_escape
217 Escapes at most the first "count" chars of pv and puts the results into
218 dsv such that the size of the escaped string will not exceed "max" chars
219 and will not contain any incomplete escape sequences.
221 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
222 will also be escaped.
224 Normally the SV will be cleared before the escaped string is prepared,
225 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
227 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
228 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
229 using C<is_utf8_string()> to determine if it is Unicode.
231 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
232 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
233 chars above 127 will be escaped using this style; otherwise, only chars above
234 255 will be so escaped; other non printable chars will use octal or
235 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
236 then all chars below 255 will be treated as printable and
237 will be output as literals.
239 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
240 string will be escaped, regardless of max. If the output is to be in hex,
241 then it will be returned as a plain hex
242 sequence. Thus the output will either be a single char,
243 an octal escape sequence, a special escape like C<\n> or a hex value.
245 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
246 not a '\\'. This is because regexes very often contain backslashed
247 sequences, whereas '%' is not a particularly common character in patterns.
249 Returns a pointer to the escaped text as held by dsv.
253 #define PV_ESCAPE_OCTBUFSIZE 32
256 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
257 const STRLEN count, const STRLEN max,
258 STRLEN * const escaped, const U32 flags )
260 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
261 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
262 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
263 STRLEN wrote = 0; /* chars written so far */
264 STRLEN chsize = 0; /* size of data to be written */
265 STRLEN readsize = 1; /* size of data just read */
266 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
267 const char *pv = str;
268 const char * const end = pv + count; /* end of string */
271 PERL_ARGS_ASSERT_PV_ESCAPE;
273 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
274 /* This won't alter the UTF-8 flag */
278 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
281 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
282 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
283 const U8 c = (U8)u & 0xFF;
286 || (flags & PERL_PV_ESCAPE_ALL)
287 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
289 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
290 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
293 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
294 "%cx{%"UVxf"}", esc, u);
295 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
298 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
302 case '\\' : /* fallthrough */
303 case '%' : if ( c == esc ) {
309 case '\v' : octbuf[1] = 'v'; break;
310 case '\t' : octbuf[1] = 't'; break;
311 case '\r' : octbuf[1] = 'r'; break;
312 case '\n' : octbuf[1] = 'n'; break;
313 case '\f' : octbuf[1] = 'f'; break;
321 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
322 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
325 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
332 if ( max && (wrote + chsize > max) ) {
334 } else if (chsize > 1) {
335 sv_catpvn(dsv, octbuf, chsize);
338 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
339 128-255 can be appended raw to the dsv. If dsv happens to be
340 UTF-8 then we need catpvf to upgrade them for us.
341 Or add a new API call sv_catpvc(). Think about that name, and
342 how to keep it clear that it's unlike the s of catpvs, which is
343 really an array octets, not a string. */
344 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
347 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
355 =for apidoc pv_pretty
357 Converts a string into something presentable, handling escaping via
358 pv_escape() and supporting quoting and ellipses.
360 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
361 double quoted with any double quotes in the string escaped. Otherwise
362 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
365 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
366 string were output then an ellipsis C<...> will be appended to the
367 string. Note that this happens AFTER it has been quoted.
369 If start_color is non-null then it will be inserted after the opening
370 quote (if there is one) but before the escaped text. If end_color
371 is non-null then it will be inserted after the escaped text but before
372 any quotes or ellipses.
374 Returns a pointer to the prettified text as held by dsv.
380 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
381 const STRLEN max, char const * const start_color, char const * const end_color,
384 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
387 PERL_ARGS_ASSERT_PV_PRETTY;
389 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
390 /* This won't alter the UTF-8 flag */
395 sv_catpvs(dsv, "\"");
396 else if ( flags & PERL_PV_PRETTY_LTGT )
399 if ( start_color != NULL )
400 sv_catpv(dsv, start_color);
402 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
404 if ( end_color != NULL )
405 sv_catpv(dsv, end_color);
408 sv_catpvs( dsv, "\"");
409 else if ( flags & PERL_PV_PRETTY_LTGT )
412 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
413 sv_catpvs(dsv, "...");
419 =for apidoc pv_display
423 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
425 except that an additional "\0" will be appended to the string when
426 len > cur and pv[cur] is "\0".
428 Note that the final string may be up to 7 chars longer than pvlim.
434 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
436 PERL_ARGS_ASSERT_PV_DISPLAY;
438 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
439 if (len > cur && pv[cur] == '\0')
440 sv_catpvs( dsv, "\\0");
445 Perl_sv_peek(pTHX_ SV *sv)
448 SV * const t = sv_newmortal();
458 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
459 /* detect data corruption under memory poisoning */
463 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
464 if (sv == &PL_sv_undef) {
465 sv_catpv(t, "SV_UNDEF");
466 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
467 SVs_GMG|SVs_SMG|SVs_RMG)) &&
471 else if (sv == &PL_sv_no) {
472 sv_catpv(t, "SV_NO");
473 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
474 SVs_GMG|SVs_SMG|SVs_RMG)) &&
475 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
481 else if (sv == &PL_sv_yes) {
482 sv_catpv(t, "SV_YES");
483 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
484 SVs_GMG|SVs_SMG|SVs_RMG)) &&
485 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
488 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
493 sv_catpv(t, "SV_PLACEHOLDER");
494 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
495 SVs_GMG|SVs_SMG|SVs_RMG)) &&
501 else if (SvREFCNT(sv) == 0) {
505 else if (DEBUG_R_TEST_) {
508 /* is this SV on the tmps stack? */
509 for (ix=PL_tmps_ix; ix>=0; ix--) {
510 if (PL_tmps_stack[ix] == sv) {
515 if (SvREFCNT(sv) > 1)
516 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
524 if (SvCUR(t) + unref > 10) {
525 SvCUR_set(t, unref + 3);
534 if (type == SVt_PVCV) {
535 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
537 } else if (type < SVt_LAST) {
538 sv_catpv(t, svshorttypenames[type]);
540 if (type == SVt_NULL)
543 sv_catpv(t, "FREED");
548 if (!SvPVX_const(sv))
549 sv_catpv(t, "(null)");
551 SV * const tmp = newSVpvs("");
555 SvOOK_offset(sv, delta);
556 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
558 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
560 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
561 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
563 SvREFCNT_dec_NN(tmp);
566 else if (SvNOKp(sv)) {
567 STORE_NUMERIC_LOCAL_SET_STANDARD();
568 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
569 RESTORE_NUMERIC_LOCAL();
571 else if (SvIOKp(sv)) {
573 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
575 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
583 if (TAINTING_get && SvTAINTED(sv))
584 sv_catpv(t, " [tainted]");
585 return SvPV_nolen(t);
589 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
593 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
596 Perl_dump_indent(aTHX_ level, file, "{}\n");
599 Perl_dump_indent(aTHX_ level, file, "{\n");
601 if (pm->op_pmflags & PMf_ONCE)
606 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
607 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
608 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
610 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
611 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
612 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
613 op_dump(pm->op_pmreplrootu.op_pmreplroot);
615 if (pm->op_code_list) {
616 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
617 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
618 do_op_dump(level, file, pm->op_code_list);
621 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
622 PTR2UV(pm->op_code_list));
624 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
625 SV * const tmpsv = pm_description(pm);
626 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
627 SvREFCNT_dec_NN(tmpsv);
630 Perl_dump_indent(aTHX_ level-1, file, "}\n");
633 const struct flag_to_name pmflags_flags_names[] = {
634 {PMf_CONST, ",CONST"},
636 {PMf_GLOBAL, ",GLOBAL"},
637 {PMf_CONTINUE, ",CONTINUE"},
638 {PMf_RETAINT, ",RETAINT"},
640 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
641 {PMf_HAS_CV, ",HAS_CV"},
642 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
643 {PMf_IS_QR, ",IS_QR"}
647 S_pm_description(pTHX_ const PMOP *pm)
649 SV * const desc = newSVpvs("");
650 const REGEXP * const regex = PM_GETRE(pm);
651 const U32 pmflags = pm->op_pmflags;
653 PERL_ARGS_ASSERT_PM_DESCRIPTION;
655 if (pmflags & PMf_ONCE)
656 sv_catpv(desc, ",ONCE");
658 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
659 sv_catpv(desc, ":USED");
661 if (pmflags & PMf_USED)
662 sv_catpv(desc, ":USED");
666 if (RX_ISTAINTED(regex))
667 sv_catpv(desc, ",TAINTED");
668 if (RX_CHECK_SUBSTR(regex)) {
669 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
670 sv_catpv(desc, ",SCANFIRST");
671 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
672 sv_catpv(desc, ",ALL");
674 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
675 sv_catpv(desc, ",SKIPWHITE");
678 append_flags(desc, pmflags, pmflags_flags_names);
683 Perl_pmop_dump(pTHX_ PMOP *pm)
685 do_pmop_dump(0, Perl_debug_log, pm);
688 /* Return a unique integer to represent the address of op o.
689 * If it already exists in PL_op_sequence, just return it;
691 * *** Note that this isn't thread-safe */
694 S_sequence_num(pTHX_ const OP *o)
703 op = newSVuv(PTR2UV(o));
705 key = SvPV_const(op, len);
707 PL_op_sequence = newHV();
708 seq = hv_fetch(PL_op_sequence, key, len, 0);
711 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
715 const struct flag_to_name op_flags_names[] = {
717 {OPf_PARENS, ",PARENS"},
720 {OPf_STACKED, ",STACKED"},
721 {OPf_SPECIAL, ",SPECIAL"}
724 const struct flag_to_name op_trans_names[] = {
725 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
726 {OPpTRANS_TO_UTF, ",TO_UTF"},
727 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
728 {OPpTRANS_SQUASH, ",SQUASH"},
729 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
730 {OPpTRANS_GROWS, ",GROWS"},
731 {OPpTRANS_DELETE, ",DELETE"}
734 const struct flag_to_name op_entersub_names[] = {
735 {OPpENTERSUB_DB, ",DB"},
736 {OPpENTERSUB_HASTARG, ",HASTARG"},
737 {OPpENTERSUB_AMPER, ",AMPER"},
738 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
739 {OPpENTERSUB_INARGS, ",INARGS"}
742 const struct flag_to_name op_const_names[] = {
743 {OPpCONST_NOVER, ",NOVER"},
744 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
745 {OPpCONST_STRICT, ",STRICT"},
746 {OPpCONST_ENTERED, ",ENTERED"},
747 {OPpCONST_FOLDED, ",FOLDED"},
748 {OPpCONST_BARE, ",BARE"}
751 const struct flag_to_name op_sort_names[] = {
752 {OPpSORT_NUMERIC, ",NUMERIC"},
753 {OPpSORT_INTEGER, ",INTEGER"},
754 {OPpSORT_REVERSE, ",REVERSE"},
755 {OPpSORT_INPLACE, ",INPLACE"},
756 {OPpSORT_DESCEND, ",DESCEND"},
757 {OPpSORT_QSORT, ",QSORT"},
758 {OPpSORT_STABLE, ",STABLE"}
761 const struct flag_to_name op_open_names[] = {
762 {OPpOPEN_IN_RAW, ",IN_RAW"},
763 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
764 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
765 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
768 const struct flag_to_name op_exit_names[] = {
769 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
770 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
773 const struct flag_to_name op_sassign_names[] = {
774 {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
775 {OPpASSIGN_CV_TO_GV, ",CV2GV"}
778 #define OP_PRIVATE_ONCE(op, flag, name) \
779 const struct flag_to_name CAT2(op, _names)[] = { \
783 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
784 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
785 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
786 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
787 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
788 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
789 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
790 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
791 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
792 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
793 OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
795 struct op_private_by_op {
798 const struct flag_to_name *start;
801 const struct op_private_by_op op_private_names[] = {
802 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
804 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
805 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
806 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
807 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
808 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
809 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
810 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
811 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
812 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
813 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
814 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
815 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
816 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
817 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
818 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
819 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
820 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
821 {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
822 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
826 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
827 const struct op_private_by_op *start = op_private_names;
828 const struct op_private_by_op *const end
829 = op_private_names + C_ARRAY_LENGTH(op_private_names);
831 /* This is a linear search, but no worse than the code that it replaced.
832 It's debugging code - size is more important than speed. */
834 if (optype == start->op_type) {
835 S_append_flags(aTHX_ tmpsv, op_private, start->start,
836 start->start + start->len);
839 } while (++start < end);
843 #define DUMP_OP_FLAGS(o,xml,level,file) \
844 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
845 SV * const tmpsv = newSVpvs(""); \
846 switch (o->op_flags & OPf_WANT) { \
847 case OPf_WANT_VOID: \
848 sv_catpv(tmpsv, ",VOID"); \
850 case OPf_WANT_SCALAR: \
851 sv_catpv(tmpsv, ",SCALAR"); \
853 case OPf_WANT_LIST: \
854 sv_catpv(tmpsv, ",LIST"); \
857 sv_catpv(tmpsv, ",UNKNOWN"); \
860 append_flags(tmpsv, o->op_flags, op_flags_names); \
861 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
862 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
863 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
864 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \
866 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
867 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
869 PerlIO_printf(file, " flags=\"%s\"", \
870 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
871 SvREFCNT_dec_NN(tmpsv); \
874 #if !defined(PERL_MAD)
875 # define xmldump_attr1(level, file, pat, arg)
877 # define xmldump_attr1(level, file, pat, arg) \
878 S_xmldump_attr(aTHX_ level, file, pat, arg)
881 #define DUMP_OP_PRIVATE(o,xml,level,file) \
882 if (o->op_private) { \
883 U32 optype = o->op_type; \
884 U32 oppriv = o->op_private; \
885 SV * const tmpsv = newSVpvs(""); \
886 if (PL_opargs[optype] & OA_TARGLEX) { \
887 if (oppriv & OPpTARGET_MY) \
888 sv_catpv(tmpsv, ",TARGET_MY"); \
890 else if (optype == OP_ENTERSUB || \
891 optype == OP_RV2SV || \
892 optype == OP_GVSV || \
893 optype == OP_RV2AV || \
894 optype == OP_RV2HV || \
895 optype == OP_RV2GV || \
896 optype == OP_AELEM || \
897 optype == OP_HELEM ) \
899 if (optype == OP_ENTERSUB) { \
900 append_flags(tmpsv, oppriv, op_entersub_names); \
903 switch (oppriv & OPpDEREF) { \
905 sv_catpv(tmpsv, ",SV"); \
908 sv_catpv(tmpsv, ",AV"); \
911 sv_catpv(tmpsv, ",HV"); \
914 if (oppriv & OPpMAYBE_LVSUB) \
915 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
917 if (optype == OP_AELEM || optype == OP_HELEM) { \
918 if (oppriv & OPpLVAL_DEFER) \
919 sv_catpv(tmpsv, ",LVAL_DEFER"); \
921 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
922 if (oppriv & OPpMAYBE_TRUEBOOL) \
923 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
924 if (oppriv & OPpTRUEBOOL) \
925 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
928 if (oppriv & HINT_STRICT_REFS) \
929 sv_catpv(tmpsv, ",STRICT_REFS"); \
930 if (oppriv & OPpOUR_INTRO) \
931 sv_catpv(tmpsv, ",OUR_INTRO"); \
934 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
936 else if (OP_IS_FILETEST(o->op_type)) { \
937 if (oppriv & OPpFT_ACCESS) \
938 sv_catpv(tmpsv, ",FT_ACCESS"); \
939 if (oppriv & OPpFT_STACKED) \
940 sv_catpv(tmpsv, ",FT_STACKED"); \
941 if (oppriv & OPpFT_STACKING) \
942 sv_catpv(tmpsv, ",FT_STACKING"); \
943 if (oppriv & OPpFT_AFTER_t) \
944 sv_catpv(tmpsv, ",AFTER_t"); \
946 else if (o->op_type == OP_AASSIGN) { \
947 if (oppriv & OPpASSIGN_COMMON) \
948 sv_catpvs(tmpsv, ",COMMON"); \
949 if (oppriv & OPpMAYBE_LVSUB) \
950 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
952 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
953 sv_catpv(tmpsv, ",INTRO"); \
954 if (o->op_type == OP_PADRANGE) \
955 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
956 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
957 if (SvCUR(tmpsv)) { \
959 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
961 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
963 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
965 SvREFCNT_dec_NN(tmpsv); \
970 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
974 const OPCODE optype = o->op_type;
976 PERL_ARGS_ASSERT_DO_OP_DUMP;
978 Perl_dump_indent(aTHX_ level, file, "{\n");
980 seq = sequence_num(o);
982 PerlIO_printf(file, "%-4"UVuf, seq);
984 PerlIO_printf(file, "????");
986 "%*sTYPE = %s ===> ",
987 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
990 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
991 sequence_num(o->op_next));
993 PerlIO_printf(file, "NULL\n");
995 if (optype == OP_NULL) {
996 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
997 if (o->op_targ == OP_NEXTSTATE) {
999 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1000 (UV)CopLINE(cCOPo));
1001 if (CopSTASHPV(cCOPo))
1002 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1004 if (CopLABEL(cCOPo))
1005 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1010 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1013 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1016 DUMP_OP_FLAGS(o,0,level,file);
1017 DUMP_OP_PRIVATE(o,0,level,file);
1020 if (PL_madskills && o->op_madprop) {
1021 SV * const tmpsv = newSVpvs("");
1022 MADPROP* mp = o->op_madprop;
1023 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1026 const char tmp = mp->mad_key;
1027 sv_setpvs(tmpsv,"'");
1029 sv_catpvn(tmpsv, &tmp, 1);
1030 sv_catpv(tmpsv, "'=");
1031 switch (mp->mad_type) {
1033 sv_catpv(tmpsv, "NULL");
1034 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1037 sv_catpv(tmpsv, "<");
1038 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1039 sv_catpv(tmpsv, ">");
1040 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1043 if ((OP*)mp->mad_val) {
1044 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1045 do_op_dump(level, file, (OP*)mp->mad_val);
1049 sv_catpv(tmpsv, "(UNK)");
1050 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1056 Perl_dump_indent(aTHX_ level, file, "}\n");
1058 SvREFCNT_dec_NN(tmpsv);
1067 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1069 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1070 if (cSVOPo->op_sv) {
1071 SV * const tmpsv = newSV(0);
1075 /* FIXME - is this making unwarranted assumptions about the
1076 UTF-8 cleanliness of the dump file handle? */
1079 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1080 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1081 SvPV_nolen_const(tmpsv));
1085 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1091 case OP_METHOD_NAMED:
1092 #ifndef USE_ITHREADS
1093 /* with ITHREADS, consts are stored in the pad, and the right pad
1094 * may not be active here, so skip */
1095 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1101 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1102 (UV)CopLINE(cCOPo));
1103 if (CopSTASHPV(cCOPo))
1104 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1106 if (CopLABEL(cCOPo))
1107 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1111 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1112 if (cLOOPo->op_redoop)
1113 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1115 PerlIO_printf(file, "DONE\n");
1116 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1117 if (cLOOPo->op_nextop)
1118 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1120 PerlIO_printf(file, "DONE\n");
1121 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1122 if (cLOOPo->op_lastop)
1123 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1125 PerlIO_printf(file, "DONE\n");
1133 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1134 if (cLOGOPo->op_other)
1135 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1137 PerlIO_printf(file, "DONE\n");
1143 do_pmop_dump(level, file, cPMOPo);
1151 if (o->op_private & OPpREFCOUNTED)
1152 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1157 if (o->op_flags & OPf_KIDS) {
1159 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1160 do_op_dump(level, file, kid);
1162 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1166 Perl_op_dump(pTHX_ const OP *o)
1168 PERL_ARGS_ASSERT_OP_DUMP;
1169 do_op_dump(0, Perl_debug_log, o);
1173 Perl_gv_dump(pTHX_ GV *gv)
1177 PERL_ARGS_ASSERT_GV_DUMP;
1180 PerlIO_printf(Perl_debug_log, "{}\n");
1183 sv = sv_newmortal();
1184 PerlIO_printf(Perl_debug_log, "{\n");
1185 gv_fullname3(sv, gv, NULL);
1186 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1187 if (gv != GvEGV(gv)) {
1188 gv_efullname3(sv, GvEGV(gv), NULL);
1189 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1191 PerlIO_putc(Perl_debug_log, '\n');
1192 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1196 /* map magic types to the symbolic names
1197 * (with the PERL_MAGIC_ prefixed stripped)
1200 static const struct { const char type; const char *name; } magic_names[] = {
1201 #include "mg_names.c"
1202 /* this null string terminates the list */
1207 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1209 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1211 for (; mg; mg = mg->mg_moremagic) {
1212 Perl_dump_indent(aTHX_ level, file,
1213 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1214 if (mg->mg_virtual) {
1215 const MGVTBL * const v = mg->mg_virtual;
1216 if (v >= PL_magic_vtables
1217 && v < PL_magic_vtables + magic_vtable_max) {
1218 const U32 i = v - PL_magic_vtables;
1219 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1222 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1225 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1228 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1232 const char *name = NULL;
1233 for (n = 0; magic_names[n].name; n++) {
1234 if (mg->mg_type == magic_names[n].type) {
1235 name = magic_names[n].name;
1240 Perl_dump_indent(aTHX_ level, file,
1241 " MG_TYPE = PERL_MAGIC_%s\n", name);
1243 Perl_dump_indent(aTHX_ level, file,
1244 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1248 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1249 if (mg->mg_type == PERL_MAGIC_envelem &&
1250 mg->mg_flags & MGf_TAINTEDDIR)
1251 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1252 if (mg->mg_type == PERL_MAGIC_regex_global &&
1253 mg->mg_flags & MGf_MINMATCH)
1254 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1255 if (mg->mg_flags & MGf_REFCOUNTED)
1256 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1257 if (mg->mg_flags & MGf_GSKIP)
1258 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1259 if (mg->mg_flags & MGf_COPY)
1260 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1261 if (mg->mg_flags & MGf_DUP)
1262 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1263 if (mg->mg_flags & MGf_LOCAL)
1264 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1265 if (mg->mg_type == PERL_MAGIC_regex_global &&
1266 mg->mg_flags & MGf_BYTES)
1267 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
1270 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1271 PTR2UV(mg->mg_obj));
1272 if (mg->mg_type == PERL_MAGIC_qr) {
1273 REGEXP* const re = (REGEXP *)mg->mg_obj;
1274 SV * const dsv = sv_newmortal();
1275 const char * const s
1276 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1278 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1279 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1281 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1282 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1285 if (mg->mg_flags & MGf_REFCOUNTED)
1286 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1289 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1291 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1292 if (mg->mg_len >= 0) {
1293 if (mg->mg_type != PERL_MAGIC_utf8) {
1294 SV * const sv = newSVpvs("");
1295 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1296 SvREFCNT_dec_NN(sv);
1299 else if (mg->mg_len == HEf_SVKEY) {
1300 PerlIO_puts(file, " => HEf_SVKEY\n");
1301 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1302 maxnest, dumpops, pvlim); /* MG is already +1 */
1305 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1310 " does not know how to handle this MG_LEN"
1312 PerlIO_putc(file, '\n');
1314 if (mg->mg_type == PERL_MAGIC_utf8) {
1315 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1318 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1319 Perl_dump_indent(aTHX_ level, file,
1320 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1323 (UV)cache[i * 2 + 1]);
1330 Perl_magic_dump(pTHX_ const MAGIC *mg)
1332 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1336 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1340 PERL_ARGS_ASSERT_DO_HV_DUMP;
1342 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1343 if (sv && (hvname = HvNAME_get(sv)))
1345 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1346 name which quite legally could contain insane things like tabs, newlines, nulls or
1347 other scary crap - this should produce sane results - except maybe for unicode package
1348 names - but we will wait for someone to file a bug on that - demerphq */
1349 SV * const tmpsv = newSVpvs("");
1350 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1353 PerlIO_putc(file, '\n');
1357 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1359 PERL_ARGS_ASSERT_DO_GV_DUMP;
1361 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1362 if (sv && GvNAME(sv))
1363 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1365 PerlIO_putc(file, '\n');
1369 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1371 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1373 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1374 if (sv && GvNAME(sv)) {
1376 PerlIO_printf(file, "\t\"");
1377 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1378 PerlIO_printf(file, "%s\" :: \"", hvname);
1379 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1382 PerlIO_putc(file, '\n');
1385 const struct flag_to_name first_sv_flags_names[] = {
1386 {SVs_TEMP, "TEMP,"},
1387 {SVs_OBJECT, "OBJECT,"},
1396 const struct flag_to_name second_sv_flags_names[] = {
1398 {SVf_FAKE, "FAKE,"},
1399 {SVf_READONLY, "READONLY,"},
1400 {SVf_IsCOW, "IsCOW,"},
1401 {SVf_BREAK, "BREAK,"},
1402 {SVf_AMAGIC, "OVERLOAD,"},
1408 const struct flag_to_name cv_flags_names[] = {
1409 {CVf_ANON, "ANON,"},
1410 {CVf_UNIQUE, "UNIQUE,"},
1411 {CVf_CLONE, "CLONE,"},
1412 {CVf_CLONED, "CLONED,"},
1413 {CVf_CONST, "CONST,"},
1414 {CVf_NODEBUG, "NODEBUG,"},
1415 {CVf_LVALUE, "LVALUE,"},
1416 {CVf_METHOD, "METHOD,"},
1417 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1418 {CVf_CVGV_RC, "CVGV_RC,"},
1419 {CVf_DYNFILE, "DYNFILE,"},
1420 {CVf_AUTOLOAD, "AUTOLOAD,"},
1421 {CVf_HASEVAL, "HASEVAL"},
1422 {CVf_SLABBED, "SLABBED,"},
1423 {CVf_ISXSUB, "ISXSUB,"}
1426 const struct flag_to_name hv_flags_names[] = {
1427 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1428 {SVphv_LAZYDEL, "LAZYDEL,"},
1429 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1430 {SVphv_CLONEABLE, "CLONEABLE,"}
1433 const struct flag_to_name gp_flags_names[] = {
1434 {GVf_INTRO, "INTRO,"},
1435 {GVf_MULTI, "MULTI,"},
1436 {GVf_ASSUMECV, "ASSUMECV,"},
1437 {GVf_IN_PAD, "IN_PAD,"}
1440 const struct flag_to_name gp_flags_imported_names[] = {
1441 {GVf_IMPORTED_SV, " SV"},
1442 {GVf_IMPORTED_AV, " AV"},
1443 {GVf_IMPORTED_HV, " HV"},
1444 {GVf_IMPORTED_CV, " CV"},
1447 const struct flag_to_name regexp_flags_names[] = {
1448 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1449 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1450 {RXf_PMf_FOLD, "PMf_FOLD,"},
1451 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1452 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1453 {RXf_ANCH_BOL, "ANCH_BOL,"},
1454 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1455 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1456 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1457 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1458 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1459 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1460 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1461 {RXf_CANY_SEEN, "CANY_SEEN,"},
1462 {RXf_NOSCAN, "NOSCAN,"},
1463 {RXf_CHECK_ALL, "CHECK_ALL,"},
1464 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1465 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1466 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1467 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1468 {RXf_SPLIT, "SPLIT,"},
1469 {RXf_COPY_DONE, "COPY_DONE,"},
1470 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1471 {RXf_TAINTED, "TAINTED,"},
1472 {RXf_START_ONLY, "START_ONLY,"},
1473 {RXf_SKIPWHITE, "SKIPWHITE,"},
1474 {RXf_WHITE, "WHITE,"},
1475 {RXf_NULL, "NULL,"},
1479 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1487 PERL_ARGS_ASSERT_DO_SV_DUMP;
1490 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1494 flags = SvFLAGS(sv);
1497 /* process general SV flags */
1499 d = Perl_newSVpvf(aTHX_
1500 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1501 PTR2UV(SvANY(sv)), PTR2UV(sv),
1502 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1503 (int)(PL_dumpindent*level), "");
1505 if (!((flags & SVpad_NAME) == SVpad_NAME
1506 && (type == SVt_PVMG || type == SVt_PVNV))) {
1507 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1508 sv_catpv(d, "PADSTALE,");
1510 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1511 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1512 sv_catpv(d, "PADTMP,");
1513 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1515 append_flags(d, flags, first_sv_flags_names);
1516 if (flags & SVf_ROK) {
1517 sv_catpv(d, "ROK,");
1518 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1520 append_flags(d, flags, second_sv_flags_names);
1521 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1522 && type != SVt_PVAV) {
1523 if (SvPCS_IMPORTED(sv))
1524 sv_catpv(d, "PCS_IMPORTED,");
1526 sv_catpv(d, "SCREAM,");
1529 /* process type-specific SV flags */
1534 append_flags(d, CvFLAGS(sv), cv_flags_names);
1537 append_flags(d, flags, hv_flags_names);
1541 if (isGV_with_GP(sv)) {
1542 append_flags(d, GvFLAGS(sv), gp_flags_names);
1544 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1545 sv_catpv(d, "IMPORT");
1546 if (GvIMPORTED(sv) == GVf_IMPORTED)
1547 sv_catpv(d, "ALL,");
1550 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1557 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1558 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1561 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1562 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1563 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1564 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1567 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1570 if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1573 /* SVphv_SHAREKEYS is also 0x20000000 */
1574 if ((type != SVt_PVHV) && SvUTF8(sv))
1575 sv_catpv(d, "UTF8");
1577 if (*(SvEND(d) - 1) == ',') {
1578 SvCUR_set(d, SvCUR(d) - 1);
1579 SvPVX(d)[SvCUR(d)] = '\0';
1584 /* dump initial SV details */
1586 #ifdef DEBUG_LEAKING_SCALARS
1587 Perl_dump_indent(aTHX_ level, file,
1588 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1589 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1591 sv->sv_debug_inpad ? "for" : "by",
1592 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1593 PTR2UV(sv->sv_debug_parent),
1597 Perl_dump_indent(aTHX_ level, file, "SV = ");
1601 if (type < SVt_LAST) {
1602 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1604 if (type == SVt_NULL) {
1609 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1614 /* Dump general SV fields */
1616 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1617 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1618 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1619 || (type == SVt_IV && !SvROK(sv))) {
1621 #ifdef PERL_OLD_COPY_ON_WRITE
1625 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1627 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1628 #ifdef PERL_OLD_COPY_ON_WRITE
1629 if (SvIsCOW_shared_hash(sv))
1630 PerlIO_printf(file, " (HASH)");
1631 else if (SvIsCOW_normal(sv))
1632 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1634 PerlIO_putc(file, '\n');
1637 if ((type == SVt_PVNV || type == SVt_PVMG)
1638 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1639 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1640 (UV) COP_SEQ_RANGE_LOW(sv));
1641 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1642 (UV) COP_SEQ_RANGE_HIGH(sv));
1643 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1644 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1645 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1646 || type == SVt_NV) {
1647 STORE_NUMERIC_LOCAL_SET_STANDARD();
1648 /* %Vg doesn't work? --jhi */
1649 #ifdef USE_LONG_DOUBLE
1650 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1652 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1654 RESTORE_NUMERIC_LOCAL();
1658 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1660 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1663 if (type < SVt_PV) {
1668 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1669 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1670 const bool re = isREGEXP(sv);
1671 const char * const ptr =
1672 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1676 SvOOK_offset(sv, delta);
1677 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1682 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1684 PerlIO_printf(file, "( %s . ) ",
1685 pv_display(d, ptr - delta, delta, 0,
1688 if (type == SVt_INVLIST) {
1689 PerlIO_printf(file, "\n");
1690 /* 4 blanks indents 2 beyond the PV, etc */
1691 _invlist_dump(file, level, " ", sv);
1694 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1697 if (SvUTF8(sv)) /* the 6? \x{....} */
1698 PerlIO_printf(file, " [UTF8 \"%s\"]",
1699 sv_uni_display(d, sv, 6 * SvCUR(sv),
1701 PerlIO_printf(file, "\n");
1703 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1705 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1707 #ifdef PERL_NEW_COPY_ON_WRITE
1708 if (SvIsCOW(sv) && SvLEN(sv))
1709 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1714 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1717 if (type >= SVt_PVMG) {
1718 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1719 HV * const ost = SvOURSTASH(sv);
1721 do_hv_dump(level, file, " OURSTASH", ost);
1722 } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1723 Perl_dump_indent(aTHX_ level, file, " MAXNAMED = %"UVuf"\n",
1724 (UV)PadnamelistMAXNAMED(sv));
1727 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1730 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1732 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1733 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1737 /* Dump type-specific SV fields */
1741 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1742 if (AvARRAY(sv) != AvALLOC(sv)) {
1743 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1744 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1747 PerlIO_putc(file, '\n');
1748 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1749 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1750 /* arylen is stored in magic, and padnamelists use SvMAGIC for
1752 if (!AvPAD_NAMELIST(sv))
1753 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1754 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1756 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1757 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1758 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1759 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1760 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1762 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1763 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1765 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1767 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1772 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1773 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1774 /* Show distribution of HEs in the ARRAY */
1776 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1779 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1780 NV theoret, sum = 0;
1782 PerlIO_printf(file, " (");
1783 Zero(freq, FREQ_MAX + 1, int);
1784 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1787 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1789 if (count > FREQ_MAX)
1795 for (i = 0; i <= max; i++) {
1797 PerlIO_printf(file, "%d%s:%d", i,
1798 (i == FREQ_MAX) ? "+" : "",
1801 PerlIO_printf(file, ", ");
1804 PerlIO_putc(file, ')');
1805 /* The "quality" of a hash is defined as the total number of
1806 comparisons needed to access every element once, relative
1807 to the expected number needed for a random hash.
1809 The total number of comparisons is equal to the sum of
1810 the squares of the number of entries in each bucket.
1811 For a random hash of n keys into k buckets, the expected
1816 for (i = max; i > 0; i--) { /* Precision: count down. */
1817 sum += freq[i] * i * i;
1819 while ((keys = keys >> 1))
1821 theoret = HvUSEDKEYS(sv);
1822 theoret += theoret * (theoret-1)/pow2;
1823 PerlIO_putc(file, '\n');
1824 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1826 PerlIO_putc(file, '\n');
1827 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1830 HE **ents = HvARRAY(sv);
1833 HE *const *const last = ents + HvMAX(sv);
1834 count = last + 1 - ents;
1839 } while (++ents <= last);
1843 struct xpvhv_aux *const aux = HvAUX(sv);
1844 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1845 " (cached = %"UVuf")\n",
1846 (UV)count, (UV)aux->xhv_fill_lazy);
1848 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1852 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1854 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1855 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1856 #ifdef PERL_HASH_RANDOMIZE_KEYS
1857 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1858 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1859 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1862 PerlIO_putc(file, '\n');
1865 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1866 if (mg && mg->mg_obj) {
1867 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1871 const char * const hvname = HvNAME_get(sv);
1873 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1877 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1878 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1879 if (HvAUX(sv)->xhv_name_count)
1880 Perl_dump_indent(aTHX_
1881 level, file, " NAMECOUNT = %"IVdf"\n",
1882 (IV)HvAUX(sv)->xhv_name_count
1884 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1885 const I32 count = HvAUX(sv)->xhv_name_count;
1887 SV * const names = newSVpvs_flags("", SVs_TEMP);
1888 /* The starting point is the first element if count is
1889 positive and the second element if count is negative. */
1890 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1891 + (count < 0 ? 1 : 0);
1892 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1893 + (count < 0 ? -count : count);
1894 while (hekp < endp) {
1896 sv_catpvs(names, ", \"");
1897 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1898 sv_catpvs(names, "\"");
1900 /* This should never happen. */
1901 sv_catpvs(names, ", (null)");
1905 Perl_dump_indent(aTHX_
1906 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1910 Perl_dump_indent(aTHX_
1911 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1915 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1917 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1921 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1922 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1923 (int)meta->mro_which->length,
1924 meta->mro_which->name,
1925 PTR2UV(meta->mro_which));
1926 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1927 (UV)meta->cache_gen);
1928 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1930 if (meta->mro_linear_all) {
1931 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1932 PTR2UV(meta->mro_linear_all));
1933 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1936 if (meta->mro_linear_current) {
1937 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1938 PTR2UV(meta->mro_linear_current));
1939 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1942 if (meta->mro_nextmethod) {
1943 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1944 PTR2UV(meta->mro_nextmethod));
1945 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1949 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1951 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1956 if (nest < maxnest) {
1957 HV * const hv = MUTABLE_HV(sv);
1962 int count = maxnest - nest;
1963 for (i=0; i <= HvMAX(hv); i++) {
1964 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1971 if (count-- <= 0) goto DONEHV;
1974 keysv = hv_iterkeysv(he);
1975 keypv = SvPV_const(keysv, len);
1978 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1980 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1981 if (HvEITER_get(hv) == he)
1982 PerlIO_printf(file, "[CURRENT] ");
1983 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1984 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1993 if (CvAUTOLOAD(sv)) {
1995 const char *const name = SvPV_const(sv, len);
1996 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
2000 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
2001 (int) CvPROTOLEN(sv), CvPROTO(sv));
2005 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2006 if (!CvISXSUB(sv)) {
2008 Perl_dump_indent(aTHX_ level, file,
2009 " START = 0x%"UVxf" ===> %"IVdf"\n",
2010 PTR2UV(CvSTART(sv)),
2011 (IV)sequence_num(CvSTART(sv)));
2013 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
2014 PTR2UV(CvROOT(sv)));
2015 if (CvROOT(sv) && dumpops) {
2016 do_op_dump(level+1, file, CvROOT(sv));
2019 SV * const constant = cv_const_sv((const CV *)sv);
2021 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2024 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2026 PTR2UV(CvXSUBANY(sv).any_ptr));
2027 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2030 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2031 (IV)CvXSUBANY(sv).any_i32);
2035 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2036 HEK_KEY(CvNAME_HEK((CV *)sv)));
2037 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2038 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2039 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2040 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2041 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2042 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2043 if (nest < maxnest) {
2044 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2047 const CV * const outside = CvOUTSIDE(sv);
2048 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2051 : CvANON(outside) ? "ANON"
2052 : (outside == PL_main_cv) ? "MAIN"
2053 : CvUNIQUE(outside) ? "UNIQUE"
2054 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2056 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2057 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2062 if (type == SVt_PVLV) {
2063 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2064 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2065 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2066 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2067 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2068 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2069 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2072 if (isREGEXP(sv)) goto dumpregexp;
2073 if (!isGV_with_GP(sv))
2075 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2076 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2077 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2078 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2081 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2082 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2083 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2084 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2085 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2086 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2087 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2088 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2089 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2090 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2091 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2092 do_gv_dump (level, file, " EGV", GvEGV(sv));
2095 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2096 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2097 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2098 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2099 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2100 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2101 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2103 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2104 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2105 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2107 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2108 PTR2UV(IoTOP_GV(sv)));
2109 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2110 maxnest, dumpops, pvlim);
2112 /* Source filters hide things that are not GVs in these three, so let's
2113 be careful out there. */
2115 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2116 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2117 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2119 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2120 PTR2UV(IoFMT_GV(sv)));
2121 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2122 maxnest, dumpops, pvlim);
2124 if (IoBOTTOM_NAME(sv))
2125 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2126 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2127 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2129 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2130 PTR2UV(IoBOTTOM_GV(sv)));
2131 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2132 maxnest, dumpops, pvlim);
2134 if (isPRINT(IoTYPE(sv)))
2135 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2137 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2138 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2143 struct regexp * const r = ReANY((REGEXP*)sv);
2144 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
2146 append_flags(d, flags, regexp_flags_names); \
2147 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2148 SvCUR_set(d, SvCUR(d) - 1); \
2149 SvPVX(d)[SvCUR(d)] = '\0'; \
2152 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
2153 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2154 (UV)(r->compflags), SvPVX_const(d));
2156 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
2157 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2158 (UV)(r->extflags), SvPVX_const(d));
2159 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2161 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2163 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2165 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2166 (UV)(r->lastparen));
2167 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2168 (UV)(r->lastcloseparen));
2169 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2171 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2172 (IV)(r->minlenret));
2173 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2175 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2176 (UV)(r->pre_prefix));
2177 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2179 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2180 (IV)(r->suboffset));
2181 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2182 (IV)(r->subcoffset));
2184 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2186 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2188 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2189 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2191 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2192 PTR2UV(r->mother_re));
2193 if (nest < maxnest && r->mother_re)
2194 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2195 maxnest, dumpops, pvlim);
2196 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2197 PTR2UV(r->paren_names));
2198 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2199 PTR2UV(r->substrs));
2200 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2201 PTR2UV(r->pprivate));
2202 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2204 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2205 PTR2UV(r->qr_anoncv));
2207 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2208 PTR2UV(r->saved_copy));
2217 Perl_sv_dump(pTHX_ SV *sv)
2221 PERL_ARGS_ASSERT_SV_DUMP;
2224 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2226 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2230 Perl_runops_debug(pTHX)
2234 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2238 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2240 #ifdef PERL_TRACE_OPS
2241 ++PL_op_exec_cnt[PL_op->op_type];
2244 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2245 PerlIO_printf(Perl_debug_log,
2246 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2247 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2248 PTR2UV(*PL_watchaddr));
2249 if (DEBUG_s_TEST_) {
2250 if (DEBUG_v_TEST_) {
2251 PerlIO_printf(Perl_debug_log, "\n");
2259 if (DEBUG_t_TEST_) debop(PL_op);
2260 if (DEBUG_P_TEST_) debprof(PL_op);
2263 OP_ENTRY_PROBE(OP_NAME(PL_op));
2264 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2265 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2273 Perl_debop(pTHX_ const OP *o)
2277 PERL_ARGS_ASSERT_DEBOP;
2279 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2282 Perl_deb(aTHX_ "%s", OP_NAME(o));
2283 switch (o->op_type) {
2286 /* With ITHREADS, consts are stored in the pad, and the right pad
2287 * may not be active here, so check.
2288 * Looks like only during compiling the pads are illegal.
2291 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2293 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2298 SV * const sv = newSV(0);
2300 /* FIXME - is this making unwarranted assumptions about the
2301 UTF-8 cleanliness of the dump file handle? */
2304 gv_fullname3(sv, cGVOPo_gv, NULL);
2305 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2306 SvREFCNT_dec_NN(sv);
2309 PerlIO_printf(Perl_debug_log, "(NULL)");
2321 count = o->op_private & OPpPADRANGE_COUNTMASK;
2323 /* print the lexical's name */
2325 CV * const cv = deb_curcv(cxstack_ix);
2327 PAD * comppad = NULL;
2331 PADLIST * const padlist = CvPADLIST(cv);
2332 comppad = *PadlistARRAY(padlist);
2334 PerlIO_printf(Perl_debug_log, "(");
2335 for (i = 0; i < count; i++) {
2337 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2338 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2340 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2343 PerlIO_printf(Perl_debug_log, ",");
2345 PerlIO_printf(Perl_debug_log, ")");
2353 PerlIO_printf(Perl_debug_log, "\n");
2358 S_deb_curcv(pTHX_ const I32 ix)
2361 const PERL_CONTEXT * const cx = &cxstack[ix];
2362 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2363 return cx->blk_sub.cv;
2364 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2365 return cx->blk_eval.cv;
2366 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2371 return deb_curcv(ix - 1);
2375 Perl_watch(pTHX_ char **addr)
2379 PERL_ARGS_ASSERT_WATCH;
2381 PL_watchaddr = addr;
2383 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2384 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2388 S_debprof(pTHX_ const OP *o)
2392 PERL_ARGS_ASSERT_DEBPROF;
2394 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2396 if (!PL_profiledata)
2397 Newxz(PL_profiledata, MAXO, U32);
2398 ++PL_profiledata[o->op_type];
2402 Perl_debprofdump(pTHX)
2406 if (!PL_profiledata)
2408 for (i = 0; i < MAXO; i++) {
2409 if (PL_profiledata[i])
2410 PerlIO_printf(Perl_debug_log,
2411 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2418 * XML variants of most of the above routines
2422 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2426 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2428 PerlIO_printf(file, "\n ");
2429 va_start(args, pat);
2430 xmldump_vindent(level, file, pat, &args);
2436 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2439 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2440 va_start(args, pat);
2441 xmldump_vindent(level, file, pat, &args);
2446 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2448 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2450 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2451 PerlIO_vprintf(file, pat, *args);
2455 Perl_xmldump_all(pTHX)
2457 xmldump_all_perl(FALSE);
2461 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2463 PerlIO_setlinebuf(PL_xmlfp);
2465 op_xmldump(PL_main_root);
2466 /* someday we might call this, when it outputs XML: */
2467 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2468 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2469 PerlIO_close(PL_xmlfp);
2474 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2476 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2477 xmldump_packsubs_perl(stash, FALSE);
2481 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2486 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2488 if (!HvARRAY(stash))
2490 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2491 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2492 GV *gv = MUTABLE_GV(HeVAL(entry));
2494 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2497 xmldump_sub_perl(gv, justperl);
2500 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2501 && (hv = GvHV(gv)) && hv != PL_defstash)
2502 xmldump_packsubs_perl(hv, justperl); /* nested package */
2508 Perl_xmldump_sub(pTHX_ const GV *gv)
2510 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2511 xmldump_sub_perl(gv, FALSE);
2515 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2519 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2521 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2524 sv = sv_newmortal();
2525 gv_fullname3(sv, gv, NULL);
2526 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2527 if (CvXSUB(GvCV(gv)))
2528 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2529 PTR2UV(CvXSUB(GvCV(gv))),
2530 (int)CvXSUBANY(GvCV(gv)).any_i32);
2531 else if (CvROOT(GvCV(gv)))
2532 op_xmldump(CvROOT(GvCV(gv)));
2534 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2538 Perl_xmldump_form(pTHX_ const GV *gv)
2540 SV * const sv = sv_newmortal();
2542 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2544 gv_fullname3(sv, gv, NULL);
2545 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2546 if (CvROOT(GvFORM(gv)))
2547 op_xmldump(CvROOT(GvFORM(gv)));
2549 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2553 Perl_xmldump_eval(pTHX)
2555 op_xmldump(PL_eval_root);
2559 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2561 PERL_ARGS_ASSERT_SV_CATXMLSV;
2562 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2566 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2568 PERL_ARGS_ASSERT_SV_CATXMLPV;
2569 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2573 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2576 const char * const e = pv + len;
2577 const char * const start = pv;
2581 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2584 dsvcur = SvCUR(dsv); /* in case we have to restart */
2589 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2591 SvCUR(dsv) = dsvcur;
2656 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2659 sv_catpvs(dsv, "<");
2662 sv_catpvs(dsv, ">");
2665 sv_catpvs(dsv, "&");
2668 sv_catpvs(dsv, """);
2672 if (c < 32 || c > 127) {
2673 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2676 const char string = (char) c;
2677 sv_catpvn(dsv, &string, 1);
2681 if ((c >= 0xD800 && c <= 0xDB7F) ||
2682 (c >= 0xDC00 && c <= 0xDFFF) ||
2683 (c >= 0xFFF0 && c <= 0xFFFF) ||
2685 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2687 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2700 Perl_sv_xmlpeek(pTHX_ SV *sv)
2702 SV * const t = sv_newmortal();
2706 PERL_ARGS_ASSERT_SV_XMLPEEK;
2712 sv_catpv(t, "VOID=\"\"");
2715 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2716 sv_catpv(t, "WILD=\"\"");
2719 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2720 if (sv == &PL_sv_undef) {
2721 sv_catpv(t, "SV_UNDEF=\"1\"");
2722 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2723 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2727 else if (sv == &PL_sv_no) {
2728 sv_catpv(t, "SV_NO=\"1\"");
2729 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2730 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2731 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2732 SVp_POK|SVp_NOK)) &&
2737 else if (sv == &PL_sv_yes) {
2738 sv_catpv(t, "SV_YES=\"1\"");
2739 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2740 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2741 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2742 SVp_POK|SVp_NOK)) &&
2744 SvPVX(sv) && *SvPVX(sv) == '1' &&
2749 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2750 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2751 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2755 sv_catpv(t, " XXX=\"\" ");
2757 else if (SvREFCNT(sv) == 0) {
2758 sv_catpv(t, " refcnt=\"0\"");
2761 else if (DEBUG_R_TEST_) {
2764 /* is this SV on the tmps stack? */
2765 for (ix=PL_tmps_ix; ix>=0; ix--) {
2766 if (PL_tmps_stack[ix] == sv) {
2771 if (SvREFCNT(sv) > 1)
2772 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2775 sv_catpv(t, " DRT=\"<T>\"");
2779 sv_catpv(t, " ROK=\"\"");
2781 switch (SvTYPE(sv)) {
2783 sv_catpv(t, " FREED=\"1\"");
2787 sv_catpv(t, " UNDEF=\"1\"");
2790 sv_catpv(t, " IV=\"");
2793 sv_catpv(t, " NV=\"");
2796 sv_catpv(t, " PV=\"");
2799 sv_catpv(t, " PVIV=\"");
2802 sv_catpv(t, " PVNV=\"");
2805 sv_catpv(t, " PVMG=\"");
2808 sv_catpv(t, " PVLV=\"");
2811 sv_catpv(t, " AV=\"");
2814 sv_catpv(t, " HV=\"");
2818 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2820 sv_catpv(t, " CV=\"()\"");
2823 sv_catpv(t, " GV=\"");
2826 sv_catpv(t, " DUMMY=\"");
2829 sv_catpv(t, " REGEXP=\"");
2832 sv_catpv(t, " FM=\"");
2835 sv_catpv(t, " IO=\"");
2844 else if (SvNOKp(sv)) {
2845 STORE_NUMERIC_LOCAL_SET_STANDARD();
2846 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2847 RESTORE_NUMERIC_LOCAL();
2849 else if (SvIOKp(sv)) {
2851 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2853 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2862 return SvPV(t, n_a);
2866 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2868 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2871 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2874 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2877 REGEXP *const r = PM_GETRE(pm);
2878 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2879 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2880 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2882 SvREFCNT_dec_NN(tmpsv);
2883 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2884 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2887 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2888 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2889 SV * const tmpsv = pm_description(pm);
2890 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2891 SvREFCNT_dec_NN(tmpsv);
2895 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2896 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2897 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2898 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2899 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2900 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2903 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2907 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2909 do_pmop_xmldump(0, PL_xmlfp, pm);
2913 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2917 const OPCODE optype = o->op_type;
2919 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2923 seq = sequence_num(o);
2924 Perl_xmldump_indent(aTHX_ level, file,
2925 "<op_%s seq=\"%"UVuf" -> ",
2930 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2931 sequence_num(o->op_next));
2933 PerlIO_printf(file, "DONE\"");
2936 if (optype == OP_NULL)
2938 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2939 if (o->op_targ == OP_NEXTSTATE)
2942 PerlIO_printf(file, " line=\"%"UVuf"\"",
2943 (UV)CopLINE(cCOPo));
2944 if (CopSTASHPV(cCOPo))
2945 PerlIO_printf(file, " package=\"%s\"",
2947 if (CopLABEL(cCOPo))
2948 PerlIO_printf(file, " label=\"%s\"",
2953 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2956 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2959 DUMP_OP_FLAGS(o,1,0,file);
2960 DUMP_OP_PRIVATE(o,1,0,file);
2964 if (o->op_flags & OPf_SPECIAL) {
2970 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2972 if (cSVOPo->op_sv) {
2973 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2974 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2980 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2981 s = SvPV(tmpsv1,len);
2982 sv_catxmlpvn(tmpsv2, s, len, 1);
2983 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2987 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2992 case OP_METHOD_NAMED:
2993 #ifndef USE_ITHREADS
2994 /* with ITHREADS, consts are stored in the pad, and the right pad
2995 * may not be active here, so skip */
2996 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3002 PerlIO_printf(file, ">\n");
3004 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3009 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3010 (UV)CopLINE(cCOPo));
3011 if (CopSTASHPV(cCOPo))
3012 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3014 if (CopLABEL(cCOPo))
3015 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3019 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3020 if (cLOOPo->op_redoop)
3021 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3023 PerlIO_printf(file, "DONE\"");
3024 S_xmldump_attr(aTHX_ level, file, "next=\"");
3025 if (cLOOPo->op_nextop)
3026 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3028 PerlIO_printf(file, "DONE\"");
3029 S_xmldump_attr(aTHX_ level, file, "last=\"");
3030 if (cLOOPo->op_lastop)
3031 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3033 PerlIO_printf(file, "DONE\"");
3041 S_xmldump_attr(aTHX_ level, file, "other=\"");
3042 if (cLOGOPo->op_other)
3043 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3045 PerlIO_printf(file, "DONE\"");
3053 if (o->op_private & OPpREFCOUNTED)
3054 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3060 if (PL_madskills && o->op_madprop) {
3061 char prevkey = '\0';
3062 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3063 const MADPROP* mp = o->op_madprop;
3067 PerlIO_printf(file, ">\n");
3069 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3072 char tmp = mp->mad_key;
3073 sv_setpvs(tmpsv,"\"");
3075 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3076 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3077 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3080 sv_catpv(tmpsv, "\"");
3081 switch (mp->mad_type) {
3083 sv_catpv(tmpsv, "NULL");
3084 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3087 sv_catpv(tmpsv, " val=\"");
3088 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3089 sv_catpv(tmpsv, "\"");
3090 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3093 sv_catpv(tmpsv, " val=\"");
3094 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3095 sv_catpv(tmpsv, "\"");
3096 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3099 if ((OP*)mp->mad_val) {
3100 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3101 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3102 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3106 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3112 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3114 SvREFCNT_dec_NN(tmpsv);
3124 PerlIO_printf(file, ">\n");
3126 do_pmop_xmldump(level, file, cPMOPo);
3132 if (o->op_flags & OPf_KIDS) {
3136 PerlIO_printf(file, ">\n");
3138 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3139 do_op_xmldump(level, file, kid);
3143 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3145 PerlIO_printf(file, " />\n");
3149 Perl_op_xmldump(pTHX_ const OP *o)
3151 PERL_ARGS_ASSERT_OP_XMLDUMP;
3153 do_op_xmldump(0, PL_xmlfp, o);
3159 * c-indentation-style: bsd
3161 * indent-tabs-mode: nil
3164 * ex: set ts=8 sts=4 sw=4 et: