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 static const char* const svtypenames[SVt_LAST] = {
50 static const char* const svshorttypenames[SVt_LAST] = {
69 #define Sequence PL_op_sequence
72 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
76 dump_vindent(level, file, pat, &args);
81 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
84 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
85 PerlIO_vprintf(file, pat, *args);
92 PerlIO_setlinebuf(Perl_debug_log);
94 op_dump(PL_main_root);
95 dump_packsubs(PL_defstash);
99 Perl_dump_packsubs(pTHX_ const HV *stash)
106 for (i = 0; i <= (I32) HvMAX(stash); i++) {
108 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
109 const GV *gv = (GV*)HeVAL(entry);
111 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
117 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
118 && (hv = GvHV(gv)) && hv != PL_defstash)
119 dump_packsubs(hv); /* nested package */
125 Perl_dump_sub(pTHX_ const GV *gv)
127 SV * const sv = sv_newmortal();
129 gv_fullname3(sv, gv, NULL);
130 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
131 if (CvISXSUB(GvCV(gv)))
132 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
133 PTR2UV(CvXSUB(GvCV(gv))),
134 (int)CvXSUBANY(GvCV(gv)).any_i32);
135 else if (CvROOT(GvCV(gv)))
136 op_dump(CvROOT(GvCV(gv)));
138 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
142 Perl_dump_form(pTHX_ const GV *gv)
144 SV * const sv = sv_newmortal();
146 gv_fullname3(sv, gv, NULL);
147 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
148 if (CvROOT(GvFORM(gv)))
149 op_dump(CvROOT(GvFORM(gv)));
151 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
158 op_dump(PL_eval_root);
163 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
164 |const STRLEN count|const STRLEN max
165 |STRLEN const *escaped, const U32 flags
167 Escapes at most the first "count" chars of pv and puts the results into
168 dsv such that the size of the escaped string will not exceed "max" chars
169 and will not contain any incomplete escape sequences.
171 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
172 will also be escaped.
174 Normally the SV will be cleared before the escaped string is prepared,
175 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
177 If PERL_PV_ESCAPE_UNI is set then the input string is treated as unicode,
178 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
179 using C<is_utf8_string()> to determine if it is unicode.
181 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
182 using C<\x01F1> style escapes, otherwise only chars above 255 will be
183 escaped using this style, other non printable chars will use octal or
184 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
185 then all chars below 255 will be treated as printable and
186 will be output as literals.
188 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
189 string will be escaped, regardles of max. If the string is utf8 and
190 the chars value is >255 then it will be returned as a plain hex
191 sequence. Thus the output will either be a single char,
192 an octal escape sequence, a special escape like C<\n> or a 3 or
193 more digit hex value.
195 Returns a pointer to the escaped text as held by dsv.
199 #define PV_ESCAPE_OCTBUFSIZE 32
202 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
203 const STRLEN count, const STRLEN max,
204 STRLEN * const escaped, const U32 flags )
206 char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
207 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
208 STRLEN wrote = 0; /* chars written so far */
209 STRLEN chsize = 0; /* size of data to be written */
210 STRLEN readsize = 1; /* size of data just read */
211 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
212 const char *pv = str;
213 const char *end = pv + count; /* end of string */
215 if (!flags & PERL_PV_ESCAPE_NOCLEAR)
216 sv_setpvn(dsv, "", 0);
218 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
221 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
222 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
223 const U8 c = (U8)u & 0xFF;
225 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
226 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
227 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
230 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
232 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
235 if ( (c == dq) || (c == '\\') || !isPRINT(c) ) {
238 case '\\' : octbuf[1] = '\\'; break;
239 case '\v' : octbuf[1] = 'v'; break;
240 case '\t' : octbuf[1] = 't'; break;
241 case '\r' : octbuf[1] = 'r'; break;
242 case '\n' : octbuf[1] = 'n'; break;
243 case '\f' : octbuf[1] = 'f'; break;
251 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
252 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
255 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
262 if ( max && (wrote + chsize > max) ) {
264 } else if (chsize > 1) {
265 sv_catpvn(dsv, octbuf, chsize);
268 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
271 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
279 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
280 |const STRLEN count|const STRLEN max\
281 |const char const *start_color| const char const *end_color\
284 Converts a string into something presentable, handling escaping via
285 pv_escape() and supporting quoting and elipses.
287 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
288 double quoted with any double quotes in the string escaped. Otherwise
289 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
292 If the PERL_PV_PRETTY_ELIPSES flag is set and not all characters in
293 string were output then an elipses C<...> will be appended to the
294 string. Note that this happens AFTER it has been quoted.
296 If start_color is non-null then it will be inserted after the opening
297 quote (if there is one) but before the escaped text. If end_color
298 is non-null then it will be inserted after the escaped text but before
299 any quotes or elipses.
301 Returns a pointer to the prettified text as held by dsv.
307 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
308 const STRLEN max, char const * const start_color, char const * const end_color,
311 U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
315 sv_setpvn(dsv, "\"", 1);
316 else if ( flags & PERL_PV_PRETTY_LTGT )
317 sv_setpvn(dsv, "<", 1);
319 sv_setpvn(dsv, "", 0);
321 if ( start_color != NULL )
322 Perl_sv_catpv( aTHX_ dsv, start_color);
324 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
326 if ( end_color != NULL )
327 Perl_sv_catpv( aTHX_ dsv, end_color);
330 sv_catpvn( dsv, "\"", 1 );
331 else if ( flags & PERL_PV_PRETTY_LTGT )
332 sv_catpvn( dsv, ">", 1);
334 if ( (flags & PERL_PV_PRETTY_ELIPSES) && ( escaped < count ) )
335 sv_catpvn( dsv, "...", 3 );
341 =for apidoc pv_display
343 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
344 STRLEN pvlim, U32 flags)
348 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
350 except that an additional "\0" will be appended to the string when
351 len > cur and pv[cur] is "\0".
353 Note that the final string may be up to 7 chars longer than pvlim.
359 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
361 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
362 if (len > cur && pv[cur] == '\0')
363 sv_catpvn( dsv, "\\0", 2 );
368 Perl_sv_peek(pTHX_ SV *sv)
371 SV * const t = sv_newmortal();
381 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
385 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
386 if (sv == &PL_sv_undef) {
387 sv_catpv(t, "SV_UNDEF");
388 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
389 SVs_GMG|SVs_SMG|SVs_RMG)) &&
393 else if (sv == &PL_sv_no) {
394 sv_catpv(t, "SV_NO");
395 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
396 SVs_GMG|SVs_SMG|SVs_RMG)) &&
397 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
403 else if (sv == &PL_sv_yes) {
404 sv_catpv(t, "SV_YES");
405 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
406 SVs_GMG|SVs_SMG|SVs_RMG)) &&
407 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
410 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
415 sv_catpv(t, "SV_PLACEHOLDER");
416 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
417 SVs_GMG|SVs_SMG|SVs_RMG)) &&
423 else if (SvREFCNT(sv) == 0) {
427 else if (DEBUG_R_TEST_) {
430 /* is this SV on the tmps stack? */
431 for (ix=PL_tmps_ix; ix>=0; ix--) {
432 if (PL_tmps_stack[ix] == sv) {
437 if (SvREFCNT(sv) > 1)
438 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
446 if (SvCUR(t) + unref > 10) {
447 SvCUR_set(t, unref + 3);
456 if (type == SVt_PVCV) {
457 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
459 } else if (type < SVt_LAST) {
460 sv_catpv(t, svshorttypenames[type]);
462 if (type == SVt_NULL)
465 sv_catpv(t, "FREED");
470 if (!SvPVX_const(sv))
471 sv_catpv(t, "(null)");
473 SV * const tmp = newSVpvs("");
476 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
477 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
479 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
480 sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv),
485 else if (SvNOKp(sv)) {
486 STORE_NUMERIC_LOCAL_SET_STANDARD();
487 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
488 RESTORE_NUMERIC_LOCAL();
490 else if (SvIOKp(sv)) {
492 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
494 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
504 return SvPV_nolen(t);
508 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
513 Perl_dump_indent(aTHX_ level, file, "{}\n");
516 Perl_dump_indent(aTHX_ level, file, "{\n");
518 if (pm->op_pmflags & PMf_ONCE)
523 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
524 ch, PM_GETRE(pm)->precomp, ch,
525 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
527 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
528 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
529 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
530 op_dump(pm->op_pmreplroot);
532 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
533 SV * const tmpsv = pm_description(pm);
534 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
538 Perl_dump_indent(aTHX_ level-1, file, "}\n");
542 S_pm_description(pTHX_ const PMOP *pm)
544 SV * const desc = newSVpvs("");
545 const REGEXP * regex = PM_GETRE(pm);
546 const U32 pmflags = pm->op_pmflags;
548 if (pm->op_pmdynflags & PMdf_USED)
549 sv_catpv(desc, ",USED");
550 if (pm->op_pmdynflags & PMdf_TAINTED)
551 sv_catpv(desc, ",TAINTED");
553 if (pmflags & PMf_ONCE)
554 sv_catpv(desc, ",ONCE");
555 if (regex && regex->check_substr) {
556 if (!(regex->extflags & RXf_NOSCAN))
557 sv_catpv(desc, ",SCANFIRST");
558 if (regex->extflags & RXf_CHECK_ALL)
559 sv_catpv(desc, ",ALL");
561 if (pmflags & PMf_SKIPWHITE)
562 sv_catpv(desc, ",SKIPWHITE");
563 if (pmflags & PMf_CONST)
564 sv_catpv(desc, ",CONST");
565 if (pmflags & PMf_KEEP)
566 sv_catpv(desc, ",KEEP");
567 if (pmflags & PMf_GLOBAL)
568 sv_catpv(desc, ",GLOBAL");
569 if (pmflags & PMf_CONTINUE)
570 sv_catpv(desc, ",CONTINUE");
571 if (pmflags & PMf_RETAINT)
572 sv_catpv(desc, ",RETAINT");
573 if (pmflags & PMf_EVAL)
574 sv_catpv(desc, ",EVAL");
579 Perl_pmop_dump(pTHX_ PMOP *pm)
581 do_pmop_dump(0, Perl_debug_log, pm);
584 /* An op sequencer. We visit the ops in the order they're to execute. */
587 S_sequence(pTHX_ register const OP *o)
590 const OP *oldop = NULL;
603 for (; o; o = o->op_next) {
605 SV * const op = newSVuv(PTR2UV(o));
606 const char * const key = SvPV_const(op, len);
608 if (hv_exists(Sequence, key, len))
611 switch (o->op_type) {
613 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
614 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
623 if (oldop && o->op_next)
630 if (oldop && o->op_next)
632 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
645 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
646 sequence_tail(cLOGOPo->op_other);
651 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
652 sequence_tail(cLOOPo->op_redoop);
653 sequence_tail(cLOOPo->op_nextop);
654 sequence_tail(cLOOPo->op_lastop);
660 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
661 sequence_tail(cPMOPo->op_pmreplstart);
668 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
676 S_sequence_tail(pTHX_ const OP *o)
678 while (o && (o->op_type == OP_NULL))
684 S_sequence_num(pTHX_ const OP *o)
692 op = newSVuv(PTR2UV(o));
693 key = SvPV_const(op, len);
694 seq = hv_fetch(Sequence, key, len, 0);
695 return seq ? SvUV(*seq): 0;
699 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
703 const OPCODE optype = o->op_type;
706 Perl_dump_indent(aTHX_ level, file, "{\n");
708 seq = sequence_num(o);
710 PerlIO_printf(file, "%-4"UVuf, seq);
712 PerlIO_printf(file, " ");
714 "%*sTYPE = %s ===> ",
715 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
717 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
718 sequence_num(o->op_next));
720 PerlIO_printf(file, "DONE\n");
722 if (optype == OP_NULL) {
723 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
724 if (o->op_targ == OP_NEXTSTATE) {
726 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
728 if (CopSTASHPV(cCOPo))
729 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
731 if (cCOPo->cop_label)
732 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
737 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
740 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
742 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
743 SV * const tmpsv = newSVpvs("");
744 switch (o->op_flags & OPf_WANT) {
746 sv_catpv(tmpsv, ",VOID");
748 case OPf_WANT_SCALAR:
749 sv_catpv(tmpsv, ",SCALAR");
752 sv_catpv(tmpsv, ",LIST");
755 sv_catpv(tmpsv, ",UNKNOWN");
758 if (o->op_flags & OPf_KIDS)
759 sv_catpv(tmpsv, ",KIDS");
760 if (o->op_flags & OPf_PARENS)
761 sv_catpv(tmpsv, ",PARENS");
762 if (o->op_flags & OPf_STACKED)
763 sv_catpv(tmpsv, ",STACKED");
764 if (o->op_flags & OPf_REF)
765 sv_catpv(tmpsv, ",REF");
766 if (o->op_flags & OPf_MOD)
767 sv_catpv(tmpsv, ",MOD");
768 if (o->op_flags & OPf_SPECIAL)
769 sv_catpv(tmpsv, ",SPECIAL");
771 sv_catpv(tmpsv, ",LATEFREE");
773 sv_catpv(tmpsv, ",LATEFREED");
775 sv_catpv(tmpsv, ",ATTACHED");
776 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
780 SV * const tmpsv = newSVpvs("");
781 if (PL_opargs[optype] & OA_TARGLEX) {
782 if (o->op_private & OPpTARGET_MY)
783 sv_catpv(tmpsv, ",TARGET_MY");
785 else if (optype == OP_LEAVESUB ||
786 optype == OP_LEAVE ||
787 optype == OP_LEAVESUBLV ||
788 optype == OP_LEAVEWRITE) {
789 if (o->op_private & OPpREFCOUNTED)
790 sv_catpv(tmpsv, ",REFCOUNTED");
792 else if (optype == OP_AASSIGN) {
793 if (o->op_private & OPpASSIGN_COMMON)
794 sv_catpv(tmpsv, ",COMMON");
796 else if (optype == OP_SASSIGN) {
797 if (o->op_private & OPpASSIGN_BACKWARDS)
798 sv_catpv(tmpsv, ",BACKWARDS");
800 else if (optype == OP_TRANS) {
801 if (o->op_private & OPpTRANS_SQUASH)
802 sv_catpv(tmpsv, ",SQUASH");
803 if (o->op_private & OPpTRANS_DELETE)
804 sv_catpv(tmpsv, ",DELETE");
805 if (o->op_private & OPpTRANS_COMPLEMENT)
806 sv_catpv(tmpsv, ",COMPLEMENT");
807 if (o->op_private & OPpTRANS_IDENTICAL)
808 sv_catpv(tmpsv, ",IDENTICAL");
809 if (o->op_private & OPpTRANS_GROWS)
810 sv_catpv(tmpsv, ",GROWS");
812 else if (optype == OP_REPEAT) {
813 if (o->op_private & OPpREPEAT_DOLIST)
814 sv_catpv(tmpsv, ",DOLIST");
816 else if (optype == OP_ENTERSUB ||
817 optype == OP_RV2SV ||
819 optype == OP_RV2AV ||
820 optype == OP_RV2HV ||
821 optype == OP_RV2GV ||
822 optype == OP_AELEM ||
825 if (optype == OP_ENTERSUB) {
826 if (o->op_private & OPpENTERSUB_AMPER)
827 sv_catpv(tmpsv, ",AMPER");
828 if (o->op_private & OPpENTERSUB_DB)
829 sv_catpv(tmpsv, ",DB");
830 if (o->op_private & OPpENTERSUB_HASTARG)
831 sv_catpv(tmpsv, ",HASTARG");
832 if (o->op_private & OPpENTERSUB_NOPAREN)
833 sv_catpv(tmpsv, ",NOPAREN");
834 if (o->op_private & OPpENTERSUB_INARGS)
835 sv_catpv(tmpsv, ",INARGS");
836 if (o->op_private & OPpENTERSUB_NOMOD)
837 sv_catpv(tmpsv, ",NOMOD");
840 switch (o->op_private & OPpDEREF) {
842 sv_catpv(tmpsv, ",SV");
845 sv_catpv(tmpsv, ",AV");
848 sv_catpv(tmpsv, ",HV");
851 if (o->op_private & OPpMAYBE_LVSUB)
852 sv_catpv(tmpsv, ",MAYBE_LVSUB");
854 if (optype == OP_AELEM || optype == OP_HELEM) {
855 if (o->op_private & OPpLVAL_DEFER)
856 sv_catpv(tmpsv, ",LVAL_DEFER");
859 if (o->op_private & HINT_STRICT_REFS)
860 sv_catpv(tmpsv, ",STRICT_REFS");
861 if (o->op_private & OPpOUR_INTRO)
862 sv_catpv(tmpsv, ",OUR_INTRO");
865 else if (optype == OP_CONST) {
866 if (o->op_private & OPpCONST_BARE)
867 sv_catpv(tmpsv, ",BARE");
868 if (o->op_private & OPpCONST_STRICT)
869 sv_catpv(tmpsv, ",STRICT");
870 if (o->op_private & OPpCONST_ARYBASE)
871 sv_catpv(tmpsv, ",ARYBASE");
872 if (o->op_private & OPpCONST_WARNING)
873 sv_catpv(tmpsv, ",WARNING");
874 if (o->op_private & OPpCONST_ENTERED)
875 sv_catpv(tmpsv, ",ENTERED");
877 else if (optype == OP_FLIP) {
878 if (o->op_private & OPpFLIP_LINENUM)
879 sv_catpv(tmpsv, ",LINENUM");
881 else if (optype == OP_FLOP) {
882 if (o->op_private & OPpFLIP_LINENUM)
883 sv_catpv(tmpsv, ",LINENUM");
885 else if (optype == OP_RV2CV) {
886 if (o->op_private & OPpLVAL_INTRO)
887 sv_catpv(tmpsv, ",INTRO");
889 else if (optype == OP_GV) {
890 if (o->op_private & OPpEARLY_CV)
891 sv_catpv(tmpsv, ",EARLY_CV");
893 else if (optype == OP_LIST) {
894 if (o->op_private & OPpLIST_GUESSED)
895 sv_catpv(tmpsv, ",GUESSED");
897 else if (optype == OP_DELETE) {
898 if (o->op_private & OPpSLICE)
899 sv_catpv(tmpsv, ",SLICE");
901 else if (optype == OP_EXISTS) {
902 if (o->op_private & OPpEXISTS_SUB)
903 sv_catpv(tmpsv, ",EXISTS_SUB");
905 else if (optype == OP_SORT) {
906 if (o->op_private & OPpSORT_NUMERIC)
907 sv_catpv(tmpsv, ",NUMERIC");
908 if (o->op_private & OPpSORT_INTEGER)
909 sv_catpv(tmpsv, ",INTEGER");
910 if (o->op_private & OPpSORT_REVERSE)
911 sv_catpv(tmpsv, ",REVERSE");
913 else if (optype == OP_THREADSV) {
914 if (o->op_private & OPpDONE_SVREF)
915 sv_catpv(tmpsv, ",SVREF");
917 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
918 if (o->op_private & OPpOPEN_IN_RAW)
919 sv_catpv(tmpsv, ",IN_RAW");
920 if (o->op_private & OPpOPEN_IN_CRLF)
921 sv_catpv(tmpsv, ",IN_CRLF");
922 if (o->op_private & OPpOPEN_OUT_RAW)
923 sv_catpv(tmpsv, ",OUT_RAW");
924 if (o->op_private & OPpOPEN_OUT_CRLF)
925 sv_catpv(tmpsv, ",OUT_CRLF");
927 else if (optype == OP_EXIT) {
928 if (o->op_private & OPpEXIT_VMSISH)
929 sv_catpv(tmpsv, ",EXIT_VMSISH");
930 if (o->op_private & OPpHUSH_VMSISH)
931 sv_catpv(tmpsv, ",HUSH_VMSISH");
933 else if (optype == OP_DIE) {
934 if (o->op_private & OPpHUSH_VMSISH)
935 sv_catpv(tmpsv, ",HUSH_VMSISH");
937 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
938 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
939 sv_catpv(tmpsv, ",FT_ACCESS");
940 if (o->op_private & OPpFT_STACKED)
941 sv_catpv(tmpsv, ",FT_STACKED");
943 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
944 sv_catpv(tmpsv, ",INTRO");
946 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
951 if (PL_madskills && o->op_madprop) {
952 SV * const tmpsv = newSVpvn("", 0);
953 MADPROP* mp = o->op_madprop;
954 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
957 char tmp = mp->mad_key;
958 sv_setpvn(tmpsv,"'",1);
960 sv_catpvn(tmpsv, &tmp, 1);
961 sv_catpv(tmpsv, "'=");
962 switch (mp->mad_type) {
964 sv_catpv(tmpsv, "NULL");
965 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
968 sv_catpv(tmpsv, "<");
969 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
970 sv_catpv(tmpsv, ">");
971 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
974 if ((OP*)mp->mad_val) {
975 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
976 do_op_dump(level, file, (OP*)mp->mad_val);
980 sv_catpv(tmpsv, "(UNK)");
981 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
987 Perl_dump_indent(aTHX_ level, file, "}\n");
998 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1000 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1001 if (cSVOPo->op_sv) {
1002 SV * const tmpsv = newSV(0);
1006 /* FIXME - it this making unwarranted assumptions about the
1007 UTF-8 cleanliness of the dump file handle? */
1010 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1011 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1012 SvPV_nolen_const(tmpsv));
1016 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1021 case OP_METHOD_NAMED:
1022 #ifndef USE_ITHREADS
1023 /* with ITHREADS, consts are stored in the pad, and the right pad
1024 * may not be active here, so skip */
1025 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1032 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1033 (UV)CopLINE(cCOPo));
1034 if (CopSTASHPV(cCOPo))
1035 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1037 if (cCOPo->cop_label)
1038 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1042 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1043 if (cLOOPo->op_redoop)
1044 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1046 PerlIO_printf(file, "DONE\n");
1047 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1048 if (cLOOPo->op_nextop)
1049 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1051 PerlIO_printf(file, "DONE\n");
1052 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1053 if (cLOOPo->op_lastop)
1054 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1056 PerlIO_printf(file, "DONE\n");
1064 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1065 if (cLOGOPo->op_other)
1066 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1068 PerlIO_printf(file, "DONE\n");
1074 do_pmop_dump(level, file, cPMOPo);
1082 if (o->op_private & OPpREFCOUNTED)
1083 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1088 if (o->op_flags & OPf_KIDS) {
1090 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1091 do_op_dump(level, file, kid);
1093 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1097 Perl_op_dump(pTHX_ const OP *o)
1099 do_op_dump(0, Perl_debug_log, o);
1103 Perl_gv_dump(pTHX_ GV *gv)
1108 PerlIO_printf(Perl_debug_log, "{}\n");
1111 sv = sv_newmortal();
1112 PerlIO_printf(Perl_debug_log, "{\n");
1113 gv_fullname3(sv, gv, NULL);
1114 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1115 if (gv != GvEGV(gv)) {
1116 gv_efullname3(sv, GvEGV(gv), NULL);
1117 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1119 PerlIO_putc(Perl_debug_log, '\n');
1120 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1124 /* map magic types to the symbolic names
1125 * (with the PERL_MAGIC_ prefixed stripped)
1128 static const struct { const char type; const char *name; } magic_names[] = {
1129 { PERL_MAGIC_sv, "sv(\\0)" },
1130 { PERL_MAGIC_arylen, "arylen(#)" },
1131 { PERL_MAGIC_rhash, "rhash(%)" },
1132 { PERL_MAGIC_regdata_names, "regdata_names(+)" },
1133 { PERL_MAGIC_pos, "pos(.)" },
1134 { PERL_MAGIC_symtab, "symtab(:)" },
1135 { PERL_MAGIC_backref, "backref(<)" },
1136 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1137 { PERL_MAGIC_overload, "overload(A)" },
1138 { PERL_MAGIC_bm, "bm(B)" },
1139 { PERL_MAGIC_regdata, "regdata(D)" },
1140 { PERL_MAGIC_env, "env(E)" },
1141 { PERL_MAGIC_hints, "hints(H)" },
1142 { PERL_MAGIC_isa, "isa(I)" },
1143 { PERL_MAGIC_dbfile, "dbfile(L)" },
1144 { PERL_MAGIC_shared, "shared(N)" },
1145 { PERL_MAGIC_tied, "tied(P)" },
1146 { PERL_MAGIC_sig, "sig(S)" },
1147 { PERL_MAGIC_uvar, "uvar(U)" },
1148 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1149 { PERL_MAGIC_overload_table, "overload_table(c)" },
1150 { PERL_MAGIC_regdatum, "regdatum(d)" },
1151 { PERL_MAGIC_envelem, "envelem(e)" },
1152 { PERL_MAGIC_fm, "fm(f)" },
1153 { PERL_MAGIC_regex_global, "regex_global(g)" },
1154 { PERL_MAGIC_hintselem, "hintselem(h)" },
1155 { PERL_MAGIC_isaelem, "isaelem(i)" },
1156 { PERL_MAGIC_nkeys, "nkeys(k)" },
1157 { PERL_MAGIC_dbline, "dbline(l)" },
1158 { PERL_MAGIC_mutex, "mutex(m)" },
1159 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1160 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1161 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1162 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1163 { PERL_MAGIC_qr, "qr(r)" },
1164 { PERL_MAGIC_sigelem, "sigelem(s)" },
1165 { PERL_MAGIC_taint, "taint(t)" },
1166 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1167 { PERL_MAGIC_vec, "vec(v)" },
1168 { PERL_MAGIC_vstring, "vstring(V)" },
1169 { PERL_MAGIC_utf8, "utf8(w)" },
1170 { PERL_MAGIC_substr, "substr(x)" },
1171 { PERL_MAGIC_defelem, "defelem(y)" },
1172 { PERL_MAGIC_ext, "ext(~)" },
1173 /* this null string terminates the list */
1178 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1180 for (; mg; mg = mg->mg_moremagic) {
1181 Perl_dump_indent(aTHX_ level, file,
1182 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1183 if (mg->mg_virtual) {
1184 const MGVTBL * const v = mg->mg_virtual;
1186 if (v == &PL_vtbl_sv) s = "sv";
1187 else if (v == &PL_vtbl_env) s = "env";
1188 else if (v == &PL_vtbl_envelem) s = "envelem";
1189 else if (v == &PL_vtbl_sig) s = "sig";
1190 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1191 else if (v == &PL_vtbl_pack) s = "pack";
1192 else if (v == &PL_vtbl_packelem) s = "packelem";
1193 else if (v == &PL_vtbl_dbline) s = "dbline";
1194 else if (v == &PL_vtbl_isa) s = "isa";
1195 else if (v == &PL_vtbl_arylen) s = "arylen";
1196 else if (v == &PL_vtbl_mglob) s = "mglob";
1197 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1198 else if (v == &PL_vtbl_taint) s = "taint";
1199 else if (v == &PL_vtbl_substr) s = "substr";
1200 else if (v == &PL_vtbl_vec) s = "vec";
1201 else if (v == &PL_vtbl_pos) s = "pos";
1202 else if (v == &PL_vtbl_bm) s = "bm";
1203 else if (v == &PL_vtbl_fm) s = "fm";
1204 else if (v == &PL_vtbl_uvar) s = "uvar";
1205 else if (v == &PL_vtbl_defelem) s = "defelem";
1206 #ifdef USE_LOCALE_COLLATE
1207 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1209 else if (v == &PL_vtbl_amagic) s = "amagic";
1210 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1211 else if (v == &PL_vtbl_backref) s = "backref";
1212 else if (v == &PL_vtbl_utf8) s = "utf8";
1213 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1214 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1217 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1219 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1222 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1225 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1229 const char *name = NULL;
1230 for (n = 0; magic_names[n].name; n++) {
1231 if (mg->mg_type == magic_names[n].type) {
1232 name = magic_names[n].name;
1237 Perl_dump_indent(aTHX_ level, file,
1238 " MG_TYPE = PERL_MAGIC_%s\n", name);
1240 Perl_dump_indent(aTHX_ level, file,
1241 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1245 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1246 if (mg->mg_type == PERL_MAGIC_envelem &&
1247 mg->mg_flags & MGf_TAINTEDDIR)
1248 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1249 if (mg->mg_flags & MGf_REFCOUNTED)
1250 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1251 if (mg->mg_flags & MGf_GSKIP)
1252 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1253 if (mg->mg_type == PERL_MAGIC_regex_global &&
1254 mg->mg_flags & MGf_MINMATCH)
1255 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1258 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1259 if (mg->mg_flags & MGf_REFCOUNTED)
1260 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1263 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1265 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1266 if (mg->mg_len >= 0) {
1267 if (mg->mg_type != PERL_MAGIC_utf8) {
1268 SV *sv = newSVpvs("");
1269 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1273 else if (mg->mg_len == HEf_SVKEY) {
1274 PerlIO_puts(file, " => HEf_SVKEY\n");
1275 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1279 PerlIO_puts(file, " ???? - please notify IZ");
1280 PerlIO_putc(file, '\n');
1282 if (mg->mg_type == PERL_MAGIC_utf8) {
1283 STRLEN *cache = (STRLEN *) mg->mg_ptr;
1286 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1287 Perl_dump_indent(aTHX_ level, file,
1288 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1291 (UV)cache[i * 2 + 1]);
1298 Perl_magic_dump(pTHX_ const MAGIC *mg)
1300 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1304 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1307 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1308 if (sv && (hvname = HvNAME_get(sv)))
1309 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1311 PerlIO_putc(file, '\n');
1315 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1317 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1318 if (sv && GvNAME(sv))
1319 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1321 PerlIO_putc(file, '\n');
1325 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1327 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1328 if (sv && GvNAME(sv)) {
1330 PerlIO_printf(file, "\t\"");
1331 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1332 PerlIO_printf(file, "%s\" :: \"", hvname);
1333 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1336 PerlIO_putc(file, '\n');
1340 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1349 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1353 flags = SvFLAGS(sv);
1356 d = Perl_newSVpvf(aTHX_
1357 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1358 PTR2UV(SvANY(sv)), PTR2UV(sv),
1359 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1360 (int)(PL_dumpindent*level), "");
1362 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1363 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1365 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1366 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1367 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1369 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1370 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1371 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1372 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1373 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1375 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1376 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1377 if (flags & SVf_POK) sv_catpv(d, "POK,");
1378 if (flags & SVf_ROK) {
1379 sv_catpv(d, "ROK,");
1380 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1382 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1383 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1384 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1386 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1387 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1388 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1389 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1390 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1391 if (SvPCS_IMPORTED(sv))
1392 sv_catpv(d, "PCS_IMPORTED,");
1394 sv_catpv(d, "SCREAM,");
1400 if (CvANON(sv)) sv_catpv(d, "ANON,");
1401 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1402 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1403 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1404 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1405 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1406 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1407 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1408 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1409 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1410 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1411 if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
1414 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1415 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1416 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1417 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1418 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1422 if (isGV_with_GP(sv)) {
1423 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1424 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1425 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1426 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1427 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1429 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1430 sv_catpv(d, "IMPORT");
1431 if (GvIMPORTED(sv) == GVf_IMPORTED)
1432 sv_catpv(d, "ALL,");
1435 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1436 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1437 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1438 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1442 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1443 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1447 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1448 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1451 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1452 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1453 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1456 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1461 /* SVphv_SHAREKEYS is also 0x20000000 */
1462 if ((type != SVt_PVHV) && SvUTF8(sv))
1463 sv_catpv(d, "UTF8");
1465 if (*(SvEND(d) - 1) == ',') {
1466 SvCUR_set(d, SvCUR(d) - 1);
1467 SvPVX(d)[SvCUR(d)] = '\0';
1472 #ifdef DEBUG_LEAKING_SCALARS
1473 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1474 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1476 sv->sv_debug_inpad ? "for" : "by",
1477 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1478 sv->sv_debug_cloned ? " (cloned)" : "");
1480 Perl_dump_indent(aTHX_ level, file, "SV = ");
1481 if (type < SVt_LAST) {
1482 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1484 if (type == SVt_NULL) {
1489 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1493 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1494 && type != SVt_PVCV && !isGV_with_GP(sv))
1495 || type == SVt_IV) {
1497 #ifdef PERL_OLD_COPY_ON_WRITE
1501 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1503 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1505 PerlIO_printf(file, " (OFFSET)");
1506 #ifdef PERL_OLD_COPY_ON_WRITE
1507 if (SvIsCOW_shared_hash(sv))
1508 PerlIO_printf(file, " (HASH)");
1509 else if (SvIsCOW_normal(sv))
1510 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1512 PerlIO_putc(file, '\n');
1514 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1515 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
1516 || type == SVt_NV) {
1517 STORE_NUMERIC_LOCAL_SET_STANDARD();
1518 /* %Vg doesn't work? --jhi */
1519 #ifdef USE_LONG_DOUBLE
1520 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1522 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1524 RESTORE_NUMERIC_LOCAL();
1527 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1529 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1531 if (type < SVt_PV) {
1535 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1536 if (SvPVX_const(sv)) {
1537 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1539 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1540 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1541 if (SvUTF8(sv)) /* the 8? \x{....} */
1542 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1543 PerlIO_printf(file, "\n");
1544 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1545 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1548 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1550 if (type >= SVt_PVMG) {
1552 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1554 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1558 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1559 if (AvARRAY(sv) != AvALLOC(sv)) {
1560 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1561 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1564 PerlIO_putc(file, '\n');
1565 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1566 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1567 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1568 sv_setpvn(d, "", 0);
1569 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1570 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1571 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1572 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1573 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1575 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1576 SV** elt = av_fetch((AV*)sv,count,0);
1578 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1580 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1585 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1586 if (HvARRAY(sv) && HvKEYS(sv)) {
1587 /* Show distribution of HEs in the ARRAY */
1589 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1592 U32 pow2 = 2, keys = HvKEYS(sv);
1593 NV theoret, sum = 0;
1595 PerlIO_printf(file, " (");
1596 Zero(freq, FREQ_MAX + 1, int);
1597 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1600 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1602 if (count > FREQ_MAX)
1608 for (i = 0; i <= max; i++) {
1610 PerlIO_printf(file, "%d%s:%d", i,
1611 (i == FREQ_MAX) ? "+" : "",
1614 PerlIO_printf(file, ", ");
1617 PerlIO_putc(file, ')');
1618 /* The "quality" of a hash is defined as the total number of
1619 comparisons needed to access every element once, relative
1620 to the expected number needed for a random hash.
1622 The total number of comparisons is equal to the sum of
1623 the squares of the number of entries in each bucket.
1624 For a random hash of n keys into k buckets, the expected
1629 for (i = max; i > 0; i--) { /* Precision: count down. */
1630 sum += freq[i] * i * i;
1632 while ((keys = keys >> 1))
1634 theoret = HvKEYS(sv);
1635 theoret += theoret * (theoret-1)/pow2;
1636 PerlIO_putc(file, '\n');
1637 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1639 PerlIO_putc(file, '\n');
1640 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1641 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1642 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1643 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1644 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1646 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1647 if (mg && mg->mg_obj) {
1648 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1652 const char * const hvname = HvNAME_get(sv);
1654 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1657 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1659 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1661 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1665 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1667 HV * const hv = (HV*)sv;
1668 int count = maxnest - nest;
1671 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1676 const U32 hash = HeHASH(he);
1678 keysv = hv_iterkeysv(he);
1679 keypv = SvPV_const(keysv, len);
1680 elt = hv_iterval(hv, he);
1681 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1683 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1685 PerlIO_printf(file, "[REHASH] ");
1686 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1687 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1689 hv_iterinit(hv); /* Return to status quo */
1695 const char *const proto = SvPV_const(sv, len);
1696 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1701 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1702 if (!CvISXSUB(sv)) {
1704 Perl_dump_indent(aTHX_ level, file,
1705 " START = 0x%"UVxf" ===> %"IVdf"\n",
1706 PTR2UV(CvSTART(sv)),
1707 (IV)sequence_num(CvSTART(sv)));
1709 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1710 PTR2UV(CvROOT(sv)));
1711 if (CvROOT(sv) && dumpops) {
1712 do_op_dump(level+1, file, CvROOT(sv));
1715 SV *constant = cv_const_sv((CV *)sv);
1717 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1720 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1722 PTR2UV(CvXSUBANY(sv).any_ptr));
1723 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1726 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1727 (IV)CvXSUBANY(sv).any_i32);
1730 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1731 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1732 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1733 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1734 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1735 if (type == SVt_PVFM)
1736 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1737 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1738 if (nest < maxnest) {
1739 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1742 const CV * const outside = CvOUTSIDE(sv);
1743 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1746 : CvANON(outside) ? "ANON"
1747 : (outside == PL_main_cv) ? "MAIN"
1748 : CvUNIQUE(outside) ? "UNIQUE"
1749 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1751 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1752 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1756 if (type == SVt_PVLV) {
1757 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1758 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1759 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1760 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1761 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1762 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1765 if (!isGV_with_GP(sv))
1767 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1768 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1769 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1770 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1773 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1774 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1775 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1776 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1777 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1778 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1779 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1780 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1781 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1782 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1783 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1784 do_gv_dump (level, file, " EGV", GvEGV(sv));
1787 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1788 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1789 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1790 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1791 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1792 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1793 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1795 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1796 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1797 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1799 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1800 PTR2UV(IoTOP_GV(sv)));
1801 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1804 /* Source filters hide things that are not GVs in these three, so let's
1805 be careful out there. */
1807 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1808 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1809 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1811 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1812 PTR2UV(IoFMT_GV(sv)));
1813 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1816 if (IoBOTTOM_NAME(sv))
1817 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1818 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1819 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1821 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1822 PTR2UV(IoBOTTOM_GV(sv)));
1823 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1826 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1827 if (isPRINT(IoTYPE(sv)))
1828 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1830 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1831 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1838 Perl_sv_dump(pTHX_ SV *sv)
1841 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1845 Perl_runops_debug(pTHX)
1849 if (ckWARN_d(WARN_DEBUGGING))
1850 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1854 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1858 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1859 PerlIO_printf(Perl_debug_log,
1860 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1861 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1862 PTR2UV(*PL_watchaddr));
1863 if (DEBUG_s_TEST_) {
1864 if (DEBUG_v_TEST_) {
1865 PerlIO_printf(Perl_debug_log, "\n");
1873 if (DEBUG_t_TEST_) debop(PL_op);
1874 if (DEBUG_P_TEST_) debprof(PL_op);
1876 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1877 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1884 Perl_debop(pTHX_ const OP *o)
1887 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1890 Perl_deb(aTHX_ "%s", OP_NAME(o));
1891 switch (o->op_type) {
1893 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1898 SV * const sv = newSV(0);
1900 /* FIXME - it this making unwarranted assumptions about the
1901 UTF-8 cleanliness of the dump file handle? */
1904 gv_fullname3(sv, cGVOPo_gv, NULL);
1905 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1909 PerlIO_printf(Perl_debug_log, "(NULL)");
1915 /* print the lexical's name */
1916 CV * const cv = deb_curcv(cxstack_ix);
1919 AV * const padlist = CvPADLIST(cv);
1920 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1921 sv = *av_fetch(comppad, o->op_targ, FALSE);
1925 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1927 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1933 PerlIO_printf(Perl_debug_log, "\n");
1938 S_deb_curcv(pTHX_ I32 ix)
1941 const PERL_CONTEXT * const cx = &cxstack[ix];
1942 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1943 return cx->blk_sub.cv;
1944 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1946 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1951 return deb_curcv(ix - 1);
1955 Perl_watch(pTHX_ char **addr)
1958 PL_watchaddr = addr;
1960 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1961 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1965 S_debprof(pTHX_ const OP *o)
1968 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1970 if (!PL_profiledata)
1971 Newxz(PL_profiledata, MAXO, U32);
1972 ++PL_profiledata[o->op_type];
1976 Perl_debprofdump(pTHX)
1980 if (!PL_profiledata)
1982 for (i = 0; i < MAXO; i++) {
1983 if (PL_profiledata[i])
1984 PerlIO_printf(Perl_debug_log,
1985 "%5lu %s\n", (unsigned long)PL_profiledata[i],
1992 * XML variants of most of the above routines
1997 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2000 PerlIO_printf(file, "\n ");
2001 va_start(args, pat);
2002 xmldump_vindent(level, file, pat, &args);
2008 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2011 va_start(args, pat);
2012 xmldump_vindent(level, file, pat, &args);
2017 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2019 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2020 PerlIO_vprintf(file, pat, *args);
2024 Perl_xmldump_all(pTHX)
2026 PerlIO_setlinebuf(PL_xmlfp);
2028 op_xmldump(PL_main_root);
2029 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2030 PerlIO_close(PL_xmlfp);
2035 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2040 if (!HvARRAY(stash))
2042 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2043 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2044 GV *gv = (GV*)HeVAL(entry);
2046 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2052 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2053 && (hv = GvHV(gv)) && hv != PL_defstash)
2054 xmldump_packsubs(hv); /* nested package */
2060 Perl_xmldump_sub(pTHX_ const GV *gv)
2062 SV *sv = sv_newmortal();
2064 gv_fullname3(sv, gv, Nullch);
2065 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2066 if (CvXSUB(GvCV(gv)))
2067 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2068 PTR2UV(CvXSUB(GvCV(gv))),
2069 (int)CvXSUBANY(GvCV(gv)).any_i32);
2070 else if (CvROOT(GvCV(gv)))
2071 op_xmldump(CvROOT(GvCV(gv)));
2073 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2077 Perl_xmldump_form(pTHX_ const GV *gv)
2079 SV *sv = sv_newmortal();
2081 gv_fullname3(sv, gv, Nullch);
2082 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2083 if (CvROOT(GvFORM(gv)))
2084 op_xmldump(CvROOT(GvFORM(gv)));
2086 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2090 Perl_xmldump_eval(pTHX)
2092 op_xmldump(PL_eval_root);
2096 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2098 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2102 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2110 sv_catpvn(dsv,"",0);
2111 dsvcur = SvCUR(dsv); /* in case we have to restart */
2116 c = utf8_to_uvchr((U8*)pv, &cl);
2118 SvCUR(dsv) = dsvcur;
2183 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2186 Perl_sv_catpvf(aTHX_ dsv, "<");
2189 Perl_sv_catpvf(aTHX_ dsv, ">");
2192 Perl_sv_catpvf(aTHX_ dsv, "&");
2195 Perl_sv_catpvf(aTHX_ dsv, """);
2199 if (c < 32 || c > 127) {
2200 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2203 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2207 if ((c >= 0xD800 && c <= 0xDB7F) ||
2208 (c >= 0xDC00 && c <= 0xDFFF) ||
2209 (c >= 0xFFF0 && c <= 0xFFFF) ||
2211 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2213 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2226 Perl_sv_xmlpeek(pTHX_ SV *sv)
2228 SV *t = sv_newmortal();
2233 sv_setpvn(t, "", 0);
2236 sv_catpv(t, "VOID=\"\"");
2239 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2240 sv_catpv(t, "WILD=\"\"");
2243 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2244 if (sv == &PL_sv_undef) {
2245 sv_catpv(t, "SV_UNDEF=\"1\"");
2246 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2247 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2251 else if (sv == &PL_sv_no) {
2252 sv_catpv(t, "SV_NO=\"1\"");
2253 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2254 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2255 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2256 SVp_POK|SVp_NOK)) &&
2261 else if (sv == &PL_sv_yes) {
2262 sv_catpv(t, "SV_YES=\"1\"");
2263 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2264 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2265 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2266 SVp_POK|SVp_NOK)) &&
2268 SvPVX(sv) && *SvPVX(sv) == '1' &&
2273 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2274 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2275 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2279 sv_catpv(t, " XXX=\"\" ");
2281 else if (SvREFCNT(sv) == 0) {
2282 sv_catpv(t, " refcnt=\"0\"");
2285 else if (DEBUG_R_TEST_) {
2288 /* is this SV on the tmps stack? */
2289 for (ix=PL_tmps_ix; ix>=0; ix--) {
2290 if (PL_tmps_stack[ix] == sv) {
2295 if (SvREFCNT(sv) > 1)
2296 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2299 sv_catpv(t, " DRT=\"<T>\"");
2303 sv_catpv(t, " ROK=\"\"");
2305 switch (SvTYPE(sv)) {
2307 sv_catpv(t, " FREED=\"1\"");
2311 sv_catpv(t, " UNDEF=\"1\"");
2314 sv_catpv(t, " IV=\"");
2317 sv_catpv(t, " NV=\"");
2320 sv_catpv(t, " RV=\"");
2323 sv_catpv(t, " PV=\"");
2326 sv_catpv(t, " PVIV=\"");
2329 sv_catpv(t, " PVNV=\"");
2332 sv_catpv(t, " PVMG=\"");
2335 sv_catpv(t, " PVLV=\"");
2338 sv_catpv(t, " AV=\"");
2341 sv_catpv(t, " HV=\"");
2345 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2347 sv_catpv(t, " CV=\"()\"");
2350 sv_catpv(t, " GV=\"");
2353 sv_catpv(t, " BIND=\"");
2356 sv_catpv(t, " FM=\"");
2359 sv_catpv(t, " IO=\"");
2368 else if (SvNOKp(sv)) {
2369 STORE_NUMERIC_LOCAL_SET_STANDARD();
2370 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2371 RESTORE_NUMERIC_LOCAL();
2373 else if (SvIOKp(sv)) {
2375 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2377 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2388 return SvPV(t, n_a);
2392 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2395 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2398 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2401 char *s = PM_GETRE(pm)->precomp;
2402 SV *tmpsv = newSVpvn("",0);
2404 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2405 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2407 SvREFCNT_dec(tmpsv);
2408 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2409 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2412 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2413 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2414 SV * const tmpsv = pm_description(pm);
2415 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2416 SvREFCNT_dec(tmpsv);
2420 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
2421 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2422 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2423 do_op_xmldump(level+2, file, pm->op_pmreplroot);
2424 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2425 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2428 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2432 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2434 do_pmop_xmldump(0, PL_xmlfp, pm);
2438 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2445 seq = sequence_num(o);
2446 Perl_xmldump_indent(aTHX_ level, file,
2447 "<op_%s seq=\"%"UVuf" -> ",
2452 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2453 sequence_num(o->op_next));
2455 PerlIO_printf(file, "DONE\"");
2458 if (o->op_type == OP_NULL)
2460 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2461 if (o->op_targ == OP_NEXTSTATE)
2464 PerlIO_printf(file, " line=\"%"UVuf"\"",
2465 (UV)CopLINE(cCOPo));
2466 if (CopSTASHPV(cCOPo))
2467 PerlIO_printf(file, " package=\"%s\"",
2469 if (cCOPo->cop_label)
2470 PerlIO_printf(file, " label=\"%s\"",
2475 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2478 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2481 SV *tmpsv = newSVpvn("", 0);
2482 switch (o->op_flags & OPf_WANT) {
2484 sv_catpv(tmpsv, ",VOID");
2486 case OPf_WANT_SCALAR:
2487 sv_catpv(tmpsv, ",SCALAR");
2490 sv_catpv(tmpsv, ",LIST");
2493 sv_catpv(tmpsv, ",UNKNOWN");
2496 if (o->op_flags & OPf_KIDS)
2497 sv_catpv(tmpsv, ",KIDS");
2498 if (o->op_flags & OPf_PARENS)
2499 sv_catpv(tmpsv, ",PARENS");
2500 if (o->op_flags & OPf_STACKED)
2501 sv_catpv(tmpsv, ",STACKED");
2502 if (o->op_flags & OPf_REF)
2503 sv_catpv(tmpsv, ",REF");
2504 if (o->op_flags & OPf_MOD)
2505 sv_catpv(tmpsv, ",MOD");
2506 if (o->op_flags & OPf_SPECIAL)
2507 sv_catpv(tmpsv, ",SPECIAL");
2508 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2509 SvREFCNT_dec(tmpsv);
2511 if (o->op_private) {
2512 SV *tmpsv = newSVpvn("", 0);
2513 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2514 if (o->op_private & OPpTARGET_MY)
2515 sv_catpv(tmpsv, ",TARGET_MY");
2517 else if (o->op_type == OP_LEAVESUB ||
2518 o->op_type == OP_LEAVE ||
2519 o->op_type == OP_LEAVESUBLV ||
2520 o->op_type == OP_LEAVEWRITE) {
2521 if (o->op_private & OPpREFCOUNTED)
2522 sv_catpv(tmpsv, ",REFCOUNTED");
2524 else if (o->op_type == OP_AASSIGN) {
2525 if (o->op_private & OPpASSIGN_COMMON)
2526 sv_catpv(tmpsv, ",COMMON");
2528 else if (o->op_type == OP_SASSIGN) {
2529 if (o->op_private & OPpASSIGN_BACKWARDS)
2530 sv_catpv(tmpsv, ",BACKWARDS");
2532 else if (o->op_type == OP_TRANS) {
2533 if (o->op_private & OPpTRANS_SQUASH)
2534 sv_catpv(tmpsv, ",SQUASH");
2535 if (o->op_private & OPpTRANS_DELETE)
2536 sv_catpv(tmpsv, ",DELETE");
2537 if (o->op_private & OPpTRANS_COMPLEMENT)
2538 sv_catpv(tmpsv, ",COMPLEMENT");
2539 if (o->op_private & OPpTRANS_IDENTICAL)
2540 sv_catpv(tmpsv, ",IDENTICAL");
2541 if (o->op_private & OPpTRANS_GROWS)
2542 sv_catpv(tmpsv, ",GROWS");
2544 else if (o->op_type == OP_REPEAT) {
2545 if (o->op_private & OPpREPEAT_DOLIST)
2546 sv_catpv(tmpsv, ",DOLIST");
2548 else if (o->op_type == OP_ENTERSUB ||
2549 o->op_type == OP_RV2SV ||
2550 o->op_type == OP_GVSV ||
2551 o->op_type == OP_RV2AV ||
2552 o->op_type == OP_RV2HV ||
2553 o->op_type == OP_RV2GV ||
2554 o->op_type == OP_AELEM ||
2555 o->op_type == OP_HELEM )
2557 if (o->op_type == OP_ENTERSUB) {
2558 if (o->op_private & OPpENTERSUB_AMPER)
2559 sv_catpv(tmpsv, ",AMPER");
2560 if (o->op_private & OPpENTERSUB_DB)
2561 sv_catpv(tmpsv, ",DB");
2562 if (o->op_private & OPpENTERSUB_HASTARG)
2563 sv_catpv(tmpsv, ",HASTARG");
2564 if (o->op_private & OPpENTERSUB_NOPAREN)
2565 sv_catpv(tmpsv, ",NOPAREN");
2566 if (o->op_private & OPpENTERSUB_INARGS)
2567 sv_catpv(tmpsv, ",INARGS");
2568 if (o->op_private & OPpENTERSUB_NOMOD)
2569 sv_catpv(tmpsv, ",NOMOD");
2572 switch (o->op_private & OPpDEREF) {
2574 sv_catpv(tmpsv, ",SV");
2577 sv_catpv(tmpsv, ",AV");
2580 sv_catpv(tmpsv, ",HV");
2583 if (o->op_private & OPpMAYBE_LVSUB)
2584 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2586 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2587 if (o->op_private & OPpLVAL_DEFER)
2588 sv_catpv(tmpsv, ",LVAL_DEFER");
2591 if (o->op_private & HINT_STRICT_REFS)
2592 sv_catpv(tmpsv, ",STRICT_REFS");
2593 if (o->op_private & OPpOUR_INTRO)
2594 sv_catpv(tmpsv, ",OUR_INTRO");
2597 else if (o->op_type == OP_CONST) {
2598 if (o->op_private & OPpCONST_BARE)
2599 sv_catpv(tmpsv, ",BARE");
2600 if (o->op_private & OPpCONST_STRICT)
2601 sv_catpv(tmpsv, ",STRICT");
2602 if (o->op_private & OPpCONST_ARYBASE)
2603 sv_catpv(tmpsv, ",ARYBASE");
2604 if (o->op_private & OPpCONST_WARNING)
2605 sv_catpv(tmpsv, ",WARNING");
2606 if (o->op_private & OPpCONST_ENTERED)
2607 sv_catpv(tmpsv, ",ENTERED");
2609 else if (o->op_type == OP_FLIP) {
2610 if (o->op_private & OPpFLIP_LINENUM)
2611 sv_catpv(tmpsv, ",LINENUM");
2613 else if (o->op_type == OP_FLOP) {
2614 if (o->op_private & OPpFLIP_LINENUM)
2615 sv_catpv(tmpsv, ",LINENUM");
2617 else if (o->op_type == OP_RV2CV) {
2618 if (o->op_private & OPpLVAL_INTRO)
2619 sv_catpv(tmpsv, ",INTRO");
2621 else if (o->op_type == OP_GV) {
2622 if (o->op_private & OPpEARLY_CV)
2623 sv_catpv(tmpsv, ",EARLY_CV");
2625 else if (o->op_type == OP_LIST) {
2626 if (o->op_private & OPpLIST_GUESSED)
2627 sv_catpv(tmpsv, ",GUESSED");
2629 else if (o->op_type == OP_DELETE) {
2630 if (o->op_private & OPpSLICE)
2631 sv_catpv(tmpsv, ",SLICE");
2633 else if (o->op_type == OP_EXISTS) {
2634 if (o->op_private & OPpEXISTS_SUB)
2635 sv_catpv(tmpsv, ",EXISTS_SUB");
2637 else if (o->op_type == OP_SORT) {
2638 if (o->op_private & OPpSORT_NUMERIC)
2639 sv_catpv(tmpsv, ",NUMERIC");
2640 if (o->op_private & OPpSORT_INTEGER)
2641 sv_catpv(tmpsv, ",INTEGER");
2642 if (o->op_private & OPpSORT_REVERSE)
2643 sv_catpv(tmpsv, ",REVERSE");
2645 else if (o->op_type == OP_THREADSV) {
2646 if (o->op_private & OPpDONE_SVREF)
2647 sv_catpv(tmpsv, ",SVREF");
2649 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2650 if (o->op_private & OPpOPEN_IN_RAW)
2651 sv_catpv(tmpsv, ",IN_RAW");
2652 if (o->op_private & OPpOPEN_IN_CRLF)
2653 sv_catpv(tmpsv, ",IN_CRLF");
2654 if (o->op_private & OPpOPEN_OUT_RAW)
2655 sv_catpv(tmpsv, ",OUT_RAW");
2656 if (o->op_private & OPpOPEN_OUT_CRLF)
2657 sv_catpv(tmpsv, ",OUT_CRLF");
2659 else if (o->op_type == OP_EXIT) {
2660 if (o->op_private & OPpEXIT_VMSISH)
2661 sv_catpv(tmpsv, ",EXIT_VMSISH");
2662 if (o->op_private & OPpHUSH_VMSISH)
2663 sv_catpv(tmpsv, ",HUSH_VMSISH");
2665 else if (o->op_type == OP_DIE) {
2666 if (o->op_private & OPpHUSH_VMSISH)
2667 sv_catpv(tmpsv, ",HUSH_VMSISH");
2669 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2670 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2671 sv_catpv(tmpsv, ",FT_ACCESS");
2672 if (o->op_private & OPpFT_STACKED)
2673 sv_catpv(tmpsv, ",FT_STACKED");
2675 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2676 sv_catpv(tmpsv, ",INTRO");
2678 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2679 SvREFCNT_dec(tmpsv);
2682 switch (o->op_type) {
2684 if (o->op_flags & OPf_SPECIAL) {
2690 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2692 if (cSVOPo->op_sv) {
2693 SV *tmpsv1 = newSV(0);
2694 SV *tmpsv2 = newSVpvn("",0);
2702 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2703 s = SvPV(tmpsv1,len);
2704 sv_catxmlpvn(tmpsv2, s, len, 1);
2705 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2709 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2713 case OP_METHOD_NAMED:
2714 #ifndef USE_ITHREADS
2715 /* with ITHREADS, consts are stored in the pad, and the right pad
2716 * may not be active here, so skip */
2717 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2723 PerlIO_printf(file, ">\n");
2725 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2731 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2732 (UV)CopLINE(cCOPo));
2733 if (CopSTASHPV(cCOPo))
2734 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2736 if (cCOPo->cop_label)
2737 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2741 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2742 if (cLOOPo->op_redoop)
2743 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2745 PerlIO_printf(file, "DONE\"");
2746 S_xmldump_attr(aTHX_ level, file, "next=\"");
2747 if (cLOOPo->op_nextop)
2748 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2750 PerlIO_printf(file, "DONE\"");
2751 S_xmldump_attr(aTHX_ level, file, "last=\"");
2752 if (cLOOPo->op_lastop)
2753 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2755 PerlIO_printf(file, "DONE\"");
2763 S_xmldump_attr(aTHX_ level, file, "other=\"");
2764 if (cLOGOPo->op_other)
2765 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2767 PerlIO_printf(file, "DONE\"");
2775 if (o->op_private & OPpREFCOUNTED)
2776 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2782 if (PL_madskills && o->op_madprop) {
2783 SV *tmpsv = newSVpvn("", 0);
2784 MADPROP* mp = o->op_madprop;
2785 sv_utf8_upgrade(tmpsv);
2788 PerlIO_printf(file, ">\n");
2790 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2793 char tmp = mp->mad_key;
2794 sv_setpvn(tmpsv,"\"",1);
2796 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2797 sv_catpv(tmpsv, "\"");
2798 switch (mp->mad_type) {
2800 sv_catpv(tmpsv, "NULL");
2801 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2804 sv_catpv(tmpsv, " val=\"");
2805 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2806 sv_catpv(tmpsv, "\"");
2807 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2810 sv_catpv(tmpsv, " val=\"");
2811 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2812 sv_catpv(tmpsv, "\"");
2813 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2816 if ((OP*)mp->mad_val) {
2817 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2818 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2819 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2823 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2829 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2831 SvREFCNT_dec(tmpsv);
2834 switch (o->op_type) {
2841 PerlIO_printf(file, ">\n");
2843 do_pmop_xmldump(level, file, cPMOPo);
2849 if (o->op_flags & OPf_KIDS) {
2853 PerlIO_printf(file, ">\n");
2855 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2856 do_op_xmldump(level, file, kid);
2860 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2862 PerlIO_printf(file, " />\n");
2866 Perl_op_xmldump(pTHX_ const OP *o)
2868 do_op_xmldump(0, PL_xmlfp, o);
2874 * c-indentation-style: bsd
2876 * indent-tabs-mode: t
2879 * ex: set ts=8 sts=4 sw=4 noet: