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");
794 OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
796 struct op_private_by_op {
799 const struct flag_to_name *start;
802 const struct op_private_by_op op_private_names[] = {
803 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
804 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
805 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
806 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
807 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
808 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
809 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
810 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
811 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
812 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
813 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
814 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
815 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
816 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
817 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
818 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
819 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
820 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
821 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
822 {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
823 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
827 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
828 const struct op_private_by_op *start = op_private_names;
829 const struct op_private_by_op *const end
830 = op_private_names + C_ARRAY_LENGTH(op_private_names);
832 /* This is a linear search, but no worse than the code that it replaced.
833 It's debugging code - size is more important than speed. */
835 if (optype == start->op_type) {
836 S_append_flags(aTHX_ tmpsv, op_private, start->start,
837 start->start + start->len);
840 } while (++start < end);
844 #define DUMP_OP_FLAGS(o,xml,level,file) \
845 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
846 SV * const tmpsv = newSVpvs(""); \
847 switch (o->op_flags & OPf_WANT) { \
848 case OPf_WANT_VOID: \
849 sv_catpv(tmpsv, ",VOID"); \
851 case OPf_WANT_SCALAR: \
852 sv_catpv(tmpsv, ",SCALAR"); \
854 case OPf_WANT_LIST: \
855 sv_catpv(tmpsv, ",LIST"); \
858 sv_catpv(tmpsv, ",UNKNOWN"); \
861 append_flags(tmpsv, o->op_flags, op_flags_names); \
862 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
863 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
864 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
866 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
867 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
869 PerlIO_printf(file, " flags=\"%s\"", \
870 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
871 SvREFCNT_dec_NN(tmpsv); \
874 #if !defined(PERL_MAD)
875 # define xmldump_attr1(level, file, pat, arg)
877 # define xmldump_attr1(level, file, pat, arg) \
878 S_xmldump_attr(aTHX_ level, file, pat, arg)
881 #define DUMP_OP_PRIVATE(o,xml,level,file) \
882 if (o->op_private) { \
883 U32 optype = o->op_type; \
884 U32 oppriv = o->op_private; \
885 SV * const tmpsv = newSVpvs(""); \
886 if (PL_opargs[optype] & OA_TARGLEX) { \
887 if (oppriv & OPpTARGET_MY) \
888 sv_catpv(tmpsv, ",TARGET_MY"); \
890 else if (optype == OP_ENTERSUB || \
891 optype == OP_RV2SV || \
892 optype == OP_GVSV || \
893 optype == OP_RV2AV || \
894 optype == OP_RV2HV || \
895 optype == OP_RV2GV || \
896 optype == OP_AELEM || \
897 optype == OP_HELEM ) \
899 if (optype == OP_ENTERSUB) { \
900 append_flags(tmpsv, oppriv, op_entersub_names); \
903 switch (oppriv & OPpDEREF) { \
905 sv_catpv(tmpsv, ",SV"); \
908 sv_catpv(tmpsv, ",AV"); \
911 sv_catpv(tmpsv, ",HV"); \
914 if (oppriv & OPpMAYBE_LVSUB) \
915 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
917 if (optype == OP_AELEM || optype == OP_HELEM) { \
918 if (oppriv & OPpLVAL_DEFER) \
919 sv_catpv(tmpsv, ",LVAL_DEFER"); \
921 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
922 if (oppriv & OPpMAYBE_TRUEBOOL) \
923 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
924 if (oppriv & OPpTRUEBOOL) \
925 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
928 if (oppriv & HINT_STRICT_REFS) \
929 sv_catpv(tmpsv, ",STRICT_REFS"); \
930 if (oppriv & OPpOUR_INTRO) \
931 sv_catpv(tmpsv, ",OUR_INTRO"); \
934 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
936 else if (OP_IS_FILETEST(o->op_type)) { \
937 if (oppriv & OPpFT_ACCESS) \
938 sv_catpv(tmpsv, ",FT_ACCESS"); \
939 if (oppriv & OPpFT_STACKED) \
940 sv_catpv(tmpsv, ",FT_STACKED"); \
941 if (oppriv & OPpFT_STACKING) \
942 sv_catpv(tmpsv, ",FT_STACKING"); \
943 if (oppriv & OPpFT_AFTER_t) \
944 sv_catpv(tmpsv, ",AFTER_t"); \
946 else if (o->op_type == OP_AASSIGN) { \
947 if (oppriv & OPpASSIGN_COMMON) \
948 sv_catpvs(tmpsv, ",COMMON"); \
949 if (oppriv & OPpMAYBE_LVSUB) \
950 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
952 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
953 sv_catpv(tmpsv, ",INTRO"); \
954 if (o->op_type == OP_PADRANGE) \
955 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
956 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
957 if (SvCUR(tmpsv)) { \
959 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
961 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
963 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
965 SvREFCNT_dec_NN(tmpsv); \
970 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
974 const OPCODE optype = o->op_type;
976 PERL_ARGS_ASSERT_DO_OP_DUMP;
978 Perl_dump_indent(aTHX_ level, file, "{\n");
980 seq = sequence_num(o);
982 PerlIO_printf(file, "%-4"UVuf, seq);
984 PerlIO_printf(file, "????");
986 "%*sTYPE = %s ===> ",
987 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
990 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
991 sequence_num(o->op_next));
993 PerlIO_printf(file, "NULL\n");
995 if (optype == OP_NULL) {
996 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
997 if (o->op_targ == OP_NEXTSTATE) {
999 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1000 (UV)CopLINE(cCOPo));
1001 if (CopSTASHPV(cCOPo))
1002 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1004 if (CopLABEL(cCOPo))
1005 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1010 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1013 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1016 DUMP_OP_FLAGS(o,0,level,file);
1017 DUMP_OP_PRIVATE(o,0,level,file);
1020 if (PL_madskills && o->op_madprop) {
1021 SV * const tmpsv = newSVpvs("");
1022 MADPROP* mp = o->op_madprop;
1023 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1026 const char tmp = mp->mad_key;
1027 sv_setpvs(tmpsv,"'");
1029 sv_catpvn(tmpsv, &tmp, 1);
1030 sv_catpv(tmpsv, "'=");
1031 switch (mp->mad_type) {
1033 sv_catpv(tmpsv, "NULL");
1034 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1037 sv_catpv(tmpsv, "<");
1038 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1039 sv_catpv(tmpsv, ">");
1040 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1043 if ((OP*)mp->mad_val) {
1044 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1045 do_op_dump(level, file, (OP*)mp->mad_val);
1049 sv_catpv(tmpsv, "(UNK)");
1050 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1056 Perl_dump_indent(aTHX_ level, file, "}\n");
1058 SvREFCNT_dec_NN(tmpsv);
1067 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1069 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1070 if (cSVOPo->op_sv) {
1071 SV * const tmpsv = newSV(0);
1075 /* FIXME - is this making unwarranted assumptions about the
1076 UTF-8 cleanliness of the dump file handle? */
1079 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1080 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1081 SvPV_nolen_const(tmpsv));
1085 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1091 case OP_METHOD_NAMED:
1092 #ifndef USE_ITHREADS
1093 /* with ITHREADS, consts are stored in the pad, and the right pad
1094 * may not be active here, so skip */
1095 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1101 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1102 (UV)CopLINE(cCOPo));
1103 if (CopSTASHPV(cCOPo))
1104 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1106 if (CopLABEL(cCOPo))
1107 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1111 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1112 if (cLOOPo->op_redoop)
1113 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1115 PerlIO_printf(file, "DONE\n");
1116 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1117 if (cLOOPo->op_nextop)
1118 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1120 PerlIO_printf(file, "DONE\n");
1121 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1122 if (cLOOPo->op_lastop)
1123 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1125 PerlIO_printf(file, "DONE\n");
1133 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1134 if (cLOGOPo->op_other)
1135 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1137 PerlIO_printf(file, "DONE\n");
1143 do_pmop_dump(level, file, cPMOPo);
1151 if (o->op_private & OPpREFCOUNTED)
1152 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1157 if (o->op_flags & OPf_KIDS) {
1159 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1160 do_op_dump(level, file, kid);
1162 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1166 Perl_op_dump(pTHX_ const OP *o)
1168 PERL_ARGS_ASSERT_OP_DUMP;
1169 do_op_dump(0, Perl_debug_log, o);
1173 Perl_gv_dump(pTHX_ GV *gv)
1177 PERL_ARGS_ASSERT_GV_DUMP;
1180 PerlIO_printf(Perl_debug_log, "{}\n");
1183 sv = sv_newmortal();
1184 PerlIO_printf(Perl_debug_log, "{\n");
1185 gv_fullname3(sv, gv, NULL);
1186 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1187 if (gv != GvEGV(gv)) {
1188 gv_efullname3(sv, GvEGV(gv), NULL);
1189 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1191 PerlIO_putc(Perl_debug_log, '\n');
1192 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1196 /* map magic types to the symbolic names
1197 * (with the PERL_MAGIC_ prefixed stripped)
1200 static const struct { const char type; const char *name; } magic_names[] = {
1201 #include "mg_names.c"
1202 /* this null string terminates the list */
1207 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1209 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1211 for (; mg; mg = mg->mg_moremagic) {
1212 Perl_dump_indent(aTHX_ level, file,
1213 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1214 if (mg->mg_virtual) {
1215 const MGVTBL * const v = mg->mg_virtual;
1216 if (v >= PL_magic_vtables
1217 && v < PL_magic_vtables + magic_vtable_max) {
1218 const U32 i = v - PL_magic_vtables;
1219 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1222 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1225 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1228 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1232 const char *name = NULL;
1233 for (n = 0; magic_names[n].name; n++) {
1234 if (mg->mg_type == magic_names[n].type) {
1235 name = magic_names[n].name;
1240 Perl_dump_indent(aTHX_ level, file,
1241 " MG_TYPE = PERL_MAGIC_%s\n", name);
1243 Perl_dump_indent(aTHX_ level, file,
1244 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1248 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1249 if (mg->mg_type == PERL_MAGIC_envelem &&
1250 mg->mg_flags & MGf_TAINTEDDIR)
1251 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1252 if (mg->mg_type == PERL_MAGIC_regex_global &&
1253 mg->mg_flags & MGf_MINMATCH)
1254 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1255 if (mg->mg_flags & MGf_REFCOUNTED)
1256 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1257 if (mg->mg_flags & MGf_GSKIP)
1258 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1259 if (mg->mg_flags & MGf_COPY)
1260 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1261 if (mg->mg_flags & MGf_DUP)
1262 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1263 if (mg->mg_flags & MGf_LOCAL)
1264 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1267 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1268 PTR2UV(mg->mg_obj));
1269 if (mg->mg_type == PERL_MAGIC_qr) {
1270 REGEXP* const re = (REGEXP *)mg->mg_obj;
1271 SV * const dsv = sv_newmortal();
1272 const char * const s
1273 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1275 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1276 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1278 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1279 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1282 if (mg->mg_flags & MGf_REFCOUNTED)
1283 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1286 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1288 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1289 if (mg->mg_len >= 0) {
1290 if (mg->mg_type != PERL_MAGIC_utf8) {
1291 SV * const sv = newSVpvs("");
1292 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1293 SvREFCNT_dec_NN(sv);
1296 else if (mg->mg_len == HEf_SVKEY) {
1297 PerlIO_puts(file, " => HEf_SVKEY\n");
1298 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1299 maxnest, dumpops, pvlim); /* MG is already +1 */
1302 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1307 " does not know how to handle this MG_LEN"
1309 PerlIO_putc(file, '\n');
1311 if (mg->mg_type == PERL_MAGIC_utf8) {
1312 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1315 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1316 Perl_dump_indent(aTHX_ level, file,
1317 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1320 (UV)cache[i * 2 + 1]);
1327 Perl_magic_dump(pTHX_ const MAGIC *mg)
1329 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1333 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1337 PERL_ARGS_ASSERT_DO_HV_DUMP;
1339 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1340 if (sv && (hvname = HvNAME_get(sv)))
1342 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1343 name which quite legally could contain insane things like tabs, newlines, nulls or
1344 other scary crap - this should produce sane results - except maybe for unicode package
1345 names - but we will wait for someone to file a bug on that - demerphq */
1346 SV * const tmpsv = newSVpvs("");
1347 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1350 PerlIO_putc(file, '\n');
1354 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1356 PERL_ARGS_ASSERT_DO_GV_DUMP;
1358 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1359 if (sv && GvNAME(sv))
1360 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1362 PerlIO_putc(file, '\n');
1366 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1368 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1370 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1371 if (sv && GvNAME(sv)) {
1373 PerlIO_printf(file, "\t\"");
1374 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1375 PerlIO_printf(file, "%s\" :: \"", hvname);
1376 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1379 PerlIO_putc(file, '\n');
1382 const struct flag_to_name first_sv_flags_names[] = {
1383 {SVs_TEMP, "TEMP,"},
1384 {SVs_OBJECT, "OBJECT,"},
1393 const struct flag_to_name second_sv_flags_names[] = {
1395 {SVf_FAKE, "FAKE,"},
1396 {SVf_READONLY, "READONLY,"},
1397 {SVf_IsCOW, "IsCOW,"},
1398 {SVf_BREAK, "BREAK,"},
1399 {SVf_AMAGIC, "OVERLOAD,"},
1405 const struct flag_to_name cv_flags_names[] = {
1406 {CVf_ANON, "ANON,"},
1407 {CVf_UNIQUE, "UNIQUE,"},
1408 {CVf_CLONE, "CLONE,"},
1409 {CVf_CLONED, "CLONED,"},
1410 {CVf_CONST, "CONST,"},
1411 {CVf_NODEBUG, "NODEBUG,"},
1412 {CVf_LVALUE, "LVALUE,"},
1413 {CVf_METHOD, "METHOD,"},
1414 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1415 {CVf_CVGV_RC, "CVGV_RC,"},
1416 {CVf_DYNFILE, "DYNFILE,"},
1417 {CVf_AUTOLOAD, "AUTOLOAD,"},
1418 {CVf_HASEVAL, "HASEVAL"},
1419 {CVf_SLABBED, "SLABBED,"},
1420 {CVf_ISXSUB, "ISXSUB,"}
1423 const struct flag_to_name hv_flags_names[] = {
1424 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1425 {SVphv_LAZYDEL, "LAZYDEL,"},
1426 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1427 {SVphv_CLONEABLE, "CLONEABLE,"}
1430 const struct flag_to_name gp_flags_names[] = {
1431 {GVf_INTRO, "INTRO,"},
1432 {GVf_MULTI, "MULTI,"},
1433 {GVf_ASSUMECV, "ASSUMECV,"},
1434 {GVf_IN_PAD, "IN_PAD,"}
1437 const struct flag_to_name gp_flags_imported_names[] = {
1438 {GVf_IMPORTED_SV, " SV"},
1439 {GVf_IMPORTED_AV, " AV"},
1440 {GVf_IMPORTED_HV, " HV"},
1441 {GVf_IMPORTED_CV, " CV"},
1444 const struct flag_to_name regexp_flags_names[] = {
1445 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1446 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1447 {RXf_PMf_FOLD, "PMf_FOLD,"},
1448 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1449 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1450 {RXf_ANCH_BOL, "ANCH_BOL,"},
1451 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1452 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1453 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1454 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1455 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1456 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1457 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1458 {RXf_CANY_SEEN, "CANY_SEEN,"},
1459 {RXf_NOSCAN, "NOSCAN,"},
1460 {RXf_CHECK_ALL, "CHECK_ALL,"},
1461 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1462 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1463 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1464 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1465 {RXf_SPLIT, "SPLIT,"},
1466 {RXf_COPY_DONE, "COPY_DONE,"},
1467 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1468 {RXf_TAINTED, "TAINTED,"},
1469 {RXf_START_ONLY, "START_ONLY,"},
1470 {RXf_SKIPWHITE, "SKIPWHITE,"},
1471 {RXf_WHITE, "WHITE,"},
1472 {RXf_NULL, "NULL,"},
1476 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1484 PERL_ARGS_ASSERT_DO_SV_DUMP;
1487 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1491 flags = SvFLAGS(sv);
1494 /* process general SV flags */
1496 d = Perl_newSVpvf(aTHX_
1497 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1498 PTR2UV(SvANY(sv)), PTR2UV(sv),
1499 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1500 (int)(PL_dumpindent*level), "");
1502 if (!((flags & SVpad_NAME) == SVpad_NAME
1503 && (type == SVt_PVMG || type == SVt_PVNV))) {
1504 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1505 sv_catpv(d, "PADSTALE,");
1507 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1508 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1509 sv_catpv(d, "PADTMP,");
1510 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1512 append_flags(d, flags, first_sv_flags_names);
1513 if (flags & SVf_ROK) {
1514 sv_catpv(d, "ROK,");
1515 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1517 append_flags(d, flags, second_sv_flags_names);
1518 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1519 if (SvPCS_IMPORTED(sv))
1520 sv_catpv(d, "PCS_IMPORTED,");
1522 sv_catpv(d, "SCREAM,");
1525 /* process type-specific SV flags */
1530 append_flags(d, CvFLAGS(sv), cv_flags_names);
1533 append_flags(d, flags, hv_flags_names);
1537 if (isGV_with_GP(sv)) {
1538 append_flags(d, GvFLAGS(sv), gp_flags_names);
1540 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1541 sv_catpv(d, "IMPORT");
1542 if (GvIMPORTED(sv) == GVf_IMPORTED)
1543 sv_catpv(d, "ALL,");
1546 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1553 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1554 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1557 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1558 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1559 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1560 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1563 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1568 /* SVphv_SHAREKEYS is also 0x20000000 */
1569 if ((type != SVt_PVHV) && SvUTF8(sv))
1570 sv_catpv(d, "UTF8");
1572 if (*(SvEND(d) - 1) == ',') {
1573 SvCUR_set(d, SvCUR(d) - 1);
1574 SvPVX(d)[SvCUR(d)] = '\0';
1579 /* dump initial SV details */
1581 #ifdef DEBUG_LEAKING_SCALARS
1582 Perl_dump_indent(aTHX_ level, file,
1583 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1584 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1586 sv->sv_debug_inpad ? "for" : "by",
1587 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1588 PTR2UV(sv->sv_debug_parent),
1592 Perl_dump_indent(aTHX_ level, file, "SV = ");
1596 if (type < SVt_LAST) {
1597 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1599 if (type == SVt_NULL) {
1604 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1609 /* Dump general SV fields */
1611 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1612 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1613 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1614 || (type == SVt_IV && !SvROK(sv))) {
1616 #ifdef PERL_OLD_COPY_ON_WRITE
1620 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1622 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1623 #ifdef PERL_OLD_COPY_ON_WRITE
1624 if (SvIsCOW_shared_hash(sv))
1625 PerlIO_printf(file, " (HASH)");
1626 else if (SvIsCOW_normal(sv))
1627 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1629 PerlIO_putc(file, '\n');
1632 if ((type == SVt_PVNV || type == SVt_PVMG)
1633 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1634 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1635 (UV) COP_SEQ_RANGE_LOW(sv));
1636 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1637 (UV) COP_SEQ_RANGE_HIGH(sv));
1638 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1639 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1640 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1641 || type == SVt_NV) {
1642 STORE_NUMERIC_LOCAL_SET_STANDARD();
1643 /* %Vg doesn't work? --jhi */
1644 #ifdef USE_LONG_DOUBLE
1645 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1647 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1649 RESTORE_NUMERIC_LOCAL();
1653 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1655 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1658 if (type < SVt_PV) {
1663 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1664 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1665 const bool re = isREGEXP(sv);
1666 const char * const ptr =
1667 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1671 SvOOK_offset(sv, delta);
1672 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1677 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
1679 PerlIO_printf(file, "( %s . ) ",
1680 pv_display(d, ptr - delta, delta, 0,
1683 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1686 if (SvUTF8(sv)) /* the 6? \x{....} */
1687 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1688 PerlIO_printf(file, "\n");
1689 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1691 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1693 #ifdef PERL_NEW_COPY_ON_WRITE
1694 if (SvIsCOW(sv) && SvLEN(sv))
1695 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1700 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1703 if (type >= SVt_PVMG) {
1704 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1705 HV * const ost = SvOURSTASH(sv);
1707 do_hv_dump(level, file, " OURSTASH", ost);
1710 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1713 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1715 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1716 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1720 /* Dump type-specific SV fields */
1724 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1725 if (AvARRAY(sv) != AvALLOC(sv)) {
1726 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1727 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1730 PerlIO_putc(file, '\n');
1731 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1732 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1733 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1735 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1736 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1737 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1738 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1739 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1741 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1742 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1744 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1746 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1751 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1752 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1753 /* Show distribution of HEs in the ARRAY */
1755 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1758 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1759 NV theoret, sum = 0;
1761 PerlIO_printf(file, " (");
1762 Zero(freq, FREQ_MAX + 1, int);
1763 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1766 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1768 if (count > FREQ_MAX)
1774 for (i = 0; i <= max; i++) {
1776 PerlIO_printf(file, "%d%s:%d", i,
1777 (i == FREQ_MAX) ? "+" : "",
1780 PerlIO_printf(file, ", ");
1783 PerlIO_putc(file, ')');
1784 /* The "quality" of a hash is defined as the total number of
1785 comparisons needed to access every element once, relative
1786 to the expected number needed for a random hash.
1788 The total number of comparisons is equal to the sum of
1789 the squares of the number of entries in each bucket.
1790 For a random hash of n keys into k buckets, the expected
1795 for (i = max; i > 0; i--) { /* Precision: count down. */
1796 sum += freq[i] * i * i;
1798 while ((keys = keys >> 1))
1800 theoret = HvUSEDKEYS(sv);
1801 theoret += theoret * (theoret-1)/pow2;
1802 PerlIO_putc(file, '\n');
1803 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1805 PerlIO_putc(file, '\n');
1806 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1809 HE **ents = HvARRAY(sv);
1812 HE *const *const last = ents + HvMAX(sv);
1813 count = last + 1 - ents;
1818 } while (++ents <= last);
1822 struct xpvhv_aux *const aux = HvAUX(sv);
1823 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1824 " (cached = %"UVuf")\n",
1825 (UV)count, (UV)aux->xhv_fill_lazy);
1827 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1831 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1833 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1834 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1835 #ifdef PERL_HASH_RANDOMIZE_KEYS
1836 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1837 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1838 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1841 PerlIO_putc(file, '\n');
1844 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1845 if (mg && mg->mg_obj) {
1846 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1850 const char * const hvname = HvNAME_get(sv);
1852 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1856 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1857 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1858 if (HvAUX(sv)->xhv_name_count)
1859 Perl_dump_indent(aTHX_
1860 level, file, " NAMECOUNT = %"IVdf"\n",
1861 (IV)HvAUX(sv)->xhv_name_count
1863 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1864 const I32 count = HvAUX(sv)->xhv_name_count;
1866 SV * const names = newSVpvs_flags("", SVs_TEMP);
1867 /* The starting point is the first element if count is
1868 positive and the second element if count is negative. */
1869 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1870 + (count < 0 ? 1 : 0);
1871 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1872 + (count < 0 ? -count : count);
1873 while (hekp < endp) {
1875 sv_catpvs(names, ", \"");
1876 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1877 sv_catpvs(names, "\"");
1879 /* This should never happen. */
1880 sv_catpvs(names, ", (null)");
1884 Perl_dump_indent(aTHX_
1885 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1889 Perl_dump_indent(aTHX_
1890 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1894 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1896 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1900 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1901 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1902 (int)meta->mro_which->length,
1903 meta->mro_which->name,
1904 PTR2UV(meta->mro_which));
1905 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1906 (UV)meta->cache_gen);
1907 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1909 if (meta->mro_linear_all) {
1910 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1911 PTR2UV(meta->mro_linear_all));
1912 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1915 if (meta->mro_linear_current) {
1916 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1917 PTR2UV(meta->mro_linear_current));
1918 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1921 if (meta->mro_nextmethod) {
1922 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1923 PTR2UV(meta->mro_nextmethod));
1924 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1928 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1930 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1935 if (nest < maxnest) {
1936 HV * const hv = MUTABLE_HV(sv);
1941 int count = maxnest - nest;
1942 for (i=0; i <= HvMAX(hv); i++) {
1943 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1950 if (count-- <= 0) goto DONEHV;
1953 keysv = hv_iterkeysv(he);
1954 keypv = SvPV_const(keysv, len);
1957 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1959 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1960 if (HvEITER_get(hv) == he)
1961 PerlIO_printf(file, "[CURRENT] ");
1962 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1963 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1972 if (CvAUTOLOAD(sv)) {
1974 const char *const name = SvPV_const(sv, len);
1975 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1979 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1980 (int) CvPROTOLEN(sv), CvPROTO(sv));
1984 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1985 if (!CvISXSUB(sv)) {
1987 Perl_dump_indent(aTHX_ level, file,
1988 " START = 0x%"UVxf" ===> %"IVdf"\n",
1989 PTR2UV(CvSTART(sv)),
1990 (IV)sequence_num(CvSTART(sv)));
1992 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1993 PTR2UV(CvROOT(sv)));
1994 if (CvROOT(sv) && dumpops) {
1995 do_op_dump(level+1, file, CvROOT(sv));
1998 SV * const constant = cv_const_sv((const CV *)sv);
2000 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2003 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2005 PTR2UV(CvXSUBANY(sv).any_ptr));
2006 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2009 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2010 (IV)CvXSUBANY(sv).any_i32);
2014 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2015 HEK_KEY(CvNAME_HEK((CV *)sv)));
2016 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2017 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2018 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2019 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2020 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2021 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2022 if (nest < maxnest) {
2023 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2026 const CV * const outside = CvOUTSIDE(sv);
2027 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2030 : CvANON(outside) ? "ANON"
2031 : (outside == PL_main_cv) ? "MAIN"
2032 : CvUNIQUE(outside) ? "UNIQUE"
2033 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2035 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2036 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2041 if (type == SVt_PVLV) {
2042 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2043 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2044 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2045 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2046 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2047 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2048 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2051 if (isREGEXP(sv)) goto dumpregexp;
2052 if (!isGV_with_GP(sv))
2054 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2055 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2056 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2057 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2060 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2061 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2062 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2063 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2064 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2065 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2066 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2067 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2068 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2069 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2070 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2071 do_gv_dump (level, file, " EGV", GvEGV(sv));
2074 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2075 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2076 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2077 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2078 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2079 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2080 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2082 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2083 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2084 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2086 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2087 PTR2UV(IoTOP_GV(sv)));
2088 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2089 maxnest, dumpops, pvlim);
2091 /* Source filters hide things that are not GVs in these three, so let's
2092 be careful out there. */
2094 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2095 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2096 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2098 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2099 PTR2UV(IoFMT_GV(sv)));
2100 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2101 maxnest, dumpops, pvlim);
2103 if (IoBOTTOM_NAME(sv))
2104 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2105 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2106 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2108 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2109 PTR2UV(IoBOTTOM_GV(sv)));
2110 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2111 maxnest, dumpops, pvlim);
2113 if (isPRINT(IoTYPE(sv)))
2114 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2116 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2117 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2122 struct regexp * const r = ReANY((REGEXP*)sv);
2123 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
2125 append_flags(d, flags, regexp_flags_names); \
2126 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2127 SvCUR_set(d, SvCUR(d) - 1); \
2128 SvPVX(d)[SvCUR(d)] = '\0'; \
2131 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
2132 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2133 (UV)(r->compflags), SvPVX_const(d));
2135 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
2136 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2137 (UV)(r->extflags), SvPVX_const(d));
2138 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2140 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2142 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2144 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2145 (UV)(r->lastparen));
2146 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2147 (UV)(r->lastcloseparen));
2148 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2150 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2151 (IV)(r->minlenret));
2152 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2154 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2155 (UV)(r->pre_prefix));
2156 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2158 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2159 (IV)(r->suboffset));
2160 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2161 (IV)(r->subcoffset));
2163 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2165 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2167 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2168 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2170 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2171 PTR2UV(r->mother_re));
2172 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2173 PTR2UV(r->paren_names));
2174 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2175 PTR2UV(r->substrs));
2176 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2177 PTR2UV(r->pprivate));
2178 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2180 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2181 PTR2UV(r->qr_anoncv));
2183 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2184 PTR2UV(r->saved_copy));
2193 Perl_sv_dump(pTHX_ SV *sv)
2197 PERL_ARGS_ASSERT_SV_DUMP;
2200 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2202 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2206 Perl_runops_debug(pTHX)
2210 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2214 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2216 #ifdef PERL_TRACE_OPS
2217 ++PL_op_exec_cnt[PL_op->op_type];
2220 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2221 PerlIO_printf(Perl_debug_log,
2222 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2223 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2224 PTR2UV(*PL_watchaddr));
2225 if (DEBUG_s_TEST_) {
2226 if (DEBUG_v_TEST_) {
2227 PerlIO_printf(Perl_debug_log, "\n");
2235 if (DEBUG_t_TEST_) debop(PL_op);
2236 if (DEBUG_P_TEST_) debprof(PL_op);
2239 OP_ENTRY_PROBE(OP_NAME(PL_op));
2240 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2241 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2249 Perl_debop(pTHX_ const OP *o)
2253 PERL_ARGS_ASSERT_DEBOP;
2255 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2258 Perl_deb(aTHX_ "%s", OP_NAME(o));
2259 switch (o->op_type) {
2262 /* With ITHREADS, consts are stored in the pad, and the right pad
2263 * may not be active here, so check.
2264 * Looks like only during compiling the pads are illegal.
2267 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2269 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2274 SV * const sv = newSV(0);
2276 /* FIXME - is this making unwarranted assumptions about the
2277 UTF-8 cleanliness of the dump file handle? */
2280 gv_fullname3(sv, cGVOPo_gv, NULL);
2281 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2282 SvREFCNT_dec_NN(sv);
2285 PerlIO_printf(Perl_debug_log, "(NULL)");
2297 count = o->op_private & OPpPADRANGE_COUNTMASK;
2299 /* print the lexical's name */
2301 CV * const cv = deb_curcv(cxstack_ix);
2303 PAD * comppad = NULL;
2307 PADLIST * const padlist = CvPADLIST(cv);
2308 comppad = *PadlistARRAY(padlist);
2310 PerlIO_printf(Perl_debug_log, "(");
2311 for (i = 0; i < count; i++) {
2313 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2314 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2316 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2319 PerlIO_printf(Perl_debug_log, ",");
2321 PerlIO_printf(Perl_debug_log, ")");
2329 PerlIO_printf(Perl_debug_log, "\n");
2334 S_deb_curcv(pTHX_ const I32 ix)
2337 const PERL_CONTEXT * const cx = &cxstack[ix];
2338 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2339 return cx->blk_sub.cv;
2340 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2341 return cx->blk_eval.cv;
2342 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2347 return deb_curcv(ix - 1);
2351 Perl_watch(pTHX_ char **addr)
2355 PERL_ARGS_ASSERT_WATCH;
2357 PL_watchaddr = addr;
2359 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2360 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2364 S_debprof(pTHX_ const OP *o)
2368 PERL_ARGS_ASSERT_DEBPROF;
2370 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2372 if (!PL_profiledata)
2373 Newxz(PL_profiledata, MAXO, U32);
2374 ++PL_profiledata[o->op_type];
2378 Perl_debprofdump(pTHX)
2382 if (!PL_profiledata)
2384 for (i = 0; i < MAXO; i++) {
2385 if (PL_profiledata[i])
2386 PerlIO_printf(Perl_debug_log,
2387 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2394 * XML variants of most of the above routines
2398 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2402 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2404 PerlIO_printf(file, "\n ");
2405 va_start(args, pat);
2406 xmldump_vindent(level, file, pat, &args);
2412 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2415 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2416 va_start(args, pat);
2417 xmldump_vindent(level, file, pat, &args);
2422 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2424 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2426 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2427 PerlIO_vprintf(file, pat, *args);
2431 Perl_xmldump_all(pTHX)
2433 xmldump_all_perl(FALSE);
2437 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2439 PerlIO_setlinebuf(PL_xmlfp);
2441 op_xmldump(PL_main_root);
2442 /* someday we might call this, when it outputs XML: */
2443 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2444 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2445 PerlIO_close(PL_xmlfp);
2450 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2452 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2453 xmldump_packsubs_perl(stash, FALSE);
2457 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2462 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2464 if (!HvARRAY(stash))
2466 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2467 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2468 GV *gv = MUTABLE_GV(HeVAL(entry));
2470 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2473 xmldump_sub_perl(gv, justperl);
2476 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2477 && (hv = GvHV(gv)) && hv != PL_defstash)
2478 xmldump_packsubs_perl(hv, justperl); /* nested package */
2484 Perl_xmldump_sub(pTHX_ const GV *gv)
2486 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2487 xmldump_sub_perl(gv, FALSE);
2491 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2495 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2497 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2500 sv = sv_newmortal();
2501 gv_fullname3(sv, gv, NULL);
2502 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2503 if (CvXSUB(GvCV(gv)))
2504 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2505 PTR2UV(CvXSUB(GvCV(gv))),
2506 (int)CvXSUBANY(GvCV(gv)).any_i32);
2507 else if (CvROOT(GvCV(gv)))
2508 op_xmldump(CvROOT(GvCV(gv)));
2510 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2514 Perl_xmldump_form(pTHX_ const GV *gv)
2516 SV * const sv = sv_newmortal();
2518 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2520 gv_fullname3(sv, gv, NULL);
2521 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2522 if (CvROOT(GvFORM(gv)))
2523 op_xmldump(CvROOT(GvFORM(gv)));
2525 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2529 Perl_xmldump_eval(pTHX)
2531 op_xmldump(PL_eval_root);
2535 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2537 PERL_ARGS_ASSERT_SV_CATXMLSV;
2538 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2542 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2544 PERL_ARGS_ASSERT_SV_CATXMLPV;
2545 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2549 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2552 const char * const e = pv + len;
2553 const char * const start = pv;
2557 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2560 dsvcur = SvCUR(dsv); /* in case we have to restart */
2565 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2567 SvCUR(dsv) = dsvcur;
2632 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2635 sv_catpvs(dsv, "<");
2638 sv_catpvs(dsv, ">");
2641 sv_catpvs(dsv, "&");
2644 sv_catpvs(dsv, """);
2648 if (c < 32 || c > 127) {
2649 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2652 const char string = (char) c;
2653 sv_catpvn(dsv, &string, 1);
2657 if ((c >= 0xD800 && c <= 0xDB7F) ||
2658 (c >= 0xDC00 && c <= 0xDFFF) ||
2659 (c >= 0xFFF0 && c <= 0xFFFF) ||
2661 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2663 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2676 Perl_sv_xmlpeek(pTHX_ SV *sv)
2678 SV * const t = sv_newmortal();
2682 PERL_ARGS_ASSERT_SV_XMLPEEK;
2688 sv_catpv(t, "VOID=\"\"");
2691 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2692 sv_catpv(t, "WILD=\"\"");
2695 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2696 if (sv == &PL_sv_undef) {
2697 sv_catpv(t, "SV_UNDEF=\"1\"");
2698 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2699 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2703 else if (sv == &PL_sv_no) {
2704 sv_catpv(t, "SV_NO=\"1\"");
2705 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2706 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2707 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2708 SVp_POK|SVp_NOK)) &&
2713 else if (sv == &PL_sv_yes) {
2714 sv_catpv(t, "SV_YES=\"1\"");
2715 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2716 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2717 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2718 SVp_POK|SVp_NOK)) &&
2720 SvPVX(sv) && *SvPVX(sv) == '1' &&
2725 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2726 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2727 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2731 sv_catpv(t, " XXX=\"\" ");
2733 else if (SvREFCNT(sv) == 0) {
2734 sv_catpv(t, " refcnt=\"0\"");
2737 else if (DEBUG_R_TEST_) {
2740 /* is this SV on the tmps stack? */
2741 for (ix=PL_tmps_ix; ix>=0; ix--) {
2742 if (PL_tmps_stack[ix] == sv) {
2747 if (SvREFCNT(sv) > 1)
2748 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2751 sv_catpv(t, " DRT=\"<T>\"");
2755 sv_catpv(t, " ROK=\"\"");
2757 switch (SvTYPE(sv)) {
2759 sv_catpv(t, " FREED=\"1\"");
2763 sv_catpv(t, " UNDEF=\"1\"");
2766 sv_catpv(t, " IV=\"");
2769 sv_catpv(t, " NV=\"");
2772 sv_catpv(t, " PV=\"");
2775 sv_catpv(t, " PVIV=\"");
2778 sv_catpv(t, " PVNV=\"");
2781 sv_catpv(t, " PVMG=\"");
2784 sv_catpv(t, " PVLV=\"");
2787 sv_catpv(t, " AV=\"");
2790 sv_catpv(t, " HV=\"");
2794 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2796 sv_catpv(t, " CV=\"()\"");
2799 sv_catpv(t, " GV=\"");
2802 sv_catpv(t, " DUMMY=\"");
2805 sv_catpv(t, " REGEXP=\"");
2808 sv_catpv(t, " FM=\"");
2811 sv_catpv(t, " IO=\"");
2820 else if (SvNOKp(sv)) {
2821 STORE_NUMERIC_LOCAL_SET_STANDARD();
2822 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2823 RESTORE_NUMERIC_LOCAL();
2825 else if (SvIOKp(sv)) {
2827 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2829 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2838 return SvPV(t, n_a);
2842 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2844 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2847 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2850 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2853 REGEXP *const r = PM_GETRE(pm);
2854 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2855 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2856 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2858 SvREFCNT_dec_NN(tmpsv);
2859 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2860 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2863 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2864 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2865 SV * const tmpsv = pm_description(pm);
2866 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2867 SvREFCNT_dec_NN(tmpsv);
2871 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2872 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2873 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2874 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2875 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2876 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2879 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2883 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2885 do_pmop_xmldump(0, PL_xmlfp, pm);
2889 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2893 const OPCODE optype = o->op_type;
2895 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2899 seq = sequence_num(o);
2900 Perl_xmldump_indent(aTHX_ level, file,
2901 "<op_%s seq=\"%"UVuf" -> ",
2906 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2907 sequence_num(o->op_next));
2909 PerlIO_printf(file, "DONE\"");
2912 if (optype == OP_NULL)
2914 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2915 if (o->op_targ == OP_NEXTSTATE)
2918 PerlIO_printf(file, " line=\"%"UVuf"\"",
2919 (UV)CopLINE(cCOPo));
2920 if (CopSTASHPV(cCOPo))
2921 PerlIO_printf(file, " package=\"%s\"",
2923 if (CopLABEL(cCOPo))
2924 PerlIO_printf(file, " label=\"%s\"",
2929 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2932 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2935 DUMP_OP_FLAGS(o,1,0,file);
2936 DUMP_OP_PRIVATE(o,1,0,file);
2940 if (o->op_flags & OPf_SPECIAL) {
2946 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2948 if (cSVOPo->op_sv) {
2949 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2950 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2956 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2957 s = SvPV(tmpsv1,len);
2958 sv_catxmlpvn(tmpsv2, s, len, 1);
2959 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2963 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2968 case OP_METHOD_NAMED:
2969 #ifndef USE_ITHREADS
2970 /* with ITHREADS, consts are stored in the pad, and the right pad
2971 * may not be active here, so skip */
2972 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2978 PerlIO_printf(file, ">\n");
2980 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2985 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2986 (UV)CopLINE(cCOPo));
2987 if (CopSTASHPV(cCOPo))
2988 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2990 if (CopLABEL(cCOPo))
2991 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2995 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2996 if (cLOOPo->op_redoop)
2997 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2999 PerlIO_printf(file, "DONE\"");
3000 S_xmldump_attr(aTHX_ level, file, "next=\"");
3001 if (cLOOPo->op_nextop)
3002 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3004 PerlIO_printf(file, "DONE\"");
3005 S_xmldump_attr(aTHX_ level, file, "last=\"");
3006 if (cLOOPo->op_lastop)
3007 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3009 PerlIO_printf(file, "DONE\"");
3017 S_xmldump_attr(aTHX_ level, file, "other=\"");
3018 if (cLOGOPo->op_other)
3019 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3021 PerlIO_printf(file, "DONE\"");
3029 if (o->op_private & OPpREFCOUNTED)
3030 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3036 if (PL_madskills && o->op_madprop) {
3037 char prevkey = '\0';
3038 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3039 const MADPROP* mp = o->op_madprop;
3043 PerlIO_printf(file, ">\n");
3045 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3048 char tmp = mp->mad_key;
3049 sv_setpvs(tmpsv,"\"");
3051 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3052 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3053 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3056 sv_catpv(tmpsv, "\"");
3057 switch (mp->mad_type) {
3059 sv_catpv(tmpsv, "NULL");
3060 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3063 sv_catpv(tmpsv, " val=\"");
3064 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3065 sv_catpv(tmpsv, "\"");
3066 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3069 sv_catpv(tmpsv, " val=\"");
3070 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3071 sv_catpv(tmpsv, "\"");
3072 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3075 if ((OP*)mp->mad_val) {
3076 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3077 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3078 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3082 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3088 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3090 SvREFCNT_dec_NN(tmpsv);
3100 PerlIO_printf(file, ">\n");
3102 do_pmop_xmldump(level, file, cPMOPo);
3108 if (o->op_flags & OPf_KIDS) {
3112 PerlIO_printf(file, ">\n");
3114 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3115 do_op_xmldump(level, file, kid);
3119 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3121 PerlIO_printf(file, " />\n");
3125 Perl_op_xmldump(pTHX_ const OP *o)
3127 PERL_ARGS_ASSERT_OP_XMLDUMP;
3129 do_op_xmldump(0, PL_xmlfp, o);
3135 * c-indentation-style: bsd
3137 * indent-tabs-mode: nil
3140 * ex: set ts=8 sts=4 sw=4 et: