3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.'"
16 /* This file contains utility routines to dump the contents of SV and OP
17 * structures, as used by command-line options like -Dt and -Dx, and
20 * It also holds the debugging version of the runops function.
24 #define PERL_IN_DUMP_C
30 #define Sequence PL_op_sequence
33 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
37 dump_vindent(level, file, pat, &args);
42 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
45 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
46 PerlIO_vprintf(file, pat, *args);
53 PerlIO_setlinebuf(Perl_debug_log);
55 op_dump(PL_main_root);
56 dump_packsubs(PL_defstash);
60 Perl_dump_packsubs(pTHX_ const HV *stash)
67 for (i = 0; i <= (I32) HvMAX(stash); i++) {
69 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
70 const GV *gv = (GV*)HeVAL(entry);
72 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
78 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
79 && (hv = GvHV(gv)) && hv != PL_defstash)
80 dump_packsubs(hv); /* nested package */
86 Perl_dump_sub(pTHX_ const GV *gv)
88 SV * const sv = sv_newmortal();
90 gv_fullname3(sv, gv, NULL);
91 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
92 if (CvISXSUB(GvCV(gv)))
93 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
94 PTR2UV(CvXSUB(GvCV(gv))),
95 (int)CvXSUBANY(GvCV(gv)).any_i32);
96 else if (CvROOT(GvCV(gv)))
97 op_dump(CvROOT(GvCV(gv)));
99 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
103 Perl_dump_form(pTHX_ const GV *gv)
105 SV * const sv = sv_newmortal();
107 gv_fullname3(sv, gv, NULL);
108 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
109 if (CvROOT(GvFORM(gv)))
110 op_dump(CvROOT(GvFORM(gv)));
112 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
119 op_dump(PL_eval_root);
124 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
125 |const STRLEN count|const STRLEN max
126 |STRLEN const *escaped, const U32 flags
128 Escapes at most the first "count" chars of pv and puts the results into
129 dsv such that the size of the escaped string will not exceed "max" chars
130 and will not contain any incomplete escape sequences.
132 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
133 will also be escaped.
135 Normally the SV will be cleared before the escaped string is prepared,
136 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
138 If PERL_PV_ESCAPE_UNI is set then the input string is treated as unicode,
139 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
140 using C<is_utf8_string()> to determine if it is unicode.
142 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
143 using C<\x01F1> style escapes, otherwise only chars above 255 will be
144 escaped using this style, other non printable chars will use octal or
145 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
146 then all chars below 255 will be treated as printable and
147 will be output as literals.
149 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
150 string will be escaped, regardles of max. If the string is utf8 and
151 the chars value is >255 then it will be returned as a plain hex
152 sequence. Thus the output will either be a single char,
153 an octal escape sequence, a special escape like C<\n> or a 3 or
154 more digit hex value.
156 Returns a pointer to the escaped text as held by dsv.
160 #define PV_ESCAPE_OCTBUFSIZE 32
163 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
164 const STRLEN count, const STRLEN max,
165 STRLEN * const escaped, const U32 flags )
167 char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
168 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
169 STRLEN wrote = 0; /* chars written so far */
170 STRLEN chsize = 0; /* size of data to be written */
171 STRLEN readsize = 1; /* size of data just read */
172 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
173 const char *pv = str;
174 const char *end = pv + count; /* end of string */
176 if (!flags & PERL_PV_ESCAPE_NOCLEAR)
177 sv_setpvn(dsv, "", 0);
179 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
182 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
183 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
184 const U8 c = (U8)u & 0xFF;
186 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
187 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
188 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
191 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
193 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
196 if ( (c == dq) || (c == '\\') || !isPRINT(c) ) {
199 case '\\' : octbuf[1] = '\\'; break;
200 case '\v' : octbuf[1] = 'v'; break;
201 case '\t' : octbuf[1] = 't'; break;
202 case '\r' : octbuf[1] = 'r'; break;
203 case '\n' : octbuf[1] = 'n'; break;
204 case '\f' : octbuf[1] = 'f'; break;
212 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
213 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
216 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
223 if ( max && (wrote + chsize > max) ) {
225 } else if (chsize > 1) {
226 sv_catpvn(dsv, octbuf, chsize);
229 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
232 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
240 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
241 |const STRLEN count|const STRLEN max\
242 |const char const *start_color| const char const *end_color\
245 Converts a string into something presentable, handling escaping via
246 pv_escape() and supporting quoting and elipses.
248 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
249 double quoted with any double quotes in the string escaped. Otherwise
250 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
253 If the PERL_PV_PRETTY_ELIPSES flag is set and not all characters in
254 string were output then an elipses C<...> will be appended to the
255 string. Note that this happens AFTER it has been quoted.
257 If start_color is non-null then it will be inserted after the opening
258 quote (if there is one) but before the escaped text. If end_color
259 is non-null then it will be inserted after the escaped text but before
260 any quotes or elipses.
262 Returns a pointer to the prettified text as held by dsv.
268 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
269 const STRLEN max, char const * const start_color, char const * const end_color,
272 U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
276 sv_setpvn(dsv, "\"", 1);
277 else if ( flags & PERL_PV_PRETTY_LTGT )
278 sv_setpvn(dsv, "<", 1);
280 sv_setpvn(dsv, "", 0);
282 if ( start_color != NULL )
283 Perl_sv_catpvf( aTHX_ dsv, "%s", start_color);
285 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
287 if ( end_color != NULL )
288 Perl_sv_catpvf( aTHX_ dsv, "%s", end_color);
291 sv_catpvn( dsv, "\"", 1 );
292 else if ( flags & PERL_PV_PRETTY_LTGT )
293 sv_catpvn( dsv, ">", 1);
295 if ( (flags & PERL_PV_PRETTY_ELIPSES) && ( escaped < count ) )
296 sv_catpvn( dsv, "...", 3 );
302 =for apidoc pv_display
304 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
305 STRLEN pvlim, U32 flags)
309 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
311 except that an additional "\0" will be appended to the string when
312 len > cur and pv[cur] is "\0".
314 Note that the final string may be up to 7 chars longer than pvlim.
320 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
322 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
323 if (len > cur && pv[cur] == '\0')
324 sv_catpvn( dsv, "\\0", 2 );
329 Perl_sv_peek(pTHX_ SV *sv)
332 SV * const t = sv_newmortal();
341 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
345 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
346 if (sv == &PL_sv_undef) {
347 sv_catpv(t, "SV_UNDEF");
348 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
349 SVs_GMG|SVs_SMG|SVs_RMG)) &&
353 else if (sv == &PL_sv_no) {
354 sv_catpv(t, "SV_NO");
355 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
356 SVs_GMG|SVs_SMG|SVs_RMG)) &&
357 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
363 else if (sv == &PL_sv_yes) {
364 sv_catpv(t, "SV_YES");
365 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
366 SVs_GMG|SVs_SMG|SVs_RMG)) &&
367 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
370 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
375 sv_catpv(t, "SV_PLACEHOLDER");
376 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
377 SVs_GMG|SVs_SMG|SVs_RMG)) &&
383 else if (SvREFCNT(sv) == 0) {
387 else if (DEBUG_R_TEST_) {
390 /* is this SV on the tmps stack? */
391 for (ix=PL_tmps_ix; ix>=0; ix--) {
392 if (PL_tmps_stack[ix] == sv) {
397 if (SvREFCNT(sv) > 1)
398 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
406 if (SvCUR(t) + unref > 10) {
407 SvCUR_set(t, unref + 3);
415 switch (SvTYPE(sv)) {
417 sv_catpv(t, "FREED");
421 sv_catpv(t, "UNDEF");
455 Perl_sv_catpvf(aTHX_ t, "CV(%s)", GvNAME(CvGV(sv)));
474 if (!SvPVX_const(sv))
475 sv_catpv(t, "(null)");
477 SV * const tmp = newSVpvs("");
480 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
481 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
483 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
484 sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv),
489 else if (SvNOKp(sv)) {
490 STORE_NUMERIC_LOCAL_SET_STANDARD();
491 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
492 RESTORE_NUMERIC_LOCAL();
494 else if (SvIOKp(sv)) {
496 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
498 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
508 return SvPV_nolen(t);
512 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
517 Perl_dump_indent(aTHX_ level, file, "{}\n");
520 Perl_dump_indent(aTHX_ level, file, "{\n");
522 if (pm->op_pmflags & PMf_ONCE)
527 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
528 ch, PM_GETRE(pm)->precomp, ch,
529 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
531 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
532 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
533 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
534 op_dump(pm->op_pmreplroot);
536 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
537 SV * const tmpsv = pm_description(pm);
538 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
542 Perl_dump_indent(aTHX_ level-1, file, "}\n");
546 S_pm_description(pTHX_ const PMOP *pm)
548 SV * const desc = newSVpvs("");
549 const REGEXP * regex = PM_GETRE(pm);
550 const U32 pmflags = pm->op_pmflags;
552 if (pm->op_pmdynflags & PMdf_USED)
553 sv_catpv(desc, ",USED");
554 if (pm->op_pmdynflags & PMdf_TAINTED)
555 sv_catpv(desc, ",TAINTED");
557 if (pmflags & PMf_ONCE)
558 sv_catpv(desc, ",ONCE");
559 if (regex && regex->check_substr) {
560 if (!(regex->reganch & ROPT_NOSCAN))
561 sv_catpv(desc, ",SCANFIRST");
562 if (regex->reganch & ROPT_CHECK_ALL)
563 sv_catpv(desc, ",ALL");
565 if (pmflags & PMf_SKIPWHITE)
566 sv_catpv(desc, ",SKIPWHITE");
567 if (pmflags & PMf_CONST)
568 sv_catpv(desc, ",CONST");
569 if (pmflags & PMf_KEEP)
570 sv_catpv(desc, ",KEEP");
571 if (pmflags & PMf_GLOBAL)
572 sv_catpv(desc, ",GLOBAL");
573 if (pmflags & PMf_CONTINUE)
574 sv_catpv(desc, ",CONTINUE");
575 if (pmflags & PMf_RETAINT)
576 sv_catpv(desc, ",RETAINT");
577 if (pmflags & PMf_EVAL)
578 sv_catpv(desc, ",EVAL");
583 Perl_pmop_dump(pTHX_ PMOP *pm)
585 do_pmop_dump(0, Perl_debug_log, pm);
588 /* An op sequencer. We visit the ops in the order they're to execute. */
591 S_sequence(pTHX_ register const OP *o)
594 const OP *oldop = NULL;
607 for (; o; o = o->op_next) {
609 SV * const op = newSVuv(PTR2UV(o));
610 const char * const key = SvPV_const(op, len);
612 if (hv_exists(Sequence, key, len))
615 switch (o->op_type) {
617 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
618 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
627 if (oldop && o->op_next)
634 if (oldop && o->op_next)
636 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
649 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
650 sequence_tail(cLOGOPo->op_other);
655 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
656 sequence_tail(cLOOPo->op_redoop);
657 sequence_tail(cLOOPo->op_nextop);
658 sequence_tail(cLOOPo->op_lastop);
664 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
665 sequence_tail(cPMOPo->op_pmreplstart);
672 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
680 S_sequence_tail(pTHX_ const OP *o)
682 while (o && (o->op_type == OP_NULL))
688 S_sequence_num(pTHX_ const OP *o)
696 op = newSVuv(PTR2UV(o));
697 key = SvPV_const(op, len);
698 seq = hv_fetch(Sequence, key, len, 0);
699 return seq ? SvUV(*seq): 0;
703 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
707 const OPCODE optype = o->op_type;
710 Perl_dump_indent(aTHX_ level, file, "{\n");
712 seq = sequence_num(o);
714 PerlIO_printf(file, "%-4"UVuf, seq);
716 PerlIO_printf(file, " ");
718 "%*sTYPE = %s ===> ",
719 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
721 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
722 sequence_num(o->op_next));
724 PerlIO_printf(file, "DONE\n");
726 if (optype == OP_NULL) {
727 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
728 if (o->op_targ == OP_NEXTSTATE) {
730 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
732 if (CopSTASHPV(cCOPo))
733 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
735 if (cCOPo->cop_label)
736 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
741 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
744 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
747 SV * const tmpsv = newSVpvs("");
748 switch (o->op_flags & OPf_WANT) {
750 sv_catpv(tmpsv, ",VOID");
752 case OPf_WANT_SCALAR:
753 sv_catpv(tmpsv, ",SCALAR");
756 sv_catpv(tmpsv, ",LIST");
759 sv_catpv(tmpsv, ",UNKNOWN");
762 if (o->op_flags & OPf_KIDS)
763 sv_catpv(tmpsv, ",KIDS");
764 if (o->op_flags & OPf_PARENS)
765 sv_catpv(tmpsv, ",PARENS");
766 if (o->op_flags & OPf_STACKED)
767 sv_catpv(tmpsv, ",STACKED");
768 if (o->op_flags & OPf_REF)
769 sv_catpv(tmpsv, ",REF");
770 if (o->op_flags & OPf_MOD)
771 sv_catpv(tmpsv, ",MOD");
772 if (o->op_flags & OPf_SPECIAL)
773 sv_catpv(tmpsv, ",SPECIAL");
774 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
778 SV * const tmpsv = newSVpvs("");
779 if (PL_opargs[optype] & OA_TARGLEX) {
780 if (o->op_private & OPpTARGET_MY)
781 sv_catpv(tmpsv, ",TARGET_MY");
783 else if (optype == OP_LEAVESUB ||
784 optype == OP_LEAVE ||
785 optype == OP_LEAVESUBLV ||
786 optype == OP_LEAVEWRITE) {
787 if (o->op_private & OPpREFCOUNTED)
788 sv_catpv(tmpsv, ",REFCOUNTED");
790 else if (optype == OP_AASSIGN) {
791 if (o->op_private & OPpASSIGN_COMMON)
792 sv_catpv(tmpsv, ",COMMON");
794 else if (optype == OP_SASSIGN) {
795 if (o->op_private & OPpASSIGN_BACKWARDS)
796 sv_catpv(tmpsv, ",BACKWARDS");
798 else if (optype == OP_TRANS) {
799 if (o->op_private & OPpTRANS_SQUASH)
800 sv_catpv(tmpsv, ",SQUASH");
801 if (o->op_private & OPpTRANS_DELETE)
802 sv_catpv(tmpsv, ",DELETE");
803 if (o->op_private & OPpTRANS_COMPLEMENT)
804 sv_catpv(tmpsv, ",COMPLEMENT");
805 if (o->op_private & OPpTRANS_IDENTICAL)
806 sv_catpv(tmpsv, ",IDENTICAL");
807 if (o->op_private & OPpTRANS_GROWS)
808 sv_catpv(tmpsv, ",GROWS");
810 else if (optype == OP_REPEAT) {
811 if (o->op_private & OPpREPEAT_DOLIST)
812 sv_catpv(tmpsv, ",DOLIST");
814 else if (optype == OP_ENTERSUB ||
815 optype == OP_RV2SV ||
817 optype == OP_RV2AV ||
818 optype == OP_RV2HV ||
819 optype == OP_RV2GV ||
820 optype == OP_AELEM ||
823 if (optype == OP_ENTERSUB) {
824 if (o->op_private & OPpENTERSUB_AMPER)
825 sv_catpv(tmpsv, ",AMPER");
826 if (o->op_private & OPpENTERSUB_DB)
827 sv_catpv(tmpsv, ",DB");
828 if (o->op_private & OPpENTERSUB_HASTARG)
829 sv_catpv(tmpsv, ",HASTARG");
830 if (o->op_private & OPpENTERSUB_NOPAREN)
831 sv_catpv(tmpsv, ",NOPAREN");
832 if (o->op_private & OPpENTERSUB_INARGS)
833 sv_catpv(tmpsv, ",INARGS");
834 if (o->op_private & OPpENTERSUB_NOMOD)
835 sv_catpv(tmpsv, ",NOMOD");
838 switch (o->op_private & OPpDEREF) {
840 sv_catpv(tmpsv, ",SV");
843 sv_catpv(tmpsv, ",AV");
846 sv_catpv(tmpsv, ",HV");
849 if (o->op_private & OPpMAYBE_LVSUB)
850 sv_catpv(tmpsv, ",MAYBE_LVSUB");
852 if (optype == OP_AELEM || optype == OP_HELEM) {
853 if (o->op_private & OPpLVAL_DEFER)
854 sv_catpv(tmpsv, ",LVAL_DEFER");
857 if (o->op_private & HINT_STRICT_REFS)
858 sv_catpv(tmpsv, ",STRICT_REFS");
859 if (o->op_private & OPpOUR_INTRO)
860 sv_catpv(tmpsv, ",OUR_INTRO");
863 else if (optype == OP_CONST) {
864 if (o->op_private & OPpCONST_BARE)
865 sv_catpv(tmpsv, ",BARE");
866 if (o->op_private & OPpCONST_STRICT)
867 sv_catpv(tmpsv, ",STRICT");
868 if (o->op_private & OPpCONST_ARYBASE)
869 sv_catpv(tmpsv, ",ARYBASE");
870 if (o->op_private & OPpCONST_WARNING)
871 sv_catpv(tmpsv, ",WARNING");
872 if (o->op_private & OPpCONST_ENTERED)
873 sv_catpv(tmpsv, ",ENTERED");
875 else if (optype == OP_FLIP) {
876 if (o->op_private & OPpFLIP_LINENUM)
877 sv_catpv(tmpsv, ",LINENUM");
879 else if (optype == OP_FLOP) {
880 if (o->op_private & OPpFLIP_LINENUM)
881 sv_catpv(tmpsv, ",LINENUM");
883 else if (optype == OP_RV2CV) {
884 if (o->op_private & OPpLVAL_INTRO)
885 sv_catpv(tmpsv, ",INTRO");
887 else if (optype == OP_GV) {
888 if (o->op_private & OPpEARLY_CV)
889 sv_catpv(tmpsv, ",EARLY_CV");
891 else if (optype == OP_LIST) {
892 if (o->op_private & OPpLIST_GUESSED)
893 sv_catpv(tmpsv, ",GUESSED");
895 else if (optype == OP_DELETE) {
896 if (o->op_private & OPpSLICE)
897 sv_catpv(tmpsv, ",SLICE");
899 else if (optype == OP_EXISTS) {
900 if (o->op_private & OPpEXISTS_SUB)
901 sv_catpv(tmpsv, ",EXISTS_SUB");
903 else if (optype == OP_SORT) {
904 if (o->op_private & OPpSORT_NUMERIC)
905 sv_catpv(tmpsv, ",NUMERIC");
906 if (o->op_private & OPpSORT_INTEGER)
907 sv_catpv(tmpsv, ",INTEGER");
908 if (o->op_private & OPpSORT_REVERSE)
909 sv_catpv(tmpsv, ",REVERSE");
911 else if (optype == OP_THREADSV) {
912 if (o->op_private & OPpDONE_SVREF)
913 sv_catpv(tmpsv, ",SVREF");
915 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
916 if (o->op_private & OPpOPEN_IN_RAW)
917 sv_catpv(tmpsv, ",IN_RAW");
918 if (o->op_private & OPpOPEN_IN_CRLF)
919 sv_catpv(tmpsv, ",IN_CRLF");
920 if (o->op_private & OPpOPEN_OUT_RAW)
921 sv_catpv(tmpsv, ",OUT_RAW");
922 if (o->op_private & OPpOPEN_OUT_CRLF)
923 sv_catpv(tmpsv, ",OUT_CRLF");
925 else if (optype == OP_EXIT) {
926 if (o->op_private & OPpEXIT_VMSISH)
927 sv_catpv(tmpsv, ",EXIT_VMSISH");
928 if (o->op_private & OPpHUSH_VMSISH)
929 sv_catpv(tmpsv, ",HUSH_VMSISH");
931 else if (optype == OP_DIE) {
932 if (o->op_private & OPpHUSH_VMSISH)
933 sv_catpv(tmpsv, ",HUSH_VMSISH");
935 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
936 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
937 sv_catpv(tmpsv, ",FT_ACCESS");
938 if (o->op_private & OPpFT_STACKED)
939 sv_catpv(tmpsv, ",FT_STACKED");
941 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
942 sv_catpv(tmpsv, ",INTRO");
944 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
949 if (PL_madskills && o->op_madprop) {
950 SV * const tmpsv = newSVpvn("", 0);
951 MADPROP* mp = o->op_madprop;
952 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
955 char tmp = mp->mad_key;
956 sv_setpvn(tmpsv,"'",1);
958 sv_catpvn(tmpsv, &tmp, 1);
959 sv_catpv(tmpsv, "'=");
960 switch (mp->mad_type) {
962 sv_catpv(tmpsv, "NULL");
963 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
966 sv_catpv(tmpsv, "<");
967 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
968 sv_catpv(tmpsv, ">");
969 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
972 if ((OP*)mp->mad_val) {
973 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
974 do_op_dump(level, file, (OP*)mp->mad_val);
978 sv_catpv(tmpsv, "(UNK)");
979 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
985 Perl_dump_indent(aTHX_ level, file, "}\n");
996 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
998 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1000 SV * const tmpsv = newSV(0);
1004 /* FIXME - it this making unwarranted assumptions about the
1005 UTF-8 cleanliness of the dump file handle? */
1008 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1009 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1010 SvPV_nolen_const(tmpsv));
1014 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1019 case OP_METHOD_NAMED:
1020 #ifndef USE_ITHREADS
1021 /* with ITHREADS, consts are stored in the pad, and the right pad
1022 * may not be active here, so skip */
1023 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1030 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1031 (UV)CopLINE(cCOPo));
1032 if (CopSTASHPV(cCOPo))
1033 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1035 if (cCOPo->cop_label)
1036 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1040 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1041 if (cLOOPo->op_redoop)
1042 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1044 PerlIO_printf(file, "DONE\n");
1045 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1046 if (cLOOPo->op_nextop)
1047 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1049 PerlIO_printf(file, "DONE\n");
1050 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1051 if (cLOOPo->op_lastop)
1052 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1054 PerlIO_printf(file, "DONE\n");
1062 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1063 if (cLOGOPo->op_other)
1064 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1066 PerlIO_printf(file, "DONE\n");
1072 do_pmop_dump(level, file, cPMOPo);
1080 if (o->op_private & OPpREFCOUNTED)
1081 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1086 if (o->op_flags & OPf_KIDS) {
1088 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1089 do_op_dump(level, file, kid);
1091 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1095 Perl_op_dump(pTHX_ const OP *o)
1097 do_op_dump(0, Perl_debug_log, o);
1101 Perl_gv_dump(pTHX_ GV *gv)
1106 PerlIO_printf(Perl_debug_log, "{}\n");
1109 sv = sv_newmortal();
1110 PerlIO_printf(Perl_debug_log, "{\n");
1111 gv_fullname3(sv, gv, NULL);
1112 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1113 if (gv != GvEGV(gv)) {
1114 gv_efullname3(sv, GvEGV(gv), NULL);
1115 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1117 PerlIO_putc(Perl_debug_log, '\n');
1118 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1122 /* map magic types to the symbolic names
1123 * (with the PERL_MAGIC_ prefixed stripped)
1126 static const struct { const char type; const char *name; } magic_names[] = {
1127 { PERL_MAGIC_sv, "sv(\\0)" },
1128 { PERL_MAGIC_arylen, "arylen(#)" },
1129 { PERL_MAGIC_rhash, "rhash(%)" },
1130 { PERL_MAGIC_pos, "pos(.)" },
1131 { PERL_MAGIC_symtab, "symtab(:)" },
1132 { PERL_MAGIC_backref, "backref(<)" },
1133 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1134 { PERL_MAGIC_overload, "overload(A)" },
1135 { PERL_MAGIC_bm, "bm(B)" },
1136 { PERL_MAGIC_regdata, "regdata(D)" },
1137 { PERL_MAGIC_env, "env(E)" },
1138 { PERL_MAGIC_hints, "hints(H)" },
1139 { PERL_MAGIC_isa, "isa(I)" },
1140 { PERL_MAGIC_dbfile, "dbfile(L)" },
1141 { PERL_MAGIC_shared, "shared(N)" },
1142 { PERL_MAGIC_tied, "tied(P)" },
1143 { PERL_MAGIC_sig, "sig(S)" },
1144 { PERL_MAGIC_uvar, "uvar(U)" },
1145 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1146 { PERL_MAGIC_overload_table, "overload_table(c)" },
1147 { PERL_MAGIC_regdatum, "regdatum(d)" },
1148 { PERL_MAGIC_envelem, "envelem(e)" },
1149 { PERL_MAGIC_fm, "fm(f)" },
1150 { PERL_MAGIC_regex_global, "regex_global(g)" },
1151 { PERL_MAGIC_hintselem, "hintselem(h)" },
1152 { PERL_MAGIC_isaelem, "isaelem(i)" },
1153 { PERL_MAGIC_nkeys, "nkeys(k)" },
1154 { PERL_MAGIC_dbline, "dbline(l)" },
1155 { PERL_MAGIC_mutex, "mutex(m)" },
1156 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1157 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1158 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1159 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1160 { PERL_MAGIC_qr, "qr(r)" },
1161 { PERL_MAGIC_sigelem, "sigelem(s)" },
1162 { PERL_MAGIC_taint, "taint(t)" },
1163 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1164 { PERL_MAGIC_vec, "vec(v)" },
1165 { PERL_MAGIC_vstring, "vstring(V)" },
1166 { PERL_MAGIC_utf8, "utf8(w)" },
1167 { PERL_MAGIC_substr, "substr(x)" },
1168 { PERL_MAGIC_defelem, "defelem(y)" },
1169 { PERL_MAGIC_ext, "ext(~)" },
1170 /* this null string terminates the list */
1175 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1177 for (; mg; mg = mg->mg_moremagic) {
1178 Perl_dump_indent(aTHX_ level, file,
1179 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1180 if (mg->mg_virtual) {
1181 const MGVTBL * const v = mg->mg_virtual;
1183 if (v == &PL_vtbl_sv) s = "sv";
1184 else if (v == &PL_vtbl_env) s = "env";
1185 else if (v == &PL_vtbl_envelem) s = "envelem";
1186 else if (v == &PL_vtbl_sig) s = "sig";
1187 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1188 else if (v == &PL_vtbl_pack) s = "pack";
1189 else if (v == &PL_vtbl_packelem) s = "packelem";
1190 else if (v == &PL_vtbl_dbline) s = "dbline";
1191 else if (v == &PL_vtbl_isa) s = "isa";
1192 else if (v == &PL_vtbl_arylen) s = "arylen";
1193 else if (v == &PL_vtbl_mglob) s = "mglob";
1194 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1195 else if (v == &PL_vtbl_taint) s = "taint";
1196 else if (v == &PL_vtbl_substr) s = "substr";
1197 else if (v == &PL_vtbl_vec) s = "vec";
1198 else if (v == &PL_vtbl_pos) s = "pos";
1199 else if (v == &PL_vtbl_bm) s = "bm";
1200 else if (v == &PL_vtbl_fm) s = "fm";
1201 else if (v == &PL_vtbl_uvar) s = "uvar";
1202 else if (v == &PL_vtbl_defelem) s = "defelem";
1203 #ifdef USE_LOCALE_COLLATE
1204 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1206 else if (v == &PL_vtbl_amagic) s = "amagic";
1207 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1208 else if (v == &PL_vtbl_backref) s = "backref";
1209 else if (v == &PL_vtbl_utf8) s = "utf8";
1210 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1211 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1214 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1216 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1219 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1222 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1226 const char *name = NULL;
1227 for (n = 0; magic_names[n].name; n++) {
1228 if (mg->mg_type == magic_names[n].type) {
1229 name = magic_names[n].name;
1234 Perl_dump_indent(aTHX_ level, file,
1235 " MG_TYPE = PERL_MAGIC_%s\n", name);
1237 Perl_dump_indent(aTHX_ level, file,
1238 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1242 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1243 if (mg->mg_type == PERL_MAGIC_envelem &&
1244 mg->mg_flags & MGf_TAINTEDDIR)
1245 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1246 if (mg->mg_flags & MGf_REFCOUNTED)
1247 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1248 if (mg->mg_flags & MGf_GSKIP)
1249 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1250 if (mg->mg_type == PERL_MAGIC_regex_global &&
1251 mg->mg_flags & MGf_MINMATCH)
1252 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1255 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1256 if (mg->mg_flags & MGf_REFCOUNTED)
1257 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1260 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1262 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1263 if (mg->mg_len >= 0) {
1264 if (mg->mg_type != PERL_MAGIC_utf8) {
1265 SV *sv = newSVpvs("");
1266 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1270 else if (mg->mg_len == HEf_SVKEY) {
1271 PerlIO_puts(file, " => HEf_SVKEY\n");
1272 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1276 PerlIO_puts(file, " ???? - please notify IZ");
1277 PerlIO_putc(file, '\n');
1279 if (mg->mg_type == PERL_MAGIC_utf8) {
1280 STRLEN *cache = (STRLEN *) mg->mg_ptr;
1283 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1284 Perl_dump_indent(aTHX_ level, file,
1285 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1288 (UV)cache[i * 2 + 1]);
1295 Perl_magic_dump(pTHX_ const MAGIC *mg)
1297 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1301 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1304 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1305 if (sv && (hvname = HvNAME_get(sv)))
1306 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1308 PerlIO_putc(file, '\n');
1312 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1314 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1315 if (sv && GvNAME(sv))
1316 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1318 PerlIO_putc(file, '\n');
1322 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1324 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1325 if (sv && GvNAME(sv)) {
1327 PerlIO_printf(file, "\t\"");
1328 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1329 PerlIO_printf(file, "%s\" :: \"", hvname);
1330 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1333 PerlIO_putc(file, '\n');
1337 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1346 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1350 flags = SvFLAGS(sv);
1353 d = Perl_newSVpvf(aTHX_
1354 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1355 PTR2UV(SvANY(sv)), PTR2UV(sv),
1356 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1357 (int)(PL_dumpindent*level), "");
1359 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1360 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1361 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1362 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1363 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1364 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1365 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1366 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1368 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1369 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1370 if (flags & SVf_POK) sv_catpv(d, "POK,");
1371 if (flags & SVf_ROK) {
1372 sv_catpv(d, "ROK,");
1373 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1375 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1376 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1377 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1379 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1380 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1381 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1382 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1383 if (flags & SVp_SCREAM && type != SVt_PVHV)
1384 sv_catpv(d, "SCREAM,");
1389 if (CvANON(sv)) sv_catpv(d, "ANON,");
1390 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1391 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1392 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1393 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1394 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1395 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1396 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1397 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1398 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1399 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1400 if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
1403 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1404 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1405 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1406 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1407 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1411 if (isGV_with_GP(sv)) {
1412 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1413 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1414 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1415 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1416 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1418 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1419 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1420 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1421 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1422 sv_catpv(d, "IMPORT");
1423 if (GvIMPORTED(sv) == GVf_IMPORTED)
1424 sv_catpv(d, "ALL,");
1427 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1428 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1429 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1430 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1436 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1437 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1440 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1441 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1444 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1449 /* SVphv_SHAREKEYS is also 0x20000000 */
1450 if ((type != SVt_PVHV) && SvUTF8(sv))
1451 sv_catpv(d, "UTF8");
1453 if (*(SvEND(d) - 1) == ',') {
1454 SvCUR_set(d, SvCUR(d) - 1);
1455 SvPVX(d)[SvCUR(d)] = '\0';
1460 #ifdef DEBUG_LEAKING_SCALARS
1461 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1462 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1464 sv->sv_debug_inpad ? "for" : "by",
1465 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1466 sv->sv_debug_cloned ? " (cloned)" : "");
1468 Perl_dump_indent(aTHX_ level, file, "SV = ");
1471 PerlIO_printf(file, "NULL%s\n", s);
1475 PerlIO_printf(file, "IV%s\n", s);
1478 PerlIO_printf(file, "NV%s\n", s);
1481 PerlIO_printf(file, "RV%s\n", s);
1484 PerlIO_printf(file, "PV%s\n", s);
1487 PerlIO_printf(file, "PVIV%s\n", s);
1490 PerlIO_printf(file, "PVNV%s\n", s);
1493 PerlIO_printf(file, "PVBM%s\n", s);
1496 PerlIO_printf(file, "PVMG%s\n", s);
1499 PerlIO_printf(file, "PVLV%s\n", s);
1502 PerlIO_printf(file, "PVAV%s\n", s);
1505 PerlIO_printf(file, "PVHV%s\n", s);
1508 PerlIO_printf(file, "PVCV%s\n", s);
1511 PerlIO_printf(file, "PVGV%s\n", s);
1514 PerlIO_printf(file, "PVFM%s\n", s);
1517 PerlIO_printf(file, "PVIO%s\n", s);
1520 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1524 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1525 && type != SVt_PVCV && !isGV_with_GP(sv))
1526 || type == SVt_IV) {
1528 #ifdef PERL_OLD_COPY_ON_WRITE
1532 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1534 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1536 PerlIO_printf(file, " (OFFSET)");
1537 #ifdef PERL_OLD_COPY_ON_WRITE
1538 if (SvIsCOW_shared_hash(sv))
1539 PerlIO_printf(file, " (HASH)");
1540 else if (SvIsCOW_normal(sv))
1541 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1543 PerlIO_putc(file, '\n');
1545 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1546 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
1547 || type == SVt_NV) {
1548 STORE_NUMERIC_LOCAL_SET_STANDARD();
1549 /* %Vg doesn't work? --jhi */
1550 #ifdef USE_LONG_DOUBLE
1551 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1553 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1555 RESTORE_NUMERIC_LOCAL();
1558 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1560 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1562 if (type < SVt_PV) {
1566 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1567 if (SvPVX_const(sv)) {
1568 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1570 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1571 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1572 if (SvUTF8(sv)) /* the 8? \x{....} */
1573 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1574 PerlIO_printf(file, "\n");
1575 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1576 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1579 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1581 if (type >= SVt_PVMG) {
1583 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1585 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1589 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1590 if (AvARRAY(sv) != AvALLOC(sv)) {
1591 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1592 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1595 PerlIO_putc(file, '\n');
1596 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1597 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1598 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1599 sv_setpvn(d, "", 0);
1600 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1601 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1602 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1603 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1604 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1606 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1607 SV** elt = av_fetch((AV*)sv,count,0);
1609 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1611 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1616 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1617 if (HvARRAY(sv) && HvKEYS(sv)) {
1618 /* Show distribution of HEs in the ARRAY */
1620 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1623 U32 pow2 = 2, keys = HvKEYS(sv);
1624 NV theoret, sum = 0;
1626 PerlIO_printf(file, " (");
1627 Zero(freq, FREQ_MAX + 1, int);
1628 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1631 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1633 if (count > FREQ_MAX)
1639 for (i = 0; i <= max; i++) {
1641 PerlIO_printf(file, "%d%s:%d", i,
1642 (i == FREQ_MAX) ? "+" : "",
1645 PerlIO_printf(file, ", ");
1648 PerlIO_putc(file, ')');
1649 /* The "quality" of a hash is defined as the total number of
1650 comparisons needed to access every element once, relative
1651 to the expected number needed for a random hash.
1653 The total number of comparisons is equal to the sum of
1654 the squares of the number of entries in each bucket.
1655 For a random hash of n keys into k buckets, the expected
1660 for (i = max; i > 0; i--) { /* Precision: count down. */
1661 sum += freq[i] * i * i;
1663 while ((keys = keys >> 1))
1665 theoret = HvKEYS(sv);
1666 theoret += theoret * (theoret-1)/pow2;
1667 PerlIO_putc(file, '\n');
1668 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1670 PerlIO_putc(file, '\n');
1671 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1672 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1673 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1674 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1675 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1677 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1678 if (mg && mg->mg_obj) {
1679 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1683 const char * const hvname = HvNAME_get(sv);
1685 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1688 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1690 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1692 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1696 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1698 HV * const hv = (HV*)sv;
1699 int count = maxnest - nest;
1702 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1707 const U32 hash = HeHASH(he);
1709 keysv = hv_iterkeysv(he);
1710 keypv = SvPV_const(keysv, len);
1711 elt = hv_iterval(hv, he);
1712 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1714 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1716 PerlIO_printf(file, "[REHASH] ");
1717 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1718 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1720 hv_iterinit(hv); /* Return to status quo */
1726 const char *const proto = SvPV_const(sv, len);
1727 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1732 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1733 if (!CvISXSUB(sv)) {
1735 Perl_dump_indent(aTHX_ level, file,
1736 " START = 0x%"UVxf" ===> %"IVdf"\n",
1737 PTR2UV(CvSTART(sv)),
1738 (IV)sequence_num(CvSTART(sv)));
1740 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1741 PTR2UV(CvROOT(sv)));
1742 if (CvROOT(sv) && dumpops) {
1743 do_op_dump(level+1, file, CvROOT(sv));
1746 SV *constant = cv_const_sv((CV *)sv);
1748 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1751 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1753 PTR2UV(CvXSUBANY(sv).any_ptr));
1754 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1757 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1758 (IV)CvXSUBANY(sv).any_i32);
1761 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1762 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1763 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1764 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1765 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1766 if (type == SVt_PVFM)
1767 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1768 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1769 if (nest < maxnest) {
1770 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1773 const CV * const outside = CvOUTSIDE(sv);
1774 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1777 : CvANON(outside) ? "ANON"
1778 : (outside == PL_main_cv) ? "MAIN"
1779 : CvUNIQUE(outside) ? "UNIQUE"
1780 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1782 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1783 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1787 if (type == SVt_PVLV) {
1788 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1789 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1790 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1791 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1792 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1793 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1796 if (!isGV_with_GP(sv))
1798 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1799 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1800 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1801 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1804 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1805 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1806 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1807 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1808 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1809 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1810 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1811 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1812 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1813 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1814 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1815 do_gv_dump (level, file, " EGV", GvEGV(sv));
1818 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1819 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1820 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1821 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1822 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1823 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1824 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1826 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1827 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1828 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1830 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1831 PTR2UV(IoTOP_GV(sv)));
1832 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1835 /* Source filters hide things that are not GVs in these three, so let's
1836 be careful out there. */
1838 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1839 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1840 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1842 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1843 PTR2UV(IoFMT_GV(sv)));
1844 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1847 if (IoBOTTOM_NAME(sv))
1848 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1849 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1850 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1852 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1853 PTR2UV(IoBOTTOM_GV(sv)));
1854 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1857 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1858 if (isPRINT(IoTYPE(sv)))
1859 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1861 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1862 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1869 Perl_sv_dump(pTHX_ SV *sv)
1872 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1876 Perl_runops_debug(pTHX)
1880 if (ckWARN_d(WARN_DEBUGGING))
1881 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1885 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1889 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1890 PerlIO_printf(Perl_debug_log,
1891 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1892 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1893 PTR2UV(*PL_watchaddr));
1894 if (DEBUG_s_TEST_) {
1895 if (DEBUG_v_TEST_) {
1896 PerlIO_printf(Perl_debug_log, "\n");
1904 if (DEBUG_t_TEST_) debop(PL_op);
1905 if (DEBUG_P_TEST_) debprof(PL_op);
1907 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1908 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1915 Perl_debop(pTHX_ const OP *o)
1918 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1921 Perl_deb(aTHX_ "%s", OP_NAME(o));
1922 switch (o->op_type) {
1924 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1929 SV * const sv = newSV(0);
1931 /* FIXME - it this making unwarranted assumptions about the
1932 UTF-8 cleanliness of the dump file handle? */
1935 gv_fullname3(sv, cGVOPo_gv, NULL);
1936 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1940 PerlIO_printf(Perl_debug_log, "(NULL)");
1946 /* print the lexical's name */
1947 CV * const cv = deb_curcv(cxstack_ix);
1950 AV * const padlist = CvPADLIST(cv);
1951 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1952 sv = *av_fetch(comppad, o->op_targ, FALSE);
1956 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1958 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1964 PerlIO_printf(Perl_debug_log, "\n");
1969 S_deb_curcv(pTHX_ I32 ix)
1972 const PERL_CONTEXT * const cx = &cxstack[ix];
1973 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1974 return cx->blk_sub.cv;
1975 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1977 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1982 return deb_curcv(ix - 1);
1986 Perl_watch(pTHX_ char **addr)
1989 PL_watchaddr = addr;
1991 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1992 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1996 S_debprof(pTHX_ const OP *o)
1999 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2001 if (!PL_profiledata)
2002 Newxz(PL_profiledata, MAXO, U32);
2003 ++PL_profiledata[o->op_type];
2007 Perl_debprofdump(pTHX)
2011 if (!PL_profiledata)
2013 for (i = 0; i < MAXO; i++) {
2014 if (PL_profiledata[i])
2015 PerlIO_printf(Perl_debug_log,
2016 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2023 * XML variants of most of the above routines
2028 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2031 PerlIO_printf(file, "\n ");
2032 va_start(args, pat);
2033 xmldump_vindent(level, file, pat, &args);
2039 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2042 va_start(args, pat);
2043 xmldump_vindent(level, file, pat, &args);
2048 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2050 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2051 PerlIO_vprintf(file, pat, *args);
2055 Perl_xmldump_all(pTHX)
2057 PerlIO_setlinebuf(PL_xmlfp);
2059 op_xmldump(PL_main_root);
2060 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2061 PerlIO_close(PL_xmlfp);
2066 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2071 if (!HvARRAY(stash))
2073 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2074 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2075 GV *gv = (GV*)HeVAL(entry);
2077 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2083 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2084 && (hv = GvHV(gv)) && hv != PL_defstash)
2085 xmldump_packsubs(hv); /* nested package */
2091 Perl_xmldump_sub(pTHX_ const GV *gv)
2093 SV *sv = sv_newmortal();
2095 gv_fullname3(sv, gv, Nullch);
2096 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2097 if (CvXSUB(GvCV(gv)))
2098 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2099 PTR2UV(CvXSUB(GvCV(gv))),
2100 (int)CvXSUBANY(GvCV(gv)).any_i32);
2101 else if (CvROOT(GvCV(gv)))
2102 op_xmldump(CvROOT(GvCV(gv)));
2104 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2108 Perl_xmldump_form(pTHX_ const GV *gv)
2110 SV *sv = sv_newmortal();
2112 gv_fullname3(sv, gv, Nullch);
2113 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2114 if (CvROOT(GvFORM(gv)))
2115 op_xmldump(CvROOT(GvFORM(gv)));
2117 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2121 Perl_xmldump_eval(pTHX)
2123 op_xmldump(PL_eval_root);
2127 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2129 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2133 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2141 sv_catpvn(dsv,"",0);
2142 dsvcur = SvCUR(dsv); /* in case we have to restart */
2147 c = utf8_to_uvchr((U8*)pv, &cl);
2149 SvCUR(dsv) = dsvcur;
2214 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2217 Perl_sv_catpvf(aTHX_ dsv, "<");
2220 Perl_sv_catpvf(aTHX_ dsv, ">");
2223 Perl_sv_catpvf(aTHX_ dsv, "&");
2226 Perl_sv_catpvf(aTHX_ dsv, """);
2230 if (c < 32 || c > 127) {
2231 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2234 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2238 if ((c >= 0xD800 && c <= 0xDB7F) ||
2239 (c >= 0xDC00 && c <= 0xDFFF) ||
2240 (c >= 0xFFF0 && c <= 0xFFFF) ||
2242 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2244 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2257 Perl_sv_xmlpeek(pTHX_ SV *sv)
2259 SV *t = sv_newmortal();
2264 sv_setpvn(t, "", 0);
2267 sv_catpv(t, "VOID=\"\"");
2270 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2271 sv_catpv(t, "WILD=\"\"");
2274 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2275 if (sv == &PL_sv_undef) {
2276 sv_catpv(t, "SV_UNDEF=\"1\"");
2277 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2278 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2282 else if (sv == &PL_sv_no) {
2283 sv_catpv(t, "SV_NO=\"1\"");
2284 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2285 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2286 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2287 SVp_POK|SVp_NOK)) &&
2292 else if (sv == &PL_sv_yes) {
2293 sv_catpv(t, "SV_YES=\"1\"");
2294 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2295 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2296 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2297 SVp_POK|SVp_NOK)) &&
2299 SvPVX(sv) && *SvPVX(sv) == '1' &&
2304 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2305 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2306 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2310 sv_catpv(t, " XXX=\"\" ");
2312 else if (SvREFCNT(sv) == 0) {
2313 sv_catpv(t, " refcnt=\"0\"");
2316 else if (DEBUG_R_TEST_) {
2319 /* is this SV on the tmps stack? */
2320 for (ix=PL_tmps_ix; ix>=0; ix--) {
2321 if (PL_tmps_stack[ix] == sv) {
2326 if (SvREFCNT(sv) > 1)
2327 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2330 sv_catpv(t, " DRT=\"<T>\"");
2334 sv_catpv(t, " ROK=\"\"");
2336 switch (SvTYPE(sv)) {
2338 sv_catpv(t, " FREED=\"1\"");
2342 sv_catpv(t, " UNDEF=\"1\"");
2345 sv_catpv(t, " IV=\"");
2348 sv_catpv(t, " NV=\"");
2351 sv_catpv(t, " RV=\"");
2354 sv_catpv(t, " PV=\"");
2357 sv_catpv(t, " PVIV=\"");
2360 sv_catpv(t, " PVNV=\"");
2363 sv_catpv(t, " PVMG=\"");
2366 sv_catpv(t, " PVLV=\"");
2369 sv_catpv(t, " AV=\"");
2372 sv_catpv(t, " HV=\"");
2376 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2378 sv_catpv(t, " CV=\"()\"");
2381 sv_catpv(t, " GV=\"");
2384 sv_catpv(t, " BM=\"");
2387 sv_catpv(t, " FM=\"");
2390 sv_catpv(t, " IO=\"");
2399 else if (SvNOKp(sv)) {
2400 STORE_NUMERIC_LOCAL_SET_STANDARD();
2401 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2402 RESTORE_NUMERIC_LOCAL();
2404 else if (SvIOKp(sv)) {
2406 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2408 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2419 return SvPV(t, n_a);
2423 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2426 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2429 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2432 char *s = PM_GETRE(pm)->precomp;
2433 SV *tmpsv = newSV(0);
2435 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2436 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2438 SvREFCNT_dec(tmpsv);
2439 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2440 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2443 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2444 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2445 SV * const tmpsv = pm_description(pm);
2446 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2447 SvREFCNT_dec(tmpsv);
2451 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
2452 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2453 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2454 do_op_xmldump(level+2, file, pm->op_pmreplroot);
2455 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2456 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2459 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2463 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2465 do_pmop_xmldump(0, PL_xmlfp, pm);
2469 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2476 seq = sequence_num(o);
2477 Perl_xmldump_indent(aTHX_ level, file,
2478 "<op_%s seq=\"%"UVuf" -> ",
2483 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2484 sequence_num(o->op_next));
2486 PerlIO_printf(file, "DONE\"");
2489 if (o->op_type == OP_NULL)
2491 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2492 if (o->op_targ == OP_NEXTSTATE)
2495 PerlIO_printf(file, " line=\"%"UVuf"\"",
2496 (UV)CopLINE(cCOPo));
2497 if (CopSTASHPV(cCOPo))
2498 PerlIO_printf(file, " package=\"%s\"",
2500 if (cCOPo->cop_label)
2501 PerlIO_printf(file, " label=\"%s\"",
2506 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2509 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2512 SV *tmpsv = newSVpvn("", 0);
2513 switch (o->op_flags & OPf_WANT) {
2515 sv_catpv(tmpsv, ",VOID");
2517 case OPf_WANT_SCALAR:
2518 sv_catpv(tmpsv, ",SCALAR");
2521 sv_catpv(tmpsv, ",LIST");
2524 sv_catpv(tmpsv, ",UNKNOWN");
2527 if (o->op_flags & OPf_KIDS)
2528 sv_catpv(tmpsv, ",KIDS");
2529 if (o->op_flags & OPf_PARENS)
2530 sv_catpv(tmpsv, ",PARENS");
2531 if (o->op_flags & OPf_STACKED)
2532 sv_catpv(tmpsv, ",STACKED");
2533 if (o->op_flags & OPf_REF)
2534 sv_catpv(tmpsv, ",REF");
2535 if (o->op_flags & OPf_MOD)
2536 sv_catpv(tmpsv, ",MOD");
2537 if (o->op_flags & OPf_SPECIAL)
2538 sv_catpv(tmpsv, ",SPECIAL");
2539 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2540 SvREFCNT_dec(tmpsv);
2542 if (o->op_private) {
2543 SV *tmpsv = newSVpvn("", 0);
2544 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2545 if (o->op_private & OPpTARGET_MY)
2546 sv_catpv(tmpsv, ",TARGET_MY");
2548 else if (o->op_type == OP_LEAVESUB ||
2549 o->op_type == OP_LEAVE ||
2550 o->op_type == OP_LEAVESUBLV ||
2551 o->op_type == OP_LEAVEWRITE) {
2552 if (o->op_private & OPpREFCOUNTED)
2553 sv_catpv(tmpsv, ",REFCOUNTED");
2555 else if (o->op_type == OP_AASSIGN) {
2556 if (o->op_private & OPpASSIGN_COMMON)
2557 sv_catpv(tmpsv, ",COMMON");
2559 else if (o->op_type == OP_SASSIGN) {
2560 if (o->op_private & OPpASSIGN_BACKWARDS)
2561 sv_catpv(tmpsv, ",BACKWARDS");
2563 else if (o->op_type == OP_TRANS) {
2564 if (o->op_private & OPpTRANS_SQUASH)
2565 sv_catpv(tmpsv, ",SQUASH");
2566 if (o->op_private & OPpTRANS_DELETE)
2567 sv_catpv(tmpsv, ",DELETE");
2568 if (o->op_private & OPpTRANS_COMPLEMENT)
2569 sv_catpv(tmpsv, ",COMPLEMENT");
2570 if (o->op_private & OPpTRANS_IDENTICAL)
2571 sv_catpv(tmpsv, ",IDENTICAL");
2572 if (o->op_private & OPpTRANS_GROWS)
2573 sv_catpv(tmpsv, ",GROWS");
2575 else if (o->op_type == OP_REPEAT) {
2576 if (o->op_private & OPpREPEAT_DOLIST)
2577 sv_catpv(tmpsv, ",DOLIST");
2579 else if (o->op_type == OP_ENTERSUB ||
2580 o->op_type == OP_RV2SV ||
2581 o->op_type == OP_GVSV ||
2582 o->op_type == OP_RV2AV ||
2583 o->op_type == OP_RV2HV ||
2584 o->op_type == OP_RV2GV ||
2585 o->op_type == OP_AELEM ||
2586 o->op_type == OP_HELEM )
2588 if (o->op_type == OP_ENTERSUB) {
2589 if (o->op_private & OPpENTERSUB_AMPER)
2590 sv_catpv(tmpsv, ",AMPER");
2591 if (o->op_private & OPpENTERSUB_DB)
2592 sv_catpv(tmpsv, ",DB");
2593 if (o->op_private & OPpENTERSUB_HASTARG)
2594 sv_catpv(tmpsv, ",HASTARG");
2595 if (o->op_private & OPpENTERSUB_NOPAREN)
2596 sv_catpv(tmpsv, ",NOPAREN");
2597 if (o->op_private & OPpENTERSUB_INARGS)
2598 sv_catpv(tmpsv, ",INARGS");
2599 if (o->op_private & OPpENTERSUB_NOMOD)
2600 sv_catpv(tmpsv, ",NOMOD");
2603 switch (o->op_private & OPpDEREF) {
2605 sv_catpv(tmpsv, ",SV");
2608 sv_catpv(tmpsv, ",AV");
2611 sv_catpv(tmpsv, ",HV");
2614 if (o->op_private & OPpMAYBE_LVSUB)
2615 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2617 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2618 if (o->op_private & OPpLVAL_DEFER)
2619 sv_catpv(tmpsv, ",LVAL_DEFER");
2622 if (o->op_private & HINT_STRICT_REFS)
2623 sv_catpv(tmpsv, ",STRICT_REFS");
2624 if (o->op_private & OPpOUR_INTRO)
2625 sv_catpv(tmpsv, ",OUR_INTRO");
2628 else if (o->op_type == OP_CONST) {
2629 if (o->op_private & OPpCONST_BARE)
2630 sv_catpv(tmpsv, ",BARE");
2631 if (o->op_private & OPpCONST_STRICT)
2632 sv_catpv(tmpsv, ",STRICT");
2633 if (o->op_private & OPpCONST_ARYBASE)
2634 sv_catpv(tmpsv, ",ARYBASE");
2635 if (o->op_private & OPpCONST_WARNING)
2636 sv_catpv(tmpsv, ",WARNING");
2637 if (o->op_private & OPpCONST_ENTERED)
2638 sv_catpv(tmpsv, ",ENTERED");
2640 else if (o->op_type == OP_FLIP) {
2641 if (o->op_private & OPpFLIP_LINENUM)
2642 sv_catpv(tmpsv, ",LINENUM");
2644 else if (o->op_type == OP_FLOP) {
2645 if (o->op_private & OPpFLIP_LINENUM)
2646 sv_catpv(tmpsv, ",LINENUM");
2648 else if (o->op_type == OP_RV2CV) {
2649 if (o->op_private & OPpLVAL_INTRO)
2650 sv_catpv(tmpsv, ",INTRO");
2652 else if (o->op_type == OP_GV) {
2653 if (o->op_private & OPpEARLY_CV)
2654 sv_catpv(tmpsv, ",EARLY_CV");
2656 else if (o->op_type == OP_LIST) {
2657 if (o->op_private & OPpLIST_GUESSED)
2658 sv_catpv(tmpsv, ",GUESSED");
2660 else if (o->op_type == OP_DELETE) {
2661 if (o->op_private & OPpSLICE)
2662 sv_catpv(tmpsv, ",SLICE");
2664 else if (o->op_type == OP_EXISTS) {
2665 if (o->op_private & OPpEXISTS_SUB)
2666 sv_catpv(tmpsv, ",EXISTS_SUB");
2668 else if (o->op_type == OP_SORT) {
2669 if (o->op_private & OPpSORT_NUMERIC)
2670 sv_catpv(tmpsv, ",NUMERIC");
2671 if (o->op_private & OPpSORT_INTEGER)
2672 sv_catpv(tmpsv, ",INTEGER");
2673 if (o->op_private & OPpSORT_REVERSE)
2674 sv_catpv(tmpsv, ",REVERSE");
2676 else if (o->op_type == OP_THREADSV) {
2677 if (o->op_private & OPpDONE_SVREF)
2678 sv_catpv(tmpsv, ",SVREF");
2680 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2681 if (o->op_private & OPpOPEN_IN_RAW)
2682 sv_catpv(tmpsv, ",IN_RAW");
2683 if (o->op_private & OPpOPEN_IN_CRLF)
2684 sv_catpv(tmpsv, ",IN_CRLF");
2685 if (o->op_private & OPpOPEN_OUT_RAW)
2686 sv_catpv(tmpsv, ",OUT_RAW");
2687 if (o->op_private & OPpOPEN_OUT_CRLF)
2688 sv_catpv(tmpsv, ",OUT_CRLF");
2690 else if (o->op_type == OP_EXIT) {
2691 if (o->op_private & OPpEXIT_VMSISH)
2692 sv_catpv(tmpsv, ",EXIT_VMSISH");
2693 if (o->op_private & OPpHUSH_VMSISH)
2694 sv_catpv(tmpsv, ",HUSH_VMSISH");
2696 else if (o->op_type == OP_DIE) {
2697 if (o->op_private & OPpHUSH_VMSISH)
2698 sv_catpv(tmpsv, ",HUSH_VMSISH");
2700 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2701 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2702 sv_catpv(tmpsv, ",FT_ACCESS");
2703 if (o->op_private & OPpFT_STACKED)
2704 sv_catpv(tmpsv, ",FT_STACKED");
2706 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2707 sv_catpv(tmpsv, ",INTRO");
2709 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2710 SvREFCNT_dec(tmpsv);
2713 switch (o->op_type) {
2715 if (o->op_flags & OPf_SPECIAL) {
2721 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2723 if (cSVOPo->op_sv) {
2724 SV *tmpsv1 = newSV(0);
2725 SV *tmpsv2 = newSV(0);
2733 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2734 s = SvPV(tmpsv1,len);
2735 sv_catxmlpvn(tmpsv2, s, len, 1);
2736 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2740 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2744 case OP_METHOD_NAMED:
2745 #ifndef USE_ITHREADS
2746 /* with ITHREADS, consts are stored in the pad, and the right pad
2747 * may not be active here, so skip */
2748 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2754 PerlIO_printf(file, ">\n");
2756 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2762 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2763 (UV)CopLINE(cCOPo));
2764 if (CopSTASHPV(cCOPo))
2765 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2767 if (cCOPo->cop_label)
2768 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2772 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2773 if (cLOOPo->op_redoop)
2774 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2776 PerlIO_printf(file, "DONE\"");
2777 S_xmldump_attr(aTHX_ level, file, "next=\"");
2778 if (cLOOPo->op_nextop)
2779 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2781 PerlIO_printf(file, "DONE\"");
2782 S_xmldump_attr(aTHX_ level, file, "last=\"");
2783 if (cLOOPo->op_lastop)
2784 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2786 PerlIO_printf(file, "DONE\"");
2794 S_xmldump_attr(aTHX_ level, file, "other=\"");
2795 if (cLOGOPo->op_other)
2796 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2798 PerlIO_printf(file, "DONE\"");
2806 if (o->op_private & OPpREFCOUNTED)
2807 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2813 if (PL_madskills && o->op_madprop) {
2814 SV *tmpsv = newSVpvn("", 0);
2815 MADPROP* mp = o->op_madprop;
2816 sv_utf8_upgrade(tmpsv);
2819 PerlIO_printf(file, ">\n");
2821 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2824 char tmp = mp->mad_key;
2825 sv_setpvn(tmpsv,"\"",1);
2827 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2828 sv_catpv(tmpsv, "\"");
2829 switch (mp->mad_type) {
2831 sv_catpv(tmpsv, "NULL");
2832 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2835 sv_catpv(tmpsv, " val=\"");
2836 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2837 sv_catpv(tmpsv, "\"");
2838 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2841 sv_catpv(tmpsv, " val=\"");
2842 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2843 sv_catpv(tmpsv, "\"");
2844 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2847 if ((OP*)mp->mad_val) {
2848 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2849 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2850 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2854 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2860 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2862 SvREFCNT_dec(tmpsv);
2865 switch (o->op_type) {
2872 PerlIO_printf(file, ">\n");
2874 do_pmop_xmldump(level, file, cPMOPo);
2880 if (o->op_flags & OPf_KIDS) {
2884 PerlIO_printf(file, ">\n");
2886 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2887 do_op_xmldump(level, file, kid);
2891 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2893 PerlIO_printf(file, " />\n");
2897 Perl_op_xmldump(pTHX_ const OP *o)
2899 do_op_xmldump(0, PL_xmlfp, o);
2905 * c-indentation-style: bsd
2907 * indent-tabs-mode: t
2910 * ex: set ts=8 sts=4 sw=4 noet: