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, RX_PRECOMP(PM_GETRE(pm)), 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) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
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 (RX_EXTFLAGS(regex) & RXf_TAINTED)
583 sv_catpv(desc, ",TAINTED");
584 if (RX_CHECK_SUBSTR(regex)) {
585 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
586 sv_catpv(desc, ",SCANFIRST");
587 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
588 sv_catpv(desc, ",ALL");
590 if (RX_EXTFLAGS(regex) & 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 REGEXP* const re = (REGEXP *)mg->mg_obj;
1287 SV * const dsv = sv_newmortal();
1288 const char * const s
1289 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1291 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1292 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1294 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1295 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1298 if (mg->mg_flags & MGf_REFCOUNTED)
1299 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1302 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1304 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1305 if (mg->mg_len >= 0) {
1306 if (mg->mg_type != PERL_MAGIC_utf8) {
1307 SV * const sv = newSVpvs("");
1308 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1312 else if (mg->mg_len == HEf_SVKEY) {
1313 PerlIO_puts(file, " => HEf_SVKEY\n");
1314 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1318 PerlIO_puts(file, " ???? - please notify IZ");
1319 PerlIO_putc(file, '\n');
1321 if (mg->mg_type == PERL_MAGIC_utf8) {
1322 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1325 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1326 Perl_dump_indent(aTHX_ level, file,
1327 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1330 (UV)cache[i * 2 + 1]);
1337 Perl_magic_dump(pTHX_ const MAGIC *mg)
1339 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1343 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1346 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1347 if (sv && (hvname = HvNAME_get(sv)))
1348 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1350 PerlIO_putc(file, '\n');
1354 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1356 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1357 if (sv && GvNAME(sv))
1358 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1360 PerlIO_putc(file, '\n');
1364 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1366 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1367 if (sv && GvNAME(sv)) {
1369 PerlIO_printf(file, "\t\"");
1370 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1371 PerlIO_printf(file, "%s\" :: \"", hvname);
1372 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1375 PerlIO_putc(file, '\n');
1379 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1388 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1392 flags = SvFLAGS(sv);
1395 d = Perl_newSVpvf(aTHX_
1396 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1397 PTR2UV(SvANY(sv)), PTR2UV(sv),
1398 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1399 (int)(PL_dumpindent*level), "");
1401 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1402 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1404 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1405 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1406 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1408 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1409 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1410 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1411 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1412 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1414 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1415 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1416 if (flags & SVf_POK) sv_catpv(d, "POK,");
1417 if (flags & SVf_ROK) {
1418 sv_catpv(d, "ROK,");
1419 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1421 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1422 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1423 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1424 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1426 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1427 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1428 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1429 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1430 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1431 if (SvPCS_IMPORTED(sv))
1432 sv_catpv(d, "PCS_IMPORTED,");
1434 sv_catpv(d, "SCREAM,");
1440 if (CvANON(sv)) sv_catpv(d, "ANON,");
1441 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1442 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1443 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1444 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1445 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1446 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1447 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1448 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1449 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1450 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1453 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1454 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1455 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1456 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1457 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1461 if (isGV_with_GP(sv)) {
1462 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1463 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1464 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1465 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1466 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1468 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1469 sv_catpv(d, "IMPORT");
1470 if (GvIMPORTED(sv) == GVf_IMPORTED)
1471 sv_catpv(d, "ALL,");
1474 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1475 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1476 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1477 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1481 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1482 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1486 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1487 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1490 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1491 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1494 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1499 /* SVphv_SHAREKEYS is also 0x20000000 */
1500 if ((type != SVt_PVHV) && SvUTF8(sv))
1501 sv_catpv(d, "UTF8");
1503 if (*(SvEND(d) - 1) == ',') {
1504 SvCUR_set(d, SvCUR(d) - 1);
1505 SvPVX(d)[SvCUR(d)] = '\0';
1510 #ifdef DEBUG_LEAKING_SCALARS
1511 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1512 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1514 sv->sv_debug_inpad ? "for" : "by",
1515 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1516 sv->sv_debug_cloned ? " (cloned)" : "");
1518 Perl_dump_indent(aTHX_ level, file, "SV = ");
1519 if (type < SVt_LAST) {
1520 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1522 if (type == SVt_NULL) {
1527 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1531 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1532 && type != SVt_PVCV && !isGV_with_GP(sv))
1533 || (type == SVt_IV && !SvROK(sv))) {
1535 #ifdef PERL_OLD_COPY_ON_WRITE
1539 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1541 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1542 #ifdef PERL_OLD_COPY_ON_WRITE
1543 if (SvIsCOW_shared_hash(sv))
1544 PerlIO_printf(file, " (HASH)");
1545 else if (SvIsCOW_normal(sv))
1546 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1548 PerlIO_putc(file, '\n');
1550 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1551 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1552 (UV) COP_SEQ_RANGE_LOW(sv));
1553 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1554 (UV) COP_SEQ_RANGE_HIGH(sv));
1555 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1556 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1557 && !isGV_with_GP(sv) && !SvVALID(sv))
1558 || type == SVt_NV) {
1559 STORE_NUMERIC_LOCAL_SET_STANDARD();
1560 /* %Vg doesn't work? --jhi */
1561 #ifdef USE_LONG_DOUBLE
1562 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1564 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1566 RESTORE_NUMERIC_LOCAL();
1569 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1571 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1573 if (type < SVt_PV) {
1577 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1578 if (SvPVX_const(sv)) {
1581 SvOOK_offset(sv, delta);
1582 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1587 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1589 PerlIO_printf(file, "( %s . ) ",
1590 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1593 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1594 if (SvUTF8(sv)) /* the 6? \x{....} */
1595 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1596 PerlIO_printf(file, "\n");
1597 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1598 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1601 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1603 if (type == SVt_REGEXP) {
1605 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1606 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1609 if (type >= SVt_PVMG) {
1610 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1611 HV * const ost = SvOURSTASH(sv);
1613 do_hv_dump(level, file, " OURSTASH", ost);
1616 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1619 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1623 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1624 if (AvARRAY(sv) != AvALLOC(sv)) {
1625 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1626 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1629 PerlIO_putc(file, '\n');
1630 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1631 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1632 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1633 sv_setpvn(d, "", 0);
1634 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1635 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1636 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1637 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1638 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1640 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1641 SV** const elt = av_fetch((AV*)sv,count,0);
1643 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1645 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1650 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1651 if (HvARRAY(sv) && HvKEYS(sv)) {
1652 /* Show distribution of HEs in the ARRAY */
1654 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1657 U32 pow2 = 2, keys = HvKEYS(sv);
1658 NV theoret, sum = 0;
1660 PerlIO_printf(file, " (");
1661 Zero(freq, FREQ_MAX + 1, int);
1662 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1665 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1667 if (count > FREQ_MAX)
1673 for (i = 0; i <= max; i++) {
1675 PerlIO_printf(file, "%d%s:%d", i,
1676 (i == FREQ_MAX) ? "+" : "",
1679 PerlIO_printf(file, ", ");
1682 PerlIO_putc(file, ')');
1683 /* The "quality" of a hash is defined as the total number of
1684 comparisons needed to access every element once, relative
1685 to the expected number needed for a random hash.
1687 The total number of comparisons is equal to the sum of
1688 the squares of the number of entries in each bucket.
1689 For a random hash of n keys into k buckets, the expected
1694 for (i = max; i > 0; i--) { /* Precision: count down. */
1695 sum += freq[i] * i * i;
1697 while ((keys = keys >> 1))
1699 theoret = HvKEYS(sv);
1700 theoret += theoret * (theoret-1)/pow2;
1701 PerlIO_putc(file, '\n');
1702 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1704 PerlIO_putc(file, '\n');
1705 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1706 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1707 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1708 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1709 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1711 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1712 if (mg && mg->mg_obj) {
1713 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1717 const char * const hvname = HvNAME_get(sv);
1719 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1722 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1724 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1726 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1730 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1732 HV * const hv = (HV*)sv;
1733 int count = maxnest - nest;
1736 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1739 const U32 hash = HeHASH(he);
1740 SV * const keysv = hv_iterkeysv(he);
1741 const char * const keypv = SvPV_const(keysv, len);
1742 SV * const elt = hv_iterval(hv, he);
1744 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1746 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1748 PerlIO_printf(file, "[REHASH] ");
1749 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1750 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1752 hv_iterinit(hv); /* Return to status quo */
1758 const char *const proto = SvPV_const(sv, len);
1759 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1764 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1765 if (!CvISXSUB(sv)) {
1767 Perl_dump_indent(aTHX_ level, file,
1768 " START = 0x%"UVxf" ===> %"IVdf"\n",
1769 PTR2UV(CvSTART(sv)),
1770 (IV)sequence_num(CvSTART(sv)));
1772 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1773 PTR2UV(CvROOT(sv)));
1774 if (CvROOT(sv) && dumpops) {
1775 do_op_dump(level+1, file, CvROOT(sv));
1778 SV * const constant = cv_const_sv((CV *)sv);
1780 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1783 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1785 PTR2UV(CvXSUBANY(sv).any_ptr));
1786 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1789 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1790 (IV)CvXSUBANY(sv).any_i32);
1793 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1794 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1795 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1796 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1797 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1798 if (type == SVt_PVFM)
1799 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1800 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1801 if (nest < maxnest) {
1802 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1805 const CV * const outside = CvOUTSIDE(sv);
1806 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1809 : CvANON(outside) ? "ANON"
1810 : (outside == PL_main_cv) ? "MAIN"
1811 : CvUNIQUE(outside) ? "UNIQUE"
1812 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1814 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1815 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1819 if (type == SVt_PVLV) {
1820 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1821 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1822 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1823 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1824 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1825 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1829 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1830 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1831 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1832 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1834 if (!isGV_with_GP(sv))
1836 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1837 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1838 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1839 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1842 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1843 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1844 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1845 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1846 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1847 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1848 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1849 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1850 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1851 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1852 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1853 do_gv_dump (level, file, " EGV", GvEGV(sv));
1856 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1857 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1858 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1859 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1860 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1861 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1862 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1864 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1865 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1866 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1868 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1869 PTR2UV(IoTOP_GV(sv)));
1870 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1873 /* Source filters hide things that are not GVs in these three, so let's
1874 be careful out there. */
1876 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1877 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1878 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1880 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1881 PTR2UV(IoFMT_GV(sv)));
1882 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1885 if (IoBOTTOM_NAME(sv))
1886 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1887 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1888 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1890 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1891 PTR2UV(IoBOTTOM_GV(sv)));
1892 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1895 if (isPRINT(IoTYPE(sv)))
1896 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1898 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1899 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1906 Perl_sv_dump(pTHX_ SV *sv)
1910 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1912 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1916 Perl_runops_debug(pTHX)
1920 if (ckWARN_d(WARN_DEBUGGING))
1921 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1925 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1929 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1930 PerlIO_printf(Perl_debug_log,
1931 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1932 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1933 PTR2UV(*PL_watchaddr));
1934 if (DEBUG_s_TEST_) {
1935 if (DEBUG_v_TEST_) {
1936 PerlIO_printf(Perl_debug_log, "\n");
1944 if (DEBUG_t_TEST_) debop(PL_op);
1945 if (DEBUG_P_TEST_) debprof(PL_op);
1947 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1948 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1955 Perl_debop(pTHX_ const OP *o)
1958 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1961 Perl_deb(aTHX_ "%s", OP_NAME(o));
1962 switch (o->op_type) {
1964 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1969 SV * const sv = newSV(0);
1971 /* FIXME - is this making unwarranted assumptions about the
1972 UTF-8 cleanliness of the dump file handle? */
1975 gv_fullname3(sv, cGVOPo_gv, NULL);
1976 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1980 PerlIO_printf(Perl_debug_log, "(NULL)");
1986 /* print the lexical's name */
1987 CV * const cv = deb_curcv(cxstack_ix);
1990 AV * const padlist = CvPADLIST(cv);
1991 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1992 sv = *av_fetch(comppad, o->op_targ, FALSE);
1996 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1998 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2004 PerlIO_printf(Perl_debug_log, "\n");
2009 S_deb_curcv(pTHX_ const I32 ix)
2012 const PERL_CONTEXT * const cx = &cxstack[ix];
2013 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2014 return cx->blk_sub.cv;
2015 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2017 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2022 return deb_curcv(ix - 1);
2026 Perl_watch(pTHX_ char **addr)
2029 PL_watchaddr = addr;
2031 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2032 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2036 S_debprof(pTHX_ const OP *o)
2039 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2041 if (!PL_profiledata)
2042 Newxz(PL_profiledata, MAXO, U32);
2043 ++PL_profiledata[o->op_type];
2047 Perl_debprofdump(pTHX)
2051 if (!PL_profiledata)
2053 for (i = 0; i < MAXO; i++) {
2054 if (PL_profiledata[i])
2055 PerlIO_printf(Perl_debug_log,
2056 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2063 * XML variants of most of the above routines
2067 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2070 PerlIO_printf(file, "\n ");
2071 va_start(args, pat);
2072 xmldump_vindent(level, file, pat, &args);
2078 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2081 va_start(args, pat);
2082 xmldump_vindent(level, file, pat, &args);
2087 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2089 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2090 PerlIO_vprintf(file, pat, *args);
2094 Perl_xmldump_all(pTHX)
2096 PerlIO_setlinebuf(PL_xmlfp);
2098 op_xmldump(PL_main_root);
2099 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2100 PerlIO_close(PL_xmlfp);
2105 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2110 if (!HvARRAY(stash))
2112 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2113 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2114 GV *gv = (GV*)HeVAL(entry);
2116 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2122 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2123 && (hv = GvHV(gv)) && hv != PL_defstash)
2124 xmldump_packsubs(hv); /* nested package */
2130 Perl_xmldump_sub(pTHX_ const GV *gv)
2132 SV * const sv = sv_newmortal();
2134 gv_fullname3(sv, gv, NULL);
2135 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2136 if (CvXSUB(GvCV(gv)))
2137 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2138 PTR2UV(CvXSUB(GvCV(gv))),
2139 (int)CvXSUBANY(GvCV(gv)).any_i32);
2140 else if (CvROOT(GvCV(gv)))
2141 op_xmldump(CvROOT(GvCV(gv)));
2143 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2147 Perl_xmldump_form(pTHX_ const GV *gv)
2149 SV * const sv = sv_newmortal();
2151 gv_fullname3(sv, gv, NULL);
2152 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2153 if (CvROOT(GvFORM(gv)))
2154 op_xmldump(CvROOT(GvFORM(gv)));
2156 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2160 Perl_xmldump_eval(pTHX)
2162 op_xmldump(PL_eval_root);
2166 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2168 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2172 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2175 const char * const e = pv + len;
2176 const char * const start = pv;
2180 sv_catpvn(dsv,"",0);
2181 dsvcur = SvCUR(dsv); /* in case we have to restart */
2186 c = utf8_to_uvchr((U8*)pv, &cl);
2188 SvCUR(dsv) = dsvcur;
2253 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2256 sv_catpvs(dsv, "<");
2259 sv_catpvs(dsv, ">");
2262 sv_catpvs(dsv, "&");
2265 sv_catpvs(dsv, """);
2269 if (c < 32 || c > 127) {
2270 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2273 const char string = (char) c;
2274 sv_catpvn(dsv, &string, 1);
2278 if ((c >= 0xD800 && c <= 0xDB7F) ||
2279 (c >= 0xDC00 && c <= 0xDFFF) ||
2280 (c >= 0xFFF0 && c <= 0xFFFF) ||
2282 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2284 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2297 Perl_sv_xmlpeek(pTHX_ SV *sv)
2299 SV * const t = sv_newmortal();
2304 sv_setpvn(t, "", 0);
2307 sv_catpv(t, "VOID=\"\"");
2310 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2311 sv_catpv(t, "WILD=\"\"");
2314 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2315 if (sv == &PL_sv_undef) {
2316 sv_catpv(t, "SV_UNDEF=\"1\"");
2317 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2318 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2322 else if (sv == &PL_sv_no) {
2323 sv_catpv(t, "SV_NO=\"1\"");
2324 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2325 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2326 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2327 SVp_POK|SVp_NOK)) &&
2332 else if (sv == &PL_sv_yes) {
2333 sv_catpv(t, "SV_YES=\"1\"");
2334 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2335 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2336 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2337 SVp_POK|SVp_NOK)) &&
2339 SvPVX(sv) && *SvPVX(sv) == '1' &&
2344 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2345 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2346 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2350 sv_catpv(t, " XXX=\"\" ");
2352 else if (SvREFCNT(sv) == 0) {
2353 sv_catpv(t, " refcnt=\"0\"");
2356 else if (DEBUG_R_TEST_) {
2359 /* is this SV on the tmps stack? */
2360 for (ix=PL_tmps_ix; ix>=0; ix--) {
2361 if (PL_tmps_stack[ix] == sv) {
2366 if (SvREFCNT(sv) > 1)
2367 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2370 sv_catpv(t, " DRT=\"<T>\"");
2374 sv_catpv(t, " ROK=\"\"");
2376 switch (SvTYPE(sv)) {
2378 sv_catpv(t, " FREED=\"1\"");
2382 sv_catpv(t, " UNDEF=\"1\"");
2385 sv_catpv(t, " IV=\"");
2388 sv_catpv(t, " NV=\"");
2391 sv_catpv(t, " PV=\"");
2394 sv_catpv(t, " PVIV=\"");
2397 sv_catpv(t, " PVNV=\"");
2400 sv_catpv(t, " PVMG=\"");
2403 sv_catpv(t, " PVLV=\"");
2406 sv_catpv(t, " AV=\"");
2409 sv_catpv(t, " HV=\"");
2413 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2415 sv_catpv(t, " CV=\"()\"");
2418 sv_catpv(t, " GV=\"");
2421 sv_catpv(t, " BIND=\"");
2424 sv_catpv(t, " ORANGE=\"");
2427 sv_catpv(t, " FM=\"");
2430 sv_catpv(t, " IO=\"");
2439 else if (SvNOKp(sv)) {
2440 STORE_NUMERIC_LOCAL_SET_STANDARD();
2441 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2442 RESTORE_NUMERIC_LOCAL();
2444 else if (SvIOKp(sv)) {
2446 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2448 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2457 return SvPV(t, n_a);
2461 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2464 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2467 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2470 REGEXP *const r = PM_GETRE(pm);
2471 /* FIXME ORANGE - REGEXP can be 8 bit, so this is sometimes buggy: */
2472 SV * const tmpsv = newSVpvn(RX_PRECOMP(r),RX_PRELEN(r));
2474 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2476 SvREFCNT_dec(tmpsv);
2477 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2478 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2481 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2482 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2483 SV * const tmpsv = pm_description(pm);
2484 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2485 SvREFCNT_dec(tmpsv);
2489 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2490 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2491 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2492 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2493 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2494 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2497 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2501 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2503 do_pmop_xmldump(0, PL_xmlfp, pm);
2507 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2514 seq = sequence_num(o);
2515 Perl_xmldump_indent(aTHX_ level, file,
2516 "<op_%s seq=\"%"UVuf" -> ",
2521 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2522 sequence_num(o->op_next));
2524 PerlIO_printf(file, "DONE\"");
2527 if (o->op_type == OP_NULL)
2529 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2530 if (o->op_targ == OP_NEXTSTATE)
2533 PerlIO_printf(file, " line=\"%"UVuf"\"",
2534 (UV)CopLINE(cCOPo));
2535 if (CopSTASHPV(cCOPo))
2536 PerlIO_printf(file, " package=\"%s\"",
2538 if (cCOPo->cop_label)
2539 PerlIO_printf(file, " label=\"%s\"",
2544 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2547 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2550 SV * const tmpsv = newSVpvn("", 0);
2551 switch (o->op_flags & OPf_WANT) {
2553 sv_catpv(tmpsv, ",VOID");
2555 case OPf_WANT_SCALAR:
2556 sv_catpv(tmpsv, ",SCALAR");
2559 sv_catpv(tmpsv, ",LIST");
2562 sv_catpv(tmpsv, ",UNKNOWN");
2565 if (o->op_flags & OPf_KIDS)
2566 sv_catpv(tmpsv, ",KIDS");
2567 if (o->op_flags & OPf_PARENS)
2568 sv_catpv(tmpsv, ",PARENS");
2569 if (o->op_flags & OPf_STACKED)
2570 sv_catpv(tmpsv, ",STACKED");
2571 if (o->op_flags & OPf_REF)
2572 sv_catpv(tmpsv, ",REF");
2573 if (o->op_flags & OPf_MOD)
2574 sv_catpv(tmpsv, ",MOD");
2575 if (o->op_flags & OPf_SPECIAL)
2576 sv_catpv(tmpsv, ",SPECIAL");
2577 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2578 SvREFCNT_dec(tmpsv);
2580 if (o->op_private) {
2581 SV * const tmpsv = newSVpvn("", 0);
2582 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2583 if (o->op_private & OPpTARGET_MY)
2584 sv_catpv(tmpsv, ",TARGET_MY");
2586 else if (o->op_type == OP_LEAVESUB ||
2587 o->op_type == OP_LEAVE ||
2588 o->op_type == OP_LEAVESUBLV ||
2589 o->op_type == OP_LEAVEWRITE) {
2590 if (o->op_private & OPpREFCOUNTED)
2591 sv_catpv(tmpsv, ",REFCOUNTED");
2593 else if (o->op_type == OP_AASSIGN) {
2594 if (o->op_private & OPpASSIGN_COMMON)
2595 sv_catpv(tmpsv, ",COMMON");
2597 else if (o->op_type == OP_SASSIGN) {
2598 if (o->op_private & OPpASSIGN_BACKWARDS)
2599 sv_catpv(tmpsv, ",BACKWARDS");
2601 else if (o->op_type == OP_TRANS) {
2602 if (o->op_private & OPpTRANS_SQUASH)
2603 sv_catpv(tmpsv, ",SQUASH");
2604 if (o->op_private & OPpTRANS_DELETE)
2605 sv_catpv(tmpsv, ",DELETE");
2606 if (o->op_private & OPpTRANS_COMPLEMENT)
2607 sv_catpv(tmpsv, ",COMPLEMENT");
2608 if (o->op_private & OPpTRANS_IDENTICAL)
2609 sv_catpv(tmpsv, ",IDENTICAL");
2610 if (o->op_private & OPpTRANS_GROWS)
2611 sv_catpv(tmpsv, ",GROWS");
2613 else if (o->op_type == OP_REPEAT) {
2614 if (o->op_private & OPpREPEAT_DOLIST)
2615 sv_catpv(tmpsv, ",DOLIST");
2617 else if (o->op_type == OP_ENTERSUB ||
2618 o->op_type == OP_RV2SV ||
2619 o->op_type == OP_GVSV ||
2620 o->op_type == OP_RV2AV ||
2621 o->op_type == OP_RV2HV ||
2622 o->op_type == OP_RV2GV ||
2623 o->op_type == OP_AELEM ||
2624 o->op_type == OP_HELEM )
2626 if (o->op_type == OP_ENTERSUB) {
2627 if (o->op_private & OPpENTERSUB_AMPER)
2628 sv_catpv(tmpsv, ",AMPER");
2629 if (o->op_private & OPpENTERSUB_DB)
2630 sv_catpv(tmpsv, ",DB");
2631 if (o->op_private & OPpENTERSUB_HASTARG)
2632 sv_catpv(tmpsv, ",HASTARG");
2633 if (o->op_private & OPpENTERSUB_NOPAREN)
2634 sv_catpv(tmpsv, ",NOPAREN");
2635 if (o->op_private & OPpENTERSUB_INARGS)
2636 sv_catpv(tmpsv, ",INARGS");
2637 if (o->op_private & OPpENTERSUB_NOMOD)
2638 sv_catpv(tmpsv, ",NOMOD");
2641 switch (o->op_private & OPpDEREF) {
2643 sv_catpv(tmpsv, ",SV");
2646 sv_catpv(tmpsv, ",AV");
2649 sv_catpv(tmpsv, ",HV");
2652 if (o->op_private & OPpMAYBE_LVSUB)
2653 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2655 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2656 if (o->op_private & OPpLVAL_DEFER)
2657 sv_catpv(tmpsv, ",LVAL_DEFER");
2660 if (o->op_private & HINT_STRICT_REFS)
2661 sv_catpv(tmpsv, ",STRICT_REFS");
2662 if (o->op_private & OPpOUR_INTRO)
2663 sv_catpv(tmpsv, ",OUR_INTRO");
2666 else if (o->op_type == OP_CONST) {
2667 if (o->op_private & OPpCONST_BARE)
2668 sv_catpv(tmpsv, ",BARE");
2669 if (o->op_private & OPpCONST_STRICT)
2670 sv_catpv(tmpsv, ",STRICT");
2671 if (o->op_private & OPpCONST_ARYBASE)
2672 sv_catpv(tmpsv, ",ARYBASE");
2673 if (o->op_private & OPpCONST_WARNING)
2674 sv_catpv(tmpsv, ",WARNING");
2675 if (o->op_private & OPpCONST_ENTERED)
2676 sv_catpv(tmpsv, ",ENTERED");
2678 else if (o->op_type == OP_FLIP) {
2679 if (o->op_private & OPpFLIP_LINENUM)
2680 sv_catpv(tmpsv, ",LINENUM");
2682 else if (o->op_type == OP_FLOP) {
2683 if (o->op_private & OPpFLIP_LINENUM)
2684 sv_catpv(tmpsv, ",LINENUM");
2686 else if (o->op_type == OP_RV2CV) {
2687 if (o->op_private & OPpLVAL_INTRO)
2688 sv_catpv(tmpsv, ",INTRO");
2690 else if (o->op_type == OP_GV) {
2691 if (o->op_private & OPpEARLY_CV)
2692 sv_catpv(tmpsv, ",EARLY_CV");
2694 else if (o->op_type == OP_LIST) {
2695 if (o->op_private & OPpLIST_GUESSED)
2696 sv_catpv(tmpsv, ",GUESSED");
2698 else if (o->op_type == OP_DELETE) {
2699 if (o->op_private & OPpSLICE)
2700 sv_catpv(tmpsv, ",SLICE");
2702 else if (o->op_type == OP_EXISTS) {
2703 if (o->op_private & OPpEXISTS_SUB)
2704 sv_catpv(tmpsv, ",EXISTS_SUB");
2706 else if (o->op_type == OP_SORT) {
2707 if (o->op_private & OPpSORT_NUMERIC)
2708 sv_catpv(tmpsv, ",NUMERIC");
2709 if (o->op_private & OPpSORT_INTEGER)
2710 sv_catpv(tmpsv, ",INTEGER");
2711 if (o->op_private & OPpSORT_REVERSE)
2712 sv_catpv(tmpsv, ",REVERSE");
2714 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2715 if (o->op_private & OPpOPEN_IN_RAW)
2716 sv_catpv(tmpsv, ",IN_RAW");
2717 if (o->op_private & OPpOPEN_IN_CRLF)
2718 sv_catpv(tmpsv, ",IN_CRLF");
2719 if (o->op_private & OPpOPEN_OUT_RAW)
2720 sv_catpv(tmpsv, ",OUT_RAW");
2721 if (o->op_private & OPpOPEN_OUT_CRLF)
2722 sv_catpv(tmpsv, ",OUT_CRLF");
2724 else if (o->op_type == OP_EXIT) {
2725 if (o->op_private & OPpEXIT_VMSISH)
2726 sv_catpv(tmpsv, ",EXIT_VMSISH");
2727 if (o->op_private & OPpHUSH_VMSISH)
2728 sv_catpv(tmpsv, ",HUSH_VMSISH");
2730 else if (o->op_type == OP_DIE) {
2731 if (o->op_private & OPpHUSH_VMSISH)
2732 sv_catpv(tmpsv, ",HUSH_VMSISH");
2734 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2735 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2736 sv_catpv(tmpsv, ",FT_ACCESS");
2737 if (o->op_private & OPpFT_STACKED)
2738 sv_catpv(tmpsv, ",FT_STACKED");
2740 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2741 sv_catpv(tmpsv, ",INTRO");
2743 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2744 SvREFCNT_dec(tmpsv);
2747 switch (o->op_type) {
2749 if (o->op_flags & OPf_SPECIAL) {
2755 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2757 if (cSVOPo->op_sv) {
2758 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2759 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2765 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
2766 s = SvPV(tmpsv1,len);
2767 sv_catxmlpvn(tmpsv2, s, len, 1);
2768 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2772 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2776 case OP_METHOD_NAMED:
2777 #ifndef USE_ITHREADS
2778 /* with ITHREADS, consts are stored in the pad, and the right pad
2779 * may not be active here, so skip */
2780 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2786 PerlIO_printf(file, ">\n");
2788 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2794 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2795 (UV)CopLINE(cCOPo));
2796 if (CopSTASHPV(cCOPo))
2797 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2799 if (cCOPo->cop_label)
2800 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2804 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2805 if (cLOOPo->op_redoop)
2806 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2808 PerlIO_printf(file, "DONE\"");
2809 S_xmldump_attr(aTHX_ level, file, "next=\"");
2810 if (cLOOPo->op_nextop)
2811 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2813 PerlIO_printf(file, "DONE\"");
2814 S_xmldump_attr(aTHX_ level, file, "last=\"");
2815 if (cLOOPo->op_lastop)
2816 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2818 PerlIO_printf(file, "DONE\"");
2826 S_xmldump_attr(aTHX_ level, file, "other=\"");
2827 if (cLOGOPo->op_other)
2828 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2830 PerlIO_printf(file, "DONE\"");
2838 if (o->op_private & OPpREFCOUNTED)
2839 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2845 if (PL_madskills && o->op_madprop) {
2846 char prevkey = '\0';
2847 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2848 const MADPROP* mp = o->op_madprop;
2852 PerlIO_printf(file, ">\n");
2854 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2857 char tmp = mp->mad_key;
2858 sv_setpvn(tmpsv,"\"",1);
2860 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2861 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2862 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2865 sv_catpv(tmpsv, "\"");
2866 switch (mp->mad_type) {
2868 sv_catpv(tmpsv, "NULL");
2869 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2872 sv_catpv(tmpsv, " val=\"");
2873 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2874 sv_catpv(tmpsv, "\"");
2875 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2878 sv_catpv(tmpsv, " val=\"");
2879 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2880 sv_catpv(tmpsv, "\"");
2881 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2884 if ((OP*)mp->mad_val) {
2885 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2886 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2887 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2891 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2897 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2899 SvREFCNT_dec(tmpsv);
2902 switch (o->op_type) {
2909 PerlIO_printf(file, ">\n");
2911 do_pmop_xmldump(level, file, cPMOPo);
2917 if (o->op_flags & OPf_KIDS) {
2921 PerlIO_printf(file, ">\n");
2923 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2924 do_op_xmldump(level, file, kid);
2928 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2930 PerlIO_printf(file, " />\n");
2934 Perl_op_xmldump(pTHX_ const OP *o)
2936 do_op_xmldump(0, PL_xmlfp, o);
2942 * c-indentation-style: bsd
2944 * indent-tabs-mode: t
2947 * ex: set ts=8 sts=4 sw=4 noet: