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_regdata_names, "regdata_names(+)" },
1131 { PERL_MAGIC_pos, "pos(.)" },
1132 { PERL_MAGIC_symtab, "symtab(:)" },
1133 { PERL_MAGIC_backref, "backref(<)" },
1134 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1135 { PERL_MAGIC_overload, "overload(A)" },
1136 { PERL_MAGIC_bm, "bm(B)" },
1137 { PERL_MAGIC_regdata, "regdata(D)" },
1138 { PERL_MAGIC_env, "env(E)" },
1139 { PERL_MAGIC_hints, "hints(H)" },
1140 { PERL_MAGIC_isa, "isa(I)" },
1141 { PERL_MAGIC_dbfile, "dbfile(L)" },
1142 { PERL_MAGIC_shared, "shared(N)" },
1143 { PERL_MAGIC_tied, "tied(P)" },
1144 { PERL_MAGIC_sig, "sig(S)" },
1145 { PERL_MAGIC_uvar, "uvar(U)" },
1146 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1147 { PERL_MAGIC_overload_table, "overload_table(c)" },
1148 { PERL_MAGIC_regdatum, "regdatum(d)" },
1149 { PERL_MAGIC_envelem, "envelem(e)" },
1150 { PERL_MAGIC_fm, "fm(f)" },
1151 { PERL_MAGIC_regex_global, "regex_global(g)" },
1152 { PERL_MAGIC_hintselem, "hintselem(h)" },
1153 { PERL_MAGIC_isaelem, "isaelem(i)" },
1154 { PERL_MAGIC_nkeys, "nkeys(k)" },
1155 { PERL_MAGIC_dbline, "dbline(l)" },
1156 { PERL_MAGIC_mutex, "mutex(m)" },
1157 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1158 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1159 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1160 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1161 { PERL_MAGIC_qr, "qr(r)" },
1162 { PERL_MAGIC_sigelem, "sigelem(s)" },
1163 { PERL_MAGIC_taint, "taint(t)" },
1164 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1165 { PERL_MAGIC_vec, "vec(v)" },
1166 { PERL_MAGIC_vstring, "vstring(V)" },
1167 { PERL_MAGIC_utf8, "utf8(w)" },
1168 { PERL_MAGIC_substr, "substr(x)" },
1169 { PERL_MAGIC_defelem, "defelem(y)" },
1170 { PERL_MAGIC_ext, "ext(~)" },
1171 /* this null string terminates the list */
1176 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1178 for (; mg; mg = mg->mg_moremagic) {
1179 Perl_dump_indent(aTHX_ level, file,
1180 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1181 if (mg->mg_virtual) {
1182 const MGVTBL * const v = mg->mg_virtual;
1184 if (v == &PL_vtbl_sv) s = "sv";
1185 else if (v == &PL_vtbl_env) s = "env";
1186 else if (v == &PL_vtbl_envelem) s = "envelem";
1187 else if (v == &PL_vtbl_sig) s = "sig";
1188 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1189 else if (v == &PL_vtbl_pack) s = "pack";
1190 else if (v == &PL_vtbl_packelem) s = "packelem";
1191 else if (v == &PL_vtbl_dbline) s = "dbline";
1192 else if (v == &PL_vtbl_isa) s = "isa";
1193 else if (v == &PL_vtbl_arylen) s = "arylen";
1194 else if (v == &PL_vtbl_mglob) s = "mglob";
1195 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1196 else if (v == &PL_vtbl_taint) s = "taint";
1197 else if (v == &PL_vtbl_substr) s = "substr";
1198 else if (v == &PL_vtbl_vec) s = "vec";
1199 else if (v == &PL_vtbl_pos) s = "pos";
1200 else if (v == &PL_vtbl_bm) s = "bm";
1201 else if (v == &PL_vtbl_fm) s = "fm";
1202 else if (v == &PL_vtbl_uvar) s = "uvar";
1203 else if (v == &PL_vtbl_defelem) s = "defelem";
1204 #ifdef USE_LOCALE_COLLATE
1205 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1207 else if (v == &PL_vtbl_amagic) s = "amagic";
1208 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1209 else if (v == &PL_vtbl_backref) s = "backref";
1210 else if (v == &PL_vtbl_utf8) s = "utf8";
1211 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1212 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1215 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1217 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1220 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1223 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1227 const char *name = NULL;
1228 for (n = 0; magic_names[n].name; n++) {
1229 if (mg->mg_type == magic_names[n].type) {
1230 name = magic_names[n].name;
1235 Perl_dump_indent(aTHX_ level, file,
1236 " MG_TYPE = PERL_MAGIC_%s\n", name);
1238 Perl_dump_indent(aTHX_ level, file,
1239 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1243 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1244 if (mg->mg_type == PERL_MAGIC_envelem &&
1245 mg->mg_flags & MGf_TAINTEDDIR)
1246 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1247 if (mg->mg_flags & MGf_REFCOUNTED)
1248 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1249 if (mg->mg_flags & MGf_GSKIP)
1250 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1251 if (mg->mg_type == PERL_MAGIC_regex_global &&
1252 mg->mg_flags & MGf_MINMATCH)
1253 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1256 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1257 if (mg->mg_flags & MGf_REFCOUNTED)
1258 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1261 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1263 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1264 if (mg->mg_len >= 0) {
1265 if (mg->mg_type != PERL_MAGIC_utf8) {
1266 SV *sv = newSVpvs("");
1267 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1271 else if (mg->mg_len == HEf_SVKEY) {
1272 PerlIO_puts(file, " => HEf_SVKEY\n");
1273 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1277 PerlIO_puts(file, " ???? - please notify IZ");
1278 PerlIO_putc(file, '\n');
1280 if (mg->mg_type == PERL_MAGIC_utf8) {
1281 STRLEN *cache = (STRLEN *) mg->mg_ptr;
1284 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1285 Perl_dump_indent(aTHX_ level, file,
1286 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1289 (UV)cache[i * 2 + 1]);
1296 Perl_magic_dump(pTHX_ const MAGIC *mg)
1298 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1302 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1305 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1306 if (sv && (hvname = HvNAME_get(sv)))
1307 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1309 PerlIO_putc(file, '\n');
1313 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1315 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1316 if (sv && GvNAME(sv))
1317 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1319 PerlIO_putc(file, '\n');
1323 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1325 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1326 if (sv && GvNAME(sv)) {
1328 PerlIO_printf(file, "\t\"");
1329 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1330 PerlIO_printf(file, "%s\" :: \"", hvname);
1331 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1334 PerlIO_putc(file, '\n');
1338 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1347 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1351 flags = SvFLAGS(sv);
1354 d = Perl_newSVpvf(aTHX_
1355 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1356 PTR2UV(SvANY(sv)), PTR2UV(sv),
1357 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1358 (int)(PL_dumpindent*level), "");
1360 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1361 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1362 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1363 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1364 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1365 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1366 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1367 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1369 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1370 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1371 if (flags & SVf_POK) sv_catpv(d, "POK,");
1372 if (flags & SVf_ROK) {
1373 sv_catpv(d, "ROK,");
1374 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1376 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1377 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1378 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1380 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1381 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1382 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1383 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1384 if (flags & SVp_SCREAM && type != SVt_PVHV)
1385 sv_catpv(d, "SCREAM,");
1390 if (CvANON(sv)) sv_catpv(d, "ANON,");
1391 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1392 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1393 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1394 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1395 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1396 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1397 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1398 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1399 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1400 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1401 if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
1404 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1405 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1406 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1407 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1408 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1412 if (isGV_with_GP(sv)) {
1413 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1414 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1415 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1416 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1417 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1419 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1420 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1421 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1422 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1423 sv_catpv(d, "IMPORT");
1424 if (GvIMPORTED(sv) == GVf_IMPORTED)
1425 sv_catpv(d, "ALL,");
1428 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1429 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1430 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1431 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1437 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1438 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1441 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1442 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1445 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1450 /* SVphv_SHAREKEYS is also 0x20000000 */
1451 if ((type != SVt_PVHV) && SvUTF8(sv))
1452 sv_catpv(d, "UTF8");
1454 if (*(SvEND(d) - 1) == ',') {
1455 SvCUR_set(d, SvCUR(d) - 1);
1456 SvPVX(d)[SvCUR(d)] = '\0';
1461 #ifdef DEBUG_LEAKING_SCALARS
1462 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1463 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1465 sv->sv_debug_inpad ? "for" : "by",
1466 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1467 sv->sv_debug_cloned ? " (cloned)" : "");
1469 Perl_dump_indent(aTHX_ level, file, "SV = ");
1472 PerlIO_printf(file, "NULL%s\n", s);
1476 PerlIO_printf(file, "IV%s\n", s);
1479 PerlIO_printf(file, "NV%s\n", s);
1482 PerlIO_printf(file, "RV%s\n", s);
1485 PerlIO_printf(file, "PV%s\n", s);
1488 PerlIO_printf(file, "PVIV%s\n", s);
1491 PerlIO_printf(file, "PVNV%s\n", s);
1494 PerlIO_printf(file, "PVBM%s\n", s);
1497 PerlIO_printf(file, "PVMG%s\n", s);
1500 PerlIO_printf(file, "PVLV%s\n", s);
1503 PerlIO_printf(file, "PVAV%s\n", s);
1506 PerlIO_printf(file, "PVHV%s\n", s);
1509 PerlIO_printf(file, "PVCV%s\n", s);
1512 PerlIO_printf(file, "PVGV%s\n", s);
1515 PerlIO_printf(file, "PVFM%s\n", s);
1518 PerlIO_printf(file, "PVIO%s\n", s);
1521 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1525 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1526 && type != SVt_PVCV && !isGV_with_GP(sv))
1527 || type == SVt_IV) {
1529 #ifdef PERL_OLD_COPY_ON_WRITE
1533 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1535 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1537 PerlIO_printf(file, " (OFFSET)");
1538 #ifdef PERL_OLD_COPY_ON_WRITE
1539 if (SvIsCOW_shared_hash(sv))
1540 PerlIO_printf(file, " (HASH)");
1541 else if (SvIsCOW_normal(sv))
1542 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1544 PerlIO_putc(file, '\n');
1546 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1547 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
1548 || type == SVt_NV) {
1549 STORE_NUMERIC_LOCAL_SET_STANDARD();
1550 /* %Vg doesn't work? --jhi */
1551 #ifdef USE_LONG_DOUBLE
1552 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1554 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1556 RESTORE_NUMERIC_LOCAL();
1559 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1561 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1563 if (type < SVt_PV) {
1567 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1568 if (SvPVX_const(sv)) {
1569 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1571 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1572 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1573 if (SvUTF8(sv)) /* the 8? \x{....} */
1574 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1575 PerlIO_printf(file, "\n");
1576 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1577 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1580 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1582 if (type >= SVt_PVMG) {
1584 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1586 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1590 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1591 if (AvARRAY(sv) != AvALLOC(sv)) {
1592 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1593 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1596 PerlIO_putc(file, '\n');
1597 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1598 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1599 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1600 sv_setpvn(d, "", 0);
1601 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1602 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1603 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1604 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1605 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1607 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1608 SV** elt = av_fetch((AV*)sv,count,0);
1610 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1612 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1617 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1618 if (HvARRAY(sv) && HvKEYS(sv)) {
1619 /* Show distribution of HEs in the ARRAY */
1621 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1624 U32 pow2 = 2, keys = HvKEYS(sv);
1625 NV theoret, sum = 0;
1627 PerlIO_printf(file, " (");
1628 Zero(freq, FREQ_MAX + 1, int);
1629 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1632 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1634 if (count > FREQ_MAX)
1640 for (i = 0; i <= max; i++) {
1642 PerlIO_printf(file, "%d%s:%d", i,
1643 (i == FREQ_MAX) ? "+" : "",
1646 PerlIO_printf(file, ", ");
1649 PerlIO_putc(file, ')');
1650 /* The "quality" of a hash is defined as the total number of
1651 comparisons needed to access every element once, relative
1652 to the expected number needed for a random hash.
1654 The total number of comparisons is equal to the sum of
1655 the squares of the number of entries in each bucket.
1656 For a random hash of n keys into k buckets, the expected
1661 for (i = max; i > 0; i--) { /* Precision: count down. */
1662 sum += freq[i] * i * i;
1664 while ((keys = keys >> 1))
1666 theoret = HvKEYS(sv);
1667 theoret += theoret * (theoret-1)/pow2;
1668 PerlIO_putc(file, '\n');
1669 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1671 PerlIO_putc(file, '\n');
1672 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1673 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1674 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1675 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1676 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1678 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1679 if (mg && mg->mg_obj) {
1680 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1684 const char * const hvname = HvNAME_get(sv);
1686 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1689 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1691 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1693 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1697 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1699 HV * const hv = (HV*)sv;
1700 int count = maxnest - nest;
1703 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1708 const U32 hash = HeHASH(he);
1710 keysv = hv_iterkeysv(he);
1711 keypv = SvPV_const(keysv, len);
1712 elt = hv_iterval(hv, he);
1713 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1715 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1717 PerlIO_printf(file, "[REHASH] ");
1718 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1719 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1721 hv_iterinit(hv); /* Return to status quo */
1727 const char *const proto = SvPV_const(sv, len);
1728 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1733 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1734 if (!CvISXSUB(sv)) {
1736 Perl_dump_indent(aTHX_ level, file,
1737 " START = 0x%"UVxf" ===> %"IVdf"\n",
1738 PTR2UV(CvSTART(sv)),
1739 (IV)sequence_num(CvSTART(sv)));
1741 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1742 PTR2UV(CvROOT(sv)));
1743 if (CvROOT(sv) && dumpops) {
1744 do_op_dump(level+1, file, CvROOT(sv));
1747 SV *constant = cv_const_sv((CV *)sv);
1749 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1752 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1754 PTR2UV(CvXSUBANY(sv).any_ptr));
1755 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1758 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1759 (IV)CvXSUBANY(sv).any_i32);
1762 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1763 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1764 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1765 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1766 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1767 if (type == SVt_PVFM)
1768 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1769 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1770 if (nest < maxnest) {
1771 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1774 const CV * const outside = CvOUTSIDE(sv);
1775 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1778 : CvANON(outside) ? "ANON"
1779 : (outside == PL_main_cv) ? "MAIN"
1780 : CvUNIQUE(outside) ? "UNIQUE"
1781 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1783 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1784 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1788 if (type == SVt_PVLV) {
1789 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1790 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1791 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1792 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1793 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1794 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1797 if (!isGV_with_GP(sv))
1799 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1800 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1801 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1802 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1805 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1806 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1807 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1808 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1809 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1810 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1811 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1812 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1813 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1814 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1815 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1816 do_gv_dump (level, file, " EGV", GvEGV(sv));
1819 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1820 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1821 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1822 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1823 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1824 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1825 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1827 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1828 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1829 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1831 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1832 PTR2UV(IoTOP_GV(sv)));
1833 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1836 /* Source filters hide things that are not GVs in these three, so let's
1837 be careful out there. */
1839 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1840 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1841 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1843 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1844 PTR2UV(IoFMT_GV(sv)));
1845 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1848 if (IoBOTTOM_NAME(sv))
1849 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1850 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1851 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1853 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1854 PTR2UV(IoBOTTOM_GV(sv)));
1855 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1858 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1859 if (isPRINT(IoTYPE(sv)))
1860 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1862 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1863 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1870 Perl_sv_dump(pTHX_ SV *sv)
1873 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1877 Perl_runops_debug(pTHX)
1881 if (ckWARN_d(WARN_DEBUGGING))
1882 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1886 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1890 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1891 PerlIO_printf(Perl_debug_log,
1892 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1893 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1894 PTR2UV(*PL_watchaddr));
1895 if (DEBUG_s_TEST_) {
1896 if (DEBUG_v_TEST_) {
1897 PerlIO_printf(Perl_debug_log, "\n");
1905 if (DEBUG_t_TEST_) debop(PL_op);
1906 if (DEBUG_P_TEST_) debprof(PL_op);
1908 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1909 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1916 Perl_debop(pTHX_ const OP *o)
1919 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1922 Perl_deb(aTHX_ "%s", OP_NAME(o));
1923 switch (o->op_type) {
1925 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1930 SV * const sv = newSV(0);
1932 /* FIXME - it this making unwarranted assumptions about the
1933 UTF-8 cleanliness of the dump file handle? */
1936 gv_fullname3(sv, cGVOPo_gv, NULL);
1937 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1941 PerlIO_printf(Perl_debug_log, "(NULL)");
1947 /* print the lexical's name */
1948 CV * const cv = deb_curcv(cxstack_ix);
1951 AV * const padlist = CvPADLIST(cv);
1952 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1953 sv = *av_fetch(comppad, o->op_targ, FALSE);
1957 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1959 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1965 PerlIO_printf(Perl_debug_log, "\n");
1970 S_deb_curcv(pTHX_ I32 ix)
1973 const PERL_CONTEXT * const cx = &cxstack[ix];
1974 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1975 return cx->blk_sub.cv;
1976 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1978 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1983 return deb_curcv(ix - 1);
1987 Perl_watch(pTHX_ char **addr)
1990 PL_watchaddr = addr;
1992 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1993 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1997 S_debprof(pTHX_ const OP *o)
2000 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2002 if (!PL_profiledata)
2003 Newxz(PL_profiledata, MAXO, U32);
2004 ++PL_profiledata[o->op_type];
2008 Perl_debprofdump(pTHX)
2012 if (!PL_profiledata)
2014 for (i = 0; i < MAXO; i++) {
2015 if (PL_profiledata[i])
2016 PerlIO_printf(Perl_debug_log,
2017 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2024 * XML variants of most of the above routines
2029 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2032 PerlIO_printf(file, "\n ");
2033 va_start(args, pat);
2034 xmldump_vindent(level, file, pat, &args);
2040 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2043 va_start(args, pat);
2044 xmldump_vindent(level, file, pat, &args);
2049 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2051 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2052 PerlIO_vprintf(file, pat, *args);
2056 Perl_xmldump_all(pTHX)
2058 PerlIO_setlinebuf(PL_xmlfp);
2060 op_xmldump(PL_main_root);
2061 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2062 PerlIO_close(PL_xmlfp);
2067 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2072 if (!HvARRAY(stash))
2074 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2075 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2076 GV *gv = (GV*)HeVAL(entry);
2078 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2084 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2085 && (hv = GvHV(gv)) && hv != PL_defstash)
2086 xmldump_packsubs(hv); /* nested package */
2092 Perl_xmldump_sub(pTHX_ const GV *gv)
2094 SV *sv = sv_newmortal();
2096 gv_fullname3(sv, gv, Nullch);
2097 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2098 if (CvXSUB(GvCV(gv)))
2099 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2100 PTR2UV(CvXSUB(GvCV(gv))),
2101 (int)CvXSUBANY(GvCV(gv)).any_i32);
2102 else if (CvROOT(GvCV(gv)))
2103 op_xmldump(CvROOT(GvCV(gv)));
2105 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2109 Perl_xmldump_form(pTHX_ const GV *gv)
2111 SV *sv = sv_newmortal();
2113 gv_fullname3(sv, gv, Nullch);
2114 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2115 if (CvROOT(GvFORM(gv)))
2116 op_xmldump(CvROOT(GvFORM(gv)));
2118 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2122 Perl_xmldump_eval(pTHX)
2124 op_xmldump(PL_eval_root);
2128 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2130 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2134 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2142 sv_catpvn(dsv,"",0);
2143 dsvcur = SvCUR(dsv); /* in case we have to restart */
2148 c = utf8_to_uvchr((U8*)pv, &cl);
2150 SvCUR(dsv) = dsvcur;
2215 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2218 Perl_sv_catpvf(aTHX_ dsv, "<");
2221 Perl_sv_catpvf(aTHX_ dsv, ">");
2224 Perl_sv_catpvf(aTHX_ dsv, "&");
2227 Perl_sv_catpvf(aTHX_ dsv, """);
2231 if (c < 32 || c > 127) {
2232 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2235 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2239 if ((c >= 0xD800 && c <= 0xDB7F) ||
2240 (c >= 0xDC00 && c <= 0xDFFF) ||
2241 (c >= 0xFFF0 && c <= 0xFFFF) ||
2243 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2245 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2258 Perl_sv_xmlpeek(pTHX_ SV *sv)
2260 SV *t = sv_newmortal();
2265 sv_setpvn(t, "", 0);
2268 sv_catpv(t, "VOID=\"\"");
2271 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2272 sv_catpv(t, "WILD=\"\"");
2275 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2276 if (sv == &PL_sv_undef) {
2277 sv_catpv(t, "SV_UNDEF=\"1\"");
2278 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2279 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2283 else if (sv == &PL_sv_no) {
2284 sv_catpv(t, "SV_NO=\"1\"");
2285 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2286 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2287 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2288 SVp_POK|SVp_NOK)) &&
2293 else if (sv == &PL_sv_yes) {
2294 sv_catpv(t, "SV_YES=\"1\"");
2295 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2296 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2297 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2298 SVp_POK|SVp_NOK)) &&
2300 SvPVX(sv) && *SvPVX(sv) == '1' &&
2305 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2306 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2307 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2311 sv_catpv(t, " XXX=\"\" ");
2313 else if (SvREFCNT(sv) == 0) {
2314 sv_catpv(t, " refcnt=\"0\"");
2317 else if (DEBUG_R_TEST_) {
2320 /* is this SV on the tmps stack? */
2321 for (ix=PL_tmps_ix; ix>=0; ix--) {
2322 if (PL_tmps_stack[ix] == sv) {
2327 if (SvREFCNT(sv) > 1)
2328 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2331 sv_catpv(t, " DRT=\"<T>\"");
2335 sv_catpv(t, " ROK=\"\"");
2337 switch (SvTYPE(sv)) {
2339 sv_catpv(t, " FREED=\"1\"");
2343 sv_catpv(t, " UNDEF=\"1\"");
2346 sv_catpv(t, " IV=\"");
2349 sv_catpv(t, " NV=\"");
2352 sv_catpv(t, " RV=\"");
2355 sv_catpv(t, " PV=\"");
2358 sv_catpv(t, " PVIV=\"");
2361 sv_catpv(t, " PVNV=\"");
2364 sv_catpv(t, " PVMG=\"");
2367 sv_catpv(t, " PVLV=\"");
2370 sv_catpv(t, " AV=\"");
2373 sv_catpv(t, " HV=\"");
2377 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2379 sv_catpv(t, " CV=\"()\"");
2382 sv_catpv(t, " GV=\"");
2385 sv_catpv(t, " BM=\"");
2388 sv_catpv(t, " FM=\"");
2391 sv_catpv(t, " IO=\"");
2400 else if (SvNOKp(sv)) {
2401 STORE_NUMERIC_LOCAL_SET_STANDARD();
2402 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2403 RESTORE_NUMERIC_LOCAL();
2405 else if (SvIOKp(sv)) {
2407 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2409 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2420 return SvPV(t, n_a);
2424 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2427 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2430 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2433 char *s = PM_GETRE(pm)->precomp;
2434 SV *tmpsv = newSV(0);
2436 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2437 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2439 SvREFCNT_dec(tmpsv);
2440 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2441 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2444 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2445 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2446 SV * const tmpsv = pm_description(pm);
2447 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2448 SvREFCNT_dec(tmpsv);
2452 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
2453 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2454 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2455 do_op_xmldump(level+2, file, pm->op_pmreplroot);
2456 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2457 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2460 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2464 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2466 do_pmop_xmldump(0, PL_xmlfp, pm);
2470 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2477 seq = sequence_num(o);
2478 Perl_xmldump_indent(aTHX_ level, file,
2479 "<op_%s seq=\"%"UVuf" -> ",
2484 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2485 sequence_num(o->op_next));
2487 PerlIO_printf(file, "DONE\"");
2490 if (o->op_type == OP_NULL)
2492 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2493 if (o->op_targ == OP_NEXTSTATE)
2496 PerlIO_printf(file, " line=\"%"UVuf"\"",
2497 (UV)CopLINE(cCOPo));
2498 if (CopSTASHPV(cCOPo))
2499 PerlIO_printf(file, " package=\"%s\"",
2501 if (cCOPo->cop_label)
2502 PerlIO_printf(file, " label=\"%s\"",
2507 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2510 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2513 SV *tmpsv = newSVpvn("", 0);
2514 switch (o->op_flags & OPf_WANT) {
2516 sv_catpv(tmpsv, ",VOID");
2518 case OPf_WANT_SCALAR:
2519 sv_catpv(tmpsv, ",SCALAR");
2522 sv_catpv(tmpsv, ",LIST");
2525 sv_catpv(tmpsv, ",UNKNOWN");
2528 if (o->op_flags & OPf_KIDS)
2529 sv_catpv(tmpsv, ",KIDS");
2530 if (o->op_flags & OPf_PARENS)
2531 sv_catpv(tmpsv, ",PARENS");
2532 if (o->op_flags & OPf_STACKED)
2533 sv_catpv(tmpsv, ",STACKED");
2534 if (o->op_flags & OPf_REF)
2535 sv_catpv(tmpsv, ",REF");
2536 if (o->op_flags & OPf_MOD)
2537 sv_catpv(tmpsv, ",MOD");
2538 if (o->op_flags & OPf_SPECIAL)
2539 sv_catpv(tmpsv, ",SPECIAL");
2540 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2541 SvREFCNT_dec(tmpsv);
2543 if (o->op_private) {
2544 SV *tmpsv = newSVpvn("", 0);
2545 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2546 if (o->op_private & OPpTARGET_MY)
2547 sv_catpv(tmpsv, ",TARGET_MY");
2549 else if (o->op_type == OP_LEAVESUB ||
2550 o->op_type == OP_LEAVE ||
2551 o->op_type == OP_LEAVESUBLV ||
2552 o->op_type == OP_LEAVEWRITE) {
2553 if (o->op_private & OPpREFCOUNTED)
2554 sv_catpv(tmpsv, ",REFCOUNTED");
2556 else if (o->op_type == OP_AASSIGN) {
2557 if (o->op_private & OPpASSIGN_COMMON)
2558 sv_catpv(tmpsv, ",COMMON");
2560 else if (o->op_type == OP_SASSIGN) {
2561 if (o->op_private & OPpASSIGN_BACKWARDS)
2562 sv_catpv(tmpsv, ",BACKWARDS");
2564 else if (o->op_type == OP_TRANS) {
2565 if (o->op_private & OPpTRANS_SQUASH)
2566 sv_catpv(tmpsv, ",SQUASH");
2567 if (o->op_private & OPpTRANS_DELETE)
2568 sv_catpv(tmpsv, ",DELETE");
2569 if (o->op_private & OPpTRANS_COMPLEMENT)
2570 sv_catpv(tmpsv, ",COMPLEMENT");
2571 if (o->op_private & OPpTRANS_IDENTICAL)
2572 sv_catpv(tmpsv, ",IDENTICAL");
2573 if (o->op_private & OPpTRANS_GROWS)
2574 sv_catpv(tmpsv, ",GROWS");
2576 else if (o->op_type == OP_REPEAT) {
2577 if (o->op_private & OPpREPEAT_DOLIST)
2578 sv_catpv(tmpsv, ",DOLIST");
2580 else if (o->op_type == OP_ENTERSUB ||
2581 o->op_type == OP_RV2SV ||
2582 o->op_type == OP_GVSV ||
2583 o->op_type == OP_RV2AV ||
2584 o->op_type == OP_RV2HV ||
2585 o->op_type == OP_RV2GV ||
2586 o->op_type == OP_AELEM ||
2587 o->op_type == OP_HELEM )
2589 if (o->op_type == OP_ENTERSUB) {
2590 if (o->op_private & OPpENTERSUB_AMPER)
2591 sv_catpv(tmpsv, ",AMPER");
2592 if (o->op_private & OPpENTERSUB_DB)
2593 sv_catpv(tmpsv, ",DB");
2594 if (o->op_private & OPpENTERSUB_HASTARG)
2595 sv_catpv(tmpsv, ",HASTARG");
2596 if (o->op_private & OPpENTERSUB_NOPAREN)
2597 sv_catpv(tmpsv, ",NOPAREN");
2598 if (o->op_private & OPpENTERSUB_INARGS)
2599 sv_catpv(tmpsv, ",INARGS");
2600 if (o->op_private & OPpENTERSUB_NOMOD)
2601 sv_catpv(tmpsv, ",NOMOD");
2604 switch (o->op_private & OPpDEREF) {
2606 sv_catpv(tmpsv, ",SV");
2609 sv_catpv(tmpsv, ",AV");
2612 sv_catpv(tmpsv, ",HV");
2615 if (o->op_private & OPpMAYBE_LVSUB)
2616 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2618 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2619 if (o->op_private & OPpLVAL_DEFER)
2620 sv_catpv(tmpsv, ",LVAL_DEFER");
2623 if (o->op_private & HINT_STRICT_REFS)
2624 sv_catpv(tmpsv, ",STRICT_REFS");
2625 if (o->op_private & OPpOUR_INTRO)
2626 sv_catpv(tmpsv, ",OUR_INTRO");
2629 else if (o->op_type == OP_CONST) {
2630 if (o->op_private & OPpCONST_BARE)
2631 sv_catpv(tmpsv, ",BARE");
2632 if (o->op_private & OPpCONST_STRICT)
2633 sv_catpv(tmpsv, ",STRICT");
2634 if (o->op_private & OPpCONST_ARYBASE)
2635 sv_catpv(tmpsv, ",ARYBASE");
2636 if (o->op_private & OPpCONST_WARNING)
2637 sv_catpv(tmpsv, ",WARNING");
2638 if (o->op_private & OPpCONST_ENTERED)
2639 sv_catpv(tmpsv, ",ENTERED");
2641 else if (o->op_type == OP_FLIP) {
2642 if (o->op_private & OPpFLIP_LINENUM)
2643 sv_catpv(tmpsv, ",LINENUM");
2645 else if (o->op_type == OP_FLOP) {
2646 if (o->op_private & OPpFLIP_LINENUM)
2647 sv_catpv(tmpsv, ",LINENUM");
2649 else if (o->op_type == OP_RV2CV) {
2650 if (o->op_private & OPpLVAL_INTRO)
2651 sv_catpv(tmpsv, ",INTRO");
2653 else if (o->op_type == OP_GV) {
2654 if (o->op_private & OPpEARLY_CV)
2655 sv_catpv(tmpsv, ",EARLY_CV");
2657 else if (o->op_type == OP_LIST) {
2658 if (o->op_private & OPpLIST_GUESSED)
2659 sv_catpv(tmpsv, ",GUESSED");
2661 else if (o->op_type == OP_DELETE) {
2662 if (o->op_private & OPpSLICE)
2663 sv_catpv(tmpsv, ",SLICE");
2665 else if (o->op_type == OP_EXISTS) {
2666 if (o->op_private & OPpEXISTS_SUB)
2667 sv_catpv(tmpsv, ",EXISTS_SUB");
2669 else if (o->op_type == OP_SORT) {
2670 if (o->op_private & OPpSORT_NUMERIC)
2671 sv_catpv(tmpsv, ",NUMERIC");
2672 if (o->op_private & OPpSORT_INTEGER)
2673 sv_catpv(tmpsv, ",INTEGER");
2674 if (o->op_private & OPpSORT_REVERSE)
2675 sv_catpv(tmpsv, ",REVERSE");
2677 else if (o->op_type == OP_THREADSV) {
2678 if (o->op_private & OPpDONE_SVREF)
2679 sv_catpv(tmpsv, ",SVREF");
2681 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2682 if (o->op_private & OPpOPEN_IN_RAW)
2683 sv_catpv(tmpsv, ",IN_RAW");
2684 if (o->op_private & OPpOPEN_IN_CRLF)
2685 sv_catpv(tmpsv, ",IN_CRLF");
2686 if (o->op_private & OPpOPEN_OUT_RAW)
2687 sv_catpv(tmpsv, ",OUT_RAW");
2688 if (o->op_private & OPpOPEN_OUT_CRLF)
2689 sv_catpv(tmpsv, ",OUT_CRLF");
2691 else if (o->op_type == OP_EXIT) {
2692 if (o->op_private & OPpEXIT_VMSISH)
2693 sv_catpv(tmpsv, ",EXIT_VMSISH");
2694 if (o->op_private & OPpHUSH_VMSISH)
2695 sv_catpv(tmpsv, ",HUSH_VMSISH");
2697 else if (o->op_type == OP_DIE) {
2698 if (o->op_private & OPpHUSH_VMSISH)
2699 sv_catpv(tmpsv, ",HUSH_VMSISH");
2701 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2702 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2703 sv_catpv(tmpsv, ",FT_ACCESS");
2704 if (o->op_private & OPpFT_STACKED)
2705 sv_catpv(tmpsv, ",FT_STACKED");
2707 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2708 sv_catpv(tmpsv, ",INTRO");
2710 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2711 SvREFCNT_dec(tmpsv);
2714 switch (o->op_type) {
2716 if (o->op_flags & OPf_SPECIAL) {
2722 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2724 if (cSVOPo->op_sv) {
2725 SV *tmpsv1 = newSV(0);
2726 SV *tmpsv2 = newSV(0);
2734 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2735 s = SvPV(tmpsv1,len);
2736 sv_catxmlpvn(tmpsv2, s, len, 1);
2737 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2741 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2745 case OP_METHOD_NAMED:
2746 #ifndef USE_ITHREADS
2747 /* with ITHREADS, consts are stored in the pad, and the right pad
2748 * may not be active here, so skip */
2749 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2755 PerlIO_printf(file, ">\n");
2757 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2763 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2764 (UV)CopLINE(cCOPo));
2765 if (CopSTASHPV(cCOPo))
2766 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2768 if (cCOPo->cop_label)
2769 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2773 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2774 if (cLOOPo->op_redoop)
2775 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2777 PerlIO_printf(file, "DONE\"");
2778 S_xmldump_attr(aTHX_ level, file, "next=\"");
2779 if (cLOOPo->op_nextop)
2780 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2782 PerlIO_printf(file, "DONE\"");
2783 S_xmldump_attr(aTHX_ level, file, "last=\"");
2784 if (cLOOPo->op_lastop)
2785 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2787 PerlIO_printf(file, "DONE\"");
2795 S_xmldump_attr(aTHX_ level, file, "other=\"");
2796 if (cLOGOPo->op_other)
2797 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2799 PerlIO_printf(file, "DONE\"");
2807 if (o->op_private & OPpREFCOUNTED)
2808 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2814 if (PL_madskills && o->op_madprop) {
2815 SV *tmpsv = newSVpvn("", 0);
2816 MADPROP* mp = o->op_madprop;
2817 sv_utf8_upgrade(tmpsv);
2820 PerlIO_printf(file, ">\n");
2822 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2825 char tmp = mp->mad_key;
2826 sv_setpvn(tmpsv,"\"",1);
2828 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2829 sv_catpv(tmpsv, "\"");
2830 switch (mp->mad_type) {
2832 sv_catpv(tmpsv, "NULL");
2833 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2836 sv_catpv(tmpsv, " val=\"");
2837 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2838 sv_catpv(tmpsv, "\"");
2839 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2842 sv_catpv(tmpsv, " val=\"");
2843 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2844 sv_catpv(tmpsv, "\"");
2845 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2848 if ((OP*)mp->mad_val) {
2849 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2850 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2851 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2855 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2861 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2863 SvREFCNT_dec(tmpsv);
2866 switch (o->op_type) {
2873 PerlIO_printf(file, ">\n");
2875 do_pmop_xmldump(level, file, cPMOPo);
2881 if (o->op_flags & OPf_KIDS) {
2885 PerlIO_printf(file, ">\n");
2887 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2888 do_op_xmldump(level, file, kid);
2892 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2894 PerlIO_printf(file, " />\n");
2898 Perl_op_xmldump(pTHX_ const OP *o)
2900 do_op_xmldump(0, PL_xmlfp, o);
2906 * c-indentation-style: bsd
2908 * indent-tabs-mode: t
2911 * ex: set ts=8 sts=4 sw=4 noet: