3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
196 not a '\\'. This is because regexes very often contain backslashed
197 sequences, whereas '%' is not a particularly common character in patterns.
199 Returns a pointer to the escaped text as held by dsv.
203 #define PV_ESCAPE_OCTBUFSIZE 32
206 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
207 const STRLEN count, const STRLEN max,
208 STRLEN * const escaped, const U32 flags )
210 char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
211 char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
212 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
213 STRLEN wrote = 0; /* chars written so far */
214 STRLEN chsize = 0; /* size of data to be written */
215 STRLEN readsize = 1; /* size of data just read */
216 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
217 const char *pv = str;
218 const char *end = pv + count; /* end of string */
221 if (!flags & PERL_PV_ESCAPE_NOCLEAR)
222 sv_setpvn(dsv, "", 0);
224 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
227 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
228 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
229 const U8 c = (U8)u & 0xFF;
231 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
232 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
233 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
236 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
237 "%cx{%"UVxf"}", esc, u);
238 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
241 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
245 case '\\' : /* fallthrough */
246 case '%' : if ( c == esc ) {
252 case '\v' : octbuf[1] = 'v'; break;
253 case '\t' : octbuf[1] = 't'; break;
254 case '\r' : octbuf[1] = 'r'; break;
255 case '\n' : octbuf[1] = 'n'; break;
256 case '\f' : octbuf[1] = 'f'; break;
264 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
265 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
268 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
275 if ( max && (wrote + chsize > max) ) {
277 } else if (chsize > 1) {
278 sv_catpvn(dsv, octbuf, chsize);
281 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
284 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
292 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
293 |const STRLEN count|const STRLEN max\
294 |const char const *start_color| const char const *end_color\
297 Converts a string into something presentable, handling escaping via
298 pv_escape() and supporting quoting and elipses.
300 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
301 double quoted with any double quotes in the string escaped. Otherwise
302 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
305 If the PERL_PV_PRETTY_ELIPSES flag is set and not all characters in
306 string were output then an elipses C<...> will be appended to the
307 string. Note that this happens AFTER it has been quoted.
309 If start_color is non-null then it will be inserted after the opening
310 quote (if there is one) but before the escaped text. If end_color
311 is non-null then it will be inserted after the escaped text but before
312 any quotes or elipses.
314 Returns a pointer to the prettified text as held by dsv.
320 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
321 const STRLEN max, char const * const start_color, char const * const end_color,
324 U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
328 sv_setpvn(dsv, "\"", 1);
329 else if ( flags & PERL_PV_PRETTY_LTGT )
330 sv_setpvn(dsv, "<", 1);
332 sv_setpvn(dsv, "", 0);
334 if ( start_color != NULL )
335 Perl_sv_catpv( aTHX_ dsv, start_color);
337 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
339 if ( end_color != NULL )
340 Perl_sv_catpv( aTHX_ dsv, end_color);
343 sv_catpvn( dsv, "\"", 1 );
344 else if ( flags & PERL_PV_PRETTY_LTGT )
345 sv_catpvn( dsv, ">", 1);
347 if ( (flags & PERL_PV_PRETTY_ELIPSES) && ( escaped < count ) )
348 sv_catpvn( dsv, "...", 3 );
354 =for apidoc pv_display
356 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
357 STRLEN pvlim, U32 flags)
361 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
363 except that an additional "\0" will be appended to the string when
364 len > cur and pv[cur] is "\0".
366 Note that the final string may be up to 7 chars longer than pvlim.
372 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
374 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
375 if (len > cur && pv[cur] == '\0')
376 sv_catpvn( dsv, "\\0", 2 );
381 Perl_sv_peek(pTHX_ SV *sv)
384 SV * const t = sv_newmortal();
394 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
398 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
399 if (sv == &PL_sv_undef) {
400 sv_catpv(t, "SV_UNDEF");
401 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
402 SVs_GMG|SVs_SMG|SVs_RMG)) &&
406 else if (sv == &PL_sv_no) {
407 sv_catpv(t, "SV_NO");
408 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
409 SVs_GMG|SVs_SMG|SVs_RMG)) &&
410 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
416 else if (sv == &PL_sv_yes) {
417 sv_catpv(t, "SV_YES");
418 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
419 SVs_GMG|SVs_SMG|SVs_RMG)) &&
420 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
423 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
428 sv_catpv(t, "SV_PLACEHOLDER");
429 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
430 SVs_GMG|SVs_SMG|SVs_RMG)) &&
436 else if (SvREFCNT(sv) == 0) {
440 else if (DEBUG_R_TEST_) {
443 /* is this SV on the tmps stack? */
444 for (ix=PL_tmps_ix; ix>=0; ix--) {
445 if (PL_tmps_stack[ix] == sv) {
450 if (SvREFCNT(sv) > 1)
451 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
459 if (SvCUR(t) + unref > 10) {
460 SvCUR_set(t, unref + 3);
469 if (type == SVt_PVCV) {
470 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
472 } else if (type < SVt_LAST) {
473 sv_catpv(t, svshorttypenames[type]);
475 if (type == SVt_NULL)
478 sv_catpv(t, "FREED");
483 if (!SvPVX_const(sv))
484 sv_catpv(t, "(null)");
486 SV * const tmp = newSVpvs("");
489 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
490 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
492 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
493 sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv),
498 else if (SvNOKp(sv)) {
499 STORE_NUMERIC_LOCAL_SET_STANDARD();
500 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
501 RESTORE_NUMERIC_LOCAL();
503 else if (SvIOKp(sv)) {
505 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
507 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
517 return SvPV_nolen(t);
521 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
526 Perl_dump_indent(aTHX_ level, file, "{}\n");
529 Perl_dump_indent(aTHX_ level, file, "{\n");
531 if (pm->op_pmflags & PMf_ONCE)
536 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
537 ch, PM_GETRE(pm)->precomp, ch,
538 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
540 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
541 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
542 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
543 op_dump(pm->op_pmreplroot);
545 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
546 SV * const tmpsv = pm_description(pm);
547 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
551 Perl_dump_indent(aTHX_ level-1, file, "}\n");
555 S_pm_description(pTHX_ const PMOP *pm)
557 SV * const desc = newSVpvs("");
558 const REGEXP * regex = PM_GETRE(pm);
559 const U32 pmflags = pm->op_pmflags;
561 if (pm->op_pmdynflags & PMdf_USED)
562 sv_catpv(desc, ",USED");
563 if (pm->op_pmdynflags & PMdf_TAINTED)
564 sv_catpv(desc, ",TAINTED");
566 if (pmflags & PMf_ONCE)
567 sv_catpv(desc, ",ONCE");
568 if (regex && regex->check_substr) {
569 if (!(regex->extflags & RXf_NOSCAN))
570 sv_catpv(desc, ",SCANFIRST");
571 if (regex->extflags & RXf_CHECK_ALL)
572 sv_catpv(desc, ",ALL");
574 if (pmflags & PMf_SKIPWHITE)
575 sv_catpv(desc, ",SKIPWHITE");
576 if (pmflags & PMf_CONST)
577 sv_catpv(desc, ",CONST");
578 if (pmflags & PMf_KEEP)
579 sv_catpv(desc, ",KEEP");
580 if (pmflags & PMf_GLOBAL)
581 sv_catpv(desc, ",GLOBAL");
582 if (pmflags & PMf_CONTINUE)
583 sv_catpv(desc, ",CONTINUE");
584 if (pmflags & PMf_RETAINT)
585 sv_catpv(desc, ",RETAINT");
586 if (pmflags & PMf_EVAL)
587 sv_catpv(desc, ",EVAL");
592 Perl_pmop_dump(pTHX_ PMOP *pm)
594 do_pmop_dump(0, Perl_debug_log, pm);
597 /* An op sequencer. We visit the ops in the order they're to execute. */
600 S_sequence(pTHX_ register const OP *o)
603 const OP *oldop = NULL;
616 for (; o; o = o->op_next) {
618 SV * const op = newSVuv(PTR2UV(o));
619 const char * const key = SvPV_const(op, len);
621 if (hv_exists(Sequence, key, len))
624 switch (o->op_type) {
626 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
627 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
636 if (oldop && o->op_next)
643 if (oldop && o->op_next)
645 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
658 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
659 sequence_tail(cLOGOPo->op_other);
664 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
665 sequence_tail(cLOOPo->op_redoop);
666 sequence_tail(cLOOPo->op_nextop);
667 sequence_tail(cLOOPo->op_lastop);
673 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
674 sequence_tail(cPMOPo->op_pmreplstart);
681 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
689 S_sequence_tail(pTHX_ const OP *o)
691 while (o && (o->op_type == OP_NULL))
697 S_sequence_num(pTHX_ const OP *o)
705 op = newSVuv(PTR2UV(o));
706 key = SvPV_const(op, len);
707 seq = hv_fetch(Sequence, key, len, 0);
708 return seq ? SvUV(*seq): 0;
712 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
716 const OPCODE optype = o->op_type;
719 Perl_dump_indent(aTHX_ level, file, "{\n");
721 seq = sequence_num(o);
723 PerlIO_printf(file, "%-4"UVuf, seq);
725 PerlIO_printf(file, " ");
727 "%*sTYPE = %s ===> ",
728 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
730 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
731 sequence_num(o->op_next));
733 PerlIO_printf(file, "DONE\n");
735 if (optype == OP_NULL) {
736 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
737 if (o->op_targ == OP_NEXTSTATE) {
739 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
741 if (CopSTASHPV(cCOPo))
742 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
744 if (cCOPo->cop_label)
745 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
750 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
753 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
755 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
756 SV * const tmpsv = newSVpvs("");
757 switch (o->op_flags & OPf_WANT) {
759 sv_catpv(tmpsv, ",VOID");
761 case OPf_WANT_SCALAR:
762 sv_catpv(tmpsv, ",SCALAR");
765 sv_catpv(tmpsv, ",LIST");
768 sv_catpv(tmpsv, ",UNKNOWN");
771 if (o->op_flags & OPf_KIDS)
772 sv_catpv(tmpsv, ",KIDS");
773 if (o->op_flags & OPf_PARENS)
774 sv_catpv(tmpsv, ",PARENS");
775 if (o->op_flags & OPf_STACKED)
776 sv_catpv(tmpsv, ",STACKED");
777 if (o->op_flags & OPf_REF)
778 sv_catpv(tmpsv, ",REF");
779 if (o->op_flags & OPf_MOD)
780 sv_catpv(tmpsv, ",MOD");
781 if (o->op_flags & OPf_SPECIAL)
782 sv_catpv(tmpsv, ",SPECIAL");
784 sv_catpv(tmpsv, ",LATEFREE");
786 sv_catpv(tmpsv, ",LATEFREED");
788 sv_catpv(tmpsv, ",ATTACHED");
789 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
793 SV * const tmpsv = newSVpvs("");
794 if (PL_opargs[optype] & OA_TARGLEX) {
795 if (o->op_private & OPpTARGET_MY)
796 sv_catpv(tmpsv, ",TARGET_MY");
798 else if (optype == OP_LEAVESUB ||
799 optype == OP_LEAVE ||
800 optype == OP_LEAVESUBLV ||
801 optype == OP_LEAVEWRITE) {
802 if (o->op_private & OPpREFCOUNTED)
803 sv_catpv(tmpsv, ",REFCOUNTED");
805 else if (optype == OP_AASSIGN) {
806 if (o->op_private & OPpASSIGN_COMMON)
807 sv_catpv(tmpsv, ",COMMON");
809 else if (optype == OP_SASSIGN) {
810 if (o->op_private & OPpASSIGN_BACKWARDS)
811 sv_catpv(tmpsv, ",BACKWARDS");
813 else if (optype == OP_TRANS) {
814 if (o->op_private & OPpTRANS_SQUASH)
815 sv_catpv(tmpsv, ",SQUASH");
816 if (o->op_private & OPpTRANS_DELETE)
817 sv_catpv(tmpsv, ",DELETE");
818 if (o->op_private & OPpTRANS_COMPLEMENT)
819 sv_catpv(tmpsv, ",COMPLEMENT");
820 if (o->op_private & OPpTRANS_IDENTICAL)
821 sv_catpv(tmpsv, ",IDENTICAL");
822 if (o->op_private & OPpTRANS_GROWS)
823 sv_catpv(tmpsv, ",GROWS");
825 else if (optype == OP_REPEAT) {
826 if (o->op_private & OPpREPEAT_DOLIST)
827 sv_catpv(tmpsv, ",DOLIST");
829 else if (optype == OP_ENTERSUB ||
830 optype == OP_RV2SV ||
832 optype == OP_RV2AV ||
833 optype == OP_RV2HV ||
834 optype == OP_RV2GV ||
835 optype == OP_AELEM ||
838 if (optype == OP_ENTERSUB) {
839 if (o->op_private & OPpENTERSUB_AMPER)
840 sv_catpv(tmpsv, ",AMPER");
841 if (o->op_private & OPpENTERSUB_DB)
842 sv_catpv(tmpsv, ",DB");
843 if (o->op_private & OPpENTERSUB_HASTARG)
844 sv_catpv(tmpsv, ",HASTARG");
845 if (o->op_private & OPpENTERSUB_NOPAREN)
846 sv_catpv(tmpsv, ",NOPAREN");
847 if (o->op_private & OPpENTERSUB_INARGS)
848 sv_catpv(tmpsv, ",INARGS");
849 if (o->op_private & OPpENTERSUB_NOMOD)
850 sv_catpv(tmpsv, ",NOMOD");
853 switch (o->op_private & OPpDEREF) {
855 sv_catpv(tmpsv, ",SV");
858 sv_catpv(tmpsv, ",AV");
861 sv_catpv(tmpsv, ",HV");
864 if (o->op_private & OPpMAYBE_LVSUB)
865 sv_catpv(tmpsv, ",MAYBE_LVSUB");
867 if (optype == OP_AELEM || optype == OP_HELEM) {
868 if (o->op_private & OPpLVAL_DEFER)
869 sv_catpv(tmpsv, ",LVAL_DEFER");
872 if (o->op_private & HINT_STRICT_REFS)
873 sv_catpv(tmpsv, ",STRICT_REFS");
874 if (o->op_private & OPpOUR_INTRO)
875 sv_catpv(tmpsv, ",OUR_INTRO");
878 else if (optype == OP_CONST) {
879 if (o->op_private & OPpCONST_BARE)
880 sv_catpv(tmpsv, ",BARE");
881 if (o->op_private & OPpCONST_STRICT)
882 sv_catpv(tmpsv, ",STRICT");
883 if (o->op_private & OPpCONST_ARYBASE)
884 sv_catpv(tmpsv, ",ARYBASE");
885 if (o->op_private & OPpCONST_WARNING)
886 sv_catpv(tmpsv, ",WARNING");
887 if (o->op_private & OPpCONST_ENTERED)
888 sv_catpv(tmpsv, ",ENTERED");
890 else if (optype == OP_FLIP) {
891 if (o->op_private & OPpFLIP_LINENUM)
892 sv_catpv(tmpsv, ",LINENUM");
894 else if (optype == OP_FLOP) {
895 if (o->op_private & OPpFLIP_LINENUM)
896 sv_catpv(tmpsv, ",LINENUM");
898 else if (optype == OP_RV2CV) {
899 if (o->op_private & OPpLVAL_INTRO)
900 sv_catpv(tmpsv, ",INTRO");
902 else if (optype == OP_GV) {
903 if (o->op_private & OPpEARLY_CV)
904 sv_catpv(tmpsv, ",EARLY_CV");
906 else if (optype == OP_LIST) {
907 if (o->op_private & OPpLIST_GUESSED)
908 sv_catpv(tmpsv, ",GUESSED");
910 else if (optype == OP_DELETE) {
911 if (o->op_private & OPpSLICE)
912 sv_catpv(tmpsv, ",SLICE");
914 else if (optype == OP_EXISTS) {
915 if (o->op_private & OPpEXISTS_SUB)
916 sv_catpv(tmpsv, ",EXISTS_SUB");
918 else if (optype == OP_SORT) {
919 if (o->op_private & OPpSORT_NUMERIC)
920 sv_catpv(tmpsv, ",NUMERIC");
921 if (o->op_private & OPpSORT_INTEGER)
922 sv_catpv(tmpsv, ",INTEGER");
923 if (o->op_private & OPpSORT_REVERSE)
924 sv_catpv(tmpsv, ",REVERSE");
926 else if (optype == OP_THREADSV) {
927 if (o->op_private & OPpDONE_SVREF)
928 sv_catpv(tmpsv, ",SVREF");
930 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
931 if (o->op_private & OPpOPEN_IN_RAW)
932 sv_catpv(tmpsv, ",IN_RAW");
933 if (o->op_private & OPpOPEN_IN_CRLF)
934 sv_catpv(tmpsv, ",IN_CRLF");
935 if (o->op_private & OPpOPEN_OUT_RAW)
936 sv_catpv(tmpsv, ",OUT_RAW");
937 if (o->op_private & OPpOPEN_OUT_CRLF)
938 sv_catpv(tmpsv, ",OUT_CRLF");
940 else if (optype == OP_EXIT) {
941 if (o->op_private & OPpEXIT_VMSISH)
942 sv_catpv(tmpsv, ",EXIT_VMSISH");
943 if (o->op_private & OPpHUSH_VMSISH)
944 sv_catpv(tmpsv, ",HUSH_VMSISH");
946 else if (optype == OP_DIE) {
947 if (o->op_private & OPpHUSH_VMSISH)
948 sv_catpv(tmpsv, ",HUSH_VMSISH");
950 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
951 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
952 sv_catpv(tmpsv, ",FT_ACCESS");
953 if (o->op_private & OPpFT_STACKED)
954 sv_catpv(tmpsv, ",FT_STACKED");
956 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
957 sv_catpv(tmpsv, ",INTRO");
959 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
964 if (PL_madskills && o->op_madprop) {
965 SV * const tmpsv = newSVpvn("", 0);
966 MADPROP* mp = o->op_madprop;
967 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
970 char tmp = mp->mad_key;
971 sv_setpvn(tmpsv,"'",1);
973 sv_catpvn(tmpsv, &tmp, 1);
974 sv_catpv(tmpsv, "'=");
975 switch (mp->mad_type) {
977 sv_catpv(tmpsv, "NULL");
978 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
981 sv_catpv(tmpsv, "<");
982 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
983 sv_catpv(tmpsv, ">");
984 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
987 if ((OP*)mp->mad_val) {
988 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
989 do_op_dump(level, file, (OP*)mp->mad_val);
993 sv_catpv(tmpsv, "(UNK)");
994 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1000 Perl_dump_indent(aTHX_ level, file, "}\n");
1002 SvREFCNT_dec(tmpsv);
1011 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1013 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1014 if (cSVOPo->op_sv) {
1015 SV * const tmpsv = newSV(0);
1019 /* FIXME - it this making unwarranted assumptions about the
1020 UTF-8 cleanliness of the dump file handle? */
1023 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1024 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1025 SvPV_nolen_const(tmpsv));
1029 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1034 case OP_METHOD_NAMED:
1035 #ifndef USE_ITHREADS
1036 /* with ITHREADS, consts are stored in the pad, and the right pad
1037 * may not be active here, so skip */
1038 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1045 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1046 (UV)CopLINE(cCOPo));
1047 if (CopSTASHPV(cCOPo))
1048 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1050 if (cCOPo->cop_label)
1051 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1055 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1056 if (cLOOPo->op_redoop)
1057 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1059 PerlIO_printf(file, "DONE\n");
1060 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1061 if (cLOOPo->op_nextop)
1062 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1064 PerlIO_printf(file, "DONE\n");
1065 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1066 if (cLOOPo->op_lastop)
1067 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1069 PerlIO_printf(file, "DONE\n");
1077 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1078 if (cLOGOPo->op_other)
1079 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1081 PerlIO_printf(file, "DONE\n");
1087 do_pmop_dump(level, file, cPMOPo);
1095 if (o->op_private & OPpREFCOUNTED)
1096 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1101 if (o->op_flags & OPf_KIDS) {
1103 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1104 do_op_dump(level, file, kid);
1106 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1110 Perl_op_dump(pTHX_ const OP *o)
1112 do_op_dump(0, Perl_debug_log, o);
1116 Perl_gv_dump(pTHX_ GV *gv)
1121 PerlIO_printf(Perl_debug_log, "{}\n");
1124 sv = sv_newmortal();
1125 PerlIO_printf(Perl_debug_log, "{\n");
1126 gv_fullname3(sv, gv, NULL);
1127 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1128 if (gv != GvEGV(gv)) {
1129 gv_efullname3(sv, GvEGV(gv), NULL);
1130 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1132 PerlIO_putc(Perl_debug_log, '\n');
1133 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1137 /* map magic types to the symbolic names
1138 * (with the PERL_MAGIC_ prefixed stripped)
1141 static const struct { const char type; const char *name; } magic_names[] = {
1142 { PERL_MAGIC_sv, "sv(\\0)" },
1143 { PERL_MAGIC_arylen, "arylen(#)" },
1144 { PERL_MAGIC_rhash, "rhash(%)" },
1145 { PERL_MAGIC_pos, "pos(.)" },
1146 { PERL_MAGIC_symtab, "symtab(:)" },
1147 { PERL_MAGIC_backref, "backref(<)" },
1148 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1149 { PERL_MAGIC_overload, "overload(A)" },
1150 { PERL_MAGIC_bm, "bm(B)" },
1151 { PERL_MAGIC_regdata, "regdata(D)" },
1152 { PERL_MAGIC_env, "env(E)" },
1153 { PERL_MAGIC_hints, "hints(H)" },
1154 { PERL_MAGIC_isa, "isa(I)" },
1155 { PERL_MAGIC_dbfile, "dbfile(L)" },
1156 { PERL_MAGIC_shared, "shared(N)" },
1157 { PERL_MAGIC_tied, "tied(P)" },
1158 { PERL_MAGIC_sig, "sig(S)" },
1159 { PERL_MAGIC_uvar, "uvar(U)" },
1160 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1161 { PERL_MAGIC_overload_table, "overload_table(c)" },
1162 { PERL_MAGIC_regdatum, "regdatum(d)" },
1163 { PERL_MAGIC_envelem, "envelem(e)" },
1164 { PERL_MAGIC_fm, "fm(f)" },
1165 { PERL_MAGIC_regex_global, "regex_global(g)" },
1166 { PERL_MAGIC_hintselem, "hintselem(h)" },
1167 { PERL_MAGIC_isaelem, "isaelem(i)" },
1168 { PERL_MAGIC_nkeys, "nkeys(k)" },
1169 { PERL_MAGIC_dbline, "dbline(l)" },
1170 { PERL_MAGIC_mutex, "mutex(m)" },
1171 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1172 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1173 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1174 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1175 { PERL_MAGIC_qr, "qr(r)" },
1176 { PERL_MAGIC_sigelem, "sigelem(s)" },
1177 { PERL_MAGIC_taint, "taint(t)" },
1178 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1179 { PERL_MAGIC_vec, "vec(v)" },
1180 { PERL_MAGIC_vstring, "vstring(V)" },
1181 { PERL_MAGIC_utf8, "utf8(w)" },
1182 { PERL_MAGIC_substr, "substr(x)" },
1183 { PERL_MAGIC_defelem, "defelem(y)" },
1184 { PERL_MAGIC_ext, "ext(~)" },
1185 /* this null string terminates the list */
1190 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1192 for (; mg; mg = mg->mg_moremagic) {
1193 Perl_dump_indent(aTHX_ level, file,
1194 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1195 if (mg->mg_virtual) {
1196 const MGVTBL * const v = mg->mg_virtual;
1198 if (v == &PL_vtbl_sv) s = "sv";
1199 else if (v == &PL_vtbl_env) s = "env";
1200 else if (v == &PL_vtbl_envelem) s = "envelem";
1201 else if (v == &PL_vtbl_sig) s = "sig";
1202 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1203 else if (v == &PL_vtbl_pack) s = "pack";
1204 else if (v == &PL_vtbl_packelem) s = "packelem";
1205 else if (v == &PL_vtbl_dbline) s = "dbline";
1206 else if (v == &PL_vtbl_isa) s = "isa";
1207 else if (v == &PL_vtbl_arylen) s = "arylen";
1208 else if (v == &PL_vtbl_mglob) s = "mglob";
1209 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1210 else if (v == &PL_vtbl_taint) s = "taint";
1211 else if (v == &PL_vtbl_substr) s = "substr";
1212 else if (v == &PL_vtbl_vec) s = "vec";
1213 else if (v == &PL_vtbl_pos) s = "pos";
1214 else if (v == &PL_vtbl_bm) s = "bm";
1215 else if (v == &PL_vtbl_fm) s = "fm";
1216 else if (v == &PL_vtbl_uvar) s = "uvar";
1217 else if (v == &PL_vtbl_defelem) s = "defelem";
1218 #ifdef USE_LOCALE_COLLATE
1219 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1221 else if (v == &PL_vtbl_amagic) s = "amagic";
1222 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1223 else if (v == &PL_vtbl_backref) s = "backref";
1224 else if (v == &PL_vtbl_utf8) s = "utf8";
1225 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1226 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1229 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1231 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1234 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1237 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1241 const char *name = NULL;
1242 for (n = 0; magic_names[n].name; n++) {
1243 if (mg->mg_type == magic_names[n].type) {
1244 name = magic_names[n].name;
1249 Perl_dump_indent(aTHX_ level, file,
1250 " MG_TYPE = PERL_MAGIC_%s\n", name);
1252 Perl_dump_indent(aTHX_ level, file,
1253 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1257 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1258 if (mg->mg_type == PERL_MAGIC_envelem &&
1259 mg->mg_flags & MGf_TAINTEDDIR)
1260 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1261 if (mg->mg_flags & MGf_REFCOUNTED)
1262 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1263 if (mg->mg_flags & MGf_GSKIP)
1264 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1265 if (mg->mg_type == PERL_MAGIC_regex_global &&
1266 mg->mg_flags & MGf_MINMATCH)
1267 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1270 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1271 if (mg->mg_flags & MGf_REFCOUNTED)
1272 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1275 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1277 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1278 if (mg->mg_len >= 0) {
1279 if (mg->mg_type != PERL_MAGIC_utf8) {
1280 SV *sv = newSVpvs("");
1281 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1285 else if (mg->mg_len == HEf_SVKEY) {
1286 PerlIO_puts(file, " => HEf_SVKEY\n");
1287 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1291 PerlIO_puts(file, " ???? - please notify IZ");
1292 PerlIO_putc(file, '\n');
1294 if (mg->mg_type == PERL_MAGIC_utf8) {
1295 STRLEN *cache = (STRLEN *) mg->mg_ptr;
1298 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1299 Perl_dump_indent(aTHX_ level, file,
1300 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1303 (UV)cache[i * 2 + 1]);
1310 Perl_magic_dump(pTHX_ const MAGIC *mg)
1312 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1316 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1319 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1320 if (sv && (hvname = HvNAME_get(sv)))
1321 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1323 PerlIO_putc(file, '\n');
1327 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1329 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1330 if (sv && GvNAME(sv))
1331 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1333 PerlIO_putc(file, '\n');
1337 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1339 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1340 if (sv && GvNAME(sv)) {
1342 PerlIO_printf(file, "\t\"");
1343 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1344 PerlIO_printf(file, "%s\" :: \"", hvname);
1345 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1348 PerlIO_putc(file, '\n');
1352 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1361 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1365 flags = SvFLAGS(sv);
1368 d = Perl_newSVpvf(aTHX_
1369 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1370 PTR2UV(SvANY(sv)), PTR2UV(sv),
1371 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1372 (int)(PL_dumpindent*level), "");
1374 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1375 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1377 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1378 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1379 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1381 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1382 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1383 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1384 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1385 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1387 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1388 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1389 if (flags & SVf_POK) sv_catpv(d, "POK,");
1390 if (flags & SVf_ROK) {
1391 sv_catpv(d, "ROK,");
1392 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1394 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1395 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1396 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1398 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1399 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1400 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1401 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1402 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1403 if (SvPCS_IMPORTED(sv))
1404 sv_catpv(d, "PCS_IMPORTED,");
1406 sv_catpv(d, "SCREAM,");
1412 if (CvANON(sv)) sv_catpv(d, "ANON,");
1413 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1414 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1415 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1416 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1417 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1418 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1419 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1420 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1421 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1422 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1423 if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
1426 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1427 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1428 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1429 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1430 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1434 if (isGV_with_GP(sv)) {
1435 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1436 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1437 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1438 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1439 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1441 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1442 sv_catpv(d, "IMPORT");
1443 if (GvIMPORTED(sv) == GVf_IMPORTED)
1444 sv_catpv(d, "ALL,");
1447 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1448 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1449 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1450 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1454 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1455 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1459 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1460 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1463 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1464 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1467 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1472 /* SVphv_SHAREKEYS is also 0x20000000 */
1473 if ((type != SVt_PVHV) && SvUTF8(sv))
1474 sv_catpv(d, "UTF8");
1476 if (*(SvEND(d) - 1) == ',') {
1477 SvCUR_set(d, SvCUR(d) - 1);
1478 SvPVX(d)[SvCUR(d)] = '\0';
1483 #ifdef DEBUG_LEAKING_SCALARS
1484 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1485 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1487 sv->sv_debug_inpad ? "for" : "by",
1488 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1489 sv->sv_debug_cloned ? " (cloned)" : "");
1491 Perl_dump_indent(aTHX_ level, file, "SV = ");
1492 if (type < SVt_LAST) {
1493 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1495 if (type == SVt_NULL) {
1500 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1504 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1505 && type != SVt_PVCV && !isGV_with_GP(sv))
1506 || type == SVt_IV) {
1508 #ifdef PERL_OLD_COPY_ON_WRITE
1512 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1514 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1516 PerlIO_printf(file, " (OFFSET)");
1517 #ifdef PERL_OLD_COPY_ON_WRITE
1518 if (SvIsCOW_shared_hash(sv))
1519 PerlIO_printf(file, " (HASH)");
1520 else if (SvIsCOW_normal(sv))
1521 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1523 PerlIO_putc(file, '\n');
1525 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1526 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1527 (UV) COP_SEQ_RANGE_LOW(sv));
1528 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1529 (UV) COP_SEQ_RANGE_HIGH(sv));
1530 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1531 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
1532 || type == SVt_NV) {
1533 STORE_NUMERIC_LOCAL_SET_STANDARD();
1534 /* %Vg doesn't work? --jhi */
1535 #ifdef USE_LONG_DOUBLE
1536 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1538 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1540 RESTORE_NUMERIC_LOCAL();
1543 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1545 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1547 if (type < SVt_PV) {
1551 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1552 if (SvPVX_const(sv)) {
1553 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1555 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1556 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1557 if (SvUTF8(sv)) /* the 8? \x{....} */
1558 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1559 PerlIO_printf(file, "\n");
1560 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1561 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1564 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1566 if (type >= SVt_PVMG) {
1567 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1569 do_hv_dump(level, file, " OURSTASH", SvOURSTASH(sv));
1572 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1575 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1579 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1580 if (AvARRAY(sv) != AvALLOC(sv)) {
1581 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1582 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1585 PerlIO_putc(file, '\n');
1586 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1587 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1588 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1589 sv_setpvn(d, "", 0);
1590 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1591 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1592 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1593 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1594 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1596 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1597 SV** elt = av_fetch((AV*)sv,count,0);
1599 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1601 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1606 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1607 if (HvARRAY(sv) && HvKEYS(sv)) {
1608 /* Show distribution of HEs in the ARRAY */
1610 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1613 U32 pow2 = 2, keys = HvKEYS(sv);
1614 NV theoret, sum = 0;
1616 PerlIO_printf(file, " (");
1617 Zero(freq, FREQ_MAX + 1, int);
1618 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1621 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1623 if (count > FREQ_MAX)
1629 for (i = 0; i <= max; i++) {
1631 PerlIO_printf(file, "%d%s:%d", i,
1632 (i == FREQ_MAX) ? "+" : "",
1635 PerlIO_printf(file, ", ");
1638 PerlIO_putc(file, ')');
1639 /* The "quality" of a hash is defined as the total number of
1640 comparisons needed to access every element once, relative
1641 to the expected number needed for a random hash.
1643 The total number of comparisons is equal to the sum of
1644 the squares of the number of entries in each bucket.
1645 For a random hash of n keys into k buckets, the expected
1650 for (i = max; i > 0; i--) { /* Precision: count down. */
1651 sum += freq[i] * i * i;
1653 while ((keys = keys >> 1))
1655 theoret = HvKEYS(sv);
1656 theoret += theoret * (theoret-1)/pow2;
1657 PerlIO_putc(file, '\n');
1658 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1660 PerlIO_putc(file, '\n');
1661 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1662 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1663 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1664 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1665 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1667 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1668 if (mg && mg->mg_obj) {
1669 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1673 const char * const hvname = HvNAME_get(sv);
1675 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1678 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1680 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1682 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1686 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1688 HV * const hv = (HV*)sv;
1689 int count = maxnest - nest;
1692 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1697 const U32 hash = HeHASH(he);
1699 keysv = hv_iterkeysv(he);
1700 keypv = SvPV_const(keysv, len);
1701 elt = hv_iterval(hv, he);
1702 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1704 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1706 PerlIO_printf(file, "[REHASH] ");
1707 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1708 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1710 hv_iterinit(hv); /* Return to status quo */
1716 const char *const proto = SvPV_const(sv, len);
1717 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1722 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1723 if (!CvISXSUB(sv)) {
1725 Perl_dump_indent(aTHX_ level, file,
1726 " START = 0x%"UVxf" ===> %"IVdf"\n",
1727 PTR2UV(CvSTART(sv)),
1728 (IV)sequence_num(CvSTART(sv)));
1730 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1731 PTR2UV(CvROOT(sv)));
1732 if (CvROOT(sv) && dumpops) {
1733 do_op_dump(level+1, file, CvROOT(sv));
1736 SV *constant = cv_const_sv((CV *)sv);
1738 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1741 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1743 PTR2UV(CvXSUBANY(sv).any_ptr));
1744 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1747 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1748 (IV)CvXSUBANY(sv).any_i32);
1751 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1752 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1753 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1754 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1755 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1756 if (type == SVt_PVFM)
1757 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1758 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1759 if (nest < maxnest) {
1760 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1763 const CV * const outside = CvOUTSIDE(sv);
1764 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1767 : CvANON(outside) ? "ANON"
1768 : (outside == PL_main_cv) ? "MAIN"
1769 : CvUNIQUE(outside) ? "UNIQUE"
1770 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1772 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1773 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1777 if (type == SVt_PVLV) {
1778 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1779 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1780 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1781 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1782 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1783 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1786 if (!isGV_with_GP(sv))
1788 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1789 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1790 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1791 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1794 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1795 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1796 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1797 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1798 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1799 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1800 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1801 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1802 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1803 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1804 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1805 do_gv_dump (level, file, " EGV", GvEGV(sv));
1808 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1809 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1810 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1811 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1812 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1813 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1814 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1816 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1817 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1818 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1820 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1821 PTR2UV(IoTOP_GV(sv)));
1822 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1825 /* Source filters hide things that are not GVs in these three, so let's
1826 be careful out there. */
1828 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1829 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1830 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1832 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1833 PTR2UV(IoFMT_GV(sv)));
1834 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1837 if (IoBOTTOM_NAME(sv))
1838 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1839 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1840 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1842 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1843 PTR2UV(IoBOTTOM_GV(sv)));
1844 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1847 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1848 if (isPRINT(IoTYPE(sv)))
1849 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1851 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1852 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1859 Perl_sv_dump(pTHX_ SV *sv)
1862 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1866 Perl_runops_debug(pTHX)
1870 if (ckWARN_d(WARN_DEBUGGING))
1871 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1875 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1879 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1880 PerlIO_printf(Perl_debug_log,
1881 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1882 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1883 PTR2UV(*PL_watchaddr));
1884 if (DEBUG_s_TEST_) {
1885 if (DEBUG_v_TEST_) {
1886 PerlIO_printf(Perl_debug_log, "\n");
1894 if (DEBUG_t_TEST_) debop(PL_op);
1895 if (DEBUG_P_TEST_) debprof(PL_op);
1897 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1898 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1905 Perl_debop(pTHX_ const OP *o)
1908 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1911 Perl_deb(aTHX_ "%s", OP_NAME(o));
1912 switch (o->op_type) {
1914 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1919 SV * const sv = newSV(0);
1921 /* FIXME - it this making unwarranted assumptions about the
1922 UTF-8 cleanliness of the dump file handle? */
1925 gv_fullname3(sv, cGVOPo_gv, NULL);
1926 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1930 PerlIO_printf(Perl_debug_log, "(NULL)");
1936 /* print the lexical's name */
1937 CV * const cv = deb_curcv(cxstack_ix);
1940 AV * const padlist = CvPADLIST(cv);
1941 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1942 sv = *av_fetch(comppad, o->op_targ, FALSE);
1946 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1948 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1954 PerlIO_printf(Perl_debug_log, "\n");
1959 S_deb_curcv(pTHX_ I32 ix)
1962 const PERL_CONTEXT * const cx = &cxstack[ix];
1963 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1964 return cx->blk_sub.cv;
1965 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1967 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1972 return deb_curcv(ix - 1);
1976 Perl_watch(pTHX_ char **addr)
1979 PL_watchaddr = addr;
1981 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1982 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1986 S_debprof(pTHX_ const OP *o)
1989 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1991 if (!PL_profiledata)
1992 Newxz(PL_profiledata, MAXO, U32);
1993 ++PL_profiledata[o->op_type];
1997 Perl_debprofdump(pTHX)
2001 if (!PL_profiledata)
2003 for (i = 0; i < MAXO; i++) {
2004 if (PL_profiledata[i])
2005 PerlIO_printf(Perl_debug_log,
2006 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2013 * XML variants of most of the above routines
2018 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2021 PerlIO_printf(file, "\n ");
2022 va_start(args, pat);
2023 xmldump_vindent(level, file, pat, &args);
2029 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2032 va_start(args, pat);
2033 xmldump_vindent(level, file, pat, &args);
2038 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2040 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2041 PerlIO_vprintf(file, pat, *args);
2045 Perl_xmldump_all(pTHX)
2047 PerlIO_setlinebuf(PL_xmlfp);
2049 op_xmldump(PL_main_root);
2050 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2051 PerlIO_close(PL_xmlfp);
2056 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2061 if (!HvARRAY(stash))
2063 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2064 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2065 GV *gv = (GV*)HeVAL(entry);
2067 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2073 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2074 && (hv = GvHV(gv)) && hv != PL_defstash)
2075 xmldump_packsubs(hv); /* nested package */
2081 Perl_xmldump_sub(pTHX_ const GV *gv)
2083 SV *sv = sv_newmortal();
2085 gv_fullname3(sv, gv, Nullch);
2086 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2087 if (CvXSUB(GvCV(gv)))
2088 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2089 PTR2UV(CvXSUB(GvCV(gv))),
2090 (int)CvXSUBANY(GvCV(gv)).any_i32);
2091 else if (CvROOT(GvCV(gv)))
2092 op_xmldump(CvROOT(GvCV(gv)));
2094 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2098 Perl_xmldump_form(pTHX_ const GV *gv)
2100 SV *sv = sv_newmortal();
2102 gv_fullname3(sv, gv, Nullch);
2103 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2104 if (CvROOT(GvFORM(gv)))
2105 op_xmldump(CvROOT(GvFORM(gv)));
2107 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2111 Perl_xmldump_eval(pTHX)
2113 op_xmldump(PL_eval_root);
2117 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2119 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2123 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2131 sv_catpvn(dsv,"",0);
2132 dsvcur = SvCUR(dsv); /* in case we have to restart */
2137 c = utf8_to_uvchr((U8*)pv, &cl);
2139 SvCUR(dsv) = dsvcur;
2204 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2207 Perl_sv_catpvf(aTHX_ dsv, "<");
2210 Perl_sv_catpvf(aTHX_ dsv, ">");
2213 Perl_sv_catpvf(aTHX_ dsv, "&");
2216 Perl_sv_catpvf(aTHX_ dsv, """);
2220 if (c < 32 || c > 127) {
2221 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2224 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2228 if ((c >= 0xD800 && c <= 0xDB7F) ||
2229 (c >= 0xDC00 && c <= 0xDFFF) ||
2230 (c >= 0xFFF0 && c <= 0xFFFF) ||
2232 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2234 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2247 Perl_sv_xmlpeek(pTHX_ SV *sv)
2249 SV *t = sv_newmortal();
2254 sv_setpvn(t, "", 0);
2257 sv_catpv(t, "VOID=\"\"");
2260 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2261 sv_catpv(t, "WILD=\"\"");
2264 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2265 if (sv == &PL_sv_undef) {
2266 sv_catpv(t, "SV_UNDEF=\"1\"");
2267 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2268 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2272 else if (sv == &PL_sv_no) {
2273 sv_catpv(t, "SV_NO=\"1\"");
2274 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2275 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2276 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2277 SVp_POK|SVp_NOK)) &&
2282 else if (sv == &PL_sv_yes) {
2283 sv_catpv(t, "SV_YES=\"1\"");
2284 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2285 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2286 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2287 SVp_POK|SVp_NOK)) &&
2289 SvPVX(sv) && *SvPVX(sv) == '1' &&
2294 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2295 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2296 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2300 sv_catpv(t, " XXX=\"\" ");
2302 else if (SvREFCNT(sv) == 0) {
2303 sv_catpv(t, " refcnt=\"0\"");
2306 else if (DEBUG_R_TEST_) {
2309 /* is this SV on the tmps stack? */
2310 for (ix=PL_tmps_ix; ix>=0; ix--) {
2311 if (PL_tmps_stack[ix] == sv) {
2316 if (SvREFCNT(sv) > 1)
2317 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2320 sv_catpv(t, " DRT=\"<T>\"");
2324 sv_catpv(t, " ROK=\"\"");
2326 switch (SvTYPE(sv)) {
2328 sv_catpv(t, " FREED=\"1\"");
2332 sv_catpv(t, " UNDEF=\"1\"");
2335 sv_catpv(t, " IV=\"");
2338 sv_catpv(t, " NV=\"");
2341 sv_catpv(t, " RV=\"");
2344 sv_catpv(t, " PV=\"");
2347 sv_catpv(t, " PVIV=\"");
2350 sv_catpv(t, " PVNV=\"");
2353 sv_catpv(t, " PVMG=\"");
2356 sv_catpv(t, " PVLV=\"");
2359 sv_catpv(t, " AV=\"");
2362 sv_catpv(t, " HV=\"");
2366 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2368 sv_catpv(t, " CV=\"()\"");
2371 sv_catpv(t, " GV=\"");
2374 sv_catpv(t, " BIND=\"");
2377 sv_catpv(t, " FM=\"");
2380 sv_catpv(t, " IO=\"");
2389 else if (SvNOKp(sv)) {
2390 STORE_NUMERIC_LOCAL_SET_STANDARD();
2391 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2392 RESTORE_NUMERIC_LOCAL();
2394 else if (SvIOKp(sv)) {
2396 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2398 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2409 return SvPV(t, n_a);
2413 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2416 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2419 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2422 char *s = PM_GETRE(pm)->precomp;
2423 SV *tmpsv = newSVpvn("",0);
2425 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2426 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2428 SvREFCNT_dec(tmpsv);
2429 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2430 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2433 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2434 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2435 SV * const tmpsv = pm_description(pm);
2436 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2437 SvREFCNT_dec(tmpsv);
2441 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
2442 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2443 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2444 do_op_xmldump(level+2, file, pm->op_pmreplroot);
2445 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2446 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2449 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2453 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2455 do_pmop_xmldump(0, PL_xmlfp, pm);
2459 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2466 seq = sequence_num(o);
2467 Perl_xmldump_indent(aTHX_ level, file,
2468 "<op_%s seq=\"%"UVuf" -> ",
2473 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2474 sequence_num(o->op_next));
2476 PerlIO_printf(file, "DONE\"");
2479 if (o->op_type == OP_NULL)
2481 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2482 if (o->op_targ == OP_NEXTSTATE)
2485 PerlIO_printf(file, " line=\"%"UVuf"\"",
2486 (UV)CopLINE(cCOPo));
2487 if (CopSTASHPV(cCOPo))
2488 PerlIO_printf(file, " package=\"%s\"",
2490 if (cCOPo->cop_label)
2491 PerlIO_printf(file, " label=\"%s\"",
2496 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2499 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2502 SV *tmpsv = newSVpvn("", 0);
2503 switch (o->op_flags & OPf_WANT) {
2505 sv_catpv(tmpsv, ",VOID");
2507 case OPf_WANT_SCALAR:
2508 sv_catpv(tmpsv, ",SCALAR");
2511 sv_catpv(tmpsv, ",LIST");
2514 sv_catpv(tmpsv, ",UNKNOWN");
2517 if (o->op_flags & OPf_KIDS)
2518 sv_catpv(tmpsv, ",KIDS");
2519 if (o->op_flags & OPf_PARENS)
2520 sv_catpv(tmpsv, ",PARENS");
2521 if (o->op_flags & OPf_STACKED)
2522 sv_catpv(tmpsv, ",STACKED");
2523 if (o->op_flags & OPf_REF)
2524 sv_catpv(tmpsv, ",REF");
2525 if (o->op_flags & OPf_MOD)
2526 sv_catpv(tmpsv, ",MOD");
2527 if (o->op_flags & OPf_SPECIAL)
2528 sv_catpv(tmpsv, ",SPECIAL");
2529 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2530 SvREFCNT_dec(tmpsv);
2532 if (o->op_private) {
2533 SV *tmpsv = newSVpvn("", 0);
2534 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2535 if (o->op_private & OPpTARGET_MY)
2536 sv_catpv(tmpsv, ",TARGET_MY");
2538 else if (o->op_type == OP_LEAVESUB ||
2539 o->op_type == OP_LEAVE ||
2540 o->op_type == OP_LEAVESUBLV ||
2541 o->op_type == OP_LEAVEWRITE) {
2542 if (o->op_private & OPpREFCOUNTED)
2543 sv_catpv(tmpsv, ",REFCOUNTED");
2545 else if (o->op_type == OP_AASSIGN) {
2546 if (o->op_private & OPpASSIGN_COMMON)
2547 sv_catpv(tmpsv, ",COMMON");
2549 else if (o->op_type == OP_SASSIGN) {
2550 if (o->op_private & OPpASSIGN_BACKWARDS)
2551 sv_catpv(tmpsv, ",BACKWARDS");
2553 else if (o->op_type == OP_TRANS) {
2554 if (o->op_private & OPpTRANS_SQUASH)
2555 sv_catpv(tmpsv, ",SQUASH");
2556 if (o->op_private & OPpTRANS_DELETE)
2557 sv_catpv(tmpsv, ",DELETE");
2558 if (o->op_private & OPpTRANS_COMPLEMENT)
2559 sv_catpv(tmpsv, ",COMPLEMENT");
2560 if (o->op_private & OPpTRANS_IDENTICAL)
2561 sv_catpv(tmpsv, ",IDENTICAL");
2562 if (o->op_private & OPpTRANS_GROWS)
2563 sv_catpv(tmpsv, ",GROWS");
2565 else if (o->op_type == OP_REPEAT) {
2566 if (o->op_private & OPpREPEAT_DOLIST)
2567 sv_catpv(tmpsv, ",DOLIST");
2569 else if (o->op_type == OP_ENTERSUB ||
2570 o->op_type == OP_RV2SV ||
2571 o->op_type == OP_GVSV ||
2572 o->op_type == OP_RV2AV ||
2573 o->op_type == OP_RV2HV ||
2574 o->op_type == OP_RV2GV ||
2575 o->op_type == OP_AELEM ||
2576 o->op_type == OP_HELEM )
2578 if (o->op_type == OP_ENTERSUB) {
2579 if (o->op_private & OPpENTERSUB_AMPER)
2580 sv_catpv(tmpsv, ",AMPER");
2581 if (o->op_private & OPpENTERSUB_DB)
2582 sv_catpv(tmpsv, ",DB");
2583 if (o->op_private & OPpENTERSUB_HASTARG)
2584 sv_catpv(tmpsv, ",HASTARG");
2585 if (o->op_private & OPpENTERSUB_NOPAREN)
2586 sv_catpv(tmpsv, ",NOPAREN");
2587 if (o->op_private & OPpENTERSUB_INARGS)
2588 sv_catpv(tmpsv, ",INARGS");
2589 if (o->op_private & OPpENTERSUB_NOMOD)
2590 sv_catpv(tmpsv, ",NOMOD");
2593 switch (o->op_private & OPpDEREF) {
2595 sv_catpv(tmpsv, ",SV");
2598 sv_catpv(tmpsv, ",AV");
2601 sv_catpv(tmpsv, ",HV");
2604 if (o->op_private & OPpMAYBE_LVSUB)
2605 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2607 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2608 if (o->op_private & OPpLVAL_DEFER)
2609 sv_catpv(tmpsv, ",LVAL_DEFER");
2612 if (o->op_private & HINT_STRICT_REFS)
2613 sv_catpv(tmpsv, ",STRICT_REFS");
2614 if (o->op_private & OPpOUR_INTRO)
2615 sv_catpv(tmpsv, ",OUR_INTRO");
2618 else if (o->op_type == OP_CONST) {
2619 if (o->op_private & OPpCONST_BARE)
2620 sv_catpv(tmpsv, ",BARE");
2621 if (o->op_private & OPpCONST_STRICT)
2622 sv_catpv(tmpsv, ",STRICT");
2623 if (o->op_private & OPpCONST_ARYBASE)
2624 sv_catpv(tmpsv, ",ARYBASE");
2625 if (o->op_private & OPpCONST_WARNING)
2626 sv_catpv(tmpsv, ",WARNING");
2627 if (o->op_private & OPpCONST_ENTERED)
2628 sv_catpv(tmpsv, ",ENTERED");
2630 else if (o->op_type == OP_FLIP) {
2631 if (o->op_private & OPpFLIP_LINENUM)
2632 sv_catpv(tmpsv, ",LINENUM");
2634 else if (o->op_type == OP_FLOP) {
2635 if (o->op_private & OPpFLIP_LINENUM)
2636 sv_catpv(tmpsv, ",LINENUM");
2638 else if (o->op_type == OP_RV2CV) {
2639 if (o->op_private & OPpLVAL_INTRO)
2640 sv_catpv(tmpsv, ",INTRO");
2642 else if (o->op_type == OP_GV) {
2643 if (o->op_private & OPpEARLY_CV)
2644 sv_catpv(tmpsv, ",EARLY_CV");
2646 else if (o->op_type == OP_LIST) {
2647 if (o->op_private & OPpLIST_GUESSED)
2648 sv_catpv(tmpsv, ",GUESSED");
2650 else if (o->op_type == OP_DELETE) {
2651 if (o->op_private & OPpSLICE)
2652 sv_catpv(tmpsv, ",SLICE");
2654 else if (o->op_type == OP_EXISTS) {
2655 if (o->op_private & OPpEXISTS_SUB)
2656 sv_catpv(tmpsv, ",EXISTS_SUB");
2658 else if (o->op_type == OP_SORT) {
2659 if (o->op_private & OPpSORT_NUMERIC)
2660 sv_catpv(tmpsv, ",NUMERIC");
2661 if (o->op_private & OPpSORT_INTEGER)
2662 sv_catpv(tmpsv, ",INTEGER");
2663 if (o->op_private & OPpSORT_REVERSE)
2664 sv_catpv(tmpsv, ",REVERSE");
2666 else if (o->op_type == OP_THREADSV) {
2667 if (o->op_private & OPpDONE_SVREF)
2668 sv_catpv(tmpsv, ",SVREF");
2670 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2671 if (o->op_private & OPpOPEN_IN_RAW)
2672 sv_catpv(tmpsv, ",IN_RAW");
2673 if (o->op_private & OPpOPEN_IN_CRLF)
2674 sv_catpv(tmpsv, ",IN_CRLF");
2675 if (o->op_private & OPpOPEN_OUT_RAW)
2676 sv_catpv(tmpsv, ",OUT_RAW");
2677 if (o->op_private & OPpOPEN_OUT_CRLF)
2678 sv_catpv(tmpsv, ",OUT_CRLF");
2680 else if (o->op_type == OP_EXIT) {
2681 if (o->op_private & OPpEXIT_VMSISH)
2682 sv_catpv(tmpsv, ",EXIT_VMSISH");
2683 if (o->op_private & OPpHUSH_VMSISH)
2684 sv_catpv(tmpsv, ",HUSH_VMSISH");
2686 else if (o->op_type == OP_DIE) {
2687 if (o->op_private & OPpHUSH_VMSISH)
2688 sv_catpv(tmpsv, ",HUSH_VMSISH");
2690 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2691 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2692 sv_catpv(tmpsv, ",FT_ACCESS");
2693 if (o->op_private & OPpFT_STACKED)
2694 sv_catpv(tmpsv, ",FT_STACKED");
2696 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2697 sv_catpv(tmpsv, ",INTRO");
2699 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2700 SvREFCNT_dec(tmpsv);
2703 switch (o->op_type) {
2705 if (o->op_flags & OPf_SPECIAL) {
2711 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2713 if (cSVOPo->op_sv) {
2714 SV *tmpsv1 = newSV(0);
2715 SV *tmpsv2 = newSVpvn("",0);
2723 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2724 s = SvPV(tmpsv1,len);
2725 sv_catxmlpvn(tmpsv2, s, len, 1);
2726 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2730 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2734 case OP_METHOD_NAMED:
2735 #ifndef USE_ITHREADS
2736 /* with ITHREADS, consts are stored in the pad, and the right pad
2737 * may not be active here, so skip */
2738 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2744 PerlIO_printf(file, ">\n");
2746 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2752 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2753 (UV)CopLINE(cCOPo));
2754 if (CopSTASHPV(cCOPo))
2755 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2757 if (cCOPo->cop_label)
2758 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2762 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2763 if (cLOOPo->op_redoop)
2764 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2766 PerlIO_printf(file, "DONE\"");
2767 S_xmldump_attr(aTHX_ level, file, "next=\"");
2768 if (cLOOPo->op_nextop)
2769 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2771 PerlIO_printf(file, "DONE\"");
2772 S_xmldump_attr(aTHX_ level, file, "last=\"");
2773 if (cLOOPo->op_lastop)
2774 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2776 PerlIO_printf(file, "DONE\"");
2784 S_xmldump_attr(aTHX_ level, file, "other=\"");
2785 if (cLOGOPo->op_other)
2786 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2788 PerlIO_printf(file, "DONE\"");
2796 if (o->op_private & OPpREFCOUNTED)
2797 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2803 if (PL_madskills && o->op_madprop) {
2804 SV *tmpsv = newSVpvn("", 0);
2805 MADPROP* mp = o->op_madprop;
2806 sv_utf8_upgrade(tmpsv);
2809 PerlIO_printf(file, ">\n");
2811 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2814 char tmp = mp->mad_key;
2815 sv_setpvn(tmpsv,"\"",1);
2817 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2818 sv_catpv(tmpsv, "\"");
2819 switch (mp->mad_type) {
2821 sv_catpv(tmpsv, "NULL");
2822 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2825 sv_catpv(tmpsv, " val=\"");
2826 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2827 sv_catpv(tmpsv, "\"");
2828 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2831 sv_catpv(tmpsv, " val=\"");
2832 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2833 sv_catpv(tmpsv, "\"");
2834 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2837 if ((OP*)mp->mad_val) {
2838 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2839 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2840 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2844 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2850 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2852 SvREFCNT_dec(tmpsv);
2855 switch (o->op_type) {
2862 PerlIO_printf(file, ">\n");
2864 do_pmop_xmldump(level, file, cPMOPo);
2870 if (o->op_flags & OPf_KIDS) {
2874 PerlIO_printf(file, ">\n");
2876 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2877 do_op_xmldump(level, file, kid);
2881 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2883 PerlIO_printf(file, " />\n");
2887 Perl_op_xmldump(pTHX_ const OP *o)
2889 do_op_xmldump(0, PL_xmlfp, o);
2895 * c-indentation-style: bsd
2897 * indent-tabs-mode: t
2900 * ex: set ts=8 sts=4 sw=4 noet: