3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'"
16 /* This file contains utility routines to dump the contents of SV and OP
17 * structures, as used by command-line options like -Dt and -Dx, and
20 * It also holds the debugging version of the runops function.
24 #define PERL_IN_DUMP_C
30 static const char* const svtypenames[SVt_LAST] = {
50 static const char* const svshorttypenames[SVt_LAST] = {
69 #define Sequence PL_op_sequence
72 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
76 dump_vindent(level, file, pat, &args);
81 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
84 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
85 PerlIO_vprintf(file, pat, *args);
92 PerlIO_setlinebuf(Perl_debug_log);
94 op_dump(PL_main_root);
95 dump_packsubs(PL_defstash);
99 Perl_dump_packsubs(pTHX_ const HV *stash)
106 for (i = 0; i <= (I32) HvMAX(stash); i++) {
108 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
109 const GV *gv = (GV*)HeVAL(entry);
111 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
117 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
118 && (hv = GvHV(gv)) && hv != PL_defstash)
119 dump_packsubs(hv); /* nested package */
125 Perl_dump_sub(pTHX_ const GV *gv)
127 SV * const sv = sv_newmortal();
129 gv_fullname3(sv, gv, NULL);
130 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
131 if (CvISXSUB(GvCV(gv)))
132 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
133 PTR2UV(CvXSUB(GvCV(gv))),
134 (int)CvXSUBANY(GvCV(gv)).any_i32);
135 else if (CvROOT(GvCV(gv)))
136 op_dump(CvROOT(GvCV(gv)));
138 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
142 Perl_dump_form(pTHX_ const GV *gv)
144 SV * const sv = sv_newmortal();
146 gv_fullname3(sv, gv, NULL);
147 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
148 if (CvROOT(GvFORM(gv)))
149 op_dump(CvROOT(GvFORM(gv)));
151 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
158 op_dump(PL_eval_root);
163 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
164 |const STRLEN count|const STRLEN max
165 |STRLEN const *escaped, const U32 flags
167 Escapes at most the first "count" chars of pv and puts the results into
168 dsv such that the size of the escaped string will not exceed "max" chars
169 and will not contain any incomplete escape sequences.
171 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
172 will also be escaped.
174 Normally the SV will be cleared before the escaped string is prepared,
175 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
177 If PERL_PV_ESCAPE_UNI is set then the input string is treated as unicode,
178 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
179 using C<is_utf8_string()> to determine if it is unicode.
181 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
182 using C<\x01F1> style escapes, otherwise only chars above 255 will be
183 escaped using this style, other non printable chars will use octal or
184 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
185 then all chars below 255 will be treated as printable and
186 will be output as literals.
188 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
189 string will be escaped, regardles of max. If the string is utf8 and
190 the chars value is >255 then it will be returned as a plain hex
191 sequence. Thus the output will either be a single char,
192 an octal escape sequence, a special escape like C<\n> or a 3 or
193 more digit hex value.
195 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
196 not a '\\'. This is because regexes very often contain backslashed
197 sequences, whereas '%' is not a particularly common character in patterns.
199 Returns a pointer to the escaped text as held by dsv.
203 #define PV_ESCAPE_OCTBUFSIZE 32
206 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
207 const STRLEN count, const STRLEN max,
208 STRLEN * const escaped, const U32 flags )
210 char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
211 char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
212 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
213 STRLEN wrote = 0; /* chars written so far */
214 STRLEN chsize = 0; /* size of data to be written */
215 STRLEN readsize = 1; /* size of data just read */
216 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
217 const char *pv = str;
218 const char *end = pv + count; /* end of string */
221 if (!flags & PERL_PV_ESCAPE_NOCLEAR)
222 sv_setpvn(dsv, "", 0);
224 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
227 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
228 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
229 const U8 c = (U8)u & 0xFF;
231 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
232 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
233 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
236 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
237 "%cx{%"UVxf"}", esc, u);
238 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
241 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
245 case '\\' : /* fallthrough */
246 case '%' : if ( c == esc ) {
252 case '\v' : octbuf[1] = 'v'; break;
253 case '\t' : octbuf[1] = 't'; break;
254 case '\r' : octbuf[1] = 'r'; break;
255 case '\n' : octbuf[1] = 'n'; break;
256 case '\f' : octbuf[1] = 'f'; break;
264 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
265 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
268 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
275 if ( max && (wrote + chsize > max) ) {
277 } else if (chsize > 1) {
278 sv_catpvn(dsv, octbuf, chsize);
281 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
284 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
292 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
293 |const STRLEN count|const STRLEN max\
294 |const char const *start_color| const char const *end_color\
297 Converts a string into something presentable, handling escaping via
298 pv_escape() and supporting quoting and elipses.
300 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
301 double quoted with any double quotes in the string escaped. Otherwise
302 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
305 If the PERL_PV_PRETTY_ELIPSES flag is set and not all characters in
306 string were output then an elipses C<...> will be appended to the
307 string. Note that this happens AFTER it has been quoted.
309 If start_color is non-null then it will be inserted after the opening
310 quote (if there is one) but before the escaped text. If end_color
311 is non-null then it will be inserted after the escaped text but before
312 any quotes or elipses.
314 Returns a pointer to the prettified text as held by dsv.
320 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
321 const STRLEN max, char const * const start_color, char const * const end_color,
324 U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
328 sv_setpvn(dsv, "\"", 1);
329 else if ( flags & PERL_PV_PRETTY_LTGT )
330 sv_setpvn(dsv, "<", 1);
332 sv_setpvn(dsv, "", 0);
334 if ( start_color != NULL )
335 Perl_sv_catpv( aTHX_ dsv, start_color);
337 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
339 if ( end_color != NULL )
340 Perl_sv_catpv( aTHX_ dsv, end_color);
343 sv_catpvn( dsv, "\"", 1 );
344 else if ( flags & PERL_PV_PRETTY_LTGT )
345 sv_catpvn( dsv, ">", 1);
347 if ( (flags & PERL_PV_PRETTY_ELIPSES) && ( escaped < count ) )
348 sv_catpvn( dsv, "...", 3 );
354 =for apidoc pv_display
356 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
357 STRLEN pvlim, U32 flags)
361 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
363 except that an additional "\0" will be appended to the string when
364 len > cur and pv[cur] is "\0".
366 Note that the final string may be up to 7 chars longer than pvlim.
372 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
374 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
375 if (len > cur && pv[cur] == '\0')
376 sv_catpvn( dsv, "\\0", 2 );
381 Perl_sv_peek(pTHX_ SV *sv)
384 SV * const t = sv_newmortal();
394 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
398 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
399 if (sv == &PL_sv_undef) {
400 sv_catpv(t, "SV_UNDEF");
401 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
402 SVs_GMG|SVs_SMG|SVs_RMG)) &&
406 else if (sv == &PL_sv_no) {
407 sv_catpv(t, "SV_NO");
408 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
409 SVs_GMG|SVs_SMG|SVs_RMG)) &&
410 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
416 else if (sv == &PL_sv_yes) {
417 sv_catpv(t, "SV_YES");
418 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
419 SVs_GMG|SVs_SMG|SVs_RMG)) &&
420 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
423 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
428 sv_catpv(t, "SV_PLACEHOLDER");
429 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
430 SVs_GMG|SVs_SMG|SVs_RMG)) &&
436 else if (SvREFCNT(sv) == 0) {
440 else if (DEBUG_R_TEST_) {
443 /* is this SV on the tmps stack? */
444 for (ix=PL_tmps_ix; ix>=0; ix--) {
445 if (PL_tmps_stack[ix] == sv) {
450 if (SvREFCNT(sv) > 1)
451 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
459 if (SvCUR(t) + unref > 10) {
460 SvCUR_set(t, unref + 3);
469 if (type == SVt_PVCV) {
470 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
472 } else if (type < SVt_LAST) {
473 sv_catpv(t, svshorttypenames[type]);
475 if (type == SVt_NULL)
478 sv_catpv(t, "FREED");
483 if (!SvPVX_const(sv))
484 sv_catpv(t, "(null)");
486 SV * const tmp = newSVpvs("");
489 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
490 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
492 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
493 sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv),
498 else if (SvNOKp(sv)) {
499 STORE_NUMERIC_LOCAL_SET_STANDARD();
500 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
501 RESTORE_NUMERIC_LOCAL();
503 else if (SvIOKp(sv)) {
505 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
507 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
517 return SvPV_nolen(t);
521 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
526 Perl_dump_indent(aTHX_ level, file, "{}\n");
529 Perl_dump_indent(aTHX_ level, file, "{\n");
531 if (pm->op_pmflags & PMf_ONCE)
536 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
537 ch, PM_GETRE(pm)->precomp, ch,
538 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
540 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
541 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
542 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
543 op_dump(pm->op_pmreplroot);
545 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
546 SV * const tmpsv = pm_description(pm);
547 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
551 Perl_dump_indent(aTHX_ level-1, file, "}\n");
555 S_pm_description(pTHX_ const PMOP *pm)
557 SV * const desc = newSVpvs("");
558 const REGEXP * regex = PM_GETRE(pm);
559 const U32 pmflags = pm->op_pmflags;
561 if (pmflags & PMf_ONCE)
562 sv_catpv(desc, ",ONCE");
564 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
565 sv_catpv(desc, ":USED");
567 if (pmflags & PMf_USED)
568 sv_catpv(desc, ":USED");
570 if (regex->extflags & RXf_TAINTED)
571 sv_catpv(desc, ",TAINTED");
574 if (regex && regex->check_substr) {
575 if (!(regex->extflags & RXf_NOSCAN))
576 sv_catpv(desc, ",SCANFIRST");
577 if (regex->extflags & RXf_CHECK_ALL)
578 sv_catpv(desc, ",ALL");
580 if (regex->extflags & RXf_SKIPWHITE)
581 sv_catpv(desc, ",SKIPWHITE");
582 if (pmflags & PMf_CONST)
583 sv_catpv(desc, ",CONST");
584 if (pmflags & PMf_KEEP)
585 sv_catpv(desc, ",KEEP");
586 if (pmflags & PMf_GLOBAL)
587 sv_catpv(desc, ",GLOBAL");
588 if (pmflags & PMf_CONTINUE)
589 sv_catpv(desc, ",CONTINUE");
590 if (pmflags & PMf_RETAINT)
591 sv_catpv(desc, ",RETAINT");
592 if (pmflags & PMf_EVAL)
593 sv_catpv(desc, ",EVAL");
598 Perl_pmop_dump(pTHX_ PMOP *pm)
600 do_pmop_dump(0, Perl_debug_log, pm);
603 /* An op sequencer. We visit the ops in the order they're to execute. */
606 S_sequence(pTHX_ register const OP *o)
609 const OP *oldop = NULL;
622 for (; o; o = o->op_next) {
624 SV * const op = newSVuv(PTR2UV(o));
625 const char * const key = SvPV_const(op, len);
627 if (hv_exists(Sequence, key, len))
630 switch (o->op_type) {
632 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
633 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
642 if (oldop && o->op_next)
649 if (oldop && o->op_next)
651 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
664 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
665 sequence_tail(cLOGOPo->op_other);
670 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
671 sequence_tail(cLOOPo->op_redoop);
672 sequence_tail(cLOOPo->op_nextop);
673 sequence_tail(cLOOPo->op_lastop);
679 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
680 sequence_tail(cPMOPo->op_pmreplstart);
687 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
695 S_sequence_tail(pTHX_ const OP *o)
697 while (o && (o->op_type == OP_NULL))
703 S_sequence_num(pTHX_ const OP *o)
711 op = newSVuv(PTR2UV(o));
712 key = SvPV_const(op, len);
713 seq = hv_fetch(Sequence, key, len, 0);
714 return seq ? SvUV(*seq): 0;
718 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
722 const OPCODE optype = o->op_type;
725 Perl_dump_indent(aTHX_ level, file, "{\n");
727 seq = sequence_num(o);
729 PerlIO_printf(file, "%-4"UVuf, seq);
731 PerlIO_printf(file, " ");
733 "%*sTYPE = %s ===> ",
734 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
736 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
737 sequence_num(o->op_next));
739 PerlIO_printf(file, "DONE\n");
741 if (optype == OP_NULL) {
742 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
743 if (o->op_targ == OP_NEXTSTATE) {
745 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
747 if (CopSTASHPV(cCOPo))
748 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
750 if (cCOPo->cop_label)
751 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
756 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
759 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
761 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
762 SV * const tmpsv = newSVpvs("");
763 switch (o->op_flags & OPf_WANT) {
765 sv_catpv(tmpsv, ",VOID");
767 case OPf_WANT_SCALAR:
768 sv_catpv(tmpsv, ",SCALAR");
771 sv_catpv(tmpsv, ",LIST");
774 sv_catpv(tmpsv, ",UNKNOWN");
777 if (o->op_flags & OPf_KIDS)
778 sv_catpv(tmpsv, ",KIDS");
779 if (o->op_flags & OPf_PARENS)
780 sv_catpv(tmpsv, ",PARENS");
781 if (o->op_flags & OPf_STACKED)
782 sv_catpv(tmpsv, ",STACKED");
783 if (o->op_flags & OPf_REF)
784 sv_catpv(tmpsv, ",REF");
785 if (o->op_flags & OPf_MOD)
786 sv_catpv(tmpsv, ",MOD");
787 if (o->op_flags & OPf_SPECIAL)
788 sv_catpv(tmpsv, ",SPECIAL");
790 sv_catpv(tmpsv, ",LATEFREE");
792 sv_catpv(tmpsv, ",LATEFREED");
794 sv_catpv(tmpsv, ",ATTACHED");
795 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
799 SV * const tmpsv = newSVpvs("");
800 if (PL_opargs[optype] & OA_TARGLEX) {
801 if (o->op_private & OPpTARGET_MY)
802 sv_catpv(tmpsv, ",TARGET_MY");
804 else if (optype == OP_LEAVESUB ||
805 optype == OP_LEAVE ||
806 optype == OP_LEAVESUBLV ||
807 optype == OP_LEAVEWRITE) {
808 if (o->op_private & OPpREFCOUNTED)
809 sv_catpv(tmpsv, ",REFCOUNTED");
811 else if (optype == OP_AASSIGN) {
812 if (o->op_private & OPpASSIGN_COMMON)
813 sv_catpv(tmpsv, ",COMMON");
815 else if (optype == OP_SASSIGN) {
816 if (o->op_private & OPpASSIGN_BACKWARDS)
817 sv_catpv(tmpsv, ",BACKWARDS");
819 else if (optype == OP_TRANS) {
820 if (o->op_private & OPpTRANS_SQUASH)
821 sv_catpv(tmpsv, ",SQUASH");
822 if (o->op_private & OPpTRANS_DELETE)
823 sv_catpv(tmpsv, ",DELETE");
824 if (o->op_private & OPpTRANS_COMPLEMENT)
825 sv_catpv(tmpsv, ",COMPLEMENT");
826 if (o->op_private & OPpTRANS_IDENTICAL)
827 sv_catpv(tmpsv, ",IDENTICAL");
828 if (o->op_private & OPpTRANS_GROWS)
829 sv_catpv(tmpsv, ",GROWS");
831 else if (optype == OP_REPEAT) {
832 if (o->op_private & OPpREPEAT_DOLIST)
833 sv_catpv(tmpsv, ",DOLIST");
835 else if (optype == OP_ENTERSUB ||
836 optype == OP_RV2SV ||
838 optype == OP_RV2AV ||
839 optype == OP_RV2HV ||
840 optype == OP_RV2GV ||
841 optype == OP_AELEM ||
844 if (optype == OP_ENTERSUB) {
845 if (o->op_private & OPpENTERSUB_AMPER)
846 sv_catpv(tmpsv, ",AMPER");
847 if (o->op_private & OPpENTERSUB_DB)
848 sv_catpv(tmpsv, ",DB");
849 if (o->op_private & OPpENTERSUB_HASTARG)
850 sv_catpv(tmpsv, ",HASTARG");
851 if (o->op_private & OPpENTERSUB_NOPAREN)
852 sv_catpv(tmpsv, ",NOPAREN");
853 if (o->op_private & OPpENTERSUB_INARGS)
854 sv_catpv(tmpsv, ",INARGS");
855 if (o->op_private & OPpENTERSUB_NOMOD)
856 sv_catpv(tmpsv, ",NOMOD");
859 switch (o->op_private & OPpDEREF) {
861 sv_catpv(tmpsv, ",SV");
864 sv_catpv(tmpsv, ",AV");
867 sv_catpv(tmpsv, ",HV");
870 if (o->op_private & OPpMAYBE_LVSUB)
871 sv_catpv(tmpsv, ",MAYBE_LVSUB");
873 if (optype == OP_AELEM || optype == OP_HELEM) {
874 if (o->op_private & OPpLVAL_DEFER)
875 sv_catpv(tmpsv, ",LVAL_DEFER");
878 if (o->op_private & HINT_STRICT_REFS)
879 sv_catpv(tmpsv, ",STRICT_REFS");
880 if (o->op_private & OPpOUR_INTRO)
881 sv_catpv(tmpsv, ",OUR_INTRO");
884 else if (optype == OP_CONST) {
885 if (o->op_private & OPpCONST_BARE)
886 sv_catpv(tmpsv, ",BARE");
887 if (o->op_private & OPpCONST_STRICT)
888 sv_catpv(tmpsv, ",STRICT");
889 if (o->op_private & OPpCONST_ARYBASE)
890 sv_catpv(tmpsv, ",ARYBASE");
891 if (o->op_private & OPpCONST_WARNING)
892 sv_catpv(tmpsv, ",WARNING");
893 if (o->op_private & OPpCONST_ENTERED)
894 sv_catpv(tmpsv, ",ENTERED");
896 else if (optype == OP_FLIP) {
897 if (o->op_private & OPpFLIP_LINENUM)
898 sv_catpv(tmpsv, ",LINENUM");
900 else if (optype == OP_FLOP) {
901 if (o->op_private & OPpFLIP_LINENUM)
902 sv_catpv(tmpsv, ",LINENUM");
904 else if (optype == OP_RV2CV) {
905 if (o->op_private & OPpLVAL_INTRO)
906 sv_catpv(tmpsv, ",INTRO");
908 else if (optype == OP_GV) {
909 if (o->op_private & OPpEARLY_CV)
910 sv_catpv(tmpsv, ",EARLY_CV");
912 else if (optype == OP_LIST) {
913 if (o->op_private & OPpLIST_GUESSED)
914 sv_catpv(tmpsv, ",GUESSED");
916 else if (optype == OP_DELETE) {
917 if (o->op_private & OPpSLICE)
918 sv_catpv(tmpsv, ",SLICE");
920 else if (optype == OP_EXISTS) {
921 if (o->op_private & OPpEXISTS_SUB)
922 sv_catpv(tmpsv, ",EXISTS_SUB");
924 else if (optype == OP_SORT) {
925 if (o->op_private & OPpSORT_NUMERIC)
926 sv_catpv(tmpsv, ",NUMERIC");
927 if (o->op_private & OPpSORT_INTEGER)
928 sv_catpv(tmpsv, ",INTEGER");
929 if (o->op_private & OPpSORT_REVERSE)
930 sv_catpv(tmpsv, ",REVERSE");
932 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
933 if (o->op_private & OPpOPEN_IN_RAW)
934 sv_catpv(tmpsv, ",IN_RAW");
935 if (o->op_private & OPpOPEN_IN_CRLF)
936 sv_catpv(tmpsv, ",IN_CRLF");
937 if (o->op_private & OPpOPEN_OUT_RAW)
938 sv_catpv(tmpsv, ",OUT_RAW");
939 if (o->op_private & OPpOPEN_OUT_CRLF)
940 sv_catpv(tmpsv, ",OUT_CRLF");
942 else if (optype == OP_EXIT) {
943 if (o->op_private & OPpEXIT_VMSISH)
944 sv_catpv(tmpsv, ",EXIT_VMSISH");
945 if (o->op_private & OPpHUSH_VMSISH)
946 sv_catpv(tmpsv, ",HUSH_VMSISH");
948 else if (optype == OP_DIE) {
949 if (o->op_private & OPpHUSH_VMSISH)
950 sv_catpv(tmpsv, ",HUSH_VMSISH");
952 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
953 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
954 sv_catpv(tmpsv, ",FT_ACCESS");
955 if (o->op_private & OPpFT_STACKED)
956 sv_catpv(tmpsv, ",FT_STACKED");
958 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
959 sv_catpv(tmpsv, ",INTRO");
961 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
966 if (PL_madskills && o->op_madprop) {
967 SV * const tmpsv = newSVpvn("", 0);
968 MADPROP* mp = o->op_madprop;
969 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
972 char tmp = mp->mad_key;
973 sv_setpvn(tmpsv,"'",1);
975 sv_catpvn(tmpsv, &tmp, 1);
976 sv_catpv(tmpsv, "'=");
977 switch (mp->mad_type) {
979 sv_catpv(tmpsv, "NULL");
980 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
983 sv_catpv(tmpsv, "<");
984 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
985 sv_catpv(tmpsv, ">");
986 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
989 if ((OP*)mp->mad_val) {
990 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
991 do_op_dump(level, file, (OP*)mp->mad_val);
995 sv_catpv(tmpsv, "(UNK)");
996 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1002 Perl_dump_indent(aTHX_ level, file, "}\n");
1004 SvREFCNT_dec(tmpsv);
1013 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1015 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1016 if (cSVOPo->op_sv) {
1017 SV * const tmpsv = newSV(0);
1021 /* FIXME - is this making unwarranted assumptions about the
1022 UTF-8 cleanliness of the dump file handle? */
1025 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1026 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1027 SvPV_nolen_const(tmpsv));
1031 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1036 case OP_METHOD_NAMED:
1037 #ifndef USE_ITHREADS
1038 /* with ITHREADS, consts are stored in the pad, and the right pad
1039 * may not be active here, so skip */
1040 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1047 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1048 (UV)CopLINE(cCOPo));
1049 if (CopSTASHPV(cCOPo))
1050 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1052 if (cCOPo->cop_label)
1053 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1057 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1058 if (cLOOPo->op_redoop)
1059 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1061 PerlIO_printf(file, "DONE\n");
1062 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1063 if (cLOOPo->op_nextop)
1064 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1066 PerlIO_printf(file, "DONE\n");
1067 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1068 if (cLOOPo->op_lastop)
1069 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1071 PerlIO_printf(file, "DONE\n");
1079 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1080 if (cLOGOPo->op_other)
1081 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1083 PerlIO_printf(file, "DONE\n");
1089 do_pmop_dump(level, file, cPMOPo);
1097 if (o->op_private & OPpREFCOUNTED)
1098 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1103 if (o->op_flags & OPf_KIDS) {
1105 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1106 do_op_dump(level, file, kid);
1108 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1112 Perl_op_dump(pTHX_ const OP *o)
1114 do_op_dump(0, Perl_debug_log, o);
1118 Perl_gv_dump(pTHX_ GV *gv)
1123 PerlIO_printf(Perl_debug_log, "{}\n");
1126 sv = sv_newmortal();
1127 PerlIO_printf(Perl_debug_log, "{\n");
1128 gv_fullname3(sv, gv, NULL);
1129 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1130 if (gv != GvEGV(gv)) {
1131 gv_efullname3(sv, GvEGV(gv), NULL);
1132 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1134 PerlIO_putc(Perl_debug_log, '\n');
1135 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1139 /* map magic types to the symbolic names
1140 * (with the PERL_MAGIC_ prefixed stripped)
1143 static const struct { const char type; const char *name; } magic_names[] = {
1144 { PERL_MAGIC_sv, "sv(\\0)" },
1145 { PERL_MAGIC_arylen, "arylen(#)" },
1146 { PERL_MAGIC_rhash, "rhash(%)" },
1147 { PERL_MAGIC_pos, "pos(.)" },
1148 { PERL_MAGIC_symtab, "symtab(:)" },
1149 { PERL_MAGIC_backref, "backref(<)" },
1150 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1151 { PERL_MAGIC_overload, "overload(A)" },
1152 { PERL_MAGIC_bm, "bm(B)" },
1153 { PERL_MAGIC_regdata, "regdata(D)" },
1154 { PERL_MAGIC_env, "env(E)" },
1155 { PERL_MAGIC_hints, "hints(H)" },
1156 { PERL_MAGIC_isa, "isa(I)" },
1157 { PERL_MAGIC_dbfile, "dbfile(L)" },
1158 { PERL_MAGIC_shared, "shared(N)" },
1159 { PERL_MAGIC_tied, "tied(P)" },
1160 { PERL_MAGIC_sig, "sig(S)" },
1161 { PERL_MAGIC_uvar, "uvar(U)" },
1162 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1163 { PERL_MAGIC_overload_table, "overload_table(c)" },
1164 { PERL_MAGIC_regdatum, "regdatum(d)" },
1165 { PERL_MAGIC_envelem, "envelem(e)" },
1166 { PERL_MAGIC_fm, "fm(f)" },
1167 { PERL_MAGIC_regex_global, "regex_global(g)" },
1168 { PERL_MAGIC_hintselem, "hintselem(h)" },
1169 { PERL_MAGIC_isaelem, "isaelem(i)" },
1170 { PERL_MAGIC_nkeys, "nkeys(k)" },
1171 { PERL_MAGIC_dbline, "dbline(l)" },
1172 { PERL_MAGIC_mutex, "mutex(m)" },
1173 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1174 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1175 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1176 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1177 { PERL_MAGIC_qr, "qr(r)" },
1178 { PERL_MAGIC_sigelem, "sigelem(s)" },
1179 { PERL_MAGIC_taint, "taint(t)" },
1180 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1181 { PERL_MAGIC_vec, "vec(v)" },
1182 { PERL_MAGIC_vstring, "vstring(V)" },
1183 { PERL_MAGIC_utf8, "utf8(w)" },
1184 { PERL_MAGIC_substr, "substr(x)" },
1185 { PERL_MAGIC_defelem, "defelem(y)" },
1186 { PERL_MAGIC_ext, "ext(~)" },
1187 /* this null string terminates the list */
1192 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1194 for (; mg; mg = mg->mg_moremagic) {
1195 Perl_dump_indent(aTHX_ level, file,
1196 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1197 if (mg->mg_virtual) {
1198 const MGVTBL * const v = mg->mg_virtual;
1200 if (v == &PL_vtbl_sv) s = "sv";
1201 else if (v == &PL_vtbl_env) s = "env";
1202 else if (v == &PL_vtbl_envelem) s = "envelem";
1203 else if (v == &PL_vtbl_sig) s = "sig";
1204 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1205 else if (v == &PL_vtbl_pack) s = "pack";
1206 else if (v == &PL_vtbl_packelem) s = "packelem";
1207 else if (v == &PL_vtbl_dbline) s = "dbline";
1208 else if (v == &PL_vtbl_isa) s = "isa";
1209 else if (v == &PL_vtbl_arylen) s = "arylen";
1210 else if (v == &PL_vtbl_mglob) s = "mglob";
1211 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1212 else if (v == &PL_vtbl_taint) s = "taint";
1213 else if (v == &PL_vtbl_substr) s = "substr";
1214 else if (v == &PL_vtbl_vec) s = "vec";
1215 else if (v == &PL_vtbl_pos) s = "pos";
1216 else if (v == &PL_vtbl_bm) s = "bm";
1217 else if (v == &PL_vtbl_fm) s = "fm";
1218 else if (v == &PL_vtbl_uvar) s = "uvar";
1219 else if (v == &PL_vtbl_defelem) s = "defelem";
1220 #ifdef USE_LOCALE_COLLATE
1221 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1223 else if (v == &PL_vtbl_amagic) s = "amagic";
1224 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1225 else if (v == &PL_vtbl_backref) s = "backref";
1226 else if (v == &PL_vtbl_utf8) s = "utf8";
1227 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1228 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1231 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1233 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1236 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1239 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1243 const char *name = NULL;
1244 for (n = 0; magic_names[n].name; n++) {
1245 if (mg->mg_type == magic_names[n].type) {
1246 name = magic_names[n].name;
1251 Perl_dump_indent(aTHX_ level, file,
1252 " MG_TYPE = PERL_MAGIC_%s\n", name);
1254 Perl_dump_indent(aTHX_ level, file,
1255 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1259 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1260 if (mg->mg_type == PERL_MAGIC_envelem &&
1261 mg->mg_flags & MGf_TAINTEDDIR)
1262 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1263 if (mg->mg_flags & MGf_REFCOUNTED)
1264 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1265 if (mg->mg_flags & MGf_GSKIP)
1266 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1267 if (mg->mg_type == PERL_MAGIC_regex_global &&
1268 mg->mg_flags & MGf_MINMATCH)
1269 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1272 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1273 PTR2UV(mg->mg_obj));
1274 if (mg->mg_type == PERL_MAGIC_qr) {
1275 regexp *re=(regexp *)mg->mg_obj;
1276 SV *dsv= sv_newmortal();
1277 const char * const s = pv_pretty(dsv, re->wrapped, re->wraplen,
1279 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELIPSES |
1280 ((re->extflags & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0))
1282 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1283 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1286 if (mg->mg_flags & MGf_REFCOUNTED)
1287 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1290 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1292 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1293 if (mg->mg_len >= 0) {
1294 if (mg->mg_type != PERL_MAGIC_utf8) {
1295 SV *sv = newSVpvs("");
1296 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1300 else if (mg->mg_len == HEf_SVKEY) {
1301 PerlIO_puts(file, " => HEf_SVKEY\n");
1302 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1306 PerlIO_puts(file, " ???? - please notify IZ");
1307 PerlIO_putc(file, '\n');
1309 if (mg->mg_type == PERL_MAGIC_utf8) {
1310 STRLEN *cache = (STRLEN *) mg->mg_ptr;
1313 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1314 Perl_dump_indent(aTHX_ level, file,
1315 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1318 (UV)cache[i * 2 + 1]);
1325 Perl_magic_dump(pTHX_ const MAGIC *mg)
1327 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1331 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1334 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1335 if (sv && (hvname = HvNAME_get(sv)))
1336 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1338 PerlIO_putc(file, '\n');
1342 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1344 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1345 if (sv && GvNAME(sv))
1346 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1348 PerlIO_putc(file, '\n');
1352 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1354 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1355 if (sv && GvNAME(sv)) {
1357 PerlIO_printf(file, "\t\"");
1358 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1359 PerlIO_printf(file, "%s\" :: \"", hvname);
1360 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1363 PerlIO_putc(file, '\n');
1367 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1376 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1380 flags = SvFLAGS(sv);
1383 d = Perl_newSVpvf(aTHX_
1384 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1385 PTR2UV(SvANY(sv)), PTR2UV(sv),
1386 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1387 (int)(PL_dumpindent*level), "");
1389 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1390 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1392 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1393 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1394 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1396 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1397 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1398 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1399 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1400 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1402 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1403 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1404 if (flags & SVf_POK) sv_catpv(d, "POK,");
1405 if (flags & SVf_ROK) {
1406 sv_catpv(d, "ROK,");
1407 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1409 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1410 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1411 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1412 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1414 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1415 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1416 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1417 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1418 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1419 if (SvPCS_IMPORTED(sv))
1420 sv_catpv(d, "PCS_IMPORTED,");
1422 sv_catpv(d, "SCREAM,");
1428 if (CvANON(sv)) sv_catpv(d, "ANON,");
1429 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1430 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1431 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1432 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1433 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1434 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1435 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1436 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1437 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1438 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1439 if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
1442 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1443 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1444 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1445 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1446 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1450 if (isGV_with_GP(sv)) {
1451 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1452 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1453 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1454 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1455 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1457 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1458 sv_catpv(d, "IMPORT");
1459 if (GvIMPORTED(sv) == GVf_IMPORTED)
1460 sv_catpv(d, "ALL,");
1463 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1464 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1465 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1466 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1470 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1471 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1475 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1476 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1479 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1480 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1483 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1488 /* SVphv_SHAREKEYS is also 0x20000000 */
1489 if ((type != SVt_PVHV) && SvUTF8(sv))
1490 sv_catpv(d, "UTF8");
1492 if (*(SvEND(d) - 1) == ',') {
1493 SvCUR_set(d, SvCUR(d) - 1);
1494 SvPVX(d)[SvCUR(d)] = '\0';
1499 #ifdef DEBUG_LEAKING_SCALARS
1500 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1501 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1503 sv->sv_debug_inpad ? "for" : "by",
1504 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1505 sv->sv_debug_cloned ? " (cloned)" : "");
1507 Perl_dump_indent(aTHX_ level, file, "SV = ");
1508 if (type < SVt_LAST) {
1509 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1511 if (type == SVt_NULL) {
1516 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1520 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1521 && type != SVt_PVCV && !isGV_with_GP(sv))
1522 || type == SVt_IV) {
1524 #ifdef PERL_OLD_COPY_ON_WRITE
1528 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1530 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1532 PerlIO_printf(file, " (OFFSET)");
1533 #ifdef PERL_OLD_COPY_ON_WRITE
1534 if (SvIsCOW_shared_hash(sv))
1535 PerlIO_printf(file, " (HASH)");
1536 else if (SvIsCOW_normal(sv))
1537 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1539 PerlIO_putc(file, '\n');
1541 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1542 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1543 (UV) COP_SEQ_RANGE_LOW(sv));
1544 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1545 (UV) COP_SEQ_RANGE_HIGH(sv));
1546 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1547 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)
1549 || type == SVt_NV) {
1550 STORE_NUMERIC_LOCAL_SET_STANDARD();
1551 /* %Vg doesn't work? --jhi */
1552 #ifdef USE_LONG_DOUBLE
1553 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1555 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1557 RESTORE_NUMERIC_LOCAL();
1560 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1562 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1564 if (type < SVt_PV) {
1568 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1569 if (SvPVX_const(sv)) {
1570 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1572 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1573 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1574 if (SvUTF8(sv)) /* the 8? \x{....} */
1575 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1576 PerlIO_printf(file, "\n");
1577 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1578 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1581 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1583 if (type >= SVt_PVMG) {
1584 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1585 HV *ost = SvOURSTASH(sv);
1587 do_hv_dump(level, file, " OURSTASH", ost);
1590 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1593 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1597 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1598 if (AvARRAY(sv) != AvALLOC(sv)) {
1599 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1600 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1603 PerlIO_putc(file, '\n');
1604 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1605 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1606 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1607 sv_setpvn(d, "", 0);
1608 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1609 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1610 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1611 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1612 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1614 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1615 SV** elt = av_fetch((AV*)sv,count,0);
1617 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1619 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1624 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1625 if (HvARRAY(sv) && HvKEYS(sv)) {
1626 /* Show distribution of HEs in the ARRAY */
1628 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1631 U32 pow2 = 2, keys = HvKEYS(sv);
1632 NV theoret, sum = 0;
1634 PerlIO_printf(file, " (");
1635 Zero(freq, FREQ_MAX + 1, int);
1636 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1639 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1641 if (count > FREQ_MAX)
1647 for (i = 0; i <= max; i++) {
1649 PerlIO_printf(file, "%d%s:%d", i,
1650 (i == FREQ_MAX) ? "+" : "",
1653 PerlIO_printf(file, ", ");
1656 PerlIO_putc(file, ')');
1657 /* The "quality" of a hash is defined as the total number of
1658 comparisons needed to access every element once, relative
1659 to the expected number needed for a random hash.
1661 The total number of comparisons is equal to the sum of
1662 the squares of the number of entries in each bucket.
1663 For a random hash of n keys into k buckets, the expected
1668 for (i = max; i > 0; i--) { /* Precision: count down. */
1669 sum += freq[i] * i * i;
1671 while ((keys = keys >> 1))
1673 theoret = HvKEYS(sv);
1674 theoret += theoret * (theoret-1)/pow2;
1675 PerlIO_putc(file, '\n');
1676 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1678 PerlIO_putc(file, '\n');
1679 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1680 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1681 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1682 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1683 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1685 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1686 if (mg && mg->mg_obj) {
1687 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1691 const char * const hvname = HvNAME_get(sv);
1693 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1696 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1698 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1700 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1704 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1706 HV * const hv = (HV*)sv;
1707 int count = maxnest - nest;
1710 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1715 const U32 hash = HeHASH(he);
1717 keysv = hv_iterkeysv(he);
1718 keypv = SvPV_const(keysv, len);
1719 elt = hv_iterval(hv, he);
1720 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1722 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1724 PerlIO_printf(file, "[REHASH] ");
1725 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1726 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1728 hv_iterinit(hv); /* Return to status quo */
1734 const char *const proto = SvPV_const(sv, len);
1735 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1740 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1741 if (!CvISXSUB(sv)) {
1743 Perl_dump_indent(aTHX_ level, file,
1744 " START = 0x%"UVxf" ===> %"IVdf"\n",
1745 PTR2UV(CvSTART(sv)),
1746 (IV)sequence_num(CvSTART(sv)));
1748 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1749 PTR2UV(CvROOT(sv)));
1750 if (CvROOT(sv) && dumpops) {
1751 do_op_dump(level+1, file, CvROOT(sv));
1754 SV *constant = cv_const_sv((CV *)sv);
1756 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1759 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1761 PTR2UV(CvXSUBANY(sv).any_ptr));
1762 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1765 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1766 (IV)CvXSUBANY(sv).any_i32);
1769 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1770 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1771 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1772 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1773 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1774 if (type == SVt_PVFM)
1775 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1776 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1777 if (nest < maxnest) {
1778 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1781 const CV * const outside = CvOUTSIDE(sv);
1782 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1785 : CvANON(outside) ? "ANON"
1786 : (outside == PL_main_cv) ? "MAIN"
1787 : CvUNIQUE(outside) ? "UNIQUE"
1788 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1790 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1791 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1795 if (type == SVt_PVLV) {
1796 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1797 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1798 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1799 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1800 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1801 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1805 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1806 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1807 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1808 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1810 if (!isGV_with_GP(sv))
1812 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1813 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1814 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1815 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1818 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1819 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1820 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1821 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1822 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1823 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1824 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1825 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1826 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1827 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1828 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1829 do_gv_dump (level, file, " EGV", GvEGV(sv));
1832 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1833 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1834 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1835 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1836 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1837 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1838 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1840 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1841 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1842 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1844 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1845 PTR2UV(IoTOP_GV(sv)));
1846 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1849 /* Source filters hide things that are not GVs in these three, so let's
1850 be careful out there. */
1852 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1853 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1854 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1856 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1857 PTR2UV(IoFMT_GV(sv)));
1858 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1861 if (IoBOTTOM_NAME(sv))
1862 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1863 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1864 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1866 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1867 PTR2UV(IoBOTTOM_GV(sv)));
1868 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1871 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1872 if (isPRINT(IoTYPE(sv)))
1873 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1875 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1876 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1883 Perl_sv_dump(pTHX_ SV *sv)
1886 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1890 Perl_runops_debug(pTHX)
1894 if (ckWARN_d(WARN_DEBUGGING))
1895 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1899 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1903 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1904 PerlIO_printf(Perl_debug_log,
1905 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1906 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1907 PTR2UV(*PL_watchaddr));
1908 if (DEBUG_s_TEST_) {
1909 if (DEBUG_v_TEST_) {
1910 PerlIO_printf(Perl_debug_log, "\n");
1918 if (DEBUG_t_TEST_) debop(PL_op);
1919 if (DEBUG_P_TEST_) debprof(PL_op);
1921 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1922 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1929 Perl_debop(pTHX_ const OP *o)
1932 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1935 Perl_deb(aTHX_ "%s", OP_NAME(o));
1936 switch (o->op_type) {
1938 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1943 SV * const sv = newSV(0);
1945 /* FIXME - is this making unwarranted assumptions about the
1946 UTF-8 cleanliness of the dump file handle? */
1949 gv_fullname3(sv, cGVOPo_gv, NULL);
1950 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1954 PerlIO_printf(Perl_debug_log, "(NULL)");
1960 /* print the lexical's name */
1961 CV * const cv = deb_curcv(cxstack_ix);
1964 AV * const padlist = CvPADLIST(cv);
1965 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1966 sv = *av_fetch(comppad, o->op_targ, FALSE);
1970 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1972 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1978 PerlIO_printf(Perl_debug_log, "\n");
1983 S_deb_curcv(pTHX_ I32 ix)
1986 const PERL_CONTEXT * const cx = &cxstack[ix];
1987 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1988 return cx->blk_sub.cv;
1989 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1991 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1996 return deb_curcv(ix - 1);
2000 Perl_watch(pTHX_ char **addr)
2003 PL_watchaddr = addr;
2005 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2006 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2010 S_debprof(pTHX_ const OP *o)
2013 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2015 if (!PL_profiledata)
2016 Newxz(PL_profiledata, MAXO, U32);
2017 ++PL_profiledata[o->op_type];
2021 Perl_debprofdump(pTHX)
2025 if (!PL_profiledata)
2027 for (i = 0; i < MAXO; i++) {
2028 if (PL_profiledata[i])
2029 PerlIO_printf(Perl_debug_log,
2030 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2037 * XML variants of most of the above routines
2042 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2045 PerlIO_printf(file, "\n ");
2046 va_start(args, pat);
2047 xmldump_vindent(level, file, pat, &args);
2053 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2056 va_start(args, pat);
2057 xmldump_vindent(level, file, pat, &args);
2062 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2064 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2065 PerlIO_vprintf(file, pat, *args);
2069 Perl_xmldump_all(pTHX)
2071 PerlIO_setlinebuf(PL_xmlfp);
2073 op_xmldump(PL_main_root);
2074 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2075 PerlIO_close(PL_xmlfp);
2080 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2085 if (!HvARRAY(stash))
2087 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2088 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2089 GV *gv = (GV*)HeVAL(entry);
2091 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2097 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2098 && (hv = GvHV(gv)) && hv != PL_defstash)
2099 xmldump_packsubs(hv); /* nested package */
2105 Perl_xmldump_sub(pTHX_ const GV *gv)
2107 SV *sv = sv_newmortal();
2109 gv_fullname3(sv, gv, Nullch);
2110 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2111 if (CvXSUB(GvCV(gv)))
2112 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2113 PTR2UV(CvXSUB(GvCV(gv))),
2114 (int)CvXSUBANY(GvCV(gv)).any_i32);
2115 else if (CvROOT(GvCV(gv)))
2116 op_xmldump(CvROOT(GvCV(gv)));
2118 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2122 Perl_xmldump_form(pTHX_ const GV *gv)
2124 SV *sv = sv_newmortal();
2126 gv_fullname3(sv, gv, Nullch);
2127 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2128 if (CvROOT(GvFORM(gv)))
2129 op_xmldump(CvROOT(GvFORM(gv)));
2131 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2135 Perl_xmldump_eval(pTHX)
2137 op_xmldump(PL_eval_root);
2141 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2143 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2147 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2155 sv_catpvn(dsv,"",0);
2156 dsvcur = SvCUR(dsv); /* in case we have to restart */
2161 c = utf8_to_uvchr((U8*)pv, &cl);
2163 SvCUR(dsv) = dsvcur;
2228 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2231 Perl_sv_catpvf(aTHX_ dsv, "<");
2234 Perl_sv_catpvf(aTHX_ dsv, ">");
2237 Perl_sv_catpvf(aTHX_ dsv, "&");
2240 Perl_sv_catpvf(aTHX_ dsv, """);
2244 if (c < 32 || c > 127) {
2245 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2248 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2252 if ((c >= 0xD800 && c <= 0xDB7F) ||
2253 (c >= 0xDC00 && c <= 0xDFFF) ||
2254 (c >= 0xFFF0 && c <= 0xFFFF) ||
2256 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2258 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2271 Perl_sv_xmlpeek(pTHX_ SV *sv)
2273 SV *t = sv_newmortal();
2278 sv_setpvn(t, "", 0);
2281 sv_catpv(t, "VOID=\"\"");
2284 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2285 sv_catpv(t, "WILD=\"\"");
2288 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2289 if (sv == &PL_sv_undef) {
2290 sv_catpv(t, "SV_UNDEF=\"1\"");
2291 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2292 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2296 else if (sv == &PL_sv_no) {
2297 sv_catpv(t, "SV_NO=\"1\"");
2298 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2299 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2300 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2301 SVp_POK|SVp_NOK)) &&
2306 else if (sv == &PL_sv_yes) {
2307 sv_catpv(t, "SV_YES=\"1\"");
2308 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2309 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2310 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2311 SVp_POK|SVp_NOK)) &&
2313 SvPVX(sv) && *SvPVX(sv) == '1' &&
2318 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2319 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2320 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2324 sv_catpv(t, " XXX=\"\" ");
2326 else if (SvREFCNT(sv) == 0) {
2327 sv_catpv(t, " refcnt=\"0\"");
2330 else if (DEBUG_R_TEST_) {
2333 /* is this SV on the tmps stack? */
2334 for (ix=PL_tmps_ix; ix>=0; ix--) {
2335 if (PL_tmps_stack[ix] == sv) {
2340 if (SvREFCNT(sv) > 1)
2341 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2344 sv_catpv(t, " DRT=\"<T>\"");
2348 sv_catpv(t, " ROK=\"\"");
2350 switch (SvTYPE(sv)) {
2352 sv_catpv(t, " FREED=\"1\"");
2356 sv_catpv(t, " UNDEF=\"1\"");
2359 sv_catpv(t, " IV=\"");
2362 sv_catpv(t, " NV=\"");
2365 sv_catpv(t, " RV=\"");
2368 sv_catpv(t, " PV=\"");
2371 sv_catpv(t, " PVIV=\"");
2374 sv_catpv(t, " PVNV=\"");
2377 sv_catpv(t, " PVMG=\"");
2380 sv_catpv(t, " PVLV=\"");
2383 sv_catpv(t, " AV=\"");
2386 sv_catpv(t, " HV=\"");
2390 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2392 sv_catpv(t, " CV=\"()\"");
2395 sv_catpv(t, " GV=\"");
2398 sv_catpv(t, " BIND=\"");
2401 sv_catpv(t, " FM=\"");
2404 sv_catpv(t, " IO=\"");
2413 else if (SvNOKp(sv)) {
2414 STORE_NUMERIC_LOCAL_SET_STANDARD();
2415 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2416 RESTORE_NUMERIC_LOCAL();
2418 else if (SvIOKp(sv)) {
2420 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2422 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2433 return SvPV(t, n_a);
2437 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2440 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2443 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2446 char *s = PM_GETRE(pm)->precomp;
2447 SV *tmpsv = newSVpvn("",0);
2449 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2450 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2452 SvREFCNT_dec(tmpsv);
2453 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2454 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2457 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2458 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2459 SV * const tmpsv = pm_description(pm);
2460 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2461 SvREFCNT_dec(tmpsv);
2465 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
2466 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2467 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2468 do_op_xmldump(level+2, file, pm->op_pmreplroot);
2469 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2470 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2473 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2477 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2479 do_pmop_xmldump(0, PL_xmlfp, pm);
2483 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2490 seq = sequence_num(o);
2491 Perl_xmldump_indent(aTHX_ level, file,
2492 "<op_%s seq=\"%"UVuf" -> ",
2497 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2498 sequence_num(o->op_next));
2500 PerlIO_printf(file, "DONE\"");
2503 if (o->op_type == OP_NULL)
2505 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2506 if (o->op_targ == OP_NEXTSTATE)
2509 PerlIO_printf(file, " line=\"%"UVuf"\"",
2510 (UV)CopLINE(cCOPo));
2511 if (CopSTASHPV(cCOPo))
2512 PerlIO_printf(file, " package=\"%s\"",
2514 if (cCOPo->cop_label)
2515 PerlIO_printf(file, " label=\"%s\"",
2520 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2523 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2526 SV *tmpsv = newSVpvn("", 0);
2527 switch (o->op_flags & OPf_WANT) {
2529 sv_catpv(tmpsv, ",VOID");
2531 case OPf_WANT_SCALAR:
2532 sv_catpv(tmpsv, ",SCALAR");
2535 sv_catpv(tmpsv, ",LIST");
2538 sv_catpv(tmpsv, ",UNKNOWN");
2541 if (o->op_flags & OPf_KIDS)
2542 sv_catpv(tmpsv, ",KIDS");
2543 if (o->op_flags & OPf_PARENS)
2544 sv_catpv(tmpsv, ",PARENS");
2545 if (o->op_flags & OPf_STACKED)
2546 sv_catpv(tmpsv, ",STACKED");
2547 if (o->op_flags & OPf_REF)
2548 sv_catpv(tmpsv, ",REF");
2549 if (o->op_flags & OPf_MOD)
2550 sv_catpv(tmpsv, ",MOD");
2551 if (o->op_flags & OPf_SPECIAL)
2552 sv_catpv(tmpsv, ",SPECIAL");
2553 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2554 SvREFCNT_dec(tmpsv);
2556 if (o->op_private) {
2557 SV *tmpsv = newSVpvn("", 0);
2558 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2559 if (o->op_private & OPpTARGET_MY)
2560 sv_catpv(tmpsv, ",TARGET_MY");
2562 else if (o->op_type == OP_LEAVESUB ||
2563 o->op_type == OP_LEAVE ||
2564 o->op_type == OP_LEAVESUBLV ||
2565 o->op_type == OP_LEAVEWRITE) {
2566 if (o->op_private & OPpREFCOUNTED)
2567 sv_catpv(tmpsv, ",REFCOUNTED");
2569 else if (o->op_type == OP_AASSIGN) {
2570 if (o->op_private & OPpASSIGN_COMMON)
2571 sv_catpv(tmpsv, ",COMMON");
2573 else if (o->op_type == OP_SASSIGN) {
2574 if (o->op_private & OPpASSIGN_BACKWARDS)
2575 sv_catpv(tmpsv, ",BACKWARDS");
2577 else if (o->op_type == OP_TRANS) {
2578 if (o->op_private & OPpTRANS_SQUASH)
2579 sv_catpv(tmpsv, ",SQUASH");
2580 if (o->op_private & OPpTRANS_DELETE)
2581 sv_catpv(tmpsv, ",DELETE");
2582 if (o->op_private & OPpTRANS_COMPLEMENT)
2583 sv_catpv(tmpsv, ",COMPLEMENT");
2584 if (o->op_private & OPpTRANS_IDENTICAL)
2585 sv_catpv(tmpsv, ",IDENTICAL");
2586 if (o->op_private & OPpTRANS_GROWS)
2587 sv_catpv(tmpsv, ",GROWS");
2589 else if (o->op_type == OP_REPEAT) {
2590 if (o->op_private & OPpREPEAT_DOLIST)
2591 sv_catpv(tmpsv, ",DOLIST");
2593 else if (o->op_type == OP_ENTERSUB ||
2594 o->op_type == OP_RV2SV ||
2595 o->op_type == OP_GVSV ||
2596 o->op_type == OP_RV2AV ||
2597 o->op_type == OP_RV2HV ||
2598 o->op_type == OP_RV2GV ||
2599 o->op_type == OP_AELEM ||
2600 o->op_type == OP_HELEM )
2602 if (o->op_type == OP_ENTERSUB) {
2603 if (o->op_private & OPpENTERSUB_AMPER)
2604 sv_catpv(tmpsv, ",AMPER");
2605 if (o->op_private & OPpENTERSUB_DB)
2606 sv_catpv(tmpsv, ",DB");
2607 if (o->op_private & OPpENTERSUB_HASTARG)
2608 sv_catpv(tmpsv, ",HASTARG");
2609 if (o->op_private & OPpENTERSUB_NOPAREN)
2610 sv_catpv(tmpsv, ",NOPAREN");
2611 if (o->op_private & OPpENTERSUB_INARGS)
2612 sv_catpv(tmpsv, ",INARGS");
2613 if (o->op_private & OPpENTERSUB_NOMOD)
2614 sv_catpv(tmpsv, ",NOMOD");
2617 switch (o->op_private & OPpDEREF) {
2619 sv_catpv(tmpsv, ",SV");
2622 sv_catpv(tmpsv, ",AV");
2625 sv_catpv(tmpsv, ",HV");
2628 if (o->op_private & OPpMAYBE_LVSUB)
2629 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2631 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2632 if (o->op_private & OPpLVAL_DEFER)
2633 sv_catpv(tmpsv, ",LVAL_DEFER");
2636 if (o->op_private & HINT_STRICT_REFS)
2637 sv_catpv(tmpsv, ",STRICT_REFS");
2638 if (o->op_private & OPpOUR_INTRO)
2639 sv_catpv(tmpsv, ",OUR_INTRO");
2642 else if (o->op_type == OP_CONST) {
2643 if (o->op_private & OPpCONST_BARE)
2644 sv_catpv(tmpsv, ",BARE");
2645 if (o->op_private & OPpCONST_STRICT)
2646 sv_catpv(tmpsv, ",STRICT");
2647 if (o->op_private & OPpCONST_ARYBASE)
2648 sv_catpv(tmpsv, ",ARYBASE");
2649 if (o->op_private & OPpCONST_WARNING)
2650 sv_catpv(tmpsv, ",WARNING");
2651 if (o->op_private & OPpCONST_ENTERED)
2652 sv_catpv(tmpsv, ",ENTERED");
2654 else if (o->op_type == OP_FLIP) {
2655 if (o->op_private & OPpFLIP_LINENUM)
2656 sv_catpv(tmpsv, ",LINENUM");
2658 else if (o->op_type == OP_FLOP) {
2659 if (o->op_private & OPpFLIP_LINENUM)
2660 sv_catpv(tmpsv, ",LINENUM");
2662 else if (o->op_type == OP_RV2CV) {
2663 if (o->op_private & OPpLVAL_INTRO)
2664 sv_catpv(tmpsv, ",INTRO");
2666 else if (o->op_type == OP_GV) {
2667 if (o->op_private & OPpEARLY_CV)
2668 sv_catpv(tmpsv, ",EARLY_CV");
2670 else if (o->op_type == OP_LIST) {
2671 if (o->op_private & OPpLIST_GUESSED)
2672 sv_catpv(tmpsv, ",GUESSED");
2674 else if (o->op_type == OP_DELETE) {
2675 if (o->op_private & OPpSLICE)
2676 sv_catpv(tmpsv, ",SLICE");
2678 else if (o->op_type == OP_EXISTS) {
2679 if (o->op_private & OPpEXISTS_SUB)
2680 sv_catpv(tmpsv, ",EXISTS_SUB");
2682 else if (o->op_type == OP_SORT) {
2683 if (o->op_private & OPpSORT_NUMERIC)
2684 sv_catpv(tmpsv, ",NUMERIC");
2685 if (o->op_private & OPpSORT_INTEGER)
2686 sv_catpv(tmpsv, ",INTEGER");
2687 if (o->op_private & OPpSORT_REVERSE)
2688 sv_catpv(tmpsv, ",REVERSE");
2690 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2691 if (o->op_private & OPpOPEN_IN_RAW)
2692 sv_catpv(tmpsv, ",IN_RAW");
2693 if (o->op_private & OPpOPEN_IN_CRLF)
2694 sv_catpv(tmpsv, ",IN_CRLF");
2695 if (o->op_private & OPpOPEN_OUT_RAW)
2696 sv_catpv(tmpsv, ",OUT_RAW");
2697 if (o->op_private & OPpOPEN_OUT_CRLF)
2698 sv_catpv(tmpsv, ",OUT_CRLF");
2700 else if (o->op_type == OP_EXIT) {
2701 if (o->op_private & OPpEXIT_VMSISH)
2702 sv_catpv(tmpsv, ",EXIT_VMSISH");
2703 if (o->op_private & OPpHUSH_VMSISH)
2704 sv_catpv(tmpsv, ",HUSH_VMSISH");
2706 else if (o->op_type == OP_DIE) {
2707 if (o->op_private & OPpHUSH_VMSISH)
2708 sv_catpv(tmpsv, ",HUSH_VMSISH");
2710 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2711 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2712 sv_catpv(tmpsv, ",FT_ACCESS");
2713 if (o->op_private & OPpFT_STACKED)
2714 sv_catpv(tmpsv, ",FT_STACKED");
2716 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2717 sv_catpv(tmpsv, ",INTRO");
2719 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2720 SvREFCNT_dec(tmpsv);
2723 switch (o->op_type) {
2725 if (o->op_flags & OPf_SPECIAL) {
2731 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2733 if (cSVOPo->op_sv) {
2734 SV *tmpsv1 = newSV(0);
2735 SV *tmpsv2 = newSVpvn("",0);
2743 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2744 s = SvPV(tmpsv1,len);
2745 sv_catxmlpvn(tmpsv2, s, len, 1);
2746 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2750 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2754 case OP_METHOD_NAMED:
2755 #ifndef USE_ITHREADS
2756 /* with ITHREADS, consts are stored in the pad, and the right pad
2757 * may not be active here, so skip */
2758 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2764 PerlIO_printf(file, ">\n");
2766 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2772 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2773 (UV)CopLINE(cCOPo));
2774 if (CopSTASHPV(cCOPo))
2775 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2777 if (cCOPo->cop_label)
2778 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2782 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2783 if (cLOOPo->op_redoop)
2784 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2786 PerlIO_printf(file, "DONE\"");
2787 S_xmldump_attr(aTHX_ level, file, "next=\"");
2788 if (cLOOPo->op_nextop)
2789 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2791 PerlIO_printf(file, "DONE\"");
2792 S_xmldump_attr(aTHX_ level, file, "last=\"");
2793 if (cLOOPo->op_lastop)
2794 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2796 PerlIO_printf(file, "DONE\"");
2804 S_xmldump_attr(aTHX_ level, file, "other=\"");
2805 if (cLOGOPo->op_other)
2806 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2808 PerlIO_printf(file, "DONE\"");
2816 if (o->op_private & OPpREFCOUNTED)
2817 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2823 if (PL_madskills && o->op_madprop) {
2824 SV *tmpsv = newSVpvn("", 0);
2825 MADPROP* mp = o->op_madprop;
2826 sv_utf8_upgrade(tmpsv);
2829 PerlIO_printf(file, ">\n");
2831 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2834 char tmp = mp->mad_key;
2835 sv_setpvn(tmpsv,"\"",1);
2837 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2838 sv_catpv(tmpsv, "\"");
2839 switch (mp->mad_type) {
2841 sv_catpv(tmpsv, "NULL");
2842 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2845 sv_catpv(tmpsv, " val=\"");
2846 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2847 sv_catpv(tmpsv, "\"");
2848 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2851 sv_catpv(tmpsv, " val=\"");
2852 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2853 sv_catpv(tmpsv, "\"");
2854 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2857 if ((OP*)mp->mad_val) {
2858 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2859 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2860 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2864 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2870 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2872 SvREFCNT_dec(tmpsv);
2875 switch (o->op_type) {
2882 PerlIO_printf(file, ">\n");
2884 do_pmop_xmldump(level, file, cPMOPo);
2890 if (o->op_flags & OPf_KIDS) {
2894 PerlIO_printf(file, ">\n");
2896 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2897 do_op_xmldump(level, file, kid);
2901 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2903 PerlIO_printf(file, " />\n");
2907 Perl_op_xmldump(pTHX_ const OP *o)
2909 do_op_xmldump(0, PL_xmlfp, o);
2915 * c-indentation-style: bsd
2917 * indent-tabs-mode: t
2920 * ex: set ts=8 sts=4 sw=4 noet: