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
32 static const char* const svtypenames[SVt_LAST] = {
52 static const char* const svshorttypenames[SVt_LAST] = {
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78 const struct flag_to_name *const end)
81 if (flags & start->flag)
82 sv_catpv(sv, start->name);
83 } while (++start < end);
86 #define append_flags(sv, f, flags) \
87 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
92 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
95 PERL_ARGS_ASSERT_DUMP_INDENT;
97 dump_vindent(level, file, pat, &args);
102 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
105 PERL_ARGS_ASSERT_DUMP_VINDENT;
106 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
107 PerlIO_vprintf(file, pat, *args);
113 dump_all_perl(FALSE);
117 Perl_dump_all_perl(pTHX_ bool justperl)
121 PerlIO_setlinebuf(Perl_debug_log);
123 op_dump(PL_main_root);
124 dump_packsubs_perl(PL_defstash, justperl);
128 Perl_dump_packsubs(pTHX_ const HV *stash)
130 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
131 dump_packsubs_perl(stash, FALSE);
135 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
140 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
144 for (i = 0; i <= (I32) HvMAX(stash); i++) {
146 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
147 const GV * const gv = (const GV *)HeVAL(entry);
148 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
151 dump_sub_perl(gv, justperl);
154 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
155 const HV * const hv = GvHV(gv);
156 if (hv && (hv != PL_defstash))
157 dump_packsubs_perl(hv, justperl); /* nested package */
164 Perl_dump_sub(pTHX_ const GV *gv)
166 PERL_ARGS_ASSERT_DUMP_SUB;
167 dump_sub_perl(gv, FALSE);
171 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
175 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
177 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
181 gv_fullname3(sv, gv, NULL);
182 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
183 if (CvISXSUB(GvCV(gv)))
184 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
185 PTR2UV(CvXSUB(GvCV(gv))),
186 (int)CvXSUBANY(GvCV(gv)).any_i32);
187 else if (CvROOT(GvCV(gv)))
188 op_dump(CvROOT(GvCV(gv)));
190 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
194 Perl_dump_form(pTHX_ const GV *gv)
196 SV * const sv = sv_newmortal();
198 PERL_ARGS_ASSERT_DUMP_FORM;
200 gv_fullname3(sv, gv, NULL);
201 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
202 if (CvROOT(GvFORM(gv)))
203 op_dump(CvROOT(GvFORM(gv)));
205 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
212 op_dump(PL_eval_root);
217 =for apidoc pv_escape
219 Escapes at most the first "count" chars of pv and puts the results into
220 dsv such that the size of the escaped string will not exceed "max" chars
221 and will not contain any incomplete escape sequences.
223 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
224 will also be escaped.
226 Normally the SV will be cleared before the escaped string is prepared,
227 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
229 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
230 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
231 using C<is_utf8_string()> to determine if it is Unicode.
233 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
234 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
235 chars above 127 will be escaped using this style; otherwise, only chars above
236 255 will be so escaped; other non printable chars will use octal or
237 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
238 then all chars below 255 will be treated as printable and
239 will be output as literals.
241 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
242 string will be escaped, regardless of max. If the output is to be in hex,
243 then it will be returned as a plain hex
244 sequence. Thus the output will either be a single char,
245 an octal escape sequence, a special escape like C<\n> or a hex value.
247 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
248 not a '\\'. This is because regexes very often contain backslashed
249 sequences, whereas '%' is not a particularly common character in patterns.
251 Returns a pointer to the escaped text as held by dsv.
255 #define PV_ESCAPE_OCTBUFSIZE 32
258 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
259 const STRLEN count, const STRLEN max,
260 STRLEN * const escaped, const U32 flags )
262 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
263 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
264 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
265 STRLEN wrote = 0; /* chars written so far */
266 STRLEN chsize = 0; /* size of data to be written */
267 STRLEN readsize = 1; /* size of data just read */
268 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
269 const char *pv = str;
270 const char * const end = pv + count; /* end of string */
273 PERL_ARGS_ASSERT_PV_ESCAPE;
275 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
276 /* This won't alter the UTF-8 flag */
280 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
283 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
284 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
285 const U8 c = (U8)u & 0xFF;
288 || (flags & PERL_PV_ESCAPE_ALL)
289 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
291 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
292 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
295 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
296 "%cx{%"UVxf"}", esc, u);
297 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
300 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
304 case '\\' : /* fallthrough */
305 case '%' : if ( c == esc ) {
311 case '\v' : octbuf[1] = 'v'; break;
312 case '\t' : octbuf[1] = 't'; break;
313 case '\r' : octbuf[1] = 'r'; break;
314 case '\n' : octbuf[1] = 'n'; break;
315 case '\f' : octbuf[1] = 'f'; break;
323 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
324 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
327 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
334 if ( max && (wrote + chsize > max) ) {
336 } else if (chsize > 1) {
337 sv_catpvn(dsv, octbuf, chsize);
340 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
341 128-255 can be appended raw to the dsv. If dsv happens to be
342 UTF-8 then we need catpvf to upgrade them for us.
343 Or add a new API call sv_catpvc(). Think about that name, and
344 how to keep it clear that it's unlike the s of catpvs, which is
345 really an array octets, not a string. */
346 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
349 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
357 =for apidoc pv_pretty
359 Converts a string into something presentable, handling escaping via
360 pv_escape() and supporting quoting and ellipses.
362 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
363 double quoted with any double quotes in the string escaped. Otherwise
364 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
367 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
368 string were output then an ellipsis C<...> will be appended to the
369 string. Note that this happens AFTER it has been quoted.
371 If start_color is non-null then it will be inserted after the opening
372 quote (if there is one) but before the escaped text. If end_color
373 is non-null then it will be inserted after the escaped text but before
374 any quotes or ellipses.
376 Returns a pointer to the prettified text as held by dsv.
382 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
383 const STRLEN max, char const * const start_color, char const * const end_color,
386 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
389 PERL_ARGS_ASSERT_PV_PRETTY;
391 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
392 /* This won't alter the UTF-8 flag */
397 sv_catpvs(dsv, "\"");
398 else if ( flags & PERL_PV_PRETTY_LTGT )
401 if ( start_color != NULL )
402 sv_catpv(dsv, start_color);
404 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
406 if ( end_color != NULL )
407 sv_catpv(dsv, end_color);
410 sv_catpvs( dsv, "\"");
411 else if ( flags & PERL_PV_PRETTY_LTGT )
414 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
415 sv_catpvs(dsv, "...");
421 =for apidoc pv_display
425 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
427 except that an additional "\0" will be appended to the string when
428 len > cur and pv[cur] is "\0".
430 Note that the final string may be up to 7 chars longer than pvlim.
436 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
438 PERL_ARGS_ASSERT_PV_DISPLAY;
440 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
441 if (len > cur && pv[cur] == '\0')
442 sv_catpvs( dsv, "\\0");
447 Perl_sv_peek(pTHX_ SV *sv)
450 SV * const t = sv_newmortal();
460 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
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),
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 (PL_tainting && 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 : "");
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_EXTFLAGS(regex) & RXf_TAINTED)
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 #define OP_PRIVATE_ONCE(op, flag, name) \
775 const struct flag_to_name CAT2(op, _names)[] = { \
779 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
780 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
781 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
782 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
783 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
784 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
785 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
786 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
787 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
788 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
789 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
790 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
792 struct op_private_by_op {
795 const struct flag_to_name *start;
798 const struct op_private_by_op op_private_names[] = {
799 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
800 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
801 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
802 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
804 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
805 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
806 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
807 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
808 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
809 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
810 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
811 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
812 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
813 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
814 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
815 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
816 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
817 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
818 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
819 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
823 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
824 const struct op_private_by_op *start = op_private_names;
825 const struct op_private_by_op *const end
826 = op_private_names + C_ARRAY_LENGTH(op_private_names);
828 /* This is a linear search, but no worse than the code that it replaced.
829 It's debugging code - size is more important than speed. */
831 if (optype == start->op_type) {
832 S_append_flags(aTHX_ tmpsv, op_private, start->start,
833 start->start + start->len);
836 } while (++start < end);
841 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
845 const OPCODE optype = o->op_type;
847 PERL_ARGS_ASSERT_DO_OP_DUMP;
849 Perl_dump_indent(aTHX_ level, file, "{\n");
851 seq = sequence_num(o);
853 PerlIO_printf(file, "%-4"UVuf, seq);
855 PerlIO_printf(file, "????");
857 "%*sTYPE = %s ===> ",
858 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
861 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
862 sequence_num(o->op_next));
864 PerlIO_printf(file, "NULL\n");
866 if (optype == OP_NULL) {
867 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
868 if (o->op_targ == OP_NEXTSTATE) {
870 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
872 if (CopSTASHPV(cCOPo))
873 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
876 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
881 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
884 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
886 if (o->op_flags || o->op_slabbed || o->op_savefree) {
887 SV * const tmpsv = newSVpvs("");
888 switch (o->op_flags & OPf_WANT) {
890 sv_catpv(tmpsv, ",VOID");
892 case OPf_WANT_SCALAR:
893 sv_catpv(tmpsv, ",SCALAR");
896 sv_catpv(tmpsv, ",LIST");
899 sv_catpv(tmpsv, ",UNKNOWN");
902 append_flags(tmpsv, o->op_flags, op_flags_names);
903 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
904 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
905 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
909 SV * const tmpsv = newSVpvs("");
910 if (PL_opargs[optype] & OA_TARGLEX) {
911 if (o->op_private & OPpTARGET_MY)
912 sv_catpv(tmpsv, ",TARGET_MY");
914 else if (optype == OP_ENTERSUB ||
915 optype == OP_RV2SV ||
917 optype == OP_RV2AV ||
918 optype == OP_RV2HV ||
919 optype == OP_RV2GV ||
920 optype == OP_AELEM ||
923 if (optype == OP_ENTERSUB) {
924 append_flags(tmpsv, o->op_private, op_entersub_names);
927 switch (o->op_private & OPpDEREF) {
929 sv_catpv(tmpsv, ",SV");
932 sv_catpv(tmpsv, ",AV");
935 sv_catpv(tmpsv, ",HV");
938 if (o->op_private & OPpMAYBE_LVSUB)
939 sv_catpv(tmpsv, ",MAYBE_LVSUB");
942 if (optype == OP_AELEM || optype == OP_HELEM) {
943 if (o->op_private & OPpLVAL_DEFER)
944 sv_catpv(tmpsv, ",LVAL_DEFER");
947 if (o->op_private & HINT_STRICT_REFS)
948 sv_catpv(tmpsv, ",STRICT_REFS");
949 if (o->op_private & OPpOUR_INTRO)
950 sv_catpv(tmpsv, ",OUR_INTRO");
953 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
955 else if (PL_check[optype] != Perl_ck_ftst) {
956 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
957 sv_catpv(tmpsv, ",FT_ACCESS");
958 if (o->op_private & OPpFT_STACKED)
959 sv_catpv(tmpsv, ",FT_STACKED");
961 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
962 sv_catpv(tmpsv, ",INTRO");
964 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
969 if (PL_madskills && o->op_madprop) {
970 SV * const tmpsv = newSVpvs("");
971 MADPROP* mp = o->op_madprop;
972 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
975 const char tmp = mp->mad_key;
976 sv_setpvs(tmpsv,"'");
978 sv_catpvn(tmpsv, &tmp, 1);
979 sv_catpv(tmpsv, "'=");
980 switch (mp->mad_type) {
982 sv_catpv(tmpsv, "NULL");
983 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
986 sv_catpv(tmpsv, "<");
987 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
988 sv_catpv(tmpsv, ">");
989 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
992 if ((OP*)mp->mad_val) {
993 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
994 do_op_dump(level, file, (OP*)mp->mad_val);
998 sv_catpv(tmpsv, "(UNK)");
999 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1005 Perl_dump_indent(aTHX_ level, file, "}\n");
1007 SvREFCNT_dec(tmpsv);
1016 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1018 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1019 if (cSVOPo->op_sv) {
1020 SV * const tmpsv = newSV(0);
1024 /* FIXME - is this making unwarranted assumptions about the
1025 UTF-8 cleanliness of the dump file handle? */
1028 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1029 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1030 SvPV_nolen_const(tmpsv));
1034 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1040 case OP_METHOD_NAMED:
1041 #ifndef USE_ITHREADS
1042 /* with ITHREADS, consts are stored in the pad, and the right pad
1043 * may not be active here, so skip */
1044 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1050 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1051 (UV)CopLINE(cCOPo));
1052 if (CopSTASHPV(cCOPo))
1053 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1055 if (CopLABEL(cCOPo))
1056 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1060 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1061 if (cLOOPo->op_redoop)
1062 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1064 PerlIO_printf(file, "DONE\n");
1065 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1066 if (cLOOPo->op_nextop)
1067 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1069 PerlIO_printf(file, "DONE\n");
1070 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1071 if (cLOOPo->op_lastop)
1072 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1074 PerlIO_printf(file, "DONE\n");
1082 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1083 if (cLOGOPo->op_other)
1084 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1086 PerlIO_printf(file, "DONE\n");
1092 do_pmop_dump(level, file, cPMOPo);
1100 if (o->op_private & OPpREFCOUNTED)
1101 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1106 if (o->op_flags & OPf_KIDS) {
1108 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1109 do_op_dump(level, file, kid);
1111 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1115 Perl_op_dump(pTHX_ const OP *o)
1117 PERL_ARGS_ASSERT_OP_DUMP;
1118 do_op_dump(0, Perl_debug_log, o);
1122 Perl_gv_dump(pTHX_ GV *gv)
1126 PERL_ARGS_ASSERT_GV_DUMP;
1129 PerlIO_printf(Perl_debug_log, "{}\n");
1132 sv = sv_newmortal();
1133 PerlIO_printf(Perl_debug_log, "{\n");
1134 gv_fullname3(sv, gv, NULL);
1135 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1136 if (gv != GvEGV(gv)) {
1137 gv_efullname3(sv, GvEGV(gv), NULL);
1138 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1140 PerlIO_putc(Perl_debug_log, '\n');
1141 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1145 /* map magic types to the symbolic names
1146 * (with the PERL_MAGIC_ prefixed stripped)
1149 static const struct { const char type; const char *name; } magic_names[] = {
1150 #include "mg_names.c"
1151 /* this null string terminates the list */
1156 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1158 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1160 for (; mg; mg = mg->mg_moremagic) {
1161 Perl_dump_indent(aTHX_ level, file,
1162 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1163 if (mg->mg_virtual) {
1164 const MGVTBL * const v = mg->mg_virtual;
1165 if (v >= PL_magic_vtables
1166 && v < PL_magic_vtables + magic_vtable_max) {
1167 const U32 i = v - PL_magic_vtables;
1168 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1171 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1174 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1177 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1181 const char *name = NULL;
1182 for (n = 0; magic_names[n].name; n++) {
1183 if (mg->mg_type == magic_names[n].type) {
1184 name = magic_names[n].name;
1189 Perl_dump_indent(aTHX_ level, file,
1190 " MG_TYPE = PERL_MAGIC_%s\n", name);
1192 Perl_dump_indent(aTHX_ level, file,
1193 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1197 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1198 if (mg->mg_type == PERL_MAGIC_envelem &&
1199 mg->mg_flags & MGf_TAINTEDDIR)
1200 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1201 if (mg->mg_type == PERL_MAGIC_regex_global &&
1202 mg->mg_flags & MGf_MINMATCH)
1203 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1204 if (mg->mg_flags & MGf_REFCOUNTED)
1205 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1206 if (mg->mg_flags & MGf_GSKIP)
1207 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1208 if (mg->mg_flags & MGf_COPY)
1209 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1210 if (mg->mg_flags & MGf_DUP)
1211 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1212 if (mg->mg_flags & MGf_LOCAL)
1213 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1216 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1217 PTR2UV(mg->mg_obj));
1218 if (mg->mg_type == PERL_MAGIC_qr) {
1219 REGEXP* const re = (REGEXP *)mg->mg_obj;
1220 SV * const dsv = sv_newmortal();
1221 const char * const s
1222 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1224 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1225 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1227 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1228 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1231 if (mg->mg_flags & MGf_REFCOUNTED)
1232 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1235 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1237 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1238 if (mg->mg_len >= 0) {
1239 if (mg->mg_type != PERL_MAGIC_utf8) {
1240 SV * const sv = newSVpvs("");
1241 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1245 else if (mg->mg_len == HEf_SVKEY) {
1246 PerlIO_puts(file, " => HEf_SVKEY\n");
1247 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1248 maxnest, dumpops, pvlim); /* MG is already +1 */
1251 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1256 " does not know how to handle this MG_LEN"
1258 PerlIO_putc(file, '\n');
1260 if (mg->mg_type == PERL_MAGIC_utf8) {
1261 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1264 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1265 Perl_dump_indent(aTHX_ level, file,
1266 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1269 (UV)cache[i * 2 + 1]);
1276 Perl_magic_dump(pTHX_ const MAGIC *mg)
1278 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1282 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1286 PERL_ARGS_ASSERT_DO_HV_DUMP;
1288 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1289 if (sv && (hvname = HvNAME_get(sv)))
1291 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1292 name which quite legally could contain insane things like tabs, newlines, nulls or
1293 other scary crap - this should produce sane results - except maybe for unicode package
1294 names - but we will wait for someone to file a bug on that - demerphq */
1295 SV * const tmpsv = newSVpvs("");
1296 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1299 PerlIO_putc(file, '\n');
1303 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1305 PERL_ARGS_ASSERT_DO_GV_DUMP;
1307 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1308 if (sv && GvNAME(sv))
1309 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1311 PerlIO_putc(file, '\n');
1315 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1317 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1319 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1320 if (sv && GvNAME(sv)) {
1322 PerlIO_printf(file, "\t\"");
1323 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1324 PerlIO_printf(file, "%s\" :: \"", hvname);
1325 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1328 PerlIO_putc(file, '\n');
1331 const struct flag_to_name first_sv_flags_names[] = {
1332 {SVs_TEMP, "TEMP,"},
1333 {SVs_OBJECT, "OBJECT,"},
1342 const struct flag_to_name second_sv_flags_names[] = {
1344 {SVf_FAKE, "FAKE,"},
1345 {SVf_READONLY, "READONLY,"},
1346 {SVf_BREAK, "BREAK,"},
1347 {SVf_AMAGIC, "OVERLOAD,"},
1353 const struct flag_to_name cv_flags_names[] = {
1354 {CVf_ANON, "ANON,"},
1355 {CVf_UNIQUE, "UNIQUE,"},
1356 {CVf_CLONE, "CLONE,"},
1357 {CVf_CLONED, "CLONED,"},
1358 {CVf_CONST, "CONST,"},
1359 {CVf_NODEBUG, "NODEBUG,"},
1360 {CVf_LVALUE, "LVALUE,"},
1361 {CVf_METHOD, "METHOD,"},
1362 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1363 {CVf_CVGV_RC, "CVGV_RC,"},
1364 {CVf_DYNFILE, "DYNFILE,"},
1365 {CVf_AUTOLOAD, "AUTOLOAD,"},
1366 {CVf_HASEVAL, "HASEVAL"},
1367 {CVf_SLABBED, "SLABBED,"},
1368 {CVf_ISXSUB, "ISXSUB,"}
1371 const struct flag_to_name hv_flags_names[] = {
1372 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1373 {SVphv_LAZYDEL, "LAZYDEL,"},
1374 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1375 {SVphv_REHASH, "REHASH,"},
1376 {SVphv_CLONEABLE, "CLONEABLE,"}
1379 const struct flag_to_name gp_flags_names[] = {
1380 {GVf_INTRO, "INTRO,"},
1381 {GVf_MULTI, "MULTI,"},
1382 {GVf_ASSUMECV, "ASSUMECV,"},
1383 {GVf_IN_PAD, "IN_PAD,"}
1386 const struct flag_to_name gp_flags_imported_names[] = {
1387 {GVf_IMPORTED_SV, " SV"},
1388 {GVf_IMPORTED_AV, " AV"},
1389 {GVf_IMPORTED_HV, " HV"},
1390 {GVf_IMPORTED_CV, " CV"},
1393 const struct flag_to_name regexp_flags_names[] = {
1394 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1395 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1396 {RXf_PMf_FOLD, "PMf_FOLD,"},
1397 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1398 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1399 {RXf_ANCH_BOL, "ANCH_BOL,"},
1400 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1401 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1402 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1403 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1404 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1405 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1406 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1407 {RXf_CANY_SEEN, "CANY_SEEN,"},
1408 {RXf_NOSCAN, "NOSCAN,"},
1409 {RXf_CHECK_ALL, "CHECK_ALL,"},
1410 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1411 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1412 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1413 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1414 {RXf_SPLIT, "SPLIT,"},
1415 {RXf_COPY_DONE, "COPY_DONE,"},
1416 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1417 {RXf_TAINTED, "TAINTED,"},
1418 {RXf_START_ONLY, "START_ONLY,"},
1419 {RXf_SKIPWHITE, "SKIPWHITE,"},
1420 {RXf_WHITE, "WHITE,"},
1421 {RXf_NULL, "NULL,"},
1425 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1433 PERL_ARGS_ASSERT_DO_SV_DUMP;
1436 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1440 flags = SvFLAGS(sv);
1443 /* process general SV flags */
1445 d = Perl_newSVpvf(aTHX_
1446 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1447 PTR2UV(SvANY(sv)), PTR2UV(sv),
1448 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1449 (int)(PL_dumpindent*level), "");
1451 if (!((flags & SVpad_NAME) == SVpad_NAME
1452 && (type == SVt_PVMG || type == SVt_PVNV))) {
1453 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1454 sv_catpv(d, "PADSTALE,");
1456 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1457 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1458 sv_catpv(d, "PADTMP,");
1459 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1461 append_flags(d, flags, first_sv_flags_names);
1462 if (flags & SVf_ROK) {
1463 sv_catpv(d, "ROK,");
1464 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1466 append_flags(d, flags, second_sv_flags_names);
1467 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1468 if (SvPCS_IMPORTED(sv))
1469 sv_catpv(d, "PCS_IMPORTED,");
1471 sv_catpv(d, "SCREAM,");
1474 /* process type-specific SV flags */
1479 append_flags(d, CvFLAGS(sv), cv_flags_names);
1482 append_flags(d, flags, hv_flags_names);
1486 if (isGV_with_GP(sv)) {
1487 append_flags(d, GvFLAGS(sv), gp_flags_names);
1489 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1490 sv_catpv(d, "IMPORT");
1491 if (GvIMPORTED(sv) == GVf_IMPORTED)
1492 sv_catpv(d, "ALL,");
1495 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1502 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1503 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1506 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1507 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1508 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1509 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1512 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1517 /* SVphv_SHAREKEYS is also 0x20000000 */
1518 if ((type != SVt_PVHV) && SvUTF8(sv))
1519 sv_catpv(d, "UTF8");
1521 if (*(SvEND(d) - 1) == ',') {
1522 SvCUR_set(d, SvCUR(d) - 1);
1523 SvPVX(d)[SvCUR(d)] = '\0';
1528 /* dump initial SV details */
1530 #ifdef DEBUG_LEAKING_SCALARS
1531 Perl_dump_indent(aTHX_ level, file,
1532 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1533 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1535 sv->sv_debug_inpad ? "for" : "by",
1536 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1537 PTR2UV(sv->sv_debug_parent),
1541 Perl_dump_indent(aTHX_ level, file, "SV = ");
1545 if (type < SVt_LAST) {
1546 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1548 if (type == SVt_NULL) {
1553 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1558 /* Dump general SV fields */
1560 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1561 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1562 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1563 || (type == SVt_IV && !SvROK(sv))) {
1565 #ifdef PERL_OLD_COPY_ON_WRITE
1569 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1571 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1572 #ifdef PERL_OLD_COPY_ON_WRITE
1573 if (SvIsCOW_shared_hash(sv))
1574 PerlIO_printf(file, " (HASH)");
1575 else if (SvIsCOW_normal(sv))
1576 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1578 PerlIO_putc(file, '\n');
1581 if ((type == SVt_PVNV || type == SVt_PVMG)
1582 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1583 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1584 (UV) COP_SEQ_RANGE_LOW(sv));
1585 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1586 (UV) COP_SEQ_RANGE_HIGH(sv));
1587 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1588 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1589 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1590 || type == SVt_NV) {
1591 STORE_NUMERIC_LOCAL_SET_STANDARD();
1592 /* %Vg doesn't work? --jhi */
1593 #ifdef USE_LONG_DOUBLE
1594 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1596 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1598 RESTORE_NUMERIC_LOCAL();
1602 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1604 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1607 if (type < SVt_PV) {
1612 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1613 if (SvPVX_const(sv)) {
1616 SvOOK_offset(sv, delta);
1617 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1622 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1624 PerlIO_printf(file, "( %s . ) ",
1625 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1628 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1629 if (SvUTF8(sv)) /* the 6? \x{....} */
1630 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1631 PerlIO_printf(file, "\n");
1632 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1633 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1636 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1639 if (type >= SVt_PVMG) {
1640 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1641 HV * const ost = SvOURSTASH(sv);
1643 do_hv_dump(level, file, " OURSTASH", ost);
1646 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1649 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1651 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1652 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1653 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1654 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1658 /* Dump type-specific SV fields */
1662 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1663 if (AvARRAY(sv) != AvALLOC(sv)) {
1664 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1665 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1668 PerlIO_putc(file, '\n');
1669 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1670 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1671 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1673 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1674 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1675 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1676 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1677 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1679 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1680 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1682 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1684 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1689 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1690 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1691 /* Show distribution of HEs in the ARRAY */
1693 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1696 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1697 NV theoret, sum = 0;
1699 PerlIO_printf(file, " (");
1700 Zero(freq, FREQ_MAX + 1, int);
1701 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1704 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1706 if (count > FREQ_MAX)
1712 for (i = 0; i <= max; i++) {
1714 PerlIO_printf(file, "%d%s:%d", i,
1715 (i == FREQ_MAX) ? "+" : "",
1718 PerlIO_printf(file, ", ");
1721 PerlIO_putc(file, ')');
1722 /* The "quality" of a hash is defined as the total number of
1723 comparisons needed to access every element once, relative
1724 to the expected number needed for a random hash.
1726 The total number of comparisons is equal to the sum of
1727 the squares of the number of entries in each bucket.
1728 For a random hash of n keys into k buckets, the expected
1733 for (i = max; i > 0; i--) { /* Precision: count down. */
1734 sum += freq[i] * i * i;
1736 while ((keys = keys >> 1))
1738 theoret = HvUSEDKEYS(sv);
1739 theoret += theoret * (theoret-1)/pow2;
1740 PerlIO_putc(file, '\n');
1741 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1743 PerlIO_putc(file, '\n');
1744 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1745 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1746 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1747 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1748 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1750 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1751 if (mg && mg->mg_obj) {
1752 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1756 const char * const hvname = HvNAME_get(sv);
1758 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1762 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1763 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1764 if (HvAUX(sv)->xhv_name_count)
1765 Perl_dump_indent(aTHX_
1766 level, file, " NAMECOUNT = %"IVdf"\n",
1767 (IV)HvAUX(sv)->xhv_name_count
1769 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1770 const I32 count = HvAUX(sv)->xhv_name_count;
1772 SV * const names = newSVpvs_flags("", SVs_TEMP);
1773 /* The starting point is the first element if count is
1774 positive and the second element if count is negative. */
1775 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1776 + (count < 0 ? 1 : 0);
1777 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1778 + (count < 0 ? -count : count);
1779 while (hekp < endp) {
1781 sv_catpvs(names, ", \"");
1782 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1783 sv_catpvs(names, "\"");
1785 /* This should never happen. */
1786 sv_catpvs(names, ", (null)");
1790 Perl_dump_indent(aTHX_
1791 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1795 Perl_dump_indent(aTHX_
1796 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1800 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1802 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1806 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1807 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1808 (int)meta->mro_which->length,
1809 meta->mro_which->name,
1810 PTR2UV(meta->mro_which));
1811 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1812 (UV)meta->cache_gen);
1813 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1815 if (meta->mro_linear_all) {
1816 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1817 PTR2UV(meta->mro_linear_all));
1818 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1821 if (meta->mro_linear_current) {
1822 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1823 PTR2UV(meta->mro_linear_current));
1824 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1827 if (meta->mro_nextmethod) {
1828 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1829 PTR2UV(meta->mro_nextmethod));
1830 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1834 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1836 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1841 if (nest < maxnest) {
1842 HV * const hv = MUTABLE_HV(sv);
1847 int count = maxnest - nest;
1848 for (i=0; i <= HvMAX(hv); i++) {
1849 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1856 if (count-- <= 0) goto DONEHV;
1859 keysv = hv_iterkeysv(he);
1860 keypv = SvPV_const(keysv, len);
1863 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1865 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1866 if (HvEITER_get(hv) == he)
1867 PerlIO_printf(file, "[CURRENT] ");
1869 PerlIO_printf(file, "[REHASH] ");
1870 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1871 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1880 if (CvAUTOLOAD(sv)) {
1882 const char *const name = SvPV_const(sv, len);
1883 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1887 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1888 (int) CvPROTOLEN(sv), CvPROTO(sv));
1892 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1893 if (!CvISXSUB(sv)) {
1895 Perl_dump_indent(aTHX_ level, file,
1896 " START = 0x%"UVxf" ===> %"IVdf"\n",
1897 PTR2UV(CvSTART(sv)),
1898 (IV)sequence_num(CvSTART(sv)));
1900 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1901 PTR2UV(CvROOT(sv)));
1902 if (CvROOT(sv) && dumpops) {
1903 do_op_dump(level+1, file, CvROOT(sv));
1906 SV * const constant = cv_const_sv((const CV *)sv);
1908 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1911 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1913 PTR2UV(CvXSUBANY(sv).any_ptr));
1914 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1917 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1918 (IV)CvXSUBANY(sv).any_i32);
1921 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1922 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1923 if (type == SVt_PVCV)
1924 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1925 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1926 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1927 if (type == SVt_PVFM)
1928 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1929 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1930 if (nest < maxnest) {
1931 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1934 const CV * const outside = CvOUTSIDE(sv);
1935 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1938 : CvANON(outside) ? "ANON"
1939 : (outside == PL_main_cv) ? "MAIN"
1940 : CvUNIQUE(outside) ? "UNIQUE"
1941 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1943 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1944 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1949 if (type == SVt_PVLV) {
1950 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1951 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1952 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1953 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1954 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
1955 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1956 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1959 if (!isGV_with_GP(sv))
1961 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1962 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1963 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1964 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1967 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1968 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1969 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1970 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1971 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1972 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1973 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1974 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1975 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1976 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1977 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1978 do_gv_dump (level, file, " EGV", GvEGV(sv));
1981 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1982 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1983 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1984 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1985 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1986 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1987 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1989 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1990 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1991 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1993 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1994 PTR2UV(IoTOP_GV(sv)));
1995 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1996 maxnest, dumpops, pvlim);
1998 /* Source filters hide things that are not GVs in these three, so let's
1999 be careful out there. */
2001 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2002 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2003 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2005 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2006 PTR2UV(IoFMT_GV(sv)));
2007 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2008 maxnest, dumpops, pvlim);
2010 if (IoBOTTOM_NAME(sv))
2011 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2012 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2013 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2015 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2016 PTR2UV(IoBOTTOM_GV(sv)));
2017 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2018 maxnest, dumpops, pvlim);
2020 if (isPRINT(IoTYPE(sv)))
2021 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2023 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2024 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2028 struct regexp * const r = (struct regexp *)SvANY(sv);
2029 flags = RX_EXTFLAGS((REGEXP*)sv);
2031 append_flags(d, flags, regexp_flags_names);
2032 if (*(SvEND(d) - 1) == ',') {
2033 SvCUR_set(d, SvCUR(d) - 1);
2034 SvPVX(d)[SvCUR(d)] = '\0';
2036 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2037 (UV)flags, SvPVX_const(d));
2038 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2040 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2042 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2043 (UV)(r->lastparen));
2044 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2045 (UV)(r->lastcloseparen));
2046 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2048 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2049 (IV)(r->minlenret));
2050 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2052 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2053 (UV)(r->pre_prefix));
2054 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2057 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2059 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2061 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2062 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2064 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2065 PTR2UV(r->mother_re));
2066 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2067 PTR2UV(r->paren_names));
2068 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2069 PTR2UV(r->substrs));
2070 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2071 PTR2UV(r->pprivate));
2072 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2074 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2075 PTR2UV(r->qr_anoncv));
2076 #ifdef PERL_OLD_COPY_ON_WRITE
2077 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2078 PTR2UV(r->saved_copy));
2087 Perl_sv_dump(pTHX_ SV *sv)
2091 PERL_ARGS_ASSERT_SV_DUMP;
2094 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2096 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2100 Perl_runops_debug(pTHX)
2104 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2108 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2111 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2112 PerlIO_printf(Perl_debug_log,
2113 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2114 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2115 PTR2UV(*PL_watchaddr));
2116 if (DEBUG_s_TEST_) {
2117 if (DEBUG_v_TEST_) {
2118 PerlIO_printf(Perl_debug_log, "\n");
2126 if (DEBUG_t_TEST_) debop(PL_op);
2127 if (DEBUG_P_TEST_) debprof(PL_op);
2129 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2130 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2137 Perl_debop(pTHX_ const OP *o)
2141 PERL_ARGS_ASSERT_DEBOP;
2143 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2146 Perl_deb(aTHX_ "%s", OP_NAME(o));
2147 switch (o->op_type) {
2150 /* With ITHREADS, consts are stored in the pad, and the right pad
2151 * may not be active here, so check.
2152 * Looks like only during compiling the pads are illegal.
2155 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2157 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2162 SV * const sv = newSV(0);
2164 /* FIXME - is this making unwarranted assumptions about the
2165 UTF-8 cleanliness of the dump file handle? */
2168 gv_fullname3(sv, cGVOPo_gv, NULL);
2169 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2173 PerlIO_printf(Perl_debug_log, "(NULL)");
2179 /* print the lexical's name */
2180 CV * const cv = deb_curcv(cxstack_ix);
2183 AV * const padlist = CvPADLIST(cv);
2184 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2185 sv = *av_fetch(comppad, o->op_targ, FALSE);
2189 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2191 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2197 PerlIO_printf(Perl_debug_log, "\n");
2202 S_deb_curcv(pTHX_ const I32 ix)
2205 const PERL_CONTEXT * const cx = &cxstack[ix];
2206 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2207 return cx->blk_sub.cv;
2208 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2209 return cx->blk_eval.cv;
2210 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2215 return deb_curcv(ix - 1);
2219 Perl_watch(pTHX_ char **addr)
2223 PERL_ARGS_ASSERT_WATCH;
2225 PL_watchaddr = addr;
2227 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2228 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2232 S_debprof(pTHX_ const OP *o)
2236 PERL_ARGS_ASSERT_DEBPROF;
2238 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2240 if (!PL_profiledata)
2241 Newxz(PL_profiledata, MAXO, U32);
2242 ++PL_profiledata[o->op_type];
2246 Perl_debprofdump(pTHX)
2250 if (!PL_profiledata)
2252 for (i = 0; i < MAXO; i++) {
2253 if (PL_profiledata[i])
2254 PerlIO_printf(Perl_debug_log,
2255 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2262 * XML variants of most of the above routines
2266 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2270 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2272 PerlIO_printf(file, "\n ");
2273 va_start(args, pat);
2274 xmldump_vindent(level, file, pat, &args);
2280 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2283 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2284 va_start(args, pat);
2285 xmldump_vindent(level, file, pat, &args);
2290 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2292 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2294 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2295 PerlIO_vprintf(file, pat, *args);
2299 Perl_xmldump_all(pTHX)
2301 xmldump_all_perl(FALSE);
2305 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2307 PerlIO_setlinebuf(PL_xmlfp);
2309 op_xmldump(PL_main_root);
2310 /* someday we might call this, when it outputs XML: */
2311 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2312 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2313 PerlIO_close(PL_xmlfp);
2318 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2320 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2321 xmldump_packsubs_perl(stash, FALSE);
2325 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2330 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2332 if (!HvARRAY(stash))
2334 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2335 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2336 GV *gv = MUTABLE_GV(HeVAL(entry));
2338 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2341 xmldump_sub_perl(gv, justperl);
2344 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2345 && (hv = GvHV(gv)) && hv != PL_defstash)
2346 xmldump_packsubs_perl(hv, justperl); /* nested package */
2352 Perl_xmldump_sub(pTHX_ const GV *gv)
2354 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2355 xmldump_sub_perl(gv, FALSE);
2359 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2363 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2365 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2368 sv = sv_newmortal();
2369 gv_fullname3(sv, gv, NULL);
2370 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2371 if (CvXSUB(GvCV(gv)))
2372 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2373 PTR2UV(CvXSUB(GvCV(gv))),
2374 (int)CvXSUBANY(GvCV(gv)).any_i32);
2375 else if (CvROOT(GvCV(gv)))
2376 op_xmldump(CvROOT(GvCV(gv)));
2378 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2382 Perl_xmldump_form(pTHX_ const GV *gv)
2384 SV * const sv = sv_newmortal();
2386 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2388 gv_fullname3(sv, gv, NULL);
2389 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2390 if (CvROOT(GvFORM(gv)))
2391 op_xmldump(CvROOT(GvFORM(gv)));
2393 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2397 Perl_xmldump_eval(pTHX)
2399 op_xmldump(PL_eval_root);
2403 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2405 PERL_ARGS_ASSERT_SV_CATXMLSV;
2406 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2410 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2412 PERL_ARGS_ASSERT_SV_CATXMLPV;
2413 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2417 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2420 const char * const e = pv + len;
2421 const char * const start = pv;
2425 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2428 dsvcur = SvCUR(dsv); /* in case we have to restart */
2433 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2435 SvCUR(dsv) = dsvcur;
2500 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2503 sv_catpvs(dsv, "<");
2506 sv_catpvs(dsv, ">");
2509 sv_catpvs(dsv, "&");
2512 sv_catpvs(dsv, """);
2516 if (c < 32 || c > 127) {
2517 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2520 const char string = (char) c;
2521 sv_catpvn(dsv, &string, 1);
2525 if ((c >= 0xD800 && c <= 0xDB7F) ||
2526 (c >= 0xDC00 && c <= 0xDFFF) ||
2527 (c >= 0xFFF0 && c <= 0xFFFF) ||
2529 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2531 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2544 Perl_sv_xmlpeek(pTHX_ SV *sv)
2546 SV * const t = sv_newmortal();
2550 PERL_ARGS_ASSERT_SV_XMLPEEK;
2556 sv_catpv(t, "VOID=\"\"");
2559 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2560 sv_catpv(t, "WILD=\"\"");
2563 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2564 if (sv == &PL_sv_undef) {
2565 sv_catpv(t, "SV_UNDEF=\"1\"");
2566 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2567 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2571 else if (sv == &PL_sv_no) {
2572 sv_catpv(t, "SV_NO=\"1\"");
2573 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2574 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2575 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2576 SVp_POK|SVp_NOK)) &&
2581 else if (sv == &PL_sv_yes) {
2582 sv_catpv(t, "SV_YES=\"1\"");
2583 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2584 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2585 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2586 SVp_POK|SVp_NOK)) &&
2588 SvPVX(sv) && *SvPVX(sv) == '1' &&
2593 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2594 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2595 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2599 sv_catpv(t, " XXX=\"\" ");
2601 else if (SvREFCNT(sv) == 0) {
2602 sv_catpv(t, " refcnt=\"0\"");
2605 else if (DEBUG_R_TEST_) {
2608 /* is this SV on the tmps stack? */
2609 for (ix=PL_tmps_ix; ix>=0; ix--) {
2610 if (PL_tmps_stack[ix] == sv) {
2615 if (SvREFCNT(sv) > 1)
2616 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2619 sv_catpv(t, " DRT=\"<T>\"");
2623 sv_catpv(t, " ROK=\"\"");
2625 switch (SvTYPE(sv)) {
2627 sv_catpv(t, " FREED=\"1\"");
2631 sv_catpv(t, " UNDEF=\"1\"");
2634 sv_catpv(t, " IV=\"");
2637 sv_catpv(t, " NV=\"");
2640 sv_catpv(t, " PV=\"");
2643 sv_catpv(t, " PVIV=\"");
2646 sv_catpv(t, " PVNV=\"");
2649 sv_catpv(t, " PVMG=\"");
2652 sv_catpv(t, " PVLV=\"");
2655 sv_catpv(t, " AV=\"");
2658 sv_catpv(t, " HV=\"");
2662 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2664 sv_catpv(t, " CV=\"()\"");
2667 sv_catpv(t, " GV=\"");
2670 sv_catpv(t, " BIND=\"");
2673 sv_catpv(t, " REGEXP=\"");
2676 sv_catpv(t, " FM=\"");
2679 sv_catpv(t, " IO=\"");
2688 else if (SvNOKp(sv)) {
2689 STORE_NUMERIC_LOCAL_SET_STANDARD();
2690 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2691 RESTORE_NUMERIC_LOCAL();
2693 else if (SvIOKp(sv)) {
2695 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2697 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2706 return SvPV(t, n_a);
2710 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2712 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2715 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2718 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2721 REGEXP *const r = PM_GETRE(pm);
2722 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2723 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2724 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2726 SvREFCNT_dec(tmpsv);
2727 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2728 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2731 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2732 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2733 SV * const tmpsv = pm_description(pm);
2734 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2735 SvREFCNT_dec(tmpsv);
2739 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2740 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2741 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2742 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2743 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2744 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2747 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2751 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2753 do_pmop_xmldump(0, PL_xmlfp, pm);
2757 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2762 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2766 seq = sequence_num(o);
2767 Perl_xmldump_indent(aTHX_ level, file,
2768 "<op_%s seq=\"%"UVuf" -> ",
2773 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2774 sequence_num(o->op_next));
2776 PerlIO_printf(file, "DONE\"");
2779 if (o->op_type == OP_NULL)
2781 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2782 if (o->op_targ == OP_NEXTSTATE)
2785 PerlIO_printf(file, " line=\"%"UVuf"\"",
2786 (UV)CopLINE(cCOPo));
2787 if (CopSTASHPV(cCOPo))
2788 PerlIO_printf(file, " package=\"%s\"",
2790 if (CopLABEL(cCOPo))
2791 PerlIO_printf(file, " label=\"%s\"",
2796 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2799 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2802 SV * const tmpsv = newSVpvs("");
2803 switch (o->op_flags & OPf_WANT) {
2805 sv_catpv(tmpsv, ",VOID");
2807 case OPf_WANT_SCALAR:
2808 sv_catpv(tmpsv, ",SCALAR");
2811 sv_catpv(tmpsv, ",LIST");
2814 sv_catpv(tmpsv, ",UNKNOWN");
2817 if (o->op_flags & OPf_KIDS)
2818 sv_catpv(tmpsv, ",KIDS");
2819 if (o->op_flags & OPf_PARENS)
2820 sv_catpv(tmpsv, ",PARENS");
2821 if (o->op_flags & OPf_STACKED)
2822 sv_catpv(tmpsv, ",STACKED");
2823 if (o->op_flags & OPf_REF)
2824 sv_catpv(tmpsv, ",REF");
2825 if (o->op_flags & OPf_MOD)
2826 sv_catpv(tmpsv, ",MOD");
2827 if (o->op_flags & OPf_SPECIAL)
2828 sv_catpv(tmpsv, ",SPECIAL");
2829 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2830 SvREFCNT_dec(tmpsv);
2832 if (o->op_private) {
2833 SV * const tmpsv = newSVpvs("");
2834 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2835 if (o->op_private & OPpTARGET_MY)
2836 sv_catpv(tmpsv, ",TARGET_MY");
2838 else if (o->op_type == OP_LEAVESUB ||
2839 o->op_type == OP_LEAVE ||
2840 o->op_type == OP_LEAVESUBLV ||
2841 o->op_type == OP_LEAVEWRITE) {
2842 if (o->op_private & OPpREFCOUNTED)
2843 sv_catpv(tmpsv, ",REFCOUNTED");
2845 else if (o->op_type == OP_AASSIGN) {
2846 if (o->op_private & OPpASSIGN_COMMON)
2847 sv_catpv(tmpsv, ",COMMON");
2849 else if (o->op_type == OP_SASSIGN) {
2850 if (o->op_private & OPpASSIGN_BACKWARDS)
2851 sv_catpv(tmpsv, ",BACKWARDS");
2853 else if (o->op_type == OP_TRANS) {
2854 if (o->op_private & OPpTRANS_SQUASH)
2855 sv_catpv(tmpsv, ",SQUASH");
2856 if (o->op_private & OPpTRANS_DELETE)
2857 sv_catpv(tmpsv, ",DELETE");
2858 if (o->op_private & OPpTRANS_COMPLEMENT)
2859 sv_catpv(tmpsv, ",COMPLEMENT");
2860 if (o->op_private & OPpTRANS_IDENTICAL)
2861 sv_catpv(tmpsv, ",IDENTICAL");
2862 if (o->op_private & OPpTRANS_GROWS)
2863 sv_catpv(tmpsv, ",GROWS");
2865 else if (o->op_type == OP_REPEAT) {
2866 if (o->op_private & OPpREPEAT_DOLIST)
2867 sv_catpv(tmpsv, ",DOLIST");
2869 else if (o->op_type == OP_ENTERSUB ||
2870 o->op_type == OP_RV2SV ||
2871 o->op_type == OP_GVSV ||
2872 o->op_type == OP_RV2AV ||
2873 o->op_type == OP_RV2HV ||
2874 o->op_type == OP_RV2GV ||
2875 o->op_type == OP_AELEM ||
2876 o->op_type == OP_HELEM )
2878 if (o->op_type == OP_ENTERSUB) {
2879 if (o->op_private & OPpENTERSUB_AMPER)
2880 sv_catpv(tmpsv, ",AMPER");
2881 if (o->op_private & OPpENTERSUB_DB)
2882 sv_catpv(tmpsv, ",DB");
2883 if (o->op_private & OPpENTERSUB_HASTARG)
2884 sv_catpv(tmpsv, ",HASTARG");
2885 if (o->op_private & OPpENTERSUB_NOPAREN)
2886 sv_catpv(tmpsv, ",NOPAREN");
2887 if (o->op_private & OPpENTERSUB_INARGS)
2888 sv_catpv(tmpsv, ",INARGS");
2891 switch (o->op_private & OPpDEREF) {
2893 sv_catpv(tmpsv, ",SV");
2896 sv_catpv(tmpsv, ",AV");
2899 sv_catpv(tmpsv, ",HV");
2902 if (o->op_private & OPpMAYBE_LVSUB)
2903 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2905 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2906 if (o->op_private & OPpLVAL_DEFER)
2907 sv_catpv(tmpsv, ",LVAL_DEFER");
2910 if (o->op_private & HINT_STRICT_REFS)
2911 sv_catpv(tmpsv, ",STRICT_REFS");
2912 if (o->op_private & OPpOUR_INTRO)
2913 sv_catpv(tmpsv, ",OUR_INTRO");
2916 else if (o->op_type == OP_CONST) {
2917 if (o->op_private & OPpCONST_BARE)
2918 sv_catpv(tmpsv, ",BARE");
2919 if (o->op_private & OPpCONST_STRICT)
2920 sv_catpv(tmpsv, ",STRICT");
2921 if (o->op_private & OPpCONST_ENTERED)
2922 sv_catpv(tmpsv, ",ENTERED");
2923 if (o->op_private & OPpCONST_FOLDED)
2924 sv_catpv(tmpsv, ",FOLDED");
2926 else if (o->op_type == OP_FLIP) {
2927 if (o->op_private & OPpFLIP_LINENUM)
2928 sv_catpv(tmpsv, ",LINENUM");
2930 else if (o->op_type == OP_FLOP) {
2931 if (o->op_private & OPpFLIP_LINENUM)
2932 sv_catpv(tmpsv, ",LINENUM");
2934 else if (o->op_type == OP_RV2CV) {
2935 if (o->op_private & OPpLVAL_INTRO)
2936 sv_catpv(tmpsv, ",INTRO");
2938 else if (o->op_type == OP_GV) {
2939 if (o->op_private & OPpEARLY_CV)
2940 sv_catpv(tmpsv, ",EARLY_CV");
2942 else if (o->op_type == OP_LIST) {
2943 if (o->op_private & OPpLIST_GUESSED)
2944 sv_catpv(tmpsv, ",GUESSED");
2946 else if (o->op_type == OP_DELETE) {
2947 if (o->op_private & OPpSLICE)
2948 sv_catpv(tmpsv, ",SLICE");
2950 else if (o->op_type == OP_EXISTS) {
2951 if (o->op_private & OPpEXISTS_SUB)
2952 sv_catpv(tmpsv, ",EXISTS_SUB");
2954 else if (o->op_type == OP_SORT) {
2955 if (o->op_private & OPpSORT_NUMERIC)
2956 sv_catpv(tmpsv, ",NUMERIC");
2957 if (o->op_private & OPpSORT_INTEGER)
2958 sv_catpv(tmpsv, ",INTEGER");
2959 if (o->op_private & OPpSORT_REVERSE)
2960 sv_catpv(tmpsv, ",REVERSE");
2962 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2963 if (o->op_private & OPpOPEN_IN_RAW)
2964 sv_catpv(tmpsv, ",IN_RAW");
2965 if (o->op_private & OPpOPEN_IN_CRLF)
2966 sv_catpv(tmpsv, ",IN_CRLF");
2967 if (o->op_private & OPpOPEN_OUT_RAW)
2968 sv_catpv(tmpsv, ",OUT_RAW");
2969 if (o->op_private & OPpOPEN_OUT_CRLF)
2970 sv_catpv(tmpsv, ",OUT_CRLF");
2972 else if (o->op_type == OP_EXIT) {
2973 if (o->op_private & OPpEXIT_VMSISH)
2974 sv_catpv(tmpsv, ",EXIT_VMSISH");
2975 if (o->op_private & OPpHUSH_VMSISH)
2976 sv_catpv(tmpsv, ",HUSH_VMSISH");
2978 else if (o->op_type == OP_DIE) {
2979 if (o->op_private & OPpHUSH_VMSISH)
2980 sv_catpv(tmpsv, ",HUSH_VMSISH");
2982 else if (PL_check[o->op_type] != Perl_ck_ftst) {
2983 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2984 sv_catpv(tmpsv, ",FT_ACCESS");
2985 if (o->op_private & OPpFT_STACKED)
2986 sv_catpv(tmpsv, ",FT_STACKED");
2988 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2989 sv_catpv(tmpsv, ",INTRO");
2991 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2992 SvREFCNT_dec(tmpsv);
2995 switch (o->op_type) {
2997 if (o->op_flags & OPf_SPECIAL) {
3003 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3005 if (cSVOPo->op_sv) {
3006 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3007 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3013 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3014 s = SvPV(tmpsv1,len);
3015 sv_catxmlpvn(tmpsv2, s, len, 1);
3016 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3020 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3025 case OP_METHOD_NAMED:
3026 #ifndef USE_ITHREADS
3027 /* with ITHREADS, consts are stored in the pad, and the right pad
3028 * may not be active here, so skip */
3029 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3035 PerlIO_printf(file, ">\n");
3037 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3042 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3043 (UV)CopLINE(cCOPo));
3044 if (CopSTASHPV(cCOPo))
3045 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3047 if (CopLABEL(cCOPo))
3048 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3052 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3053 if (cLOOPo->op_redoop)
3054 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3056 PerlIO_printf(file, "DONE\"");
3057 S_xmldump_attr(aTHX_ level, file, "next=\"");
3058 if (cLOOPo->op_nextop)
3059 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3061 PerlIO_printf(file, "DONE\"");
3062 S_xmldump_attr(aTHX_ level, file, "last=\"");
3063 if (cLOOPo->op_lastop)
3064 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3066 PerlIO_printf(file, "DONE\"");
3074 S_xmldump_attr(aTHX_ level, file, "other=\"");
3075 if (cLOGOPo->op_other)
3076 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3078 PerlIO_printf(file, "DONE\"");
3086 if (o->op_private & OPpREFCOUNTED)
3087 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3093 if (PL_madskills && o->op_madprop) {
3094 char prevkey = '\0';
3095 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3096 const MADPROP* mp = o->op_madprop;
3100 PerlIO_printf(file, ">\n");
3102 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3105 char tmp = mp->mad_key;
3106 sv_setpvs(tmpsv,"\"");
3108 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3109 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3110 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3113 sv_catpv(tmpsv, "\"");
3114 switch (mp->mad_type) {
3116 sv_catpv(tmpsv, "NULL");
3117 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3120 sv_catpv(tmpsv, " val=\"");
3121 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3122 sv_catpv(tmpsv, "\"");
3123 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3126 sv_catpv(tmpsv, " val=\"");
3127 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3128 sv_catpv(tmpsv, "\"");
3129 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3132 if ((OP*)mp->mad_val) {
3133 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3134 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3135 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3139 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3145 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3147 SvREFCNT_dec(tmpsv);
3150 switch (o->op_type) {
3157 PerlIO_printf(file, ">\n");
3159 do_pmop_xmldump(level, file, cPMOPo);
3165 if (o->op_flags & OPf_KIDS) {
3169 PerlIO_printf(file, ">\n");
3171 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3172 do_op_xmldump(level, file, kid);
3176 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3178 PerlIO_printf(file, " />\n");
3182 Perl_op_xmldump(pTHX_ const OP *o)
3184 PERL_ARGS_ASSERT_OP_XMLDUMP;
3186 do_op_xmldump(0, PL_xmlfp, o);
3192 * c-indentation-style: bsd
3194 * indent-tabs-mode: nil
3197 * ex: set ts=8 sts=4 sw=4 et: