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
31 static const char* const svtypenames[SVt_LAST] = {
51 static const char* const svshorttypenames[SVt_LAST] = {
76 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
77 const struct flag_to_name *const end)
80 if (flags & start->flag)
81 sv_catpv(sv, start->name);
82 } while (++start < end);
85 #define append_flags(sv, f, flags) \
86 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
91 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
94 PERL_ARGS_ASSERT_DUMP_INDENT;
96 dump_vindent(level, file, pat, &args);
101 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
104 PERL_ARGS_ASSERT_DUMP_VINDENT;
105 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
106 PerlIO_vprintf(file, pat, *args);
112 dump_all_perl(FALSE);
116 Perl_dump_all_perl(pTHX_ bool justperl)
120 PerlIO_setlinebuf(Perl_debug_log);
122 op_dump(PL_main_root);
123 dump_packsubs_perl(PL_defstash, justperl);
127 Perl_dump_packsubs(pTHX_ const HV *stash)
129 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
130 dump_packsubs_perl(stash, FALSE);
134 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
139 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
143 for (i = 0; i <= (I32) HvMAX(stash); i++) {
145 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
146 const GV * const gv = (const GV *)HeVAL(entry);
147 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
150 dump_sub_perl(gv, justperl);
153 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
154 const HV * const hv = GvHV(gv);
155 if (hv && (hv != PL_defstash))
156 dump_packsubs_perl(hv, justperl); /* nested package */
163 Perl_dump_sub(pTHX_ const GV *gv)
165 PERL_ARGS_ASSERT_DUMP_SUB;
166 dump_sub_perl(gv, FALSE);
170 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
174 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
176 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
180 gv_fullname3(sv, gv, NULL);
181 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
182 if (CvISXSUB(GvCV(gv)))
183 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
184 PTR2UV(CvXSUB(GvCV(gv))),
185 (int)CvXSUBANY(GvCV(gv)).any_i32);
186 else if (CvROOT(GvCV(gv)))
187 op_dump(CvROOT(GvCV(gv)));
189 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
193 Perl_dump_form(pTHX_ const GV *gv)
195 SV * const sv = sv_newmortal();
197 PERL_ARGS_ASSERT_DUMP_FORM;
199 gv_fullname3(sv, gv, NULL);
200 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
201 if (CvROOT(GvFORM(gv)))
202 op_dump(CvROOT(GvFORM(gv)));
204 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
211 op_dump(PL_eval_root);
216 =for apidoc pv_escape
218 Escapes at most the first "count" chars of pv and puts the results into
219 dsv such that the size of the escaped string will not exceed "max" chars
220 and will not contain any incomplete escape sequences.
222 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
223 will also be escaped.
225 Normally the SV will be cleared before the escaped string is prepared,
226 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
228 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
229 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
230 using C<is_utf8_string()> to determine if it is Unicode.
232 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
233 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
234 chars above 127 will be escaped using this style; otherwise, only chars above
235 255 will be so escaped; other non printable chars will use octal or
236 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
237 then all chars below 255 will be treated as printable and
238 will be output as literals.
240 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
241 string will be escaped, regardless of max. If the output is to be in hex,
242 then it will be returned as a plain hex
243 sequence. Thus the output will either be a single char,
244 an octal escape sequence, a special escape like C<\n> or a hex value.
246 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
247 not a '\\'. This is because regexes very often contain backslashed
248 sequences, whereas '%' is not a particularly common character in patterns.
250 Returns a pointer to the escaped text as held by dsv.
254 #define PV_ESCAPE_OCTBUFSIZE 32
257 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
258 const STRLEN count, const STRLEN max,
259 STRLEN * const escaped, const U32 flags )
261 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
262 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
263 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
264 STRLEN wrote = 0; /* chars written so far */
265 STRLEN chsize = 0; /* size of data to be written */
266 STRLEN readsize = 1; /* size of data just read */
267 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
268 const char *pv = str;
269 const char * const end = pv + count; /* end of string */
272 PERL_ARGS_ASSERT_PV_ESCAPE;
274 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
275 /* This won't alter the UTF-8 flag */
279 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
282 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
283 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
284 const U8 c = (U8)u & 0xFF;
287 || (flags & PERL_PV_ESCAPE_ALL)
288 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
290 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
291 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
294 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
295 "%cx{%"UVxf"}", esc, u);
296 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
299 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
303 case '\\' : /* fallthrough */
304 case '%' : if ( c == esc ) {
310 case '\v' : octbuf[1] = 'v'; break;
311 case '\t' : octbuf[1] = 't'; break;
312 case '\r' : octbuf[1] = 'r'; break;
313 case '\n' : octbuf[1] = 'n'; break;
314 case '\f' : octbuf[1] = 'f'; break;
322 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
323 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
326 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
333 if ( max && (wrote + chsize > max) ) {
335 } else if (chsize > 1) {
336 sv_catpvn(dsv, octbuf, chsize);
339 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
340 128-255 can be appended raw to the dsv. If dsv happens to be
341 UTF-8 then we need catpvf to upgrade them for us.
342 Or add a new API call sv_catpvc(). Think about that name, and
343 how to keep it clear that it's unlike the s of catpvs, which is
344 really an array octets, not a string. */
345 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
348 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
356 =for apidoc pv_pretty
358 Converts a string into something presentable, handling escaping via
359 pv_escape() and supporting quoting and ellipses.
361 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
362 double quoted with any double quotes in the string escaped. Otherwise
363 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
366 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
367 string were output then an ellipsis C<...> will be appended to the
368 string. Note that this happens AFTER it has been quoted.
370 If start_color is non-null then it will be inserted after the opening
371 quote (if there is one) but before the escaped text. If end_color
372 is non-null then it will be inserted after the escaped text but before
373 any quotes or ellipses.
375 Returns a pointer to the prettified text as held by dsv.
381 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
382 const STRLEN max, char const * const start_color, char const * const end_color,
385 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
388 PERL_ARGS_ASSERT_PV_PRETTY;
390 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
391 /* This won't alter the UTF-8 flag */
396 sv_catpvs(dsv, "\"");
397 else if ( flags & PERL_PV_PRETTY_LTGT )
400 if ( start_color != NULL )
401 sv_catpv(dsv, start_color);
403 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
405 if ( end_color != NULL )
406 sv_catpv(dsv, end_color);
409 sv_catpvs( dsv, "\"");
410 else if ( flags & PERL_PV_PRETTY_LTGT )
413 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
414 sv_catpvs(dsv, "...");
420 =for apidoc pv_display
424 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
426 except that an additional "\0" will be appended to the string when
427 len > cur and pv[cur] is "\0".
429 Note that the final string may be up to 7 chars longer than pvlim.
435 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
437 PERL_ARGS_ASSERT_PV_DISPLAY;
439 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
440 if (len > cur && pv[cur] == '\0')
441 sv_catpvs( dsv, "\\0");
446 Perl_sv_peek(pTHX_ SV *sv)
449 SV * const t = sv_newmortal();
459 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
460 /* detect data corruption under memory poisoning */
464 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
465 if (sv == &PL_sv_undef) {
466 sv_catpv(t, "SV_UNDEF");
467 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
468 SVs_GMG|SVs_SMG|SVs_RMG)) &&
472 else if (sv == &PL_sv_no) {
473 sv_catpv(t, "SV_NO");
474 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
475 SVs_GMG|SVs_SMG|SVs_RMG)) &&
476 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
482 else if (sv == &PL_sv_yes) {
483 sv_catpv(t, "SV_YES");
484 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
485 SVs_GMG|SVs_SMG|SVs_RMG)) &&
486 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
489 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
494 sv_catpv(t, "SV_PLACEHOLDER");
495 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
496 SVs_GMG|SVs_SMG|SVs_RMG)) &&
502 else if (SvREFCNT(sv) == 0) {
506 else if (DEBUG_R_TEST_) {
509 /* is this SV on the tmps stack? */
510 for (ix=PL_tmps_ix; ix>=0; ix--) {
511 if (PL_tmps_stack[ix] == sv) {
516 if (SvREFCNT(sv) > 1)
517 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
525 if (SvCUR(t) + unref > 10) {
526 SvCUR_set(t, unref + 3);
535 if (type == SVt_PVCV) {
536 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
538 } else if (type < SVt_LAST) {
539 sv_catpv(t, svshorttypenames[type]);
541 if (type == SVt_NULL)
544 sv_catpv(t, "FREED");
549 if (!SvPVX_const(sv))
550 sv_catpv(t, "(null)");
552 SV * const tmp = newSVpvs("");
556 SvOOK_offset(sv, delta);
557 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
559 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
561 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
562 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
564 SvREFCNT_dec_NN(tmp);
567 else if (SvNOKp(sv)) {
568 STORE_NUMERIC_LOCAL_SET_STANDARD();
569 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
570 RESTORE_NUMERIC_LOCAL();
572 else if (SvIOKp(sv)) {
574 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
576 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
584 if (TAINTING_get && SvTAINTED(sv))
585 sv_catpv(t, " [tainted]");
586 return SvPV_nolen(t);
590 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
594 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
597 Perl_dump_indent(aTHX_ level, file, "{}\n");
600 Perl_dump_indent(aTHX_ level, file, "{\n");
602 if (pm->op_pmflags & PMf_ONCE)
607 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
608 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
609 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
611 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
612 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
613 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
614 op_dump(pm->op_pmreplrootu.op_pmreplroot);
616 if (pm->op_code_list) {
617 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
618 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
619 do_op_dump(level, file, pm->op_code_list);
622 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
623 PTR2UV(pm->op_code_list));
625 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
626 SV * const tmpsv = pm_description(pm);
627 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
628 SvREFCNT_dec_NN(tmpsv);
631 Perl_dump_indent(aTHX_ level-1, file, "}\n");
634 const struct flag_to_name pmflags_flags_names[] = {
635 {PMf_CONST, ",CONST"},
637 {PMf_GLOBAL, ",GLOBAL"},
638 {PMf_CONTINUE, ",CONTINUE"},
639 {PMf_RETAINT, ",RETAINT"},
641 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
642 {PMf_HAS_CV, ",HAS_CV"},
643 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
644 {PMf_IS_QR, ",IS_QR"}
648 S_pm_description(pTHX_ const PMOP *pm)
650 SV * const desc = newSVpvs("");
651 const REGEXP * const regex = PM_GETRE(pm);
652 const U32 pmflags = pm->op_pmflags;
654 PERL_ARGS_ASSERT_PM_DESCRIPTION;
656 if (pmflags & PMf_ONCE)
657 sv_catpv(desc, ",ONCE");
659 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
660 sv_catpv(desc, ":USED");
662 if (pmflags & PMf_USED)
663 sv_catpv(desc, ":USED");
667 if (RX_ISTAINTED(regex))
668 sv_catpv(desc, ",TAINTED");
669 if (RX_CHECK_SUBSTR(regex)) {
670 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
671 sv_catpv(desc, ",SCANFIRST");
672 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
673 sv_catpv(desc, ",ALL");
675 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
676 sv_catpv(desc, ",SKIPWHITE");
679 append_flags(desc, pmflags, pmflags_flags_names);
684 Perl_pmop_dump(pTHX_ PMOP *pm)
686 do_pmop_dump(0, Perl_debug_log, pm);
689 /* Return a unique integer to represent the address of op o.
690 * If it already exists in PL_op_sequence, just return it;
692 * *** Note that this isn't thread-safe */
695 S_sequence_num(pTHX_ const OP *o)
704 op = newSVuv(PTR2UV(o));
706 key = SvPV_const(op, len);
708 PL_op_sequence = newHV();
709 seq = hv_fetch(PL_op_sequence, key, len, 0);
712 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
716 const struct flag_to_name op_flags_names[] = {
718 {OPf_PARENS, ",PARENS"},
721 {OPf_STACKED, ",STACKED"},
722 {OPf_SPECIAL, ",SPECIAL"}
725 const struct flag_to_name op_trans_names[] = {
726 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
727 {OPpTRANS_TO_UTF, ",TO_UTF"},
728 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
729 {OPpTRANS_SQUASH, ",SQUASH"},
730 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
731 {OPpTRANS_GROWS, ",GROWS"},
732 {OPpTRANS_DELETE, ",DELETE"}
735 const struct flag_to_name op_entersub_names[] = {
736 {OPpENTERSUB_DB, ",DB"},
737 {OPpENTERSUB_HASTARG, ",HASTARG"},
738 {OPpENTERSUB_AMPER, ",AMPER"},
739 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
740 {OPpENTERSUB_INARGS, ",INARGS"}
743 const struct flag_to_name op_const_names[] = {
744 {OPpCONST_NOVER, ",NOVER"},
745 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
746 {OPpCONST_STRICT, ",STRICT"},
747 {OPpCONST_ENTERED, ",ENTERED"},
748 {OPpCONST_FOLDED, ",FOLDED"},
749 {OPpCONST_BARE, ",BARE"}
752 const struct flag_to_name op_sort_names[] = {
753 {OPpSORT_NUMERIC, ",NUMERIC"},
754 {OPpSORT_INTEGER, ",INTEGER"},
755 {OPpSORT_REVERSE, ",REVERSE"},
756 {OPpSORT_INPLACE, ",INPLACE"},
757 {OPpSORT_DESCEND, ",DESCEND"},
758 {OPpSORT_QSORT, ",QSORT"},
759 {OPpSORT_STABLE, ",STABLE"}
762 const struct flag_to_name op_open_names[] = {
763 {OPpOPEN_IN_RAW, ",IN_RAW"},
764 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
765 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
766 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
769 const struct flag_to_name op_exit_names[] = {
770 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
771 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
774 const struct flag_to_name op_sassign_names[] = {
775 {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
776 {OPpASSIGN_CV_TO_GV, ",CV2GV"}
779 #define OP_PRIVATE_ONCE(op, flag, name) \
780 const struct flag_to_name CAT2(op, _names)[] = { \
784 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
785 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
786 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
787 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
788 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
789 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
790 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
791 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
792 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
793 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
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_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"); \
864 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
865 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
867 PerlIO_printf(file, " flags=\"%s\"", \
868 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
869 SvREFCNT_dec_NN(tmpsv); \
872 #if !defined(PERL_MAD)
873 # define xmldump_attr1(level, file, pat, arg)
875 # define xmldump_attr1(level, file, pat, arg) \
876 S_xmldump_attr(aTHX_ level, file, pat, arg)
879 #define DUMP_OP_PRIVATE(o,xml,level,file) \
880 if (o->op_private) { \
881 U32 optype = o->op_type; \
882 U32 oppriv = o->op_private; \
883 SV * const tmpsv = newSVpvs(""); \
884 if (PL_opargs[optype] & OA_TARGLEX) { \
885 if (oppriv & OPpTARGET_MY) \
886 sv_catpv(tmpsv, ",TARGET_MY"); \
888 else if (optype == OP_ENTERSUB || \
889 optype == OP_RV2SV || \
890 optype == OP_GVSV || \
891 optype == OP_RV2AV || \
892 optype == OP_RV2HV || \
893 optype == OP_RV2GV || \
894 optype == OP_AELEM || \
895 optype == OP_HELEM ) \
897 if (optype == OP_ENTERSUB) { \
898 append_flags(tmpsv, oppriv, op_entersub_names); \
901 switch (oppriv & OPpDEREF) { \
903 sv_catpv(tmpsv, ",SV"); \
906 sv_catpv(tmpsv, ",AV"); \
909 sv_catpv(tmpsv, ",HV"); \
912 if (oppriv & OPpMAYBE_LVSUB) \
913 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
915 if (optype == OP_AELEM || optype == OP_HELEM) { \
916 if (oppriv & OPpLVAL_DEFER) \
917 sv_catpv(tmpsv, ",LVAL_DEFER"); \
919 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
920 if (oppriv & OPpMAYBE_TRUEBOOL) \
921 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
922 if (oppriv & OPpTRUEBOOL) \
923 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
926 if (oppriv & HINT_STRICT_REFS) \
927 sv_catpv(tmpsv, ",STRICT_REFS"); \
928 if (oppriv & OPpOUR_INTRO) \
929 sv_catpv(tmpsv, ",OUR_INTRO"); \
932 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
934 else if (OP_IS_FILETEST(o->op_type)) { \
935 if (oppriv & OPpFT_ACCESS) \
936 sv_catpv(tmpsv, ",FT_ACCESS"); \
937 if (oppriv & OPpFT_STACKED) \
938 sv_catpv(tmpsv, ",FT_STACKED"); \
939 if (oppriv & OPpFT_STACKING) \
940 sv_catpv(tmpsv, ",FT_STACKING"); \
941 if (oppriv & OPpFT_AFTER_t) \
942 sv_catpv(tmpsv, ",AFTER_t"); \
944 else if (o->op_type == OP_AASSIGN) { \
945 if (oppriv & OPpASSIGN_COMMON) \
946 sv_catpvs(tmpsv, ",COMMON"); \
947 if (oppriv & OPpMAYBE_LVSUB) \
948 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
950 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
951 sv_catpv(tmpsv, ",INTRO"); \
952 if (o->op_type == OP_PADRANGE) \
953 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
954 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
955 if (SvCUR(tmpsv)) { \
957 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
959 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
961 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
963 SvREFCNT_dec_NN(tmpsv); \
968 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
972 const OPCODE optype = o->op_type;
974 PERL_ARGS_ASSERT_DO_OP_DUMP;
976 Perl_dump_indent(aTHX_ level, file, "{\n");
978 seq = sequence_num(o);
980 PerlIO_printf(file, "%-4"UVuf, seq);
982 PerlIO_printf(file, "????");
984 "%*sTYPE = %s ===> ",
985 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
988 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
989 sequence_num(o->op_next));
991 PerlIO_printf(file, "NULL\n");
993 if (optype == OP_NULL) {
994 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
995 if (o->op_targ == OP_NEXTSTATE) {
997 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
999 if (CopSTASHPV(cCOPo))
1000 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1002 if (CopLABEL(cCOPo))
1003 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1008 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1011 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1014 DUMP_OP_FLAGS(o,0,level,file);
1015 DUMP_OP_PRIVATE(o,0,level,file);
1018 if (PL_madskills && o->op_madprop) {
1019 SV * const tmpsv = newSVpvs("");
1020 MADPROP* mp = o->op_madprop;
1021 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1024 const char tmp = mp->mad_key;
1025 sv_setpvs(tmpsv,"'");
1027 sv_catpvn(tmpsv, &tmp, 1);
1028 sv_catpv(tmpsv, "'=");
1029 switch (mp->mad_type) {
1031 sv_catpv(tmpsv, "NULL");
1032 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1035 sv_catpv(tmpsv, "<");
1036 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1037 sv_catpv(tmpsv, ">");
1038 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1041 if ((OP*)mp->mad_val) {
1042 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1043 do_op_dump(level, file, (OP*)mp->mad_val);
1047 sv_catpv(tmpsv, "(UNK)");
1048 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1054 Perl_dump_indent(aTHX_ level, file, "}\n");
1056 SvREFCNT_dec_NN(tmpsv);
1065 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1067 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1068 if (cSVOPo->op_sv) {
1069 SV * const tmpsv = newSV(0);
1073 /* FIXME - is this making unwarranted assumptions about the
1074 UTF-8 cleanliness of the dump file handle? */
1077 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1078 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1079 SvPV_nolen_const(tmpsv));
1083 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1089 case OP_METHOD_NAMED:
1090 #ifndef USE_ITHREADS
1091 /* with ITHREADS, consts are stored in the pad, and the right pad
1092 * may not be active here, so skip */
1093 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1099 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1100 (UV)CopLINE(cCOPo));
1101 if (CopSTASHPV(cCOPo))
1102 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1104 if (CopLABEL(cCOPo))
1105 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1109 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1110 if (cLOOPo->op_redoop)
1111 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1113 PerlIO_printf(file, "DONE\n");
1114 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1115 if (cLOOPo->op_nextop)
1116 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1118 PerlIO_printf(file, "DONE\n");
1119 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1120 if (cLOOPo->op_lastop)
1121 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1123 PerlIO_printf(file, "DONE\n");
1131 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1132 if (cLOGOPo->op_other)
1133 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1135 PerlIO_printf(file, "DONE\n");
1141 do_pmop_dump(level, file, cPMOPo);
1149 if (o->op_private & OPpREFCOUNTED)
1150 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1155 if (o->op_flags & OPf_KIDS) {
1157 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1158 do_op_dump(level, file, kid);
1160 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1164 Perl_op_dump(pTHX_ const OP *o)
1166 PERL_ARGS_ASSERT_OP_DUMP;
1167 do_op_dump(0, Perl_debug_log, o);
1171 Perl_gv_dump(pTHX_ GV *gv)
1175 PERL_ARGS_ASSERT_GV_DUMP;
1178 PerlIO_printf(Perl_debug_log, "{}\n");
1181 sv = sv_newmortal();
1182 PerlIO_printf(Perl_debug_log, "{\n");
1183 gv_fullname3(sv, gv, NULL);
1184 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1185 if (gv != GvEGV(gv)) {
1186 gv_efullname3(sv, GvEGV(gv), NULL);
1187 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1189 PerlIO_putc(Perl_debug_log, '\n');
1190 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1194 /* map magic types to the symbolic names
1195 * (with the PERL_MAGIC_ prefixed stripped)
1198 static const struct { const char type; const char *name; } magic_names[] = {
1199 #include "mg_names.c"
1200 /* this null string terminates the list */
1205 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1207 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1209 for (; mg; mg = mg->mg_moremagic) {
1210 Perl_dump_indent(aTHX_ level, file,
1211 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1212 if (mg->mg_virtual) {
1213 const MGVTBL * const v = mg->mg_virtual;
1214 if (v >= PL_magic_vtables
1215 && v < PL_magic_vtables + magic_vtable_max) {
1216 const U32 i = v - PL_magic_vtables;
1217 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1220 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1223 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1226 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1230 const char *name = NULL;
1231 for (n = 0; magic_names[n].name; n++) {
1232 if (mg->mg_type == magic_names[n].type) {
1233 name = magic_names[n].name;
1238 Perl_dump_indent(aTHX_ level, file,
1239 " MG_TYPE = PERL_MAGIC_%s\n", name);
1241 Perl_dump_indent(aTHX_ level, file,
1242 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1246 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1247 if (mg->mg_type == PERL_MAGIC_envelem &&
1248 mg->mg_flags & MGf_TAINTEDDIR)
1249 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1250 if (mg->mg_type == PERL_MAGIC_regex_global &&
1251 mg->mg_flags & MGf_MINMATCH)
1252 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1253 if (mg->mg_flags & MGf_REFCOUNTED)
1254 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1255 if (mg->mg_flags & MGf_GSKIP)
1256 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1257 if (mg->mg_flags & MGf_COPY)
1258 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1259 if (mg->mg_flags & MGf_DUP)
1260 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1261 if (mg->mg_flags & MGf_LOCAL)
1262 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1265 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1266 PTR2UV(mg->mg_obj));
1267 if (mg->mg_type == PERL_MAGIC_qr) {
1268 REGEXP* const re = (REGEXP *)mg->mg_obj;
1269 SV * const dsv = sv_newmortal();
1270 const char * const s
1271 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1273 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1274 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1276 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1277 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1280 if (mg->mg_flags & MGf_REFCOUNTED)
1281 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1284 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1286 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1287 if (mg->mg_len >= 0) {
1288 if (mg->mg_type != PERL_MAGIC_utf8) {
1289 SV * const sv = newSVpvs("");
1290 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1291 SvREFCNT_dec_NN(sv);
1294 else if (mg->mg_len == HEf_SVKEY) {
1295 PerlIO_puts(file, " => HEf_SVKEY\n");
1296 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1297 maxnest, dumpops, pvlim); /* MG is already +1 */
1300 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1305 " does not know how to handle this MG_LEN"
1307 PerlIO_putc(file, '\n');
1309 if (mg->mg_type == PERL_MAGIC_utf8) {
1310 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1313 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1314 Perl_dump_indent(aTHX_ level, file,
1315 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1318 (UV)cache[i * 2 + 1]);
1325 Perl_magic_dump(pTHX_ const MAGIC *mg)
1327 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1331 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1335 PERL_ARGS_ASSERT_DO_HV_DUMP;
1337 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1338 if (sv && (hvname = HvNAME_get(sv)))
1340 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1341 name which quite legally could contain insane things like tabs, newlines, nulls or
1342 other scary crap - this should produce sane results - except maybe for unicode package
1343 names - but we will wait for someone to file a bug on that - demerphq */
1344 SV * const tmpsv = newSVpvs("");
1345 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1348 PerlIO_putc(file, '\n');
1352 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1354 PERL_ARGS_ASSERT_DO_GV_DUMP;
1356 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1357 if (sv && GvNAME(sv))
1358 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1360 PerlIO_putc(file, '\n');
1364 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1366 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1368 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1369 if (sv && GvNAME(sv)) {
1371 PerlIO_printf(file, "\t\"");
1372 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1373 PerlIO_printf(file, "%s\" :: \"", hvname);
1374 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1377 PerlIO_putc(file, '\n');
1380 const struct flag_to_name first_sv_flags_names[] = {
1381 {SVs_TEMP, "TEMP,"},
1382 {SVs_OBJECT, "OBJECT,"},
1391 const struct flag_to_name second_sv_flags_names[] = {
1393 {SVf_FAKE, "FAKE,"},
1394 {SVf_READONLY, "READONLY,"},
1395 {SVf_IsCOW, "IsCOW,"},
1396 {SVf_BREAK, "BREAK,"},
1397 {SVf_AMAGIC, "OVERLOAD,"},
1403 const struct flag_to_name cv_flags_names[] = {
1404 {CVf_ANON, "ANON,"},
1405 {CVf_UNIQUE, "UNIQUE,"},
1406 {CVf_CLONE, "CLONE,"},
1407 {CVf_CLONED, "CLONED,"},
1408 {CVf_CONST, "CONST,"},
1409 {CVf_NODEBUG, "NODEBUG,"},
1410 {CVf_LVALUE, "LVALUE,"},
1411 {CVf_METHOD, "METHOD,"},
1412 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1413 {CVf_CVGV_RC, "CVGV_RC,"},
1414 {CVf_DYNFILE, "DYNFILE,"},
1415 {CVf_AUTOLOAD, "AUTOLOAD,"},
1416 {CVf_HASEVAL, "HASEVAL"},
1417 {CVf_SLABBED, "SLABBED,"},
1418 {CVf_ISXSUB, "ISXSUB,"}
1421 const struct flag_to_name hv_flags_names[] = {
1422 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1423 {SVphv_LAZYDEL, "LAZYDEL,"},
1424 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1425 {SVphv_CLONEABLE, "CLONEABLE,"}
1428 const struct flag_to_name gp_flags_names[] = {
1429 {GVf_INTRO, "INTRO,"},
1430 {GVf_MULTI, "MULTI,"},
1431 {GVf_ASSUMECV, "ASSUMECV,"},
1432 {GVf_IN_PAD, "IN_PAD,"}
1435 const struct flag_to_name gp_flags_imported_names[] = {
1436 {GVf_IMPORTED_SV, " SV"},
1437 {GVf_IMPORTED_AV, " AV"},
1438 {GVf_IMPORTED_HV, " HV"},
1439 {GVf_IMPORTED_CV, " CV"},
1442 const struct flag_to_name regexp_flags_names[] = {
1443 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1444 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1445 {RXf_PMf_FOLD, "PMf_FOLD,"},
1446 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1447 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1448 {RXf_ANCH_BOL, "ANCH_BOL,"},
1449 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1450 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1451 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1452 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1453 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1454 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1455 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1456 {RXf_CANY_SEEN, "CANY_SEEN,"},
1457 {RXf_NOSCAN, "NOSCAN,"},
1458 {RXf_CHECK_ALL, "CHECK_ALL,"},
1459 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1460 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1461 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1462 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1463 {RXf_SPLIT, "SPLIT,"},
1464 {RXf_COPY_DONE, "COPY_DONE,"},
1465 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1466 {RXf_TAINTED, "TAINTED,"},
1467 {RXf_START_ONLY, "START_ONLY,"},
1468 {RXf_SKIPWHITE, "SKIPWHITE,"},
1469 {RXf_WHITE, "WHITE,"},
1470 {RXf_NULL, "NULL,"},
1474 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1482 PERL_ARGS_ASSERT_DO_SV_DUMP;
1485 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1489 flags = SvFLAGS(sv);
1492 /* process general SV flags */
1494 d = Perl_newSVpvf(aTHX_
1495 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1496 PTR2UV(SvANY(sv)), PTR2UV(sv),
1497 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1498 (int)(PL_dumpindent*level), "");
1500 if (!((flags & SVpad_NAME) == SVpad_NAME
1501 && (type == SVt_PVMG || type == SVt_PVNV))) {
1502 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1503 sv_catpv(d, "PADSTALE,");
1505 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1506 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1507 sv_catpv(d, "PADTMP,");
1508 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1510 append_flags(d, flags, first_sv_flags_names);
1511 if (flags & SVf_ROK) {
1512 sv_catpv(d, "ROK,");
1513 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1515 append_flags(d, flags, second_sv_flags_names);
1516 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1517 if (SvPCS_IMPORTED(sv))
1518 sv_catpv(d, "PCS_IMPORTED,");
1520 sv_catpv(d, "SCREAM,");
1523 /* process type-specific SV flags */
1528 append_flags(d, CvFLAGS(sv), cv_flags_names);
1531 append_flags(d, flags, hv_flags_names);
1535 if (isGV_with_GP(sv)) {
1536 append_flags(d, GvFLAGS(sv), gp_flags_names);
1538 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1539 sv_catpv(d, "IMPORT");
1540 if (GvIMPORTED(sv) == GVf_IMPORTED)
1541 sv_catpv(d, "ALL,");
1544 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1551 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1552 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1555 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1556 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1557 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1558 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1561 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1566 /* SVphv_SHAREKEYS is also 0x20000000 */
1567 if ((type != SVt_PVHV) && SvUTF8(sv))
1568 sv_catpv(d, "UTF8");
1570 if (*(SvEND(d) - 1) == ',') {
1571 SvCUR_set(d, SvCUR(d) - 1);
1572 SvPVX(d)[SvCUR(d)] = '\0';
1577 /* dump initial SV details */
1579 #ifdef DEBUG_LEAKING_SCALARS
1580 Perl_dump_indent(aTHX_ level, file,
1581 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1582 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1584 sv->sv_debug_inpad ? "for" : "by",
1585 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1586 PTR2UV(sv->sv_debug_parent),
1590 Perl_dump_indent(aTHX_ level, file, "SV = ");
1594 if (type < SVt_LAST) {
1595 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1597 if (type == SVt_NULL) {
1602 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1607 /* Dump general SV fields */
1609 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1610 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1611 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1612 || (type == SVt_IV && !SvROK(sv))) {
1614 #ifdef PERL_OLD_COPY_ON_WRITE
1618 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1620 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1621 #ifdef PERL_OLD_COPY_ON_WRITE
1622 if (SvIsCOW_shared_hash(sv))
1623 PerlIO_printf(file, " (HASH)");
1624 else if (SvIsCOW_normal(sv))
1625 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1627 PerlIO_putc(file, '\n');
1630 if ((type == SVt_PVNV || type == SVt_PVMG)
1631 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1632 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1633 (UV) COP_SEQ_RANGE_LOW(sv));
1634 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1635 (UV) COP_SEQ_RANGE_HIGH(sv));
1636 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1637 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1638 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1639 || type == SVt_NV) {
1640 STORE_NUMERIC_LOCAL_SET_STANDARD();
1641 /* %Vg doesn't work? --jhi */
1642 #ifdef USE_LONG_DOUBLE
1643 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1645 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1647 RESTORE_NUMERIC_LOCAL();
1651 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1653 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1656 if (type < SVt_PV) {
1661 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1662 const bool re = isREGEXP(sv);
1663 const char * const ptr =
1664 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1668 SvOOK_offset(sv, delta);
1669 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1674 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1676 PerlIO_printf(file, "( %s . ) ",
1677 pv_display(d, ptr - delta, delta, 0,
1680 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1683 if (SvUTF8(sv)) /* the 6? \x{....} */
1684 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1685 PerlIO_printf(file, "\n");
1686 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1688 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1690 #ifdef PERL_NEW_COPY_ON_WRITE
1691 if (SvIsCOW(sv) && SvLEN(sv))
1692 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1697 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1700 if (type >= SVt_PVMG) {
1701 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1702 HV * const ost = SvOURSTASH(sv);
1704 do_hv_dump(level, file, " OURSTASH", ost);
1707 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1710 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1712 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1713 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1714 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1715 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1719 /* Dump type-specific SV fields */
1723 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1724 if (AvARRAY(sv) != AvALLOC(sv)) {
1725 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1726 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1729 PerlIO_putc(file, '\n');
1730 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1731 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1732 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1734 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1735 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1736 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1737 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1738 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1740 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1741 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1743 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1745 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1750 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1751 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1752 /* Show distribution of HEs in the ARRAY */
1754 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1757 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1758 NV theoret, sum = 0;
1760 PerlIO_printf(file, " (");
1761 Zero(freq, FREQ_MAX + 1, int);
1762 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1765 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1767 if (count > FREQ_MAX)
1773 for (i = 0; i <= max; i++) {
1775 PerlIO_printf(file, "%d%s:%d", i,
1776 (i == FREQ_MAX) ? "+" : "",
1779 PerlIO_printf(file, ", ");
1782 PerlIO_putc(file, ')');
1783 /* The "quality" of a hash is defined as the total number of
1784 comparisons needed to access every element once, relative
1785 to the expected number needed for a random hash.
1787 The total number of comparisons is equal to the sum of
1788 the squares of the number of entries in each bucket.
1789 For a random hash of n keys into k buckets, the expected
1794 for (i = max; i > 0; i--) { /* Precision: count down. */
1795 sum += freq[i] * i * i;
1797 while ((keys = keys >> 1))
1799 theoret = HvUSEDKEYS(sv);
1800 theoret += theoret * (theoret-1)/pow2;
1801 PerlIO_putc(file, '\n');
1802 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1804 PerlIO_putc(file, '\n');
1805 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1806 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1807 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1809 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1810 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1811 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1812 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1813 PerlIO_printf(file, " (LAST = 0x%"UVxf")\n", (UV)HvLASTRAND_get(sv));
1815 PerlIO_putc(file, '\n');
1819 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1820 if (mg && mg->mg_obj) {
1821 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1825 const char * const hvname = HvNAME_get(sv);
1827 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1831 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1832 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1833 if (HvAUX(sv)->xhv_name_count)
1834 Perl_dump_indent(aTHX_
1835 level, file, " NAMECOUNT = %"IVdf"\n",
1836 (IV)HvAUX(sv)->xhv_name_count
1838 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1839 const I32 count = HvAUX(sv)->xhv_name_count;
1841 SV * const names = newSVpvs_flags("", SVs_TEMP);
1842 /* The starting point is the first element if count is
1843 positive and the second element if count is negative. */
1844 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1845 + (count < 0 ? 1 : 0);
1846 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1847 + (count < 0 ? -count : count);
1848 while (hekp < endp) {
1850 sv_catpvs(names, ", \"");
1851 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1852 sv_catpvs(names, "\"");
1854 /* This should never happen. */
1855 sv_catpvs(names, ", (null)");
1859 Perl_dump_indent(aTHX_
1860 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1864 Perl_dump_indent(aTHX_
1865 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1869 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1871 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1875 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1876 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1877 (int)meta->mro_which->length,
1878 meta->mro_which->name,
1879 PTR2UV(meta->mro_which));
1880 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1881 (UV)meta->cache_gen);
1882 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1884 if (meta->mro_linear_all) {
1885 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1886 PTR2UV(meta->mro_linear_all));
1887 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1890 if (meta->mro_linear_current) {
1891 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1892 PTR2UV(meta->mro_linear_current));
1893 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1896 if (meta->mro_nextmethod) {
1897 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1898 PTR2UV(meta->mro_nextmethod));
1899 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1903 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1905 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1910 if (nest < maxnest) {
1911 HV * const hv = MUTABLE_HV(sv);
1916 int count = maxnest - nest;
1917 for (i=0; i <= HvMAX(hv); i++) {
1918 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1925 if (count-- <= 0) goto DONEHV;
1928 keysv = hv_iterkeysv(he);
1929 keypv = SvPV_const(keysv, len);
1932 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1934 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1935 if (HvEITER_get(hv) == he)
1936 PerlIO_printf(file, "[CURRENT] ");
1937 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1938 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1947 if (CvAUTOLOAD(sv)) {
1949 const char *const name = SvPV_const(sv, len);
1950 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1954 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1955 (int) CvPROTOLEN(sv), CvPROTO(sv));
1959 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1960 if (!CvISXSUB(sv)) {
1962 Perl_dump_indent(aTHX_ level, file,
1963 " START = 0x%"UVxf" ===> %"IVdf"\n",
1964 PTR2UV(CvSTART(sv)),
1965 (IV)sequence_num(CvSTART(sv)));
1967 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1968 PTR2UV(CvROOT(sv)));
1969 if (CvROOT(sv) && dumpops) {
1970 do_op_dump(level+1, file, CvROOT(sv));
1973 SV * const constant = cv_const_sv((const CV *)sv);
1975 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1978 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1980 PTR2UV(CvXSUBANY(sv).any_ptr));
1981 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1984 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1985 (IV)CvXSUBANY(sv).any_i32);
1989 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1990 HEK_KEY(CvNAME_HEK((CV *)sv)));
1991 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1992 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1993 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1994 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1995 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1996 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1997 if (nest < maxnest) {
1998 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2001 const CV * const outside = CvOUTSIDE(sv);
2002 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2005 : CvANON(outside) ? "ANON"
2006 : (outside == PL_main_cv) ? "MAIN"
2007 : CvUNIQUE(outside) ? "UNIQUE"
2008 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2010 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2011 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2016 if (type == SVt_PVLV) {
2017 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2018 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2019 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2020 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2021 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2022 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2023 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2026 if (isREGEXP(sv)) goto dumpregexp;
2027 if (!isGV_with_GP(sv))
2029 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2030 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2031 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2032 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2036 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2037 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2038 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2040 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2041 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2043 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2044 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2045 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2046 do_gv_dump (level, file, " EGV", GvEGV(sv));
2049 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2050 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2051 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2052 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2053 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2054 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2055 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2057 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2058 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2059 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2061 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2062 PTR2UV(IoTOP_GV(sv)));
2063 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2064 maxnest, dumpops, pvlim);
2066 /* Source filters hide things that are not GVs in these three, so let's
2067 be careful out there. */
2069 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2070 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2071 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2073 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2074 PTR2UV(IoFMT_GV(sv)));
2075 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2076 maxnest, dumpops, pvlim);
2078 if (IoBOTTOM_NAME(sv))
2079 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2080 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2081 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2083 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2084 PTR2UV(IoBOTTOM_GV(sv)));
2085 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2086 maxnest, dumpops, pvlim);
2088 if (isPRINT(IoTYPE(sv)))
2089 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2091 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2092 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2097 struct regexp * const r = ReANY((REGEXP*)sv);
2098 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
2100 append_flags(d, flags, regexp_flags_names); \
2101 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2102 SvCUR_set(d, SvCUR(d) - 1); \
2103 SvPVX(d)[SvCUR(d)] = '\0'; \
2106 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
2107 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2108 (UV)(r->compflags), SvPVX_const(d));
2110 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
2111 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2112 (UV)(r->extflags), SvPVX_const(d));
2113 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2115 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2117 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2119 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2120 (UV)(r->lastparen));
2121 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2122 (UV)(r->lastcloseparen));
2123 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2125 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2126 (IV)(r->minlenret));
2127 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2129 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2130 (UV)(r->pre_prefix));
2131 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2133 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2134 (IV)(r->suboffset));
2135 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2136 (IV)(r->subcoffset));
2138 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2140 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2142 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2143 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2145 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2146 PTR2UV(r->mother_re));
2147 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2148 PTR2UV(r->paren_names));
2149 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2150 PTR2UV(r->substrs));
2151 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2152 PTR2UV(r->pprivate));
2153 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2155 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2156 PTR2UV(r->qr_anoncv));
2158 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2159 PTR2UV(r->saved_copy));
2168 Perl_sv_dump(pTHX_ SV *sv)
2172 PERL_ARGS_ASSERT_SV_DUMP;
2175 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2177 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2181 Perl_runops_debug(pTHX)
2185 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2189 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2192 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2193 PerlIO_printf(Perl_debug_log,
2194 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2195 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2196 PTR2UV(*PL_watchaddr));
2197 if (DEBUG_s_TEST_) {
2198 if (DEBUG_v_TEST_) {
2199 PerlIO_printf(Perl_debug_log, "\n");
2207 if (DEBUG_t_TEST_) debop(PL_op);
2208 if (DEBUG_P_TEST_) debprof(PL_op);
2211 OP_ENTRY_PROBE(OP_NAME(PL_op));
2212 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2213 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2220 Perl_debop(pTHX_ const OP *o)
2224 PERL_ARGS_ASSERT_DEBOP;
2226 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2229 Perl_deb(aTHX_ "%s", OP_NAME(o));
2230 switch (o->op_type) {
2233 /* With ITHREADS, consts are stored in the pad, and the right pad
2234 * may not be active here, so check.
2235 * Looks like only during compiling the pads are illegal.
2238 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2240 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2245 SV * const sv = newSV(0);
2247 /* FIXME - is this making unwarranted assumptions about the
2248 UTF-8 cleanliness of the dump file handle? */
2251 gv_fullname3(sv, cGVOPo_gv, NULL);
2252 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2253 SvREFCNT_dec_NN(sv);
2256 PerlIO_printf(Perl_debug_log, "(NULL)");
2268 count = o->op_private & OPpPADRANGE_COUNTMASK;
2270 /* print the lexical's name */
2272 CV * const cv = deb_curcv(cxstack_ix);
2274 PAD * comppad = NULL;
2278 PADLIST * const padlist = CvPADLIST(cv);
2279 comppad = *PadlistARRAY(padlist);
2281 PerlIO_printf(Perl_debug_log, "(");
2282 for (i = 0; i < count; i++) {
2284 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2285 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2287 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2290 PerlIO_printf(Perl_debug_log, ",");
2292 PerlIO_printf(Perl_debug_log, ")");
2300 PerlIO_printf(Perl_debug_log, "\n");
2305 S_deb_curcv(pTHX_ const I32 ix)
2308 const PERL_CONTEXT * const cx = &cxstack[ix];
2309 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2310 return cx->blk_sub.cv;
2311 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2312 return cx->blk_eval.cv;
2313 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2318 return deb_curcv(ix - 1);
2322 Perl_watch(pTHX_ char **addr)
2326 PERL_ARGS_ASSERT_WATCH;
2328 PL_watchaddr = addr;
2330 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2331 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2335 S_debprof(pTHX_ const OP *o)
2339 PERL_ARGS_ASSERT_DEBPROF;
2341 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2343 if (!PL_profiledata)
2344 Newxz(PL_profiledata, MAXO, U32);
2345 ++PL_profiledata[o->op_type];
2349 Perl_debprofdump(pTHX)
2353 if (!PL_profiledata)
2355 for (i = 0; i < MAXO; i++) {
2356 if (PL_profiledata[i])
2357 PerlIO_printf(Perl_debug_log,
2358 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2365 * XML variants of most of the above routines
2369 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2373 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2375 PerlIO_printf(file, "\n ");
2376 va_start(args, pat);
2377 xmldump_vindent(level, file, pat, &args);
2383 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2386 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2387 va_start(args, pat);
2388 xmldump_vindent(level, file, pat, &args);
2393 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2395 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2397 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2398 PerlIO_vprintf(file, pat, *args);
2402 Perl_xmldump_all(pTHX)
2404 xmldump_all_perl(FALSE);
2408 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2410 PerlIO_setlinebuf(PL_xmlfp);
2412 op_xmldump(PL_main_root);
2413 /* someday we might call this, when it outputs XML: */
2414 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2415 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2416 PerlIO_close(PL_xmlfp);
2421 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2423 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2424 xmldump_packsubs_perl(stash, FALSE);
2428 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2433 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2435 if (!HvARRAY(stash))
2437 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2438 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2439 GV *gv = MUTABLE_GV(HeVAL(entry));
2441 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2444 xmldump_sub_perl(gv, justperl);
2447 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2448 && (hv = GvHV(gv)) && hv != PL_defstash)
2449 xmldump_packsubs_perl(hv, justperl); /* nested package */
2455 Perl_xmldump_sub(pTHX_ const GV *gv)
2457 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2458 xmldump_sub_perl(gv, FALSE);
2462 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2466 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2468 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2471 sv = sv_newmortal();
2472 gv_fullname3(sv, gv, NULL);
2473 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2474 if (CvXSUB(GvCV(gv)))
2475 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2476 PTR2UV(CvXSUB(GvCV(gv))),
2477 (int)CvXSUBANY(GvCV(gv)).any_i32);
2478 else if (CvROOT(GvCV(gv)))
2479 op_xmldump(CvROOT(GvCV(gv)));
2481 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2485 Perl_xmldump_form(pTHX_ const GV *gv)
2487 SV * const sv = sv_newmortal();
2489 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2491 gv_fullname3(sv, gv, NULL);
2492 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2493 if (CvROOT(GvFORM(gv)))
2494 op_xmldump(CvROOT(GvFORM(gv)));
2496 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2500 Perl_xmldump_eval(pTHX)
2502 op_xmldump(PL_eval_root);
2506 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2508 PERL_ARGS_ASSERT_SV_CATXMLSV;
2509 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2513 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2515 PERL_ARGS_ASSERT_SV_CATXMLPV;
2516 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2520 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2523 const char * const e = pv + len;
2524 const char * const start = pv;
2528 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2531 dsvcur = SvCUR(dsv); /* in case we have to restart */
2536 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2538 SvCUR(dsv) = dsvcur;
2603 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2606 sv_catpvs(dsv, "<");
2609 sv_catpvs(dsv, ">");
2612 sv_catpvs(dsv, "&");
2615 sv_catpvs(dsv, """);
2619 if (c < 32 || c > 127) {
2620 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2623 const char string = (char) c;
2624 sv_catpvn(dsv, &string, 1);
2628 if ((c >= 0xD800 && c <= 0xDB7F) ||
2629 (c >= 0xDC00 && c <= 0xDFFF) ||
2630 (c >= 0xFFF0 && c <= 0xFFFF) ||
2632 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2634 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2647 Perl_sv_xmlpeek(pTHX_ SV *sv)
2649 SV * const t = sv_newmortal();
2653 PERL_ARGS_ASSERT_SV_XMLPEEK;
2659 sv_catpv(t, "VOID=\"\"");
2662 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2663 sv_catpv(t, "WILD=\"\"");
2666 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2667 if (sv == &PL_sv_undef) {
2668 sv_catpv(t, "SV_UNDEF=\"1\"");
2669 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2670 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2674 else if (sv == &PL_sv_no) {
2675 sv_catpv(t, "SV_NO=\"1\"");
2676 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2677 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2678 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2679 SVp_POK|SVp_NOK)) &&
2684 else if (sv == &PL_sv_yes) {
2685 sv_catpv(t, "SV_YES=\"1\"");
2686 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2687 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2688 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2689 SVp_POK|SVp_NOK)) &&
2691 SvPVX(sv) && *SvPVX(sv) == '1' &&
2696 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2697 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2698 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2702 sv_catpv(t, " XXX=\"\" ");
2704 else if (SvREFCNT(sv) == 0) {
2705 sv_catpv(t, " refcnt=\"0\"");
2708 else if (DEBUG_R_TEST_) {
2711 /* is this SV on the tmps stack? */
2712 for (ix=PL_tmps_ix; ix>=0; ix--) {
2713 if (PL_tmps_stack[ix] == sv) {
2718 if (SvREFCNT(sv) > 1)
2719 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2722 sv_catpv(t, " DRT=\"<T>\"");
2726 sv_catpv(t, " ROK=\"\"");
2728 switch (SvTYPE(sv)) {
2730 sv_catpv(t, " FREED=\"1\"");
2734 sv_catpv(t, " UNDEF=\"1\"");
2737 sv_catpv(t, " IV=\"");
2740 sv_catpv(t, " NV=\"");
2743 sv_catpv(t, " PV=\"");
2746 sv_catpv(t, " PVIV=\"");
2749 sv_catpv(t, " PVNV=\"");
2752 sv_catpv(t, " PVMG=\"");
2755 sv_catpv(t, " PVLV=\"");
2758 sv_catpv(t, " AV=\"");
2761 sv_catpv(t, " HV=\"");
2765 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2767 sv_catpv(t, " CV=\"()\"");
2770 sv_catpv(t, " GV=\"");
2773 sv_catpv(t, " BIND=\"");
2776 sv_catpv(t, " REGEXP=\"");
2779 sv_catpv(t, " FM=\"");
2782 sv_catpv(t, " IO=\"");
2791 else if (SvNOKp(sv)) {
2792 STORE_NUMERIC_LOCAL_SET_STANDARD();
2793 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2794 RESTORE_NUMERIC_LOCAL();
2796 else if (SvIOKp(sv)) {
2798 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2800 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2809 return SvPV(t, n_a);
2813 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2815 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2818 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2821 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2824 REGEXP *const r = PM_GETRE(pm);
2825 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2826 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2827 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2829 SvREFCNT_dec_NN(tmpsv);
2830 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2831 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2834 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2835 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2836 SV * const tmpsv = pm_description(pm);
2837 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2838 SvREFCNT_dec_NN(tmpsv);
2842 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2843 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2844 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2845 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2846 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2847 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2850 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2854 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2856 do_pmop_xmldump(0, PL_xmlfp, pm);
2860 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2864 const OPCODE optype = o->op_type;
2866 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2870 seq = sequence_num(o);
2871 Perl_xmldump_indent(aTHX_ level, file,
2872 "<op_%s seq=\"%"UVuf" -> ",
2877 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2878 sequence_num(o->op_next));
2880 PerlIO_printf(file, "DONE\"");
2883 if (optype == OP_NULL)
2885 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2886 if (o->op_targ == OP_NEXTSTATE)
2889 PerlIO_printf(file, " line=\"%"UVuf"\"",
2890 (UV)CopLINE(cCOPo));
2891 if (CopSTASHPV(cCOPo))
2892 PerlIO_printf(file, " package=\"%s\"",
2894 if (CopLABEL(cCOPo))
2895 PerlIO_printf(file, " label=\"%s\"",
2900 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2903 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2906 DUMP_OP_FLAGS(o,1,0,file);
2907 DUMP_OP_PRIVATE(o,1,0,file);
2911 if (o->op_flags & OPf_SPECIAL) {
2917 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2919 if (cSVOPo->op_sv) {
2920 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2921 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2927 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2928 s = SvPV(tmpsv1,len);
2929 sv_catxmlpvn(tmpsv2, s, len, 1);
2930 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2934 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2939 case OP_METHOD_NAMED:
2940 #ifndef USE_ITHREADS
2941 /* with ITHREADS, consts are stored in the pad, and the right pad
2942 * may not be active here, so skip */
2943 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2949 PerlIO_printf(file, ">\n");
2951 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2956 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2957 (UV)CopLINE(cCOPo));
2958 if (CopSTASHPV(cCOPo))
2959 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2961 if (CopLABEL(cCOPo))
2962 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2966 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2967 if (cLOOPo->op_redoop)
2968 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2970 PerlIO_printf(file, "DONE\"");
2971 S_xmldump_attr(aTHX_ level, file, "next=\"");
2972 if (cLOOPo->op_nextop)
2973 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2975 PerlIO_printf(file, "DONE\"");
2976 S_xmldump_attr(aTHX_ level, file, "last=\"");
2977 if (cLOOPo->op_lastop)
2978 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2980 PerlIO_printf(file, "DONE\"");
2988 S_xmldump_attr(aTHX_ level, file, "other=\"");
2989 if (cLOGOPo->op_other)
2990 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2992 PerlIO_printf(file, "DONE\"");
3000 if (o->op_private & OPpREFCOUNTED)
3001 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3007 if (PL_madskills && o->op_madprop) {
3008 char prevkey = '\0';
3009 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3010 const MADPROP* mp = o->op_madprop;
3014 PerlIO_printf(file, ">\n");
3016 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3019 char tmp = mp->mad_key;
3020 sv_setpvs(tmpsv,"\"");
3022 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3023 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3024 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3027 sv_catpv(tmpsv, "\"");
3028 switch (mp->mad_type) {
3030 sv_catpv(tmpsv, "NULL");
3031 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3034 sv_catpv(tmpsv, " val=\"");
3035 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3036 sv_catpv(tmpsv, "\"");
3037 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3040 sv_catpv(tmpsv, " val=\"");
3041 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3042 sv_catpv(tmpsv, "\"");
3043 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3046 if ((OP*)mp->mad_val) {
3047 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3048 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3049 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3053 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3059 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3061 SvREFCNT_dec_NN(tmpsv);
3071 PerlIO_printf(file, ">\n");
3073 do_pmop_xmldump(level, file, cPMOPo);
3079 if (o->op_flags & OPf_KIDS) {
3083 PerlIO_printf(file, ">\n");
3085 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3086 do_op_xmldump(level, file, kid);
3090 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3092 PerlIO_printf(file, " />\n");
3096 Perl_op_xmldump(pTHX_ const OP *o)
3098 PERL_ARGS_ASSERT_OP_XMLDUMP;
3100 do_op_xmldump(0, PL_xmlfp, o);
3106 * c-indentation-style: bsd
3108 * indent-tabs-mode: nil
3111 * ex: set ts=8 sts=4 sw=4 et: