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) {
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");
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 & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1361 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1363 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1364 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1365 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1367 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1368 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1369 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1370 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1371 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1373 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1374 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1375 if (flags & SVf_POK) sv_catpv(d, "POK,");
1376 if (flags & SVf_ROK) {
1377 sv_catpv(d, "ROK,");
1378 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1380 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1381 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1382 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1384 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1385 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1386 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1387 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1388 if (flags & SVp_SCREAM && type != SVt_PVHV)
1389 sv_catpv(d, "SCREAM,");
1394 if (CvANON(sv)) sv_catpv(d, "ANON,");
1395 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1396 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1397 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1398 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1399 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1400 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1401 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1402 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1403 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1404 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1405 if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
1408 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1409 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1410 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1411 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1412 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1416 if (isGV_with_GP(sv)) {
1417 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1418 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1419 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1420 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1421 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1423 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1424 sv_catpv(d, "IMPORT");
1425 if (GvIMPORTED(sv) == GVf_IMPORTED)
1426 sv_catpv(d, "ALL,");
1429 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1430 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1431 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1432 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1436 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1437 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1441 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1442 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1445 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1446 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1447 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1450 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1455 /* SVphv_SHAREKEYS is also 0x20000000 */
1456 if ((type != SVt_PVHV) && SvUTF8(sv))
1457 sv_catpv(d, "UTF8");
1459 if (*(SvEND(d) - 1) == ',') {
1460 SvCUR_set(d, SvCUR(d) - 1);
1461 SvPVX(d)[SvCUR(d)] = '\0';
1466 #ifdef DEBUG_LEAKING_SCALARS
1467 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1468 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1470 sv->sv_debug_inpad ? "for" : "by",
1471 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1472 sv->sv_debug_cloned ? " (cloned)" : "");
1474 Perl_dump_indent(aTHX_ level, file, "SV = ");
1475 if (type < SVt_LAST) {
1476 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1478 if (type == SVt_NULL) {
1483 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1487 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1488 && type != SVt_PVCV && !isGV_with_GP(sv))
1489 || type == SVt_IV) {
1491 #ifdef PERL_OLD_COPY_ON_WRITE
1495 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1497 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1499 PerlIO_printf(file, " (OFFSET)");
1500 #ifdef PERL_OLD_COPY_ON_WRITE
1501 if (SvIsCOW_shared_hash(sv))
1502 PerlIO_printf(file, " (HASH)");
1503 else if (SvIsCOW_normal(sv))
1504 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1506 PerlIO_putc(file, '\n');
1508 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1509 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
1510 || type == SVt_NV) {
1511 STORE_NUMERIC_LOCAL_SET_STANDARD();
1512 /* %Vg doesn't work? --jhi */
1513 #ifdef USE_LONG_DOUBLE
1514 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1516 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1518 RESTORE_NUMERIC_LOCAL();
1521 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1523 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1525 if (type < SVt_PV) {
1529 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1530 if (SvPVX_const(sv)) {
1531 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1533 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1534 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1535 if (SvUTF8(sv)) /* the 8? \x{....} */
1536 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1537 PerlIO_printf(file, "\n");
1538 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1539 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1542 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1544 if (type >= SVt_PVMG) {
1546 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1548 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1552 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1553 if (AvARRAY(sv) != AvALLOC(sv)) {
1554 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1555 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1558 PerlIO_putc(file, '\n');
1559 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1560 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1561 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1562 sv_setpvn(d, "", 0);
1563 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1564 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1565 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1566 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1567 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1569 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1570 SV** elt = av_fetch((AV*)sv,count,0);
1572 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1574 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1579 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1580 if (HvARRAY(sv) && HvKEYS(sv)) {
1581 /* Show distribution of HEs in the ARRAY */
1583 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1586 U32 pow2 = 2, keys = HvKEYS(sv);
1587 NV theoret, sum = 0;
1589 PerlIO_printf(file, " (");
1590 Zero(freq, FREQ_MAX + 1, int);
1591 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1594 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1596 if (count > FREQ_MAX)
1602 for (i = 0; i <= max; i++) {
1604 PerlIO_printf(file, "%d%s:%d", i,
1605 (i == FREQ_MAX) ? "+" : "",
1608 PerlIO_printf(file, ", ");
1611 PerlIO_putc(file, ')');
1612 /* The "quality" of a hash is defined as the total number of
1613 comparisons needed to access every element once, relative
1614 to the expected number needed for a random hash.
1616 The total number of comparisons is equal to the sum of
1617 the squares of the number of entries in each bucket.
1618 For a random hash of n keys into k buckets, the expected
1623 for (i = max; i > 0; i--) { /* Precision: count down. */
1624 sum += freq[i] * i * i;
1626 while ((keys = keys >> 1))
1628 theoret = HvKEYS(sv);
1629 theoret += theoret * (theoret-1)/pow2;
1630 PerlIO_putc(file, '\n');
1631 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1633 PerlIO_putc(file, '\n');
1634 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1635 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1636 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1637 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1638 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1640 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1641 if (mg && mg->mg_obj) {
1642 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1646 const char * const hvname = HvNAME_get(sv);
1648 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1651 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1653 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1655 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1659 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1661 HV * const hv = (HV*)sv;
1662 int count = maxnest - nest;
1665 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1670 const U32 hash = HeHASH(he);
1672 keysv = hv_iterkeysv(he);
1673 keypv = SvPV_const(keysv, len);
1674 elt = hv_iterval(hv, he);
1675 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1677 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1679 PerlIO_printf(file, "[REHASH] ");
1680 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1681 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1683 hv_iterinit(hv); /* Return to status quo */
1689 const char *const proto = SvPV_const(sv, len);
1690 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1695 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1696 if (!CvISXSUB(sv)) {
1698 Perl_dump_indent(aTHX_ level, file,
1699 " START = 0x%"UVxf" ===> %"IVdf"\n",
1700 PTR2UV(CvSTART(sv)),
1701 (IV)sequence_num(CvSTART(sv)));
1703 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1704 PTR2UV(CvROOT(sv)));
1705 if (CvROOT(sv) && dumpops) {
1706 do_op_dump(level+1, file, CvROOT(sv));
1709 SV *constant = cv_const_sv((CV *)sv);
1711 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1714 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1716 PTR2UV(CvXSUBANY(sv).any_ptr));
1717 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1720 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1721 (IV)CvXSUBANY(sv).any_i32);
1724 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1725 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1726 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1727 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1728 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1729 if (type == SVt_PVFM)
1730 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1731 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1732 if (nest < maxnest) {
1733 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1736 const CV * const outside = CvOUTSIDE(sv);
1737 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1740 : CvANON(outside) ? "ANON"
1741 : (outside == PL_main_cv) ? "MAIN"
1742 : CvUNIQUE(outside) ? "UNIQUE"
1743 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1745 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1746 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1750 if (type == SVt_PVLV) {
1751 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1752 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1753 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1754 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1755 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1756 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1759 if (!isGV_with_GP(sv))
1761 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1762 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1763 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1764 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1767 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1768 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1769 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1770 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1771 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1772 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1773 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1774 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1775 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1776 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1777 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1778 do_gv_dump (level, file, " EGV", GvEGV(sv));
1781 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1782 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1783 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1784 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1785 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1786 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1787 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1789 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1790 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1791 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1793 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1794 PTR2UV(IoTOP_GV(sv)));
1795 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1798 /* Source filters hide things that are not GVs in these three, so let's
1799 be careful out there. */
1801 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1802 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1803 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1805 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1806 PTR2UV(IoFMT_GV(sv)));
1807 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1810 if (IoBOTTOM_NAME(sv))
1811 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1812 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1813 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1815 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1816 PTR2UV(IoBOTTOM_GV(sv)));
1817 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1820 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1821 if (isPRINT(IoTYPE(sv)))
1822 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1824 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1825 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1832 Perl_sv_dump(pTHX_ SV *sv)
1835 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1839 Perl_runops_debug(pTHX)
1843 if (ckWARN_d(WARN_DEBUGGING))
1844 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1848 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1852 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1853 PerlIO_printf(Perl_debug_log,
1854 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1855 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1856 PTR2UV(*PL_watchaddr));
1857 if (DEBUG_s_TEST_) {
1858 if (DEBUG_v_TEST_) {
1859 PerlIO_printf(Perl_debug_log, "\n");
1867 if (DEBUG_t_TEST_) debop(PL_op);
1868 if (DEBUG_P_TEST_) debprof(PL_op);
1870 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1871 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1878 Perl_debop(pTHX_ const OP *o)
1881 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1884 Perl_deb(aTHX_ "%s", OP_NAME(o));
1885 switch (o->op_type) {
1887 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1892 SV * const sv = newSV(0);
1894 /* FIXME - it this making unwarranted assumptions about the
1895 UTF-8 cleanliness of the dump file handle? */
1898 gv_fullname3(sv, cGVOPo_gv, NULL);
1899 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1903 PerlIO_printf(Perl_debug_log, "(NULL)");
1909 /* print the lexical's name */
1910 CV * const cv = deb_curcv(cxstack_ix);
1913 AV * const padlist = CvPADLIST(cv);
1914 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1915 sv = *av_fetch(comppad, o->op_targ, FALSE);
1919 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1921 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1927 PerlIO_printf(Perl_debug_log, "\n");
1932 S_deb_curcv(pTHX_ I32 ix)
1935 const PERL_CONTEXT * const cx = &cxstack[ix];
1936 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1937 return cx->blk_sub.cv;
1938 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1940 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1945 return deb_curcv(ix - 1);
1949 Perl_watch(pTHX_ char **addr)
1952 PL_watchaddr = addr;
1954 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1955 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1959 S_debprof(pTHX_ const OP *o)
1962 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1964 if (!PL_profiledata)
1965 Newxz(PL_profiledata, MAXO, U32);
1966 ++PL_profiledata[o->op_type];
1970 Perl_debprofdump(pTHX)
1974 if (!PL_profiledata)
1976 for (i = 0; i < MAXO; i++) {
1977 if (PL_profiledata[i])
1978 PerlIO_printf(Perl_debug_log,
1979 "%5lu %s\n", (unsigned long)PL_profiledata[i],
1986 * XML variants of most of the above routines
1991 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
1994 PerlIO_printf(file, "\n ");
1995 va_start(args, pat);
1996 xmldump_vindent(level, file, pat, &args);
2002 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2005 va_start(args, pat);
2006 xmldump_vindent(level, file, pat, &args);
2011 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2013 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2014 PerlIO_vprintf(file, pat, *args);
2018 Perl_xmldump_all(pTHX)
2020 PerlIO_setlinebuf(PL_xmlfp);
2022 op_xmldump(PL_main_root);
2023 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2024 PerlIO_close(PL_xmlfp);
2029 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2034 if (!HvARRAY(stash))
2036 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2037 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2038 GV *gv = (GV*)HeVAL(entry);
2040 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2046 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2047 && (hv = GvHV(gv)) && hv != PL_defstash)
2048 xmldump_packsubs(hv); /* nested package */
2054 Perl_xmldump_sub(pTHX_ const GV *gv)
2056 SV *sv = sv_newmortal();
2058 gv_fullname3(sv, gv, Nullch);
2059 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2060 if (CvXSUB(GvCV(gv)))
2061 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2062 PTR2UV(CvXSUB(GvCV(gv))),
2063 (int)CvXSUBANY(GvCV(gv)).any_i32);
2064 else if (CvROOT(GvCV(gv)))
2065 op_xmldump(CvROOT(GvCV(gv)));
2067 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2071 Perl_xmldump_form(pTHX_ const GV *gv)
2073 SV *sv = sv_newmortal();
2075 gv_fullname3(sv, gv, Nullch);
2076 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2077 if (CvROOT(GvFORM(gv)))
2078 op_xmldump(CvROOT(GvFORM(gv)));
2080 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2084 Perl_xmldump_eval(pTHX)
2086 op_xmldump(PL_eval_root);
2090 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2092 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2096 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2104 sv_catpvn(dsv,"",0);
2105 dsvcur = SvCUR(dsv); /* in case we have to restart */
2110 c = utf8_to_uvchr((U8*)pv, &cl);
2112 SvCUR(dsv) = dsvcur;
2177 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2180 Perl_sv_catpvf(aTHX_ dsv, "<");
2183 Perl_sv_catpvf(aTHX_ dsv, ">");
2186 Perl_sv_catpvf(aTHX_ dsv, "&");
2189 Perl_sv_catpvf(aTHX_ dsv, """);
2193 if (c < 32 || c > 127) {
2194 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2197 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2201 if ((c >= 0xD800 && c <= 0xDB7F) ||
2202 (c >= 0xDC00 && c <= 0xDFFF) ||
2203 (c >= 0xFFF0 && c <= 0xFFFF) ||
2205 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2207 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2220 Perl_sv_xmlpeek(pTHX_ SV *sv)
2222 SV *t = sv_newmortal();
2227 sv_setpvn(t, "", 0);
2230 sv_catpv(t, "VOID=\"\"");
2233 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2234 sv_catpv(t, "WILD=\"\"");
2237 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2238 if (sv == &PL_sv_undef) {
2239 sv_catpv(t, "SV_UNDEF=\"1\"");
2240 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2241 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2245 else if (sv == &PL_sv_no) {
2246 sv_catpv(t, "SV_NO=\"1\"");
2247 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2248 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2249 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2250 SVp_POK|SVp_NOK)) &&
2255 else if (sv == &PL_sv_yes) {
2256 sv_catpv(t, "SV_YES=\"1\"");
2257 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2258 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2259 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2260 SVp_POK|SVp_NOK)) &&
2262 SvPVX(sv) && *SvPVX(sv) == '1' &&
2267 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2268 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2269 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2273 sv_catpv(t, " XXX=\"\" ");
2275 else if (SvREFCNT(sv) == 0) {
2276 sv_catpv(t, " refcnt=\"0\"");
2279 else if (DEBUG_R_TEST_) {
2282 /* is this SV on the tmps stack? */
2283 for (ix=PL_tmps_ix; ix>=0; ix--) {
2284 if (PL_tmps_stack[ix] == sv) {
2289 if (SvREFCNT(sv) > 1)
2290 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2293 sv_catpv(t, " DRT=\"<T>\"");
2297 sv_catpv(t, " ROK=\"\"");
2299 switch (SvTYPE(sv)) {
2301 sv_catpv(t, " FREED=\"1\"");
2305 sv_catpv(t, " UNDEF=\"1\"");
2308 sv_catpv(t, " IV=\"");
2311 sv_catpv(t, " NV=\"");
2314 sv_catpv(t, " RV=\"");
2317 sv_catpv(t, " PV=\"");
2320 sv_catpv(t, " PVIV=\"");
2323 sv_catpv(t, " PVNV=\"");
2326 sv_catpv(t, " PVMG=\"");
2329 sv_catpv(t, " PVLV=\"");
2332 sv_catpv(t, " AV=\"");
2335 sv_catpv(t, " HV=\"");
2339 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2341 sv_catpv(t, " CV=\"()\"");
2344 sv_catpv(t, " GV=\"");
2347 sv_catpv(t, " BIND=\"");
2350 sv_catpv(t, " FM=\"");
2353 sv_catpv(t, " IO=\"");
2362 else if (SvNOKp(sv)) {
2363 STORE_NUMERIC_LOCAL_SET_STANDARD();
2364 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2365 RESTORE_NUMERIC_LOCAL();
2367 else if (SvIOKp(sv)) {
2369 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2371 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2382 return SvPV(t, n_a);
2386 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2389 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2392 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2395 char *s = PM_GETRE(pm)->precomp;
2396 SV *tmpsv = newSVpvn("",0);
2398 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2399 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2401 SvREFCNT_dec(tmpsv);
2402 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2403 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2406 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2407 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2408 SV * const tmpsv = pm_description(pm);
2409 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2410 SvREFCNT_dec(tmpsv);
2414 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
2415 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2416 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2417 do_op_xmldump(level+2, file, pm->op_pmreplroot);
2418 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2419 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2422 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2426 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2428 do_pmop_xmldump(0, PL_xmlfp, pm);
2432 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2439 seq = sequence_num(o);
2440 Perl_xmldump_indent(aTHX_ level, file,
2441 "<op_%s seq=\"%"UVuf" -> ",
2446 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2447 sequence_num(o->op_next));
2449 PerlIO_printf(file, "DONE\"");
2452 if (o->op_type == OP_NULL)
2454 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2455 if (o->op_targ == OP_NEXTSTATE)
2458 PerlIO_printf(file, " line=\"%"UVuf"\"",
2459 (UV)CopLINE(cCOPo));
2460 if (CopSTASHPV(cCOPo))
2461 PerlIO_printf(file, " package=\"%s\"",
2463 if (cCOPo->cop_label)
2464 PerlIO_printf(file, " label=\"%s\"",
2469 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2472 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2475 SV *tmpsv = newSVpvn("", 0);
2476 switch (o->op_flags & OPf_WANT) {
2478 sv_catpv(tmpsv, ",VOID");
2480 case OPf_WANT_SCALAR:
2481 sv_catpv(tmpsv, ",SCALAR");
2484 sv_catpv(tmpsv, ",LIST");
2487 sv_catpv(tmpsv, ",UNKNOWN");
2490 if (o->op_flags & OPf_KIDS)
2491 sv_catpv(tmpsv, ",KIDS");
2492 if (o->op_flags & OPf_PARENS)
2493 sv_catpv(tmpsv, ",PARENS");
2494 if (o->op_flags & OPf_STACKED)
2495 sv_catpv(tmpsv, ",STACKED");
2496 if (o->op_flags & OPf_REF)
2497 sv_catpv(tmpsv, ",REF");
2498 if (o->op_flags & OPf_MOD)
2499 sv_catpv(tmpsv, ",MOD");
2500 if (o->op_flags & OPf_SPECIAL)
2501 sv_catpv(tmpsv, ",SPECIAL");
2502 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2503 SvREFCNT_dec(tmpsv);
2505 if (o->op_private) {
2506 SV *tmpsv = newSVpvn("", 0);
2507 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2508 if (o->op_private & OPpTARGET_MY)
2509 sv_catpv(tmpsv, ",TARGET_MY");
2511 else if (o->op_type == OP_LEAVESUB ||
2512 o->op_type == OP_LEAVE ||
2513 o->op_type == OP_LEAVESUBLV ||
2514 o->op_type == OP_LEAVEWRITE) {
2515 if (o->op_private & OPpREFCOUNTED)
2516 sv_catpv(tmpsv, ",REFCOUNTED");
2518 else if (o->op_type == OP_AASSIGN) {
2519 if (o->op_private & OPpASSIGN_COMMON)
2520 sv_catpv(tmpsv, ",COMMON");
2522 else if (o->op_type == OP_SASSIGN) {
2523 if (o->op_private & OPpASSIGN_BACKWARDS)
2524 sv_catpv(tmpsv, ",BACKWARDS");
2526 else if (o->op_type == OP_TRANS) {
2527 if (o->op_private & OPpTRANS_SQUASH)
2528 sv_catpv(tmpsv, ",SQUASH");
2529 if (o->op_private & OPpTRANS_DELETE)
2530 sv_catpv(tmpsv, ",DELETE");
2531 if (o->op_private & OPpTRANS_COMPLEMENT)
2532 sv_catpv(tmpsv, ",COMPLEMENT");
2533 if (o->op_private & OPpTRANS_IDENTICAL)
2534 sv_catpv(tmpsv, ",IDENTICAL");
2535 if (o->op_private & OPpTRANS_GROWS)
2536 sv_catpv(tmpsv, ",GROWS");
2538 else if (o->op_type == OP_REPEAT) {
2539 if (o->op_private & OPpREPEAT_DOLIST)
2540 sv_catpv(tmpsv, ",DOLIST");
2542 else if (o->op_type == OP_ENTERSUB ||
2543 o->op_type == OP_RV2SV ||
2544 o->op_type == OP_GVSV ||
2545 o->op_type == OP_RV2AV ||
2546 o->op_type == OP_RV2HV ||
2547 o->op_type == OP_RV2GV ||
2548 o->op_type == OP_AELEM ||
2549 o->op_type == OP_HELEM )
2551 if (o->op_type == OP_ENTERSUB) {
2552 if (o->op_private & OPpENTERSUB_AMPER)
2553 sv_catpv(tmpsv, ",AMPER");
2554 if (o->op_private & OPpENTERSUB_DB)
2555 sv_catpv(tmpsv, ",DB");
2556 if (o->op_private & OPpENTERSUB_HASTARG)
2557 sv_catpv(tmpsv, ",HASTARG");
2558 if (o->op_private & OPpENTERSUB_NOPAREN)
2559 sv_catpv(tmpsv, ",NOPAREN");
2560 if (o->op_private & OPpENTERSUB_INARGS)
2561 sv_catpv(tmpsv, ",INARGS");
2562 if (o->op_private & OPpENTERSUB_NOMOD)
2563 sv_catpv(tmpsv, ",NOMOD");
2566 switch (o->op_private & OPpDEREF) {
2568 sv_catpv(tmpsv, ",SV");
2571 sv_catpv(tmpsv, ",AV");
2574 sv_catpv(tmpsv, ",HV");
2577 if (o->op_private & OPpMAYBE_LVSUB)
2578 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2580 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2581 if (o->op_private & OPpLVAL_DEFER)
2582 sv_catpv(tmpsv, ",LVAL_DEFER");
2585 if (o->op_private & HINT_STRICT_REFS)
2586 sv_catpv(tmpsv, ",STRICT_REFS");
2587 if (o->op_private & OPpOUR_INTRO)
2588 sv_catpv(tmpsv, ",OUR_INTRO");
2591 else if (o->op_type == OP_CONST) {
2592 if (o->op_private & OPpCONST_BARE)
2593 sv_catpv(tmpsv, ",BARE");
2594 if (o->op_private & OPpCONST_STRICT)
2595 sv_catpv(tmpsv, ",STRICT");
2596 if (o->op_private & OPpCONST_ARYBASE)
2597 sv_catpv(tmpsv, ",ARYBASE");
2598 if (o->op_private & OPpCONST_WARNING)
2599 sv_catpv(tmpsv, ",WARNING");
2600 if (o->op_private & OPpCONST_ENTERED)
2601 sv_catpv(tmpsv, ",ENTERED");
2603 else if (o->op_type == OP_FLIP) {
2604 if (o->op_private & OPpFLIP_LINENUM)
2605 sv_catpv(tmpsv, ",LINENUM");
2607 else if (o->op_type == OP_FLOP) {
2608 if (o->op_private & OPpFLIP_LINENUM)
2609 sv_catpv(tmpsv, ",LINENUM");
2611 else if (o->op_type == OP_RV2CV) {
2612 if (o->op_private & OPpLVAL_INTRO)
2613 sv_catpv(tmpsv, ",INTRO");
2615 else if (o->op_type == OP_GV) {
2616 if (o->op_private & OPpEARLY_CV)
2617 sv_catpv(tmpsv, ",EARLY_CV");
2619 else if (o->op_type == OP_LIST) {
2620 if (o->op_private & OPpLIST_GUESSED)
2621 sv_catpv(tmpsv, ",GUESSED");
2623 else if (o->op_type == OP_DELETE) {
2624 if (o->op_private & OPpSLICE)
2625 sv_catpv(tmpsv, ",SLICE");
2627 else if (o->op_type == OP_EXISTS) {
2628 if (o->op_private & OPpEXISTS_SUB)
2629 sv_catpv(tmpsv, ",EXISTS_SUB");
2631 else if (o->op_type == OP_SORT) {
2632 if (o->op_private & OPpSORT_NUMERIC)
2633 sv_catpv(tmpsv, ",NUMERIC");
2634 if (o->op_private & OPpSORT_INTEGER)
2635 sv_catpv(tmpsv, ",INTEGER");
2636 if (o->op_private & OPpSORT_REVERSE)
2637 sv_catpv(tmpsv, ",REVERSE");
2639 else if (o->op_type == OP_THREADSV) {
2640 if (o->op_private & OPpDONE_SVREF)
2641 sv_catpv(tmpsv, ",SVREF");
2643 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2644 if (o->op_private & OPpOPEN_IN_RAW)
2645 sv_catpv(tmpsv, ",IN_RAW");
2646 if (o->op_private & OPpOPEN_IN_CRLF)
2647 sv_catpv(tmpsv, ",IN_CRLF");
2648 if (o->op_private & OPpOPEN_OUT_RAW)
2649 sv_catpv(tmpsv, ",OUT_RAW");
2650 if (o->op_private & OPpOPEN_OUT_CRLF)
2651 sv_catpv(tmpsv, ",OUT_CRLF");
2653 else if (o->op_type == OP_EXIT) {
2654 if (o->op_private & OPpEXIT_VMSISH)
2655 sv_catpv(tmpsv, ",EXIT_VMSISH");
2656 if (o->op_private & OPpHUSH_VMSISH)
2657 sv_catpv(tmpsv, ",HUSH_VMSISH");
2659 else if (o->op_type == OP_DIE) {
2660 if (o->op_private & OPpHUSH_VMSISH)
2661 sv_catpv(tmpsv, ",HUSH_VMSISH");
2663 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2664 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2665 sv_catpv(tmpsv, ",FT_ACCESS");
2666 if (o->op_private & OPpFT_STACKED)
2667 sv_catpv(tmpsv, ",FT_STACKED");
2669 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2670 sv_catpv(tmpsv, ",INTRO");
2672 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2673 SvREFCNT_dec(tmpsv);
2676 switch (o->op_type) {
2678 if (o->op_flags & OPf_SPECIAL) {
2684 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2686 if (cSVOPo->op_sv) {
2687 SV *tmpsv1 = newSV(0);
2688 SV *tmpsv2 = newSVpvn("",0);
2696 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2697 s = SvPV(tmpsv1,len);
2698 sv_catxmlpvn(tmpsv2, s, len, 1);
2699 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2703 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2707 case OP_METHOD_NAMED:
2708 #ifndef USE_ITHREADS
2709 /* with ITHREADS, consts are stored in the pad, and the right pad
2710 * may not be active here, so skip */
2711 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2717 PerlIO_printf(file, ">\n");
2719 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2725 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2726 (UV)CopLINE(cCOPo));
2727 if (CopSTASHPV(cCOPo))
2728 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2730 if (cCOPo->cop_label)
2731 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2735 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2736 if (cLOOPo->op_redoop)
2737 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2739 PerlIO_printf(file, "DONE\"");
2740 S_xmldump_attr(aTHX_ level, file, "next=\"");
2741 if (cLOOPo->op_nextop)
2742 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2744 PerlIO_printf(file, "DONE\"");
2745 S_xmldump_attr(aTHX_ level, file, "last=\"");
2746 if (cLOOPo->op_lastop)
2747 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2749 PerlIO_printf(file, "DONE\"");
2757 S_xmldump_attr(aTHX_ level, file, "other=\"");
2758 if (cLOGOPo->op_other)
2759 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2761 PerlIO_printf(file, "DONE\"");
2769 if (o->op_private & OPpREFCOUNTED)
2770 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2776 if (PL_madskills && o->op_madprop) {
2777 SV *tmpsv = newSVpvn("", 0);
2778 MADPROP* mp = o->op_madprop;
2779 sv_utf8_upgrade(tmpsv);
2782 PerlIO_printf(file, ">\n");
2784 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2787 char tmp = mp->mad_key;
2788 sv_setpvn(tmpsv,"\"",1);
2790 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2791 sv_catpv(tmpsv, "\"");
2792 switch (mp->mad_type) {
2794 sv_catpv(tmpsv, "NULL");
2795 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2798 sv_catpv(tmpsv, " val=\"");
2799 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2800 sv_catpv(tmpsv, "\"");
2801 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2804 sv_catpv(tmpsv, " val=\"");
2805 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2806 sv_catpv(tmpsv, "\"");
2807 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2810 if ((OP*)mp->mad_val) {
2811 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2812 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2813 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2817 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2823 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2825 SvREFCNT_dec(tmpsv);
2828 switch (o->op_type) {
2835 PerlIO_printf(file, ">\n");
2837 do_pmop_xmldump(level, file, cPMOPo);
2843 if (o->op_flags & OPf_KIDS) {
2847 PerlIO_printf(file, ">\n");
2849 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2850 do_op_xmldump(level, file, kid);
2854 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2856 PerlIO_printf(file, " />\n");
2860 Perl_op_xmldump(pTHX_ const OP *o)
2862 do_op_xmldump(0, PL_xmlfp, o);
2868 * c-indentation-style: bsd
2870 * indent-tabs-mode: t
2873 * ex: set ts=8 sts=4 sw=4 noet: