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));
1058 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1059 (UV)CopLINE(cCOPo));
1060 if (CopSTASHPV(cCOPo))
1061 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1063 if (cCOPo->cop_label)
1064 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1068 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1069 if (cLOOPo->op_redoop)
1070 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1072 PerlIO_printf(file, "DONE\n");
1073 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1074 if (cLOOPo->op_nextop)
1075 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1077 PerlIO_printf(file, "DONE\n");
1078 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1079 if (cLOOPo->op_lastop)
1080 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1082 PerlIO_printf(file, "DONE\n");
1090 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1091 if (cLOGOPo->op_other)
1092 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1094 PerlIO_printf(file, "DONE\n");
1100 do_pmop_dump(level, file, cPMOPo);
1108 if (o->op_private & OPpREFCOUNTED)
1109 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1114 if (o->op_flags & OPf_KIDS) {
1116 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1117 do_op_dump(level, file, kid);
1119 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1123 Perl_op_dump(pTHX_ const OP *o)
1125 do_op_dump(0, Perl_debug_log, o);
1129 Perl_gv_dump(pTHX_ GV *gv)
1134 PerlIO_printf(Perl_debug_log, "{}\n");
1137 sv = sv_newmortal();
1138 PerlIO_printf(Perl_debug_log, "{\n");
1139 gv_fullname3(sv, gv, NULL);
1140 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1141 if (gv != GvEGV(gv)) {
1142 gv_efullname3(sv, GvEGV(gv), NULL);
1143 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1145 PerlIO_putc(Perl_debug_log, '\n');
1146 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1150 /* map magic types to the symbolic names
1151 * (with the PERL_MAGIC_ prefixed stripped)
1154 static const struct { const char type; const char *name; } magic_names[] = {
1155 { PERL_MAGIC_sv, "sv(\\0)" },
1156 { PERL_MAGIC_arylen, "arylen(#)" },
1157 { PERL_MAGIC_rhash, "rhash(%)" },
1158 { PERL_MAGIC_pos, "pos(.)" },
1159 { PERL_MAGIC_symtab, "symtab(:)" },
1160 { PERL_MAGIC_backref, "backref(<)" },
1161 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1162 { PERL_MAGIC_overload, "overload(A)" },
1163 { PERL_MAGIC_bm, "bm(B)" },
1164 { PERL_MAGIC_regdata, "regdata(D)" },
1165 { PERL_MAGIC_env, "env(E)" },
1166 { PERL_MAGIC_hints, "hints(H)" },
1167 { PERL_MAGIC_isa, "isa(I)" },
1168 { PERL_MAGIC_dbfile, "dbfile(L)" },
1169 { PERL_MAGIC_shared, "shared(N)" },
1170 { PERL_MAGIC_tied, "tied(P)" },
1171 { PERL_MAGIC_sig, "sig(S)" },
1172 { PERL_MAGIC_uvar, "uvar(U)" },
1173 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1174 { PERL_MAGIC_overload_table, "overload_table(c)" },
1175 { PERL_MAGIC_regdatum, "regdatum(d)" },
1176 { PERL_MAGIC_envelem, "envelem(e)" },
1177 { PERL_MAGIC_fm, "fm(f)" },
1178 { PERL_MAGIC_regex_global, "regex_global(g)" },
1179 { PERL_MAGIC_hintselem, "hintselem(h)" },
1180 { PERL_MAGIC_isaelem, "isaelem(i)" },
1181 { PERL_MAGIC_nkeys, "nkeys(k)" },
1182 { PERL_MAGIC_dbline, "dbline(l)" },
1183 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1184 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1185 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1186 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1187 { PERL_MAGIC_qr, "qr(r)" },
1188 { PERL_MAGIC_sigelem, "sigelem(s)" },
1189 { PERL_MAGIC_taint, "taint(t)" },
1190 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1191 { PERL_MAGIC_vec, "vec(v)" },
1192 { PERL_MAGIC_vstring, "vstring(V)" },
1193 { PERL_MAGIC_utf8, "utf8(w)" },
1194 { PERL_MAGIC_substr, "substr(x)" },
1195 { PERL_MAGIC_defelem, "defelem(y)" },
1196 { PERL_MAGIC_ext, "ext(~)" },
1197 /* this null string terminates the list */
1202 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1204 for (; mg; mg = mg->mg_moremagic) {
1205 Perl_dump_indent(aTHX_ level, file,
1206 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1207 if (mg->mg_virtual) {
1208 const MGVTBL * const v = mg->mg_virtual;
1210 if (v == &PL_vtbl_sv) s = "sv";
1211 else if (v == &PL_vtbl_env) s = "env";
1212 else if (v == &PL_vtbl_envelem) s = "envelem";
1213 else if (v == &PL_vtbl_sig) s = "sig";
1214 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1215 else if (v == &PL_vtbl_pack) s = "pack";
1216 else if (v == &PL_vtbl_packelem) s = "packelem";
1217 else if (v == &PL_vtbl_dbline) s = "dbline";
1218 else if (v == &PL_vtbl_isa) s = "isa";
1219 else if (v == &PL_vtbl_arylen) s = "arylen";
1220 else if (v == &PL_vtbl_mglob) s = "mglob";
1221 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1222 else if (v == &PL_vtbl_taint) s = "taint";
1223 else if (v == &PL_vtbl_substr) s = "substr";
1224 else if (v == &PL_vtbl_vec) s = "vec";
1225 else if (v == &PL_vtbl_pos) s = "pos";
1226 else if (v == &PL_vtbl_bm) s = "bm";
1227 else if (v == &PL_vtbl_fm) s = "fm";
1228 else if (v == &PL_vtbl_uvar) s = "uvar";
1229 else if (v == &PL_vtbl_defelem) s = "defelem";
1230 #ifdef USE_LOCALE_COLLATE
1231 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1233 else if (v == &PL_vtbl_amagic) s = "amagic";
1234 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1235 else if (v == &PL_vtbl_backref) s = "backref";
1236 else if (v == &PL_vtbl_utf8) s = "utf8";
1237 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1238 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1241 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1243 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1246 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1249 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1253 const char *name = NULL;
1254 for (n = 0; magic_names[n].name; n++) {
1255 if (mg->mg_type == magic_names[n].type) {
1256 name = magic_names[n].name;
1261 Perl_dump_indent(aTHX_ level, file,
1262 " MG_TYPE = PERL_MAGIC_%s\n", name);
1264 Perl_dump_indent(aTHX_ level, file,
1265 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1269 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1270 if (mg->mg_type == PERL_MAGIC_envelem &&
1271 mg->mg_flags & MGf_TAINTEDDIR)
1272 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1273 if (mg->mg_flags & MGf_REFCOUNTED)
1274 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1275 if (mg->mg_flags & MGf_GSKIP)
1276 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1277 if (mg->mg_type == PERL_MAGIC_regex_global &&
1278 mg->mg_flags & MGf_MINMATCH)
1279 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1282 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1283 PTR2UV(mg->mg_obj));
1284 if (mg->mg_type == PERL_MAGIC_qr) {
1285 REGEXP* const re = (REGEXP *)mg->mg_obj;
1286 SV * const dsv = sv_newmortal();
1287 const char * const s
1288 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1290 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1291 (RX_UTF8(re) ? 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));
1541 #ifdef PERL_OLD_COPY_ON_WRITE
1542 if (SvIsCOW_shared_hash(sv))
1543 PerlIO_printf(file, " (HASH)");
1544 else if (SvIsCOW_normal(sv))
1545 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1547 PerlIO_putc(file, '\n');
1549 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1550 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1551 (UV) COP_SEQ_RANGE_LOW(sv));
1552 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1553 (UV) COP_SEQ_RANGE_HIGH(sv));
1554 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1555 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1556 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1557 || type == SVt_NV) {
1558 STORE_NUMERIC_LOCAL_SET_STANDARD();
1559 /* %Vg doesn't work? --jhi */
1560 #ifdef USE_LONG_DOUBLE
1561 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1563 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1565 RESTORE_NUMERIC_LOCAL();
1568 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1570 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1572 if (type < SVt_PV) {
1576 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1577 if (SvPVX_const(sv)) {
1580 SvOOK_offset(sv, delta);
1581 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1586 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1588 PerlIO_printf(file, "( %s . ) ",
1589 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1592 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1593 if (SvUTF8(sv)) /* the 6? \x{....} */
1594 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1595 PerlIO_printf(file, "\n");
1596 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1597 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1600 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1602 if (type == SVt_REGEXP) {
1604 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1605 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1608 if (type >= SVt_PVMG) {
1609 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1610 HV * const ost = SvOURSTASH(sv);
1612 do_hv_dump(level, file, " OURSTASH", ost);
1615 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1618 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1622 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1623 if (AvARRAY(sv) != AvALLOC(sv)) {
1624 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1625 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1628 PerlIO_putc(file, '\n');
1629 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1630 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1631 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1632 sv_setpvn(d, "", 0);
1633 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1634 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1635 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1636 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1637 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1639 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1640 SV** const elt = av_fetch((AV*)sv,count,0);
1642 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1644 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1649 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1650 if (HvARRAY(sv) && HvKEYS(sv)) {
1651 /* Show distribution of HEs in the ARRAY */
1653 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1656 U32 pow2 = 2, keys = HvKEYS(sv);
1657 NV theoret, sum = 0;
1659 PerlIO_printf(file, " (");
1660 Zero(freq, FREQ_MAX + 1, int);
1661 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1664 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1666 if (count > FREQ_MAX)
1672 for (i = 0; i <= max; i++) {
1674 PerlIO_printf(file, "%d%s:%d", i,
1675 (i == FREQ_MAX) ? "+" : "",
1678 PerlIO_printf(file, ", ");
1681 PerlIO_putc(file, ')');
1682 /* The "quality" of a hash is defined as the total number of
1683 comparisons needed to access every element once, relative
1684 to the expected number needed for a random hash.
1686 The total number of comparisons is equal to the sum of
1687 the squares of the number of entries in each bucket.
1688 For a random hash of n keys into k buckets, the expected
1693 for (i = max; i > 0; i--) { /* Precision: count down. */
1694 sum += freq[i] * i * i;
1696 while ((keys = keys >> 1))
1698 theoret = HvKEYS(sv);
1699 theoret += theoret * (theoret-1)/pow2;
1700 PerlIO_putc(file, '\n');
1701 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1703 PerlIO_putc(file, '\n');
1704 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1705 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1706 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1707 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1708 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1710 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1711 if (mg && mg->mg_obj) {
1712 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1716 const char * const hvname = HvNAME_get(sv);
1718 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1721 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1723 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1725 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1729 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1731 HV * const hv = (HV*)sv;
1732 int count = maxnest - nest;
1735 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1738 const U32 hash = HeHASH(he);
1739 SV * const keysv = hv_iterkeysv(he);
1740 const char * const keypv = SvPV_const(keysv, len);
1741 SV * const elt = hv_iterval(hv, he);
1743 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1745 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1747 PerlIO_printf(file, "[REHASH] ");
1748 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1749 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1751 hv_iterinit(hv); /* Return to status quo */
1757 const char *const proto = SvPV_const(sv, len);
1758 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1763 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1764 if (!CvISXSUB(sv)) {
1766 Perl_dump_indent(aTHX_ level, file,
1767 " START = 0x%"UVxf" ===> %"IVdf"\n",
1768 PTR2UV(CvSTART(sv)),
1769 (IV)sequence_num(CvSTART(sv)));
1771 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1772 PTR2UV(CvROOT(sv)));
1773 if (CvROOT(sv) && dumpops) {
1774 do_op_dump(level+1, file, CvROOT(sv));
1777 SV * const constant = cv_const_sv((CV *)sv);
1779 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1782 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1784 PTR2UV(CvXSUBANY(sv).any_ptr));
1785 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1788 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1789 (IV)CvXSUBANY(sv).any_i32);
1792 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1793 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1794 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1795 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1796 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1797 if (type == SVt_PVFM)
1798 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1799 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1800 if (nest < maxnest) {
1801 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1804 const CV * const outside = CvOUTSIDE(sv);
1805 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1808 : CvANON(outside) ? "ANON"
1809 : (outside == PL_main_cv) ? "MAIN"
1810 : CvUNIQUE(outside) ? "UNIQUE"
1811 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1813 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1814 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1818 if (type == SVt_PVLV) {
1819 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1820 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1821 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1822 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1823 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1824 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1828 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1829 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1830 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1831 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1833 if (!isGV_with_GP(sv))
1835 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1836 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1837 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1838 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1841 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1842 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1843 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1844 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1845 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1846 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1847 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1848 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1849 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1850 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1851 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1852 do_gv_dump (level, file, " EGV", GvEGV(sv));
1855 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1856 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1857 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1858 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1859 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1860 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1861 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1863 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1864 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1865 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1867 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1868 PTR2UV(IoTOP_GV(sv)));
1869 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1872 /* Source filters hide things that are not GVs in these three, so let's
1873 be careful out there. */
1875 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1876 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1877 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1879 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1880 PTR2UV(IoFMT_GV(sv)));
1881 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1884 if (IoBOTTOM_NAME(sv))
1885 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1886 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1887 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1889 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1890 PTR2UV(IoBOTTOM_GV(sv)));
1891 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1894 if (isPRINT(IoTYPE(sv)))
1895 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1897 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1898 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1905 Perl_sv_dump(pTHX_ SV *sv)
1909 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1911 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1915 Perl_runops_debug(pTHX)
1919 if (ckWARN_d(WARN_DEBUGGING))
1920 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1924 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1928 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1929 PerlIO_printf(Perl_debug_log,
1930 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1931 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1932 PTR2UV(*PL_watchaddr));
1933 if (DEBUG_s_TEST_) {
1934 if (DEBUG_v_TEST_) {
1935 PerlIO_printf(Perl_debug_log, "\n");
1943 if (DEBUG_t_TEST_) debop(PL_op);
1944 if (DEBUG_P_TEST_) debprof(PL_op);
1946 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1947 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1954 Perl_debop(pTHX_ const OP *o)
1957 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1960 Perl_deb(aTHX_ "%s", OP_NAME(o));
1961 switch (o->op_type) {
1963 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1968 SV * const sv = newSV(0);
1970 /* FIXME - is this making unwarranted assumptions about the
1971 UTF-8 cleanliness of the dump file handle? */
1974 gv_fullname3(sv, cGVOPo_gv, NULL);
1975 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1979 PerlIO_printf(Perl_debug_log, "(NULL)");
1985 /* print the lexical's name */
1986 CV * const cv = deb_curcv(cxstack_ix);
1989 AV * const padlist = CvPADLIST(cv);
1990 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1991 sv = *av_fetch(comppad, o->op_targ, FALSE);
1995 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1997 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2003 PerlIO_printf(Perl_debug_log, "\n");
2008 S_deb_curcv(pTHX_ const I32 ix)
2011 const PERL_CONTEXT * const cx = &cxstack[ix];
2012 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2013 return cx->blk_sub.cv;
2014 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2016 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2021 return deb_curcv(ix - 1);
2025 Perl_watch(pTHX_ char **addr)
2028 PL_watchaddr = addr;
2030 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2031 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2035 S_debprof(pTHX_ const OP *o)
2038 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2040 if (!PL_profiledata)
2041 Newxz(PL_profiledata, MAXO, U32);
2042 ++PL_profiledata[o->op_type];
2046 Perl_debprofdump(pTHX)
2050 if (!PL_profiledata)
2052 for (i = 0; i < MAXO; i++) {
2053 if (PL_profiledata[i])
2054 PerlIO_printf(Perl_debug_log,
2055 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2062 * XML variants of most of the above routines
2066 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2069 PerlIO_printf(file, "\n ");
2070 va_start(args, pat);
2071 xmldump_vindent(level, file, pat, &args);
2077 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2080 va_start(args, pat);
2081 xmldump_vindent(level, file, pat, &args);
2086 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2088 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2089 PerlIO_vprintf(file, pat, *args);
2093 Perl_xmldump_all(pTHX)
2095 PerlIO_setlinebuf(PL_xmlfp);
2097 op_xmldump(PL_main_root);
2098 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2099 PerlIO_close(PL_xmlfp);
2104 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2109 if (!HvARRAY(stash))
2111 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2112 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2113 GV *gv = (GV*)HeVAL(entry);
2115 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2121 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2122 && (hv = GvHV(gv)) && hv != PL_defstash)
2123 xmldump_packsubs(hv); /* nested package */
2129 Perl_xmldump_sub(pTHX_ const GV *gv)
2131 SV * const sv = sv_newmortal();
2133 gv_fullname3(sv, gv, NULL);
2134 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2135 if (CvXSUB(GvCV(gv)))
2136 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2137 PTR2UV(CvXSUB(GvCV(gv))),
2138 (int)CvXSUBANY(GvCV(gv)).any_i32);
2139 else if (CvROOT(GvCV(gv)))
2140 op_xmldump(CvROOT(GvCV(gv)));
2142 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2146 Perl_xmldump_form(pTHX_ const GV *gv)
2148 SV * const sv = sv_newmortal();
2150 gv_fullname3(sv, gv, NULL);
2151 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2152 if (CvROOT(GvFORM(gv)))
2153 op_xmldump(CvROOT(GvFORM(gv)));
2155 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2159 Perl_xmldump_eval(pTHX)
2161 op_xmldump(PL_eval_root);
2165 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2167 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2171 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2174 const char * const e = pv + len;
2175 const char * const start = pv;
2179 sv_catpvn(dsv,"",0);
2180 dsvcur = SvCUR(dsv); /* in case we have to restart */
2185 c = utf8_to_uvchr((U8*)pv, &cl);
2187 SvCUR(dsv) = dsvcur;
2252 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2255 sv_catpvs(dsv, "<");
2258 sv_catpvs(dsv, ">");
2261 sv_catpvs(dsv, "&");
2264 sv_catpvs(dsv, """);
2268 if (c < 32 || c > 127) {
2269 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2272 const char string = (char) c;
2273 sv_catpvn(dsv, &string, 1);
2277 if ((c >= 0xD800 && c <= 0xDB7F) ||
2278 (c >= 0xDC00 && c <= 0xDFFF) ||
2279 (c >= 0xFFF0 && c <= 0xFFFF) ||
2281 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2283 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2296 Perl_sv_xmlpeek(pTHX_ SV *sv)
2298 SV * const t = sv_newmortal();
2303 sv_setpvn(t, "", 0);
2306 sv_catpv(t, "VOID=\"\"");
2309 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2310 sv_catpv(t, "WILD=\"\"");
2313 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2314 if (sv == &PL_sv_undef) {
2315 sv_catpv(t, "SV_UNDEF=\"1\"");
2316 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2317 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2321 else if (sv == &PL_sv_no) {
2322 sv_catpv(t, "SV_NO=\"1\"");
2323 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2324 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2325 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2326 SVp_POK|SVp_NOK)) &&
2331 else if (sv == &PL_sv_yes) {
2332 sv_catpv(t, "SV_YES=\"1\"");
2333 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2334 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2335 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2336 SVp_POK|SVp_NOK)) &&
2338 SvPVX(sv) && *SvPVX(sv) == '1' &&
2343 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2344 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2345 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2349 sv_catpv(t, " XXX=\"\" ");
2351 else if (SvREFCNT(sv) == 0) {
2352 sv_catpv(t, " refcnt=\"0\"");
2355 else if (DEBUG_R_TEST_) {
2358 /* is this SV on the tmps stack? */
2359 for (ix=PL_tmps_ix; ix>=0; ix--) {
2360 if (PL_tmps_stack[ix] == sv) {
2365 if (SvREFCNT(sv) > 1)
2366 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2369 sv_catpv(t, " DRT=\"<T>\"");
2373 sv_catpv(t, " ROK=\"\"");
2375 switch (SvTYPE(sv)) {
2377 sv_catpv(t, " FREED=\"1\"");
2381 sv_catpv(t, " UNDEF=\"1\"");
2384 sv_catpv(t, " IV=\"");
2387 sv_catpv(t, " NV=\"");
2390 sv_catpv(t, " PV=\"");
2393 sv_catpv(t, " PVIV=\"");
2396 sv_catpv(t, " PVNV=\"");
2399 sv_catpv(t, " PVMG=\"");
2402 sv_catpv(t, " PVLV=\"");
2405 sv_catpv(t, " AV=\"");
2408 sv_catpv(t, " HV=\"");
2412 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2414 sv_catpv(t, " CV=\"()\"");
2417 sv_catpv(t, " GV=\"");
2420 sv_catpv(t, " BIND=\"");
2423 sv_catpv(t, " ORANGE=\"");
2426 sv_catpv(t, " FM=\"");
2429 sv_catpv(t, " IO=\"");
2438 else if (SvNOKp(sv)) {
2439 STORE_NUMERIC_LOCAL_SET_STANDARD();
2440 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2441 RESTORE_NUMERIC_LOCAL();
2443 else if (SvIOKp(sv)) {
2445 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2447 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2456 return SvPV(t, n_a);
2460 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2463 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2466 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2469 REGEXP *const r = PM_GETRE(pm);
2470 SV * const tmpsv = newSVsv((SV*)r);
2471 sv_utf8_upgrade(tmpsv);
2472 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2474 SvREFCNT_dec(tmpsv);
2475 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2476 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2479 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2480 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2481 SV * const tmpsv = pm_description(pm);
2482 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2483 SvREFCNT_dec(tmpsv);
2487 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2488 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2489 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2490 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2491 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2492 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2495 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2499 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2501 do_pmop_xmldump(0, PL_xmlfp, pm);
2505 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2512 seq = sequence_num(o);
2513 Perl_xmldump_indent(aTHX_ level, file,
2514 "<op_%s seq=\"%"UVuf" -> ",
2519 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2520 sequence_num(o->op_next));
2522 PerlIO_printf(file, "DONE\"");
2525 if (o->op_type == OP_NULL)
2527 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2528 if (o->op_targ == OP_NEXTSTATE)
2531 PerlIO_printf(file, " line=\"%"UVuf"\"",
2532 (UV)CopLINE(cCOPo));
2533 if (CopSTASHPV(cCOPo))
2534 PerlIO_printf(file, " package=\"%s\"",
2536 if (cCOPo->cop_label)
2537 PerlIO_printf(file, " label=\"%s\"",
2542 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2545 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2548 SV * const tmpsv = newSVpvn("", 0);
2549 switch (o->op_flags & OPf_WANT) {
2551 sv_catpv(tmpsv, ",VOID");
2553 case OPf_WANT_SCALAR:
2554 sv_catpv(tmpsv, ",SCALAR");
2557 sv_catpv(tmpsv, ",LIST");
2560 sv_catpv(tmpsv, ",UNKNOWN");
2563 if (o->op_flags & OPf_KIDS)
2564 sv_catpv(tmpsv, ",KIDS");
2565 if (o->op_flags & OPf_PARENS)
2566 sv_catpv(tmpsv, ",PARENS");
2567 if (o->op_flags & OPf_STACKED)
2568 sv_catpv(tmpsv, ",STACKED");
2569 if (o->op_flags & OPf_REF)
2570 sv_catpv(tmpsv, ",REF");
2571 if (o->op_flags & OPf_MOD)
2572 sv_catpv(tmpsv, ",MOD");
2573 if (o->op_flags & OPf_SPECIAL)
2574 sv_catpv(tmpsv, ",SPECIAL");
2575 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2576 SvREFCNT_dec(tmpsv);
2578 if (o->op_private) {
2579 SV * const tmpsv = newSVpvn("", 0);
2580 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2581 if (o->op_private & OPpTARGET_MY)
2582 sv_catpv(tmpsv, ",TARGET_MY");
2584 else if (o->op_type == OP_LEAVESUB ||
2585 o->op_type == OP_LEAVE ||
2586 o->op_type == OP_LEAVESUBLV ||
2587 o->op_type == OP_LEAVEWRITE) {
2588 if (o->op_private & OPpREFCOUNTED)
2589 sv_catpv(tmpsv, ",REFCOUNTED");
2591 else if (o->op_type == OP_AASSIGN) {
2592 if (o->op_private & OPpASSIGN_COMMON)
2593 sv_catpv(tmpsv, ",COMMON");
2595 else if (o->op_type == OP_SASSIGN) {
2596 if (o->op_private & OPpASSIGN_BACKWARDS)
2597 sv_catpv(tmpsv, ",BACKWARDS");
2599 else if (o->op_type == OP_TRANS) {
2600 if (o->op_private & OPpTRANS_SQUASH)
2601 sv_catpv(tmpsv, ",SQUASH");
2602 if (o->op_private & OPpTRANS_DELETE)
2603 sv_catpv(tmpsv, ",DELETE");
2604 if (o->op_private & OPpTRANS_COMPLEMENT)
2605 sv_catpv(tmpsv, ",COMPLEMENT");
2606 if (o->op_private & OPpTRANS_IDENTICAL)
2607 sv_catpv(tmpsv, ",IDENTICAL");
2608 if (o->op_private & OPpTRANS_GROWS)
2609 sv_catpv(tmpsv, ",GROWS");
2611 else if (o->op_type == OP_REPEAT) {
2612 if (o->op_private & OPpREPEAT_DOLIST)
2613 sv_catpv(tmpsv, ",DOLIST");
2615 else if (o->op_type == OP_ENTERSUB ||
2616 o->op_type == OP_RV2SV ||
2617 o->op_type == OP_GVSV ||
2618 o->op_type == OP_RV2AV ||
2619 o->op_type == OP_RV2HV ||
2620 o->op_type == OP_RV2GV ||
2621 o->op_type == OP_AELEM ||
2622 o->op_type == OP_HELEM )
2624 if (o->op_type == OP_ENTERSUB) {
2625 if (o->op_private & OPpENTERSUB_AMPER)
2626 sv_catpv(tmpsv, ",AMPER");
2627 if (o->op_private & OPpENTERSUB_DB)
2628 sv_catpv(tmpsv, ",DB");
2629 if (o->op_private & OPpENTERSUB_HASTARG)
2630 sv_catpv(tmpsv, ",HASTARG");
2631 if (o->op_private & OPpENTERSUB_NOPAREN)
2632 sv_catpv(tmpsv, ",NOPAREN");
2633 if (o->op_private & OPpENTERSUB_INARGS)
2634 sv_catpv(tmpsv, ",INARGS");
2635 if (o->op_private & OPpENTERSUB_NOMOD)
2636 sv_catpv(tmpsv, ",NOMOD");
2639 switch (o->op_private & OPpDEREF) {
2641 sv_catpv(tmpsv, ",SV");
2644 sv_catpv(tmpsv, ",AV");
2647 sv_catpv(tmpsv, ",HV");
2650 if (o->op_private & OPpMAYBE_LVSUB)
2651 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2653 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2654 if (o->op_private & OPpLVAL_DEFER)
2655 sv_catpv(tmpsv, ",LVAL_DEFER");
2658 if (o->op_private & HINT_STRICT_REFS)
2659 sv_catpv(tmpsv, ",STRICT_REFS");
2660 if (o->op_private & OPpOUR_INTRO)
2661 sv_catpv(tmpsv, ",OUR_INTRO");
2664 else if (o->op_type == OP_CONST) {
2665 if (o->op_private & OPpCONST_BARE)
2666 sv_catpv(tmpsv, ",BARE");
2667 if (o->op_private & OPpCONST_STRICT)
2668 sv_catpv(tmpsv, ",STRICT");
2669 if (o->op_private & OPpCONST_ARYBASE)
2670 sv_catpv(tmpsv, ",ARYBASE");
2671 if (o->op_private & OPpCONST_WARNING)
2672 sv_catpv(tmpsv, ",WARNING");
2673 if (o->op_private & OPpCONST_ENTERED)
2674 sv_catpv(tmpsv, ",ENTERED");
2676 else if (o->op_type == OP_FLIP) {
2677 if (o->op_private & OPpFLIP_LINENUM)
2678 sv_catpv(tmpsv, ",LINENUM");
2680 else if (o->op_type == OP_FLOP) {
2681 if (o->op_private & OPpFLIP_LINENUM)
2682 sv_catpv(tmpsv, ",LINENUM");
2684 else if (o->op_type == OP_RV2CV) {
2685 if (o->op_private & OPpLVAL_INTRO)
2686 sv_catpv(tmpsv, ",INTRO");
2688 else if (o->op_type == OP_GV) {
2689 if (o->op_private & OPpEARLY_CV)
2690 sv_catpv(tmpsv, ",EARLY_CV");
2692 else if (o->op_type == OP_LIST) {
2693 if (o->op_private & OPpLIST_GUESSED)
2694 sv_catpv(tmpsv, ",GUESSED");
2696 else if (o->op_type == OP_DELETE) {
2697 if (o->op_private & OPpSLICE)
2698 sv_catpv(tmpsv, ",SLICE");
2700 else if (o->op_type == OP_EXISTS) {
2701 if (o->op_private & OPpEXISTS_SUB)
2702 sv_catpv(tmpsv, ",EXISTS_SUB");
2704 else if (o->op_type == OP_SORT) {
2705 if (o->op_private & OPpSORT_NUMERIC)
2706 sv_catpv(tmpsv, ",NUMERIC");
2707 if (o->op_private & OPpSORT_INTEGER)
2708 sv_catpv(tmpsv, ",INTEGER");
2709 if (o->op_private & OPpSORT_REVERSE)
2710 sv_catpv(tmpsv, ",REVERSE");
2712 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2713 if (o->op_private & OPpOPEN_IN_RAW)
2714 sv_catpv(tmpsv, ",IN_RAW");
2715 if (o->op_private & OPpOPEN_IN_CRLF)
2716 sv_catpv(tmpsv, ",IN_CRLF");
2717 if (o->op_private & OPpOPEN_OUT_RAW)
2718 sv_catpv(tmpsv, ",OUT_RAW");
2719 if (o->op_private & OPpOPEN_OUT_CRLF)
2720 sv_catpv(tmpsv, ",OUT_CRLF");
2722 else if (o->op_type == OP_EXIT) {
2723 if (o->op_private & OPpEXIT_VMSISH)
2724 sv_catpv(tmpsv, ",EXIT_VMSISH");
2725 if (o->op_private & OPpHUSH_VMSISH)
2726 sv_catpv(tmpsv, ",HUSH_VMSISH");
2728 else if (o->op_type == OP_DIE) {
2729 if (o->op_private & OPpHUSH_VMSISH)
2730 sv_catpv(tmpsv, ",HUSH_VMSISH");
2732 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2733 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2734 sv_catpv(tmpsv, ",FT_ACCESS");
2735 if (o->op_private & OPpFT_STACKED)
2736 sv_catpv(tmpsv, ",FT_STACKED");
2738 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2739 sv_catpv(tmpsv, ",INTRO");
2741 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2742 SvREFCNT_dec(tmpsv);
2745 switch (o->op_type) {
2747 if (o->op_flags & OPf_SPECIAL) {
2753 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2755 if (cSVOPo->op_sv) {
2756 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2757 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2763 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
2764 s = SvPV(tmpsv1,len);
2765 sv_catxmlpvn(tmpsv2, s, len, 1);
2766 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2770 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2774 case OP_METHOD_NAMED:
2775 #ifndef USE_ITHREADS
2776 /* with ITHREADS, consts are stored in the pad, and the right pad
2777 * may not be active here, so skip */
2778 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2784 PerlIO_printf(file, ">\n");
2786 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2791 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2792 (UV)CopLINE(cCOPo));
2793 if (CopSTASHPV(cCOPo))
2794 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2796 if (cCOPo->cop_label)
2797 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2801 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2802 if (cLOOPo->op_redoop)
2803 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2805 PerlIO_printf(file, "DONE\"");
2806 S_xmldump_attr(aTHX_ level, file, "next=\"");
2807 if (cLOOPo->op_nextop)
2808 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2810 PerlIO_printf(file, "DONE\"");
2811 S_xmldump_attr(aTHX_ level, file, "last=\"");
2812 if (cLOOPo->op_lastop)
2813 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2815 PerlIO_printf(file, "DONE\"");
2823 S_xmldump_attr(aTHX_ level, file, "other=\"");
2824 if (cLOGOPo->op_other)
2825 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2827 PerlIO_printf(file, "DONE\"");
2835 if (o->op_private & OPpREFCOUNTED)
2836 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2842 if (PL_madskills && o->op_madprop) {
2843 char prevkey = '\0';
2844 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2845 const MADPROP* mp = o->op_madprop;
2849 PerlIO_printf(file, ">\n");
2851 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2854 char tmp = mp->mad_key;
2855 sv_setpvn(tmpsv,"\"",1);
2857 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2858 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2859 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2862 sv_catpv(tmpsv, "\"");
2863 switch (mp->mad_type) {
2865 sv_catpv(tmpsv, "NULL");
2866 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2869 sv_catpv(tmpsv, " val=\"");
2870 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2871 sv_catpv(tmpsv, "\"");
2872 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2875 sv_catpv(tmpsv, " val=\"");
2876 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2877 sv_catpv(tmpsv, "\"");
2878 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2881 if ((OP*)mp->mad_val) {
2882 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2883 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2884 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2888 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2894 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2896 SvREFCNT_dec(tmpsv);
2899 switch (o->op_type) {
2906 PerlIO_printf(file, ">\n");
2908 do_pmop_xmldump(level, file, cPMOPo);
2914 if (o->op_flags & OPf_KIDS) {
2918 PerlIO_printf(file, ">\n");
2920 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2921 do_op_xmldump(level, file, kid);
2925 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2927 PerlIO_printf(file, " />\n");
2931 Perl_op_xmldump(pTHX_ const OP *o)
2933 do_op_xmldump(0, PL_xmlfp, o);
2939 * c-indentation-style: bsd
2941 * indent-tabs-mode: t
2944 * ex: set ts=8 sts=4 sw=4 noet: