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 * const gv = (GV*)HeVAL(entry);
110 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
116 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
117 const HV * const hv = GvHV(gv);
118 if (hv && (hv != PL_defstash))
119 dump_packsubs(hv); /* nested package */
126 Perl_dump_sub(pTHX_ const GV *gv)
128 SV * const sv = sv_newmortal();
130 gv_fullname3(sv, gv, NULL);
131 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
132 if (CvISXSUB(GvCV(gv)))
133 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
134 PTR2UV(CvXSUB(GvCV(gv))),
135 (int)CvXSUBANY(GvCV(gv)).any_i32);
136 else if (CvROOT(GvCV(gv)))
137 op_dump(CvROOT(GvCV(gv)));
139 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
143 Perl_dump_form(pTHX_ const GV *gv)
145 SV * const sv = sv_newmortal();
147 gv_fullname3(sv, gv, NULL);
148 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
149 if (CvROOT(GvFORM(gv)))
150 op_dump(CvROOT(GvFORM(gv)));
152 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
159 op_dump(PL_eval_root);
164 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
165 |const STRLEN count|const STRLEN max
166 |STRLEN const *escaped, const U32 flags
168 Escapes at most the first "count" chars of pv and puts the results into
169 dsv such that the size of the escaped string will not exceed "max" chars
170 and will not contain any incomplete escape sequences.
172 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
173 will also be escaped.
175 Normally the SV will be cleared before the escaped string is prepared,
176 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
178 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
179 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
180 using C<is_utf8_string()> to determine if it is Unicode.
182 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
183 using C<\x01F1> style escapes, otherwise only chars above 255 will be
184 escaped using this style, other non printable chars will use octal or
185 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
186 then all chars below 255 will be treated as printable and
187 will be output as literals.
189 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
190 string will be escaped, regardles of max. If the string is utf8 and
191 the chars value is >255 then it will be returned as a plain hex
192 sequence. Thus the output will either be a single char,
193 an octal escape sequence, a special escape like C<\n> or a 3 or
194 more digit hex value.
196 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
197 not a '\\'. This is because regexes very often contain backslashed
198 sequences, whereas '%' is not a particularly common character in patterns.
200 Returns a pointer to the escaped text as held by dsv.
204 #define PV_ESCAPE_OCTBUFSIZE 32
207 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
208 const STRLEN count, const STRLEN max,
209 STRLEN * const escaped, const U32 flags )
211 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
212 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
213 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
214 STRLEN wrote = 0; /* chars written so far */
215 STRLEN chsize = 0; /* size of data to be written */
216 STRLEN readsize = 1; /* size of data just read */
217 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
218 const char *pv = str;
219 const char * const end = pv + count; /* end of string */
222 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
223 /* This won't alter the UTF-8 flag */
224 sv_setpvn(dsv, "", 0);
227 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
230 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
231 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
232 const U8 c = (U8)u & 0xFF;
234 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
235 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
236 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
239 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
240 "%cx{%"UVxf"}", esc, u);
241 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
244 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
248 case '\\' : /* fallthrough */
249 case '%' : if ( c == esc ) {
255 case '\v' : octbuf[1] = 'v'; break;
256 case '\t' : octbuf[1] = 't'; break;
257 case '\r' : octbuf[1] = 'r'; break;
258 case '\n' : octbuf[1] = 'n'; break;
259 case '\f' : octbuf[1] = 'f'; break;
267 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
268 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
271 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
278 if ( max && (wrote + chsize > max) ) {
280 } else if (chsize > 1) {
281 sv_catpvn(dsv, octbuf, chsize);
284 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
285 128-255 can be appended raw to the dsv. If dsv happens to be
286 UTF-8 then we need catpvf to upgrade them for us.
287 Or add a new API call sv_catpvc(). Think about that name, and
288 how to keep it clear that it's unlike the s of catpvs, which is
289 really an array octets, not a string. */
290 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
293 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
301 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
302 |const STRLEN count|const STRLEN max\
303 |const char const *start_color| const char const *end_color\
306 Converts a string into something presentable, handling escaping via
307 pv_escape() and supporting quoting and ellipses.
309 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
310 double quoted with any double quotes in the string escaped. Otherwise
311 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
314 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
315 string were output then an ellipsis C<...> will be appended to the
316 string. Note that this happens AFTER it has been quoted.
318 If start_color is non-null then it will be inserted after the opening
319 quote (if there is one) but before the escaped text. If end_color
320 is non-null then it will be inserted after the escaped text but before
321 any quotes or ellipses.
323 Returns a pointer to the prettified text as held by dsv.
329 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
330 const STRLEN max, char const * const start_color, char const * const end_color,
333 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
336 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
337 /* This won't alter the UTF-8 flag */
338 sv_setpvn(dsv, "", 0);
342 sv_catpvn(dsv, "\"", 1);
343 else if ( flags & PERL_PV_PRETTY_LTGT )
344 sv_catpvn(dsv, "<", 1);
346 if ( start_color != NULL )
347 Perl_sv_catpv( aTHX_ dsv, start_color);
349 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
351 if ( end_color != NULL )
352 Perl_sv_catpv( aTHX_ dsv, end_color);
355 sv_catpvn( dsv, "\"", 1 );
356 else if ( flags & PERL_PV_PRETTY_LTGT )
357 sv_catpvn( dsv, ">", 1);
359 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
360 sv_catpvn( dsv, "...", 3 );
366 =for apidoc pv_display
368 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
369 STRLEN pvlim, U32 flags)
373 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
375 except that an additional "\0" will be appended to the string when
376 len > cur and pv[cur] is "\0".
378 Note that the final string may be up to 7 chars longer than pvlim.
384 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
386 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
387 if (len > cur && pv[cur] == '\0')
388 sv_catpvn( dsv, "\\0", 2 );
393 Perl_sv_peek(pTHX_ SV *sv)
396 SV * const t = sv_newmortal();
406 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
410 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
411 if (sv == &PL_sv_undef) {
412 sv_catpv(t, "SV_UNDEF");
413 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
414 SVs_GMG|SVs_SMG|SVs_RMG)) &&
418 else if (sv == &PL_sv_no) {
419 sv_catpv(t, "SV_NO");
420 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
421 SVs_GMG|SVs_SMG|SVs_RMG)) &&
422 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
428 else if (sv == &PL_sv_yes) {
429 sv_catpv(t, "SV_YES");
430 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
431 SVs_GMG|SVs_SMG|SVs_RMG)) &&
432 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
435 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
440 sv_catpv(t, "SV_PLACEHOLDER");
441 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
442 SVs_GMG|SVs_SMG|SVs_RMG)) &&
448 else if (SvREFCNT(sv) == 0) {
452 else if (DEBUG_R_TEST_) {
455 /* is this SV on the tmps stack? */
456 for (ix=PL_tmps_ix; ix>=0; ix--) {
457 if (PL_tmps_stack[ix] == sv) {
462 if (SvREFCNT(sv) > 1)
463 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
471 if (SvCUR(t) + unref > 10) {
472 SvCUR_set(t, unref + 3);
481 if (type == SVt_PVCV) {
482 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
484 } else if (type < SVt_LAST) {
485 sv_catpv(t, svshorttypenames[type]);
487 if (type == SVt_NULL)
490 sv_catpv(t, "FREED");
495 if (!SvPVX_const(sv))
496 sv_catpv(t, "(null)");
498 SV * const tmp = newSVpvs("");
501 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
502 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
504 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
505 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
510 else if (SvNOKp(sv)) {
511 STORE_NUMERIC_LOCAL_SET_STANDARD();
512 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
513 RESTORE_NUMERIC_LOCAL();
515 else if (SvIOKp(sv)) {
517 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
519 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
527 return SvPV_nolen(t);
531 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
536 Perl_dump_indent(aTHX_ level, file, "{}\n");
539 Perl_dump_indent(aTHX_ level, file, "{\n");
541 if (pm->op_pmflags & PMf_ONCE)
546 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
547 ch, PM_GETRE(pm)->precomp, ch,
548 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
550 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
551 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
552 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
553 op_dump(pm->op_pmreplrootu.op_pmreplroot);
555 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
556 SV * const tmpsv = pm_description(pm);
557 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
561 Perl_dump_indent(aTHX_ level-1, file, "}\n");
565 S_pm_description(pTHX_ const PMOP *pm)
567 SV * const desc = newSVpvs("");
568 const REGEXP * const regex = PM_GETRE(pm);
569 const U32 pmflags = pm->op_pmflags;
571 if (pmflags & PMf_ONCE)
572 sv_catpv(desc, ",ONCE");
574 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
575 sv_catpv(desc, ":USED");
577 if (pmflags & PMf_USED)
578 sv_catpv(desc, ":USED");
582 if (regex->extflags & RXf_TAINTED)
583 sv_catpv(desc, ",TAINTED");
584 if (regex->check_substr) {
585 if (!(regex->extflags & RXf_NOSCAN))
586 sv_catpv(desc, ",SCANFIRST");
587 if (regex->extflags & RXf_CHECK_ALL)
588 sv_catpv(desc, ",ALL");
590 if (regex->extflags & RXf_SKIPWHITE)
591 sv_catpv(desc, ",SKIPWHITE");
594 if (pmflags & PMf_CONST)
595 sv_catpv(desc, ",CONST");
596 if (pmflags & PMf_KEEP)
597 sv_catpv(desc, ",KEEP");
598 if (pmflags & PMf_GLOBAL)
599 sv_catpv(desc, ",GLOBAL");
600 if (pmflags & PMf_CONTINUE)
601 sv_catpv(desc, ",CONTINUE");
602 if (pmflags & PMf_RETAINT)
603 sv_catpv(desc, ",RETAINT");
604 if (pmflags & PMf_EVAL)
605 sv_catpv(desc, ",EVAL");
610 Perl_pmop_dump(pTHX_ PMOP *pm)
612 do_pmop_dump(0, Perl_debug_log, pm);
615 /* An op sequencer. We visit the ops in the order they're to execute. */
618 S_sequence(pTHX_ register const OP *o)
621 const OP *oldop = NULL;
634 for (; o; o = o->op_next) {
636 SV * const op = newSVuv(PTR2UV(o));
637 const char * const key = SvPV_const(op, len);
639 if (hv_exists(Sequence, key, len))
642 switch (o->op_type) {
644 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
645 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
654 if (oldop && o->op_next)
661 if (oldop && o->op_next)
663 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
676 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
677 sequence_tail(cLOGOPo->op_other);
682 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
683 sequence_tail(cLOOPo->op_redoop);
684 sequence_tail(cLOOPo->op_nextop);
685 sequence_tail(cLOOPo->op_lastop);
689 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
690 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
699 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
707 S_sequence_tail(pTHX_ const OP *o)
709 while (o && (o->op_type == OP_NULL))
715 S_sequence_num(pTHX_ const OP *o)
723 op = newSVuv(PTR2UV(o));
724 key = SvPV_const(op, len);
725 seq = hv_fetch(Sequence, key, len, 0);
726 return seq ? SvUV(*seq): 0;
730 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
734 const OPCODE optype = o->op_type;
737 Perl_dump_indent(aTHX_ level, file, "{\n");
739 seq = sequence_num(o);
741 PerlIO_printf(file, "%-4"UVuf, seq);
743 PerlIO_printf(file, " ");
745 "%*sTYPE = %s ===> ",
746 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
748 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
749 sequence_num(o->op_next));
751 PerlIO_printf(file, "DONE\n");
753 if (optype == OP_NULL) {
754 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
755 if (o->op_targ == OP_NEXTSTATE) {
757 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
759 if (CopSTASHPV(cCOPo))
760 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
762 if (cCOPo->cop_label)
763 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
768 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
771 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
773 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
774 SV * const tmpsv = newSVpvs("");
775 switch (o->op_flags & OPf_WANT) {
777 sv_catpv(tmpsv, ",VOID");
779 case OPf_WANT_SCALAR:
780 sv_catpv(tmpsv, ",SCALAR");
783 sv_catpv(tmpsv, ",LIST");
786 sv_catpv(tmpsv, ",UNKNOWN");
789 if (o->op_flags & OPf_KIDS)
790 sv_catpv(tmpsv, ",KIDS");
791 if (o->op_flags & OPf_PARENS)
792 sv_catpv(tmpsv, ",PARENS");
793 if (o->op_flags & OPf_STACKED)
794 sv_catpv(tmpsv, ",STACKED");
795 if (o->op_flags & OPf_REF)
796 sv_catpv(tmpsv, ",REF");
797 if (o->op_flags & OPf_MOD)
798 sv_catpv(tmpsv, ",MOD");
799 if (o->op_flags & OPf_SPECIAL)
800 sv_catpv(tmpsv, ",SPECIAL");
802 sv_catpv(tmpsv, ",LATEFREE");
804 sv_catpv(tmpsv, ",LATEFREED");
806 sv_catpv(tmpsv, ",ATTACHED");
807 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
811 SV * const tmpsv = newSVpvs("");
812 if (PL_opargs[optype] & OA_TARGLEX) {
813 if (o->op_private & OPpTARGET_MY)
814 sv_catpv(tmpsv, ",TARGET_MY");
816 else if (optype == OP_LEAVESUB ||
817 optype == OP_LEAVE ||
818 optype == OP_LEAVESUBLV ||
819 optype == OP_LEAVEWRITE) {
820 if (o->op_private & OPpREFCOUNTED)
821 sv_catpv(tmpsv, ",REFCOUNTED");
823 else if (optype == OP_AASSIGN) {
824 if (o->op_private & OPpASSIGN_COMMON)
825 sv_catpv(tmpsv, ",COMMON");
827 else if (optype == OP_SASSIGN) {
828 if (o->op_private & OPpASSIGN_BACKWARDS)
829 sv_catpv(tmpsv, ",BACKWARDS");
831 else if (optype == OP_TRANS) {
832 if (o->op_private & OPpTRANS_SQUASH)
833 sv_catpv(tmpsv, ",SQUASH");
834 if (o->op_private & OPpTRANS_DELETE)
835 sv_catpv(tmpsv, ",DELETE");
836 if (o->op_private & OPpTRANS_COMPLEMENT)
837 sv_catpv(tmpsv, ",COMPLEMENT");
838 if (o->op_private & OPpTRANS_IDENTICAL)
839 sv_catpv(tmpsv, ",IDENTICAL");
840 if (o->op_private & OPpTRANS_GROWS)
841 sv_catpv(tmpsv, ",GROWS");
843 else if (optype == OP_REPEAT) {
844 if (o->op_private & OPpREPEAT_DOLIST)
845 sv_catpv(tmpsv, ",DOLIST");
847 else if (optype == OP_ENTERSUB ||
848 optype == OP_RV2SV ||
850 optype == OP_RV2AV ||
851 optype == OP_RV2HV ||
852 optype == OP_RV2GV ||
853 optype == OP_AELEM ||
856 if (optype == OP_ENTERSUB) {
857 if (o->op_private & OPpENTERSUB_AMPER)
858 sv_catpv(tmpsv, ",AMPER");
859 if (o->op_private & OPpENTERSUB_DB)
860 sv_catpv(tmpsv, ",DB");
861 if (o->op_private & OPpENTERSUB_HASTARG)
862 sv_catpv(tmpsv, ",HASTARG");
863 if (o->op_private & OPpENTERSUB_NOPAREN)
864 sv_catpv(tmpsv, ",NOPAREN");
865 if (o->op_private & OPpENTERSUB_INARGS)
866 sv_catpv(tmpsv, ",INARGS");
867 if (o->op_private & OPpENTERSUB_NOMOD)
868 sv_catpv(tmpsv, ",NOMOD");
871 switch (o->op_private & OPpDEREF) {
873 sv_catpv(tmpsv, ",SV");
876 sv_catpv(tmpsv, ",AV");
879 sv_catpv(tmpsv, ",HV");
882 if (o->op_private & OPpMAYBE_LVSUB)
883 sv_catpv(tmpsv, ",MAYBE_LVSUB");
885 if (optype == OP_AELEM || optype == OP_HELEM) {
886 if (o->op_private & OPpLVAL_DEFER)
887 sv_catpv(tmpsv, ",LVAL_DEFER");
890 if (o->op_private & HINT_STRICT_REFS)
891 sv_catpv(tmpsv, ",STRICT_REFS");
892 if (o->op_private & OPpOUR_INTRO)
893 sv_catpv(tmpsv, ",OUR_INTRO");
896 else if (optype == OP_CONST) {
897 if (o->op_private & OPpCONST_BARE)
898 sv_catpv(tmpsv, ",BARE");
899 if (o->op_private & OPpCONST_STRICT)
900 sv_catpv(tmpsv, ",STRICT");
901 if (o->op_private & OPpCONST_ARYBASE)
902 sv_catpv(tmpsv, ",ARYBASE");
903 if (o->op_private & OPpCONST_WARNING)
904 sv_catpv(tmpsv, ",WARNING");
905 if (o->op_private & OPpCONST_ENTERED)
906 sv_catpv(tmpsv, ",ENTERED");
908 else if (optype == OP_FLIP) {
909 if (o->op_private & OPpFLIP_LINENUM)
910 sv_catpv(tmpsv, ",LINENUM");
912 else if (optype == OP_FLOP) {
913 if (o->op_private & OPpFLIP_LINENUM)
914 sv_catpv(tmpsv, ",LINENUM");
916 else if (optype == OP_RV2CV) {
917 if (o->op_private & OPpLVAL_INTRO)
918 sv_catpv(tmpsv, ",INTRO");
920 else if (optype == OP_GV) {
921 if (o->op_private & OPpEARLY_CV)
922 sv_catpv(tmpsv, ",EARLY_CV");
924 else if (optype == OP_LIST) {
925 if (o->op_private & OPpLIST_GUESSED)
926 sv_catpv(tmpsv, ",GUESSED");
928 else if (optype == OP_DELETE) {
929 if (o->op_private & OPpSLICE)
930 sv_catpv(tmpsv, ",SLICE");
932 else if (optype == OP_EXISTS) {
933 if (o->op_private & OPpEXISTS_SUB)
934 sv_catpv(tmpsv, ",EXISTS_SUB");
936 else if (optype == OP_SORT) {
937 if (o->op_private & OPpSORT_NUMERIC)
938 sv_catpv(tmpsv, ",NUMERIC");
939 if (o->op_private & OPpSORT_INTEGER)
940 sv_catpv(tmpsv, ",INTEGER");
941 if (o->op_private & OPpSORT_REVERSE)
942 sv_catpv(tmpsv, ",REVERSE");
944 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
945 if (o->op_private & OPpOPEN_IN_RAW)
946 sv_catpv(tmpsv, ",IN_RAW");
947 if (o->op_private & OPpOPEN_IN_CRLF)
948 sv_catpv(tmpsv, ",IN_CRLF");
949 if (o->op_private & OPpOPEN_OUT_RAW)
950 sv_catpv(tmpsv, ",OUT_RAW");
951 if (o->op_private & OPpOPEN_OUT_CRLF)
952 sv_catpv(tmpsv, ",OUT_CRLF");
954 else if (optype == OP_EXIT) {
955 if (o->op_private & OPpEXIT_VMSISH)
956 sv_catpv(tmpsv, ",EXIT_VMSISH");
957 if (o->op_private & OPpHUSH_VMSISH)
958 sv_catpv(tmpsv, ",HUSH_VMSISH");
960 else if (optype == OP_DIE) {
961 if (o->op_private & OPpHUSH_VMSISH)
962 sv_catpv(tmpsv, ",HUSH_VMSISH");
964 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
965 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
966 sv_catpv(tmpsv, ",FT_ACCESS");
967 if (o->op_private & OPpFT_STACKED)
968 sv_catpv(tmpsv, ",FT_STACKED");
970 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
971 sv_catpv(tmpsv, ",INTRO");
973 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
978 if (PL_madskills && o->op_madprop) {
979 SV * const tmpsv = newSVpvn("", 0);
980 MADPROP* mp = o->op_madprop;
981 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
984 const char tmp = mp->mad_key;
985 sv_setpvn(tmpsv,"'",1);
987 sv_catpvn(tmpsv, &tmp, 1);
988 sv_catpv(tmpsv, "'=");
989 switch (mp->mad_type) {
991 sv_catpv(tmpsv, "NULL");
992 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
995 sv_catpv(tmpsv, "<");
996 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
997 sv_catpv(tmpsv, ">");
998 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1001 if ((OP*)mp->mad_val) {
1002 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1003 do_op_dump(level, file, (OP*)mp->mad_val);
1007 sv_catpv(tmpsv, "(UNK)");
1008 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1014 Perl_dump_indent(aTHX_ level, file, "}\n");
1016 SvREFCNT_dec(tmpsv);
1025 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1027 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1028 if (cSVOPo->op_sv) {
1029 SV * const tmpsv = newSV(0);
1033 /* FIXME - is this making unwarranted assumptions about the
1034 UTF-8 cleanliness of the dump file handle? */
1037 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1038 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1039 SvPV_nolen_const(tmpsv));
1043 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1048 case OP_METHOD_NAMED:
1049 #ifndef USE_ITHREADS
1050 /* with ITHREADS, consts are stored in the pad, and the right pad
1051 * may not be active here, so skip */
1052 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1059 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1060 (UV)CopLINE(cCOPo));
1061 if (CopSTASHPV(cCOPo))
1062 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1064 if (cCOPo->cop_label)
1065 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1069 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1070 if (cLOOPo->op_redoop)
1071 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1073 PerlIO_printf(file, "DONE\n");
1074 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1075 if (cLOOPo->op_nextop)
1076 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1078 PerlIO_printf(file, "DONE\n");
1079 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1080 if (cLOOPo->op_lastop)
1081 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1083 PerlIO_printf(file, "DONE\n");
1091 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1092 if (cLOGOPo->op_other)
1093 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1095 PerlIO_printf(file, "DONE\n");
1101 do_pmop_dump(level, file, cPMOPo);
1109 if (o->op_private & OPpREFCOUNTED)
1110 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1115 if (o->op_flags & OPf_KIDS) {
1117 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1118 do_op_dump(level, file, kid);
1120 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1124 Perl_op_dump(pTHX_ const OP *o)
1126 do_op_dump(0, Perl_debug_log, o);
1130 Perl_gv_dump(pTHX_ GV *gv)
1135 PerlIO_printf(Perl_debug_log, "{}\n");
1138 sv = sv_newmortal();
1139 PerlIO_printf(Perl_debug_log, "{\n");
1140 gv_fullname3(sv, gv, NULL);
1141 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1142 if (gv != GvEGV(gv)) {
1143 gv_efullname3(sv, GvEGV(gv), NULL);
1144 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1146 PerlIO_putc(Perl_debug_log, '\n');
1147 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1151 /* map magic types to the symbolic names
1152 * (with the PERL_MAGIC_ prefixed stripped)
1155 static const struct { const char type; const char *name; } magic_names[] = {
1156 { PERL_MAGIC_sv, "sv(\\0)" },
1157 { PERL_MAGIC_arylen, "arylen(#)" },
1158 { PERL_MAGIC_rhash, "rhash(%)" },
1159 { PERL_MAGIC_pos, "pos(.)" },
1160 { PERL_MAGIC_symtab, "symtab(:)" },
1161 { PERL_MAGIC_backref, "backref(<)" },
1162 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1163 { PERL_MAGIC_overload, "overload(A)" },
1164 { PERL_MAGIC_bm, "bm(B)" },
1165 { PERL_MAGIC_regdata, "regdata(D)" },
1166 { PERL_MAGIC_env, "env(E)" },
1167 { PERL_MAGIC_hints, "hints(H)" },
1168 { PERL_MAGIC_isa, "isa(I)" },
1169 { PERL_MAGIC_dbfile, "dbfile(L)" },
1170 { PERL_MAGIC_shared, "shared(N)" },
1171 { PERL_MAGIC_tied, "tied(P)" },
1172 { PERL_MAGIC_sig, "sig(S)" },
1173 { PERL_MAGIC_uvar, "uvar(U)" },
1174 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1175 { PERL_MAGIC_overload_table, "overload_table(c)" },
1176 { PERL_MAGIC_regdatum, "regdatum(d)" },
1177 { PERL_MAGIC_envelem, "envelem(e)" },
1178 { PERL_MAGIC_fm, "fm(f)" },
1179 { PERL_MAGIC_regex_global, "regex_global(g)" },
1180 { PERL_MAGIC_hintselem, "hintselem(h)" },
1181 { PERL_MAGIC_isaelem, "isaelem(i)" },
1182 { PERL_MAGIC_nkeys, "nkeys(k)" },
1183 { PERL_MAGIC_dbline, "dbline(l)" },
1184 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1185 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1186 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1187 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1188 { PERL_MAGIC_qr, "qr(r)" },
1189 { PERL_MAGIC_sigelem, "sigelem(s)" },
1190 { PERL_MAGIC_taint, "taint(t)" },
1191 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1192 { PERL_MAGIC_vec, "vec(v)" },
1193 { PERL_MAGIC_vstring, "vstring(V)" },
1194 { PERL_MAGIC_utf8, "utf8(w)" },
1195 { PERL_MAGIC_substr, "substr(x)" },
1196 { PERL_MAGIC_defelem, "defelem(y)" },
1197 { PERL_MAGIC_ext, "ext(~)" },
1198 /* this null string terminates the list */
1203 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1205 for (; mg; mg = mg->mg_moremagic) {
1206 Perl_dump_indent(aTHX_ level, file,
1207 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1208 if (mg->mg_virtual) {
1209 const MGVTBL * const v = mg->mg_virtual;
1211 if (v == &PL_vtbl_sv) s = "sv";
1212 else if (v == &PL_vtbl_env) s = "env";
1213 else if (v == &PL_vtbl_envelem) s = "envelem";
1214 else if (v == &PL_vtbl_sig) s = "sig";
1215 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1216 else if (v == &PL_vtbl_pack) s = "pack";
1217 else if (v == &PL_vtbl_packelem) s = "packelem";
1218 else if (v == &PL_vtbl_dbline) s = "dbline";
1219 else if (v == &PL_vtbl_isa) s = "isa";
1220 else if (v == &PL_vtbl_arylen) s = "arylen";
1221 else if (v == &PL_vtbl_mglob) s = "mglob";
1222 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1223 else if (v == &PL_vtbl_taint) s = "taint";
1224 else if (v == &PL_vtbl_substr) s = "substr";
1225 else if (v == &PL_vtbl_vec) s = "vec";
1226 else if (v == &PL_vtbl_pos) s = "pos";
1227 else if (v == &PL_vtbl_bm) s = "bm";
1228 else if (v == &PL_vtbl_fm) s = "fm";
1229 else if (v == &PL_vtbl_uvar) s = "uvar";
1230 else if (v == &PL_vtbl_defelem) s = "defelem";
1231 #ifdef USE_LOCALE_COLLATE
1232 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1234 else if (v == &PL_vtbl_amagic) s = "amagic";
1235 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1236 else if (v == &PL_vtbl_backref) s = "backref";
1237 else if (v == &PL_vtbl_utf8) s = "utf8";
1238 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1239 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1242 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1244 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1247 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1250 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1254 const char *name = NULL;
1255 for (n = 0; magic_names[n].name; n++) {
1256 if (mg->mg_type == magic_names[n].type) {
1257 name = magic_names[n].name;
1262 Perl_dump_indent(aTHX_ level, file,
1263 " MG_TYPE = PERL_MAGIC_%s\n", name);
1265 Perl_dump_indent(aTHX_ level, file,
1266 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1270 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1271 if (mg->mg_type == PERL_MAGIC_envelem &&
1272 mg->mg_flags & MGf_TAINTEDDIR)
1273 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1274 if (mg->mg_flags & MGf_REFCOUNTED)
1275 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1276 if (mg->mg_flags & MGf_GSKIP)
1277 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1278 if (mg->mg_type == PERL_MAGIC_regex_global &&
1279 mg->mg_flags & MGf_MINMATCH)
1280 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1283 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1284 PTR2UV(mg->mg_obj));
1285 if (mg->mg_type == PERL_MAGIC_qr) {
1286 const regexp * const re = (regexp *)mg->mg_obj;
1287 SV * const dsv = sv_newmortal();
1288 const char * const s = pv_pretty(dsv, re->wrapped, re->wraplen,
1290 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1291 ((re->extflags & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0))
1293 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1294 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1297 if (mg->mg_flags & MGf_REFCOUNTED)
1298 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1301 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1303 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1304 if (mg->mg_len >= 0) {
1305 if (mg->mg_type != PERL_MAGIC_utf8) {
1306 SV * const sv = newSVpvs("");
1307 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1311 else if (mg->mg_len == HEf_SVKEY) {
1312 PerlIO_puts(file, " => HEf_SVKEY\n");
1313 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1317 PerlIO_puts(file, " ???? - please notify IZ");
1318 PerlIO_putc(file, '\n');
1320 if (mg->mg_type == PERL_MAGIC_utf8) {
1321 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1324 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1325 Perl_dump_indent(aTHX_ level, file,
1326 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1329 (UV)cache[i * 2 + 1]);
1336 Perl_magic_dump(pTHX_ const MAGIC *mg)
1338 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1342 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1345 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1346 if (sv && (hvname = HvNAME_get(sv)))
1347 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1349 PerlIO_putc(file, '\n');
1353 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1355 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1356 if (sv && GvNAME(sv))
1357 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1359 PerlIO_putc(file, '\n');
1363 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1365 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1366 if (sv && GvNAME(sv)) {
1368 PerlIO_printf(file, "\t\"");
1369 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1370 PerlIO_printf(file, "%s\" :: \"", hvname);
1371 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1374 PerlIO_putc(file, '\n');
1378 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1387 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1391 flags = SvFLAGS(sv);
1394 d = Perl_newSVpvf(aTHX_
1395 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1396 PTR2UV(SvANY(sv)), PTR2UV(sv),
1397 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1398 (int)(PL_dumpindent*level), "");
1400 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1401 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1403 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1404 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1405 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1407 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1408 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1409 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1410 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1411 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1413 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1414 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1415 if (flags & SVf_POK) sv_catpv(d, "POK,");
1416 if (flags & SVf_ROK) {
1417 sv_catpv(d, "ROK,");
1418 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1420 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1421 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1422 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1423 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1425 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1426 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1427 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1428 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1429 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1430 if (SvPCS_IMPORTED(sv))
1431 sv_catpv(d, "PCS_IMPORTED,");
1433 sv_catpv(d, "SCREAM,");
1439 if (CvANON(sv)) sv_catpv(d, "ANON,");
1440 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1441 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1442 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1443 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1444 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1445 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1446 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1447 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1448 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1449 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1452 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1453 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1454 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1455 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1456 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1460 if (isGV_with_GP(sv)) {
1461 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1462 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1463 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1464 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1465 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1467 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1468 sv_catpv(d, "IMPORT");
1469 if (GvIMPORTED(sv) == GVf_IMPORTED)
1470 sv_catpv(d, "ALL,");
1473 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1474 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1475 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1476 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1480 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1481 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1485 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1486 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1489 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1490 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1493 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1498 /* SVphv_SHAREKEYS is also 0x20000000 */
1499 if ((type != SVt_PVHV) && SvUTF8(sv))
1500 sv_catpv(d, "UTF8");
1502 if (*(SvEND(d) - 1) == ',') {
1503 SvCUR_set(d, SvCUR(d) - 1);
1504 SvPVX(d)[SvCUR(d)] = '\0';
1509 #ifdef DEBUG_LEAKING_SCALARS
1510 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1511 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1513 sv->sv_debug_inpad ? "for" : "by",
1514 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1515 sv->sv_debug_cloned ? " (cloned)" : "");
1517 Perl_dump_indent(aTHX_ level, file, "SV = ");
1518 if (type < SVt_LAST) {
1519 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1521 if (type == SVt_NULL) {
1526 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1530 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1531 && type != SVt_PVCV && !isGV_with_GP(sv))
1532 || (type == SVt_IV && !SvROK(sv))) {
1534 #ifdef PERL_OLD_COPY_ON_WRITE
1538 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1540 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1542 PerlIO_printf(file, " (OFFSET)");
1543 #ifdef PERL_OLD_COPY_ON_WRITE
1544 if (SvIsCOW_shared_hash(sv))
1545 PerlIO_printf(file, " (HASH)");
1546 else if (SvIsCOW_normal(sv))
1547 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1549 PerlIO_putc(file, '\n');
1551 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1552 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1553 (UV) COP_SEQ_RANGE_LOW(sv));
1554 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1555 (UV) COP_SEQ_RANGE_HIGH(sv));
1556 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1557 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)
1559 || type == SVt_NV) {
1560 STORE_NUMERIC_LOCAL_SET_STANDARD();
1561 /* %Vg doesn't work? --jhi */
1562 #ifdef USE_LONG_DOUBLE
1563 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1565 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1567 RESTORE_NUMERIC_LOCAL();
1570 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1572 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1574 if (type < SVt_PV) {
1578 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1579 if (SvPVX_const(sv)) {
1580 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1582 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1583 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1584 if (SvUTF8(sv)) /* the 6? \x{....} */
1585 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1586 PerlIO_printf(file, "\n");
1587 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1588 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1591 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1593 if (type >= SVt_PVMG) {
1594 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1595 HV * const ost = SvOURSTASH(sv);
1597 do_hv_dump(level, file, " OURSTASH", ost);
1600 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1603 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1607 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1608 if (AvARRAY(sv) != AvALLOC(sv)) {
1609 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1610 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1613 PerlIO_putc(file, '\n');
1614 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1615 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1616 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1617 sv_setpvn(d, "", 0);
1618 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1619 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1620 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1621 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1622 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1624 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1625 SV** const elt = av_fetch((AV*)sv,count,0);
1627 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1629 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1634 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1635 if (HvARRAY(sv) && HvKEYS(sv)) {
1636 /* Show distribution of HEs in the ARRAY */
1638 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1641 U32 pow2 = 2, keys = HvKEYS(sv);
1642 NV theoret, sum = 0;
1644 PerlIO_printf(file, " (");
1645 Zero(freq, FREQ_MAX + 1, int);
1646 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1649 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1651 if (count > FREQ_MAX)
1657 for (i = 0; i <= max; i++) {
1659 PerlIO_printf(file, "%d%s:%d", i,
1660 (i == FREQ_MAX) ? "+" : "",
1663 PerlIO_printf(file, ", ");
1666 PerlIO_putc(file, ')');
1667 /* The "quality" of a hash is defined as the total number of
1668 comparisons needed to access every element once, relative
1669 to the expected number needed for a random hash.
1671 The total number of comparisons is equal to the sum of
1672 the squares of the number of entries in each bucket.
1673 For a random hash of n keys into k buckets, the expected
1678 for (i = max; i > 0; i--) { /* Precision: count down. */
1679 sum += freq[i] * i * i;
1681 while ((keys = keys >> 1))
1683 theoret = HvKEYS(sv);
1684 theoret += theoret * (theoret-1)/pow2;
1685 PerlIO_putc(file, '\n');
1686 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1688 PerlIO_putc(file, '\n');
1689 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1690 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1691 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1692 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1693 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1695 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1696 if (mg && mg->mg_obj) {
1697 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1701 const char * const hvname = HvNAME_get(sv);
1703 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1706 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1708 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1710 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1714 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1716 HV * const hv = (HV*)sv;
1717 int count = maxnest - nest;
1720 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1723 const U32 hash = HeHASH(he);
1724 SV * const keysv = hv_iterkeysv(he);
1725 const char * const keypv = SvPV_const(keysv, len);
1726 SV * const elt = hv_iterval(hv, he);
1728 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1730 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1732 PerlIO_printf(file, "[REHASH] ");
1733 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1734 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1736 hv_iterinit(hv); /* Return to status quo */
1742 const char *const proto = SvPV_const(sv, len);
1743 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1748 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1749 if (!CvISXSUB(sv)) {
1751 Perl_dump_indent(aTHX_ level, file,
1752 " START = 0x%"UVxf" ===> %"IVdf"\n",
1753 PTR2UV(CvSTART(sv)),
1754 (IV)sequence_num(CvSTART(sv)));
1756 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1757 PTR2UV(CvROOT(sv)));
1758 if (CvROOT(sv) && dumpops) {
1759 do_op_dump(level+1, file, CvROOT(sv));
1762 SV * const constant = cv_const_sv((CV *)sv);
1764 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1767 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1769 PTR2UV(CvXSUBANY(sv).any_ptr));
1770 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1773 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1774 (IV)CvXSUBANY(sv).any_i32);
1777 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1778 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1779 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1780 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1781 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1782 if (type == SVt_PVFM)
1783 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1784 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1785 if (nest < maxnest) {
1786 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1789 const CV * const outside = CvOUTSIDE(sv);
1790 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1793 : CvANON(outside) ? "ANON"
1794 : (outside == PL_main_cv) ? "MAIN"
1795 : CvUNIQUE(outside) ? "UNIQUE"
1796 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1798 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1799 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1803 if (type == SVt_PVLV) {
1804 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1805 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1806 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1807 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1808 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1809 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1813 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1814 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1815 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1816 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1818 if (!isGV_with_GP(sv))
1820 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1821 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1822 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1823 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1826 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1827 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1828 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1829 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1830 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1831 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1832 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1833 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1834 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1835 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1836 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1837 do_gv_dump (level, file, " EGV", GvEGV(sv));
1840 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1841 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1842 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1843 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1844 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1845 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1846 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1848 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1849 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1850 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1852 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1853 PTR2UV(IoTOP_GV(sv)));
1854 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1857 /* Source filters hide things that are not GVs in these three, so let's
1858 be careful out there. */
1860 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1861 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1862 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1864 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1865 PTR2UV(IoFMT_GV(sv)));
1866 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1869 if (IoBOTTOM_NAME(sv))
1870 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1871 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1872 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1874 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1875 PTR2UV(IoBOTTOM_GV(sv)));
1876 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1879 if (isPRINT(IoTYPE(sv)))
1880 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1882 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1883 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1890 Perl_sv_dump(pTHX_ SV *sv)
1894 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1896 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1900 Perl_runops_debug(pTHX)
1904 if (ckWARN_d(WARN_DEBUGGING))
1905 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1909 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1913 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1914 PerlIO_printf(Perl_debug_log,
1915 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1916 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1917 PTR2UV(*PL_watchaddr));
1918 if (DEBUG_s_TEST_) {
1919 if (DEBUG_v_TEST_) {
1920 PerlIO_printf(Perl_debug_log, "\n");
1928 if (DEBUG_t_TEST_) debop(PL_op);
1929 if (DEBUG_P_TEST_) debprof(PL_op);
1931 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1932 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1939 Perl_debop(pTHX_ const OP *o)
1942 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1945 Perl_deb(aTHX_ "%s", OP_NAME(o));
1946 switch (o->op_type) {
1948 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1953 SV * const sv = newSV(0);
1955 /* FIXME - is this making unwarranted assumptions about the
1956 UTF-8 cleanliness of the dump file handle? */
1959 gv_fullname3(sv, cGVOPo_gv, NULL);
1960 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1964 PerlIO_printf(Perl_debug_log, "(NULL)");
1970 /* print the lexical's name */
1971 CV * const cv = deb_curcv(cxstack_ix);
1974 AV * const padlist = CvPADLIST(cv);
1975 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1976 sv = *av_fetch(comppad, o->op_targ, FALSE);
1980 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1982 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1988 PerlIO_printf(Perl_debug_log, "\n");
1993 S_deb_curcv(pTHX_ const I32 ix)
1996 const PERL_CONTEXT * const cx = &cxstack[ix];
1997 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1998 return cx->blk_sub.cv;
1999 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2001 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2006 return deb_curcv(ix - 1);
2010 Perl_watch(pTHX_ char **addr)
2013 PL_watchaddr = addr;
2015 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2016 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2020 S_debprof(pTHX_ const OP *o)
2023 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2025 if (!PL_profiledata)
2026 Newxz(PL_profiledata, MAXO, U32);
2027 ++PL_profiledata[o->op_type];
2031 Perl_debprofdump(pTHX)
2035 if (!PL_profiledata)
2037 for (i = 0; i < MAXO; i++) {
2038 if (PL_profiledata[i])
2039 PerlIO_printf(Perl_debug_log,
2040 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2047 * XML variants of most of the above routines
2051 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2054 PerlIO_printf(file, "\n ");
2055 va_start(args, pat);
2056 xmldump_vindent(level, file, pat, &args);
2062 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2065 va_start(args, pat);
2066 xmldump_vindent(level, file, pat, &args);
2071 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2073 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2074 PerlIO_vprintf(file, pat, *args);
2078 Perl_xmldump_all(pTHX)
2080 PerlIO_setlinebuf(PL_xmlfp);
2082 op_xmldump(PL_main_root);
2083 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2084 PerlIO_close(PL_xmlfp);
2089 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2094 if (!HvARRAY(stash))
2096 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2097 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2098 GV *gv = (GV*)HeVAL(entry);
2100 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2106 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2107 && (hv = GvHV(gv)) && hv != PL_defstash)
2108 xmldump_packsubs(hv); /* nested package */
2114 Perl_xmldump_sub(pTHX_ const GV *gv)
2116 SV * const sv = sv_newmortal();
2118 gv_fullname3(sv, gv, NULL);
2119 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2120 if (CvXSUB(GvCV(gv)))
2121 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2122 PTR2UV(CvXSUB(GvCV(gv))),
2123 (int)CvXSUBANY(GvCV(gv)).any_i32);
2124 else if (CvROOT(GvCV(gv)))
2125 op_xmldump(CvROOT(GvCV(gv)));
2127 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2131 Perl_xmldump_form(pTHX_ const GV *gv)
2133 SV * const sv = sv_newmortal();
2135 gv_fullname3(sv, gv, NULL);
2136 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2137 if (CvROOT(GvFORM(gv)))
2138 op_xmldump(CvROOT(GvFORM(gv)));
2140 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2144 Perl_xmldump_eval(pTHX)
2146 op_xmldump(PL_eval_root);
2150 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2152 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2156 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2159 const char * const e = pv + len;
2160 const char * const start = pv;
2164 sv_catpvn(dsv,"",0);
2165 dsvcur = SvCUR(dsv); /* in case we have to restart */
2170 c = utf8_to_uvchr((U8*)pv, &cl);
2172 SvCUR(dsv) = dsvcur;
2237 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2240 sv_catpvs(dsv, "<");
2243 sv_catpvs(dsv, ">");
2246 sv_catpvs(dsv, "&");
2249 sv_catpvs(dsv, """);
2253 if (c < 32 || c > 127) {
2254 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2257 const char string = (char) c;
2258 sv_catpvn(dsv, &string, 1);
2262 if ((c >= 0xD800 && c <= 0xDB7F) ||
2263 (c >= 0xDC00 && c <= 0xDFFF) ||
2264 (c >= 0xFFF0 && c <= 0xFFFF) ||
2266 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2268 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2281 Perl_sv_xmlpeek(pTHX_ SV *sv)
2283 SV * const t = sv_newmortal();
2288 sv_setpvn(t, "", 0);
2291 sv_catpv(t, "VOID=\"\"");
2294 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2295 sv_catpv(t, "WILD=\"\"");
2298 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2299 if (sv == &PL_sv_undef) {
2300 sv_catpv(t, "SV_UNDEF=\"1\"");
2301 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2302 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2306 else if (sv == &PL_sv_no) {
2307 sv_catpv(t, "SV_NO=\"1\"");
2308 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2309 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2310 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2311 SVp_POK|SVp_NOK)) &&
2316 else if (sv == &PL_sv_yes) {
2317 sv_catpv(t, "SV_YES=\"1\"");
2318 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2319 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2320 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2321 SVp_POK|SVp_NOK)) &&
2323 SvPVX(sv) && *SvPVX(sv) == '1' &&
2328 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2329 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2330 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2334 sv_catpv(t, " XXX=\"\" ");
2336 else if (SvREFCNT(sv) == 0) {
2337 sv_catpv(t, " refcnt=\"0\"");
2340 else if (DEBUG_R_TEST_) {
2343 /* is this SV on the tmps stack? */
2344 for (ix=PL_tmps_ix; ix>=0; ix--) {
2345 if (PL_tmps_stack[ix] == sv) {
2350 if (SvREFCNT(sv) > 1)
2351 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2354 sv_catpv(t, " DRT=\"<T>\"");
2358 sv_catpv(t, " ROK=\"\"");
2360 switch (SvTYPE(sv)) {
2362 sv_catpv(t, " FREED=\"1\"");
2366 sv_catpv(t, " UNDEF=\"1\"");
2369 sv_catpv(t, " IV=\"");
2372 sv_catpv(t, " NV=\"");
2375 sv_catpv(t, " PV=\"");
2378 sv_catpv(t, " PVIV=\"");
2381 sv_catpv(t, " PVNV=\"");
2384 sv_catpv(t, " PVMG=\"");
2387 sv_catpv(t, " PVLV=\"");
2390 sv_catpv(t, " AV=\"");
2393 sv_catpv(t, " HV=\"");
2397 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2399 sv_catpv(t, " CV=\"()\"");
2402 sv_catpv(t, " GV=\"");
2405 sv_catpv(t, " BIND=\"");
2408 sv_catpv(t, " ORANGE=\"");
2411 sv_catpv(t, " FM=\"");
2414 sv_catpv(t, " IO=\"");
2423 else if (SvNOKp(sv)) {
2424 STORE_NUMERIC_LOCAL_SET_STANDARD();
2425 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2426 RESTORE_NUMERIC_LOCAL();
2428 else if (SvIOKp(sv)) {
2430 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2432 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2441 return SvPV(t, n_a);
2445 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2448 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2451 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2454 const regexp *const r = PM_GETRE(pm);
2455 SV * const tmpsv = newSVpvn(r->precomp,r->prelen);
2457 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2459 SvREFCNT_dec(tmpsv);
2460 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2461 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2464 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2465 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2466 SV * const tmpsv = pm_description(pm);
2467 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2468 SvREFCNT_dec(tmpsv);
2472 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2473 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2474 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2475 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2476 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2477 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2480 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2484 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2486 do_pmop_xmldump(0, PL_xmlfp, pm);
2490 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2497 seq = sequence_num(o);
2498 Perl_xmldump_indent(aTHX_ level, file,
2499 "<op_%s seq=\"%"UVuf" -> ",
2504 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2505 sequence_num(o->op_next));
2507 PerlIO_printf(file, "DONE\"");
2510 if (o->op_type == OP_NULL)
2512 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2513 if (o->op_targ == OP_NEXTSTATE)
2516 PerlIO_printf(file, " line=\"%"UVuf"\"",
2517 (UV)CopLINE(cCOPo));
2518 if (CopSTASHPV(cCOPo))
2519 PerlIO_printf(file, " package=\"%s\"",
2521 if (cCOPo->cop_label)
2522 PerlIO_printf(file, " label=\"%s\"",
2527 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2530 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2533 SV * const tmpsv = newSVpvn("", 0);
2534 switch (o->op_flags & OPf_WANT) {
2536 sv_catpv(tmpsv, ",VOID");
2538 case OPf_WANT_SCALAR:
2539 sv_catpv(tmpsv, ",SCALAR");
2542 sv_catpv(tmpsv, ",LIST");
2545 sv_catpv(tmpsv, ",UNKNOWN");
2548 if (o->op_flags & OPf_KIDS)
2549 sv_catpv(tmpsv, ",KIDS");
2550 if (o->op_flags & OPf_PARENS)
2551 sv_catpv(tmpsv, ",PARENS");
2552 if (o->op_flags & OPf_STACKED)
2553 sv_catpv(tmpsv, ",STACKED");
2554 if (o->op_flags & OPf_REF)
2555 sv_catpv(tmpsv, ",REF");
2556 if (o->op_flags & OPf_MOD)
2557 sv_catpv(tmpsv, ",MOD");
2558 if (o->op_flags & OPf_SPECIAL)
2559 sv_catpv(tmpsv, ",SPECIAL");
2560 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2561 SvREFCNT_dec(tmpsv);
2563 if (o->op_private) {
2564 SV * const tmpsv = newSVpvn("", 0);
2565 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2566 if (o->op_private & OPpTARGET_MY)
2567 sv_catpv(tmpsv, ",TARGET_MY");
2569 else if (o->op_type == OP_LEAVESUB ||
2570 o->op_type == OP_LEAVE ||
2571 o->op_type == OP_LEAVESUBLV ||
2572 o->op_type == OP_LEAVEWRITE) {
2573 if (o->op_private & OPpREFCOUNTED)
2574 sv_catpv(tmpsv, ",REFCOUNTED");
2576 else if (o->op_type == OP_AASSIGN) {
2577 if (o->op_private & OPpASSIGN_COMMON)
2578 sv_catpv(tmpsv, ",COMMON");
2580 else if (o->op_type == OP_SASSIGN) {
2581 if (o->op_private & OPpASSIGN_BACKWARDS)
2582 sv_catpv(tmpsv, ",BACKWARDS");
2584 else if (o->op_type == OP_TRANS) {
2585 if (o->op_private & OPpTRANS_SQUASH)
2586 sv_catpv(tmpsv, ",SQUASH");
2587 if (o->op_private & OPpTRANS_DELETE)
2588 sv_catpv(tmpsv, ",DELETE");
2589 if (o->op_private & OPpTRANS_COMPLEMENT)
2590 sv_catpv(tmpsv, ",COMPLEMENT");
2591 if (o->op_private & OPpTRANS_IDENTICAL)
2592 sv_catpv(tmpsv, ",IDENTICAL");
2593 if (o->op_private & OPpTRANS_GROWS)
2594 sv_catpv(tmpsv, ",GROWS");
2596 else if (o->op_type == OP_REPEAT) {
2597 if (o->op_private & OPpREPEAT_DOLIST)
2598 sv_catpv(tmpsv, ",DOLIST");
2600 else if (o->op_type == OP_ENTERSUB ||
2601 o->op_type == OP_RV2SV ||
2602 o->op_type == OP_GVSV ||
2603 o->op_type == OP_RV2AV ||
2604 o->op_type == OP_RV2HV ||
2605 o->op_type == OP_RV2GV ||
2606 o->op_type == OP_AELEM ||
2607 o->op_type == OP_HELEM )
2609 if (o->op_type == OP_ENTERSUB) {
2610 if (o->op_private & OPpENTERSUB_AMPER)
2611 sv_catpv(tmpsv, ",AMPER");
2612 if (o->op_private & OPpENTERSUB_DB)
2613 sv_catpv(tmpsv, ",DB");
2614 if (o->op_private & OPpENTERSUB_HASTARG)
2615 sv_catpv(tmpsv, ",HASTARG");
2616 if (o->op_private & OPpENTERSUB_NOPAREN)
2617 sv_catpv(tmpsv, ",NOPAREN");
2618 if (o->op_private & OPpENTERSUB_INARGS)
2619 sv_catpv(tmpsv, ",INARGS");
2620 if (o->op_private & OPpENTERSUB_NOMOD)
2621 sv_catpv(tmpsv, ",NOMOD");
2624 switch (o->op_private & OPpDEREF) {
2626 sv_catpv(tmpsv, ",SV");
2629 sv_catpv(tmpsv, ",AV");
2632 sv_catpv(tmpsv, ",HV");
2635 if (o->op_private & OPpMAYBE_LVSUB)
2636 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2638 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2639 if (o->op_private & OPpLVAL_DEFER)
2640 sv_catpv(tmpsv, ",LVAL_DEFER");
2643 if (o->op_private & HINT_STRICT_REFS)
2644 sv_catpv(tmpsv, ",STRICT_REFS");
2645 if (o->op_private & OPpOUR_INTRO)
2646 sv_catpv(tmpsv, ",OUR_INTRO");
2649 else if (o->op_type == OP_CONST) {
2650 if (o->op_private & OPpCONST_BARE)
2651 sv_catpv(tmpsv, ",BARE");
2652 if (o->op_private & OPpCONST_STRICT)
2653 sv_catpv(tmpsv, ",STRICT");
2654 if (o->op_private & OPpCONST_ARYBASE)
2655 sv_catpv(tmpsv, ",ARYBASE");
2656 if (o->op_private & OPpCONST_WARNING)
2657 sv_catpv(tmpsv, ",WARNING");
2658 if (o->op_private & OPpCONST_ENTERED)
2659 sv_catpv(tmpsv, ",ENTERED");
2661 else if (o->op_type == OP_FLIP) {
2662 if (o->op_private & OPpFLIP_LINENUM)
2663 sv_catpv(tmpsv, ",LINENUM");
2665 else if (o->op_type == OP_FLOP) {
2666 if (o->op_private & OPpFLIP_LINENUM)
2667 sv_catpv(tmpsv, ",LINENUM");
2669 else if (o->op_type == OP_RV2CV) {
2670 if (o->op_private & OPpLVAL_INTRO)
2671 sv_catpv(tmpsv, ",INTRO");
2673 else if (o->op_type == OP_GV) {
2674 if (o->op_private & OPpEARLY_CV)
2675 sv_catpv(tmpsv, ",EARLY_CV");
2677 else if (o->op_type == OP_LIST) {
2678 if (o->op_private & OPpLIST_GUESSED)
2679 sv_catpv(tmpsv, ",GUESSED");
2681 else if (o->op_type == OP_DELETE) {
2682 if (o->op_private & OPpSLICE)
2683 sv_catpv(tmpsv, ",SLICE");
2685 else if (o->op_type == OP_EXISTS) {
2686 if (o->op_private & OPpEXISTS_SUB)
2687 sv_catpv(tmpsv, ",EXISTS_SUB");
2689 else if (o->op_type == OP_SORT) {
2690 if (o->op_private & OPpSORT_NUMERIC)
2691 sv_catpv(tmpsv, ",NUMERIC");
2692 if (o->op_private & OPpSORT_INTEGER)
2693 sv_catpv(tmpsv, ",INTEGER");
2694 if (o->op_private & OPpSORT_REVERSE)
2695 sv_catpv(tmpsv, ",REVERSE");
2697 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2698 if (o->op_private & OPpOPEN_IN_RAW)
2699 sv_catpv(tmpsv, ",IN_RAW");
2700 if (o->op_private & OPpOPEN_IN_CRLF)
2701 sv_catpv(tmpsv, ",IN_CRLF");
2702 if (o->op_private & OPpOPEN_OUT_RAW)
2703 sv_catpv(tmpsv, ",OUT_RAW");
2704 if (o->op_private & OPpOPEN_OUT_CRLF)
2705 sv_catpv(tmpsv, ",OUT_CRLF");
2707 else if (o->op_type == OP_EXIT) {
2708 if (o->op_private & OPpEXIT_VMSISH)
2709 sv_catpv(tmpsv, ",EXIT_VMSISH");
2710 if (o->op_private & OPpHUSH_VMSISH)
2711 sv_catpv(tmpsv, ",HUSH_VMSISH");
2713 else if (o->op_type == OP_DIE) {
2714 if (o->op_private & OPpHUSH_VMSISH)
2715 sv_catpv(tmpsv, ",HUSH_VMSISH");
2717 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2718 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2719 sv_catpv(tmpsv, ",FT_ACCESS");
2720 if (o->op_private & OPpFT_STACKED)
2721 sv_catpv(tmpsv, ",FT_STACKED");
2723 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2724 sv_catpv(tmpsv, ",INTRO");
2726 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2727 SvREFCNT_dec(tmpsv);
2730 switch (o->op_type) {
2732 if (o->op_flags & OPf_SPECIAL) {
2738 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2740 if (cSVOPo->op_sv) {
2741 SV * const tmpsv1 = newSV(0);
2742 SV * const tmpsv2 = newSVpvn("",0);
2750 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
2751 s = SvPV(tmpsv1,len);
2752 sv_catxmlpvn(tmpsv2, s, len, 1);
2753 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2757 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2761 case OP_METHOD_NAMED:
2762 #ifndef USE_ITHREADS
2763 /* with ITHREADS, consts are stored in the pad, and the right pad
2764 * may not be active here, so skip */
2765 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2771 PerlIO_printf(file, ">\n");
2773 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2779 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2780 (UV)CopLINE(cCOPo));
2781 if (CopSTASHPV(cCOPo))
2782 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2784 if (cCOPo->cop_label)
2785 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2789 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2790 if (cLOOPo->op_redoop)
2791 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2793 PerlIO_printf(file, "DONE\"");
2794 S_xmldump_attr(aTHX_ level, file, "next=\"");
2795 if (cLOOPo->op_nextop)
2796 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2798 PerlIO_printf(file, "DONE\"");
2799 S_xmldump_attr(aTHX_ level, file, "last=\"");
2800 if (cLOOPo->op_lastop)
2801 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2803 PerlIO_printf(file, "DONE\"");
2811 S_xmldump_attr(aTHX_ level, file, "other=\"");
2812 if (cLOGOPo->op_other)
2813 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2815 PerlIO_printf(file, "DONE\"");
2823 if (o->op_private & OPpREFCOUNTED)
2824 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2830 if (PL_madskills && o->op_madprop) {
2831 char prevkey = '\0';
2832 SV * const tmpsv = newSVpvn("", 0);
2833 const MADPROP* mp = o->op_madprop;
2835 sv_utf8_upgrade(tmpsv);
2838 PerlIO_printf(file, ">\n");
2840 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2843 char tmp = mp->mad_key;
2844 sv_setpvn(tmpsv,"\"",1);
2846 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2847 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2848 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2851 sv_catpv(tmpsv, "\"");
2852 switch (mp->mad_type) {
2854 sv_catpv(tmpsv, "NULL");
2855 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2858 sv_catpv(tmpsv, " val=\"");
2859 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2860 sv_catpv(tmpsv, "\"");
2861 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2864 sv_catpv(tmpsv, " val=\"");
2865 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2866 sv_catpv(tmpsv, "\"");
2867 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2870 if ((OP*)mp->mad_val) {
2871 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2872 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2873 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2877 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2883 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2885 SvREFCNT_dec(tmpsv);
2888 switch (o->op_type) {
2895 PerlIO_printf(file, ">\n");
2897 do_pmop_xmldump(level, file, cPMOPo);
2903 if (o->op_flags & OPf_KIDS) {
2907 PerlIO_printf(file, ">\n");
2909 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2910 do_op_xmldump(level, file, kid);
2914 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2916 PerlIO_printf(file, " />\n");
2920 Perl_op_xmldump(pTHX_ const OP *o)
2922 do_op_xmldump(0, PL_xmlfp, o);
2928 * c-indentation-style: bsd
2930 * indent-tabs-mode: t
2933 * ex: set ts=8 sts=4 sw=4 noet: