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_pmreplrootu.op_pmreplroot) {
542 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
543 op_dump(pm->op_pmreplrootu.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");
572 if (regex->extflags & RXf_TAINTED)
573 sv_catpv(desc, ",TAINTED");
574 if (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");
584 if (pmflags & PMf_CONST)
585 sv_catpv(desc, ",CONST");
586 if (pmflags & PMf_KEEP)
587 sv_catpv(desc, ",KEEP");
588 if (pmflags & PMf_GLOBAL)
589 sv_catpv(desc, ",GLOBAL");
590 if (pmflags & PMf_CONTINUE)
591 sv_catpv(desc, ",CONTINUE");
592 if (pmflags & PMf_RETAINT)
593 sv_catpv(desc, ",RETAINT");
594 if (pmflags & PMf_EVAL)
595 sv_catpv(desc, ",EVAL");
600 Perl_pmop_dump(pTHX_ PMOP *pm)
602 do_pmop_dump(0, Perl_debug_log, pm);
605 /* An op sequencer. We visit the ops in the order they're to execute. */
608 S_sequence(pTHX_ register const OP *o)
611 const OP *oldop = NULL;
624 for (; o; o = o->op_next) {
626 SV * const op = newSVuv(PTR2UV(o));
627 const char * const key = SvPV_const(op, len);
629 if (hv_exists(Sequence, key, len))
632 switch (o->op_type) {
634 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
635 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
644 if (oldop && o->op_next)
651 if (oldop && o->op_next)
653 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
666 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
667 sequence_tail(cLOGOPo->op_other);
672 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
673 sequence_tail(cLOOPo->op_redoop);
674 sequence_tail(cLOOPo->op_nextop);
675 sequence_tail(cLOOPo->op_lastop);
679 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
680 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
689 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
697 S_sequence_tail(pTHX_ const OP *o)
699 while (o && (o->op_type == OP_NULL))
705 S_sequence_num(pTHX_ const OP *o)
713 op = newSVuv(PTR2UV(o));
714 key = SvPV_const(op, len);
715 seq = hv_fetch(Sequence, key, len, 0);
716 return seq ? SvUV(*seq): 0;
720 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
724 const OPCODE optype = o->op_type;
727 Perl_dump_indent(aTHX_ level, file, "{\n");
729 seq = sequence_num(o);
731 PerlIO_printf(file, "%-4"UVuf, seq);
733 PerlIO_printf(file, " ");
735 "%*sTYPE = %s ===> ",
736 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
738 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
739 sequence_num(o->op_next));
741 PerlIO_printf(file, "DONE\n");
743 if (optype == OP_NULL) {
744 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
745 if (o->op_targ == OP_NEXTSTATE) {
747 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
749 if (CopSTASHPV(cCOPo))
750 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
752 if (cCOPo->cop_label)
753 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
758 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
761 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
763 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
764 SV * const tmpsv = newSVpvs("");
765 switch (o->op_flags & OPf_WANT) {
767 sv_catpv(tmpsv, ",VOID");
769 case OPf_WANT_SCALAR:
770 sv_catpv(tmpsv, ",SCALAR");
773 sv_catpv(tmpsv, ",LIST");
776 sv_catpv(tmpsv, ",UNKNOWN");
779 if (o->op_flags & OPf_KIDS)
780 sv_catpv(tmpsv, ",KIDS");
781 if (o->op_flags & OPf_PARENS)
782 sv_catpv(tmpsv, ",PARENS");
783 if (o->op_flags & OPf_STACKED)
784 sv_catpv(tmpsv, ",STACKED");
785 if (o->op_flags & OPf_REF)
786 sv_catpv(tmpsv, ",REF");
787 if (o->op_flags & OPf_MOD)
788 sv_catpv(tmpsv, ",MOD");
789 if (o->op_flags & OPf_SPECIAL)
790 sv_catpv(tmpsv, ",SPECIAL");
792 sv_catpv(tmpsv, ",LATEFREE");
794 sv_catpv(tmpsv, ",LATEFREED");
796 sv_catpv(tmpsv, ",ATTACHED");
797 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
801 SV * const tmpsv = newSVpvs("");
802 if (PL_opargs[optype] & OA_TARGLEX) {
803 if (o->op_private & OPpTARGET_MY)
804 sv_catpv(tmpsv, ",TARGET_MY");
806 else if (optype == OP_LEAVESUB ||
807 optype == OP_LEAVE ||
808 optype == OP_LEAVESUBLV ||
809 optype == OP_LEAVEWRITE) {
810 if (o->op_private & OPpREFCOUNTED)
811 sv_catpv(tmpsv, ",REFCOUNTED");
813 else if (optype == OP_AASSIGN) {
814 if (o->op_private & OPpASSIGN_COMMON)
815 sv_catpv(tmpsv, ",COMMON");
817 else if (optype == OP_SASSIGN) {
818 if (o->op_private & OPpASSIGN_BACKWARDS)
819 sv_catpv(tmpsv, ",BACKWARDS");
821 else if (optype == OP_TRANS) {
822 if (o->op_private & OPpTRANS_SQUASH)
823 sv_catpv(tmpsv, ",SQUASH");
824 if (o->op_private & OPpTRANS_DELETE)
825 sv_catpv(tmpsv, ",DELETE");
826 if (o->op_private & OPpTRANS_COMPLEMENT)
827 sv_catpv(tmpsv, ",COMPLEMENT");
828 if (o->op_private & OPpTRANS_IDENTICAL)
829 sv_catpv(tmpsv, ",IDENTICAL");
830 if (o->op_private & OPpTRANS_GROWS)
831 sv_catpv(tmpsv, ",GROWS");
833 else if (optype == OP_REPEAT) {
834 if (o->op_private & OPpREPEAT_DOLIST)
835 sv_catpv(tmpsv, ",DOLIST");
837 else if (optype == OP_ENTERSUB ||
838 optype == OP_RV2SV ||
840 optype == OP_RV2AV ||
841 optype == OP_RV2HV ||
842 optype == OP_RV2GV ||
843 optype == OP_AELEM ||
846 if (optype == OP_ENTERSUB) {
847 if (o->op_private & OPpENTERSUB_AMPER)
848 sv_catpv(tmpsv, ",AMPER");
849 if (o->op_private & OPpENTERSUB_DB)
850 sv_catpv(tmpsv, ",DB");
851 if (o->op_private & OPpENTERSUB_HASTARG)
852 sv_catpv(tmpsv, ",HASTARG");
853 if (o->op_private & OPpENTERSUB_NOPAREN)
854 sv_catpv(tmpsv, ",NOPAREN");
855 if (o->op_private & OPpENTERSUB_INARGS)
856 sv_catpv(tmpsv, ",INARGS");
857 if (o->op_private & OPpENTERSUB_NOMOD)
858 sv_catpv(tmpsv, ",NOMOD");
861 switch (o->op_private & OPpDEREF) {
863 sv_catpv(tmpsv, ",SV");
866 sv_catpv(tmpsv, ",AV");
869 sv_catpv(tmpsv, ",HV");
872 if (o->op_private & OPpMAYBE_LVSUB)
873 sv_catpv(tmpsv, ",MAYBE_LVSUB");
875 if (optype == OP_AELEM || optype == OP_HELEM) {
876 if (o->op_private & OPpLVAL_DEFER)
877 sv_catpv(tmpsv, ",LVAL_DEFER");
880 if (o->op_private & HINT_STRICT_REFS)
881 sv_catpv(tmpsv, ",STRICT_REFS");
882 if (o->op_private & OPpOUR_INTRO)
883 sv_catpv(tmpsv, ",OUR_INTRO");
886 else if (optype == OP_CONST) {
887 if (o->op_private & OPpCONST_BARE)
888 sv_catpv(tmpsv, ",BARE");
889 if (o->op_private & OPpCONST_STRICT)
890 sv_catpv(tmpsv, ",STRICT");
891 if (o->op_private & OPpCONST_ARYBASE)
892 sv_catpv(tmpsv, ",ARYBASE");
893 if (o->op_private & OPpCONST_WARNING)
894 sv_catpv(tmpsv, ",WARNING");
895 if (o->op_private & OPpCONST_ENTERED)
896 sv_catpv(tmpsv, ",ENTERED");
898 else if (optype == OP_FLIP) {
899 if (o->op_private & OPpFLIP_LINENUM)
900 sv_catpv(tmpsv, ",LINENUM");
902 else if (optype == OP_FLOP) {
903 if (o->op_private & OPpFLIP_LINENUM)
904 sv_catpv(tmpsv, ",LINENUM");
906 else if (optype == OP_RV2CV) {
907 if (o->op_private & OPpLVAL_INTRO)
908 sv_catpv(tmpsv, ",INTRO");
910 else if (optype == OP_GV) {
911 if (o->op_private & OPpEARLY_CV)
912 sv_catpv(tmpsv, ",EARLY_CV");
914 else if (optype == OP_LIST) {
915 if (o->op_private & OPpLIST_GUESSED)
916 sv_catpv(tmpsv, ",GUESSED");
918 else if (optype == OP_DELETE) {
919 if (o->op_private & OPpSLICE)
920 sv_catpv(tmpsv, ",SLICE");
922 else if (optype == OP_EXISTS) {
923 if (o->op_private & OPpEXISTS_SUB)
924 sv_catpv(tmpsv, ",EXISTS_SUB");
926 else if (optype == OP_SORT) {
927 if (o->op_private & OPpSORT_NUMERIC)
928 sv_catpv(tmpsv, ",NUMERIC");
929 if (o->op_private & OPpSORT_INTEGER)
930 sv_catpv(tmpsv, ",INTEGER");
931 if (o->op_private & OPpSORT_REVERSE)
932 sv_catpv(tmpsv, ",REVERSE");
934 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
935 if (o->op_private & OPpOPEN_IN_RAW)
936 sv_catpv(tmpsv, ",IN_RAW");
937 if (o->op_private & OPpOPEN_IN_CRLF)
938 sv_catpv(tmpsv, ",IN_CRLF");
939 if (o->op_private & OPpOPEN_OUT_RAW)
940 sv_catpv(tmpsv, ",OUT_RAW");
941 if (o->op_private & OPpOPEN_OUT_CRLF)
942 sv_catpv(tmpsv, ",OUT_CRLF");
944 else if (optype == OP_EXIT) {
945 if (o->op_private & OPpEXIT_VMSISH)
946 sv_catpv(tmpsv, ",EXIT_VMSISH");
947 if (o->op_private & OPpHUSH_VMSISH)
948 sv_catpv(tmpsv, ",HUSH_VMSISH");
950 else if (optype == OP_DIE) {
951 if (o->op_private & OPpHUSH_VMSISH)
952 sv_catpv(tmpsv, ",HUSH_VMSISH");
954 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
955 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
956 sv_catpv(tmpsv, ",FT_ACCESS");
957 if (o->op_private & OPpFT_STACKED)
958 sv_catpv(tmpsv, ",FT_STACKED");
960 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
961 sv_catpv(tmpsv, ",INTRO");
963 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
968 if (PL_madskills && o->op_madprop) {
969 SV * const tmpsv = newSVpvn("", 0);
970 MADPROP* mp = o->op_madprop;
971 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
974 char tmp = mp->mad_key;
975 sv_setpvn(tmpsv,"'",1);
977 sv_catpvn(tmpsv, &tmp, 1);
978 sv_catpv(tmpsv, "'=");
979 switch (mp->mad_type) {
981 sv_catpv(tmpsv, "NULL");
982 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
985 sv_catpv(tmpsv, "<");
986 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
987 sv_catpv(tmpsv, ">");
988 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
991 if ((OP*)mp->mad_val) {
992 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
993 do_op_dump(level, file, (OP*)mp->mad_val);
997 sv_catpv(tmpsv, "(UNK)");
998 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1004 Perl_dump_indent(aTHX_ level, file, "}\n");
1006 SvREFCNT_dec(tmpsv);
1015 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1017 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1018 if (cSVOPo->op_sv) {
1019 SV * const tmpsv = newSV(0);
1023 /* FIXME - is this making unwarranted assumptions about the
1024 UTF-8 cleanliness of the dump file handle? */
1027 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1028 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1029 SvPV_nolen_const(tmpsv));
1033 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1038 case OP_METHOD_NAMED:
1039 #ifndef USE_ITHREADS
1040 /* with ITHREADS, consts are stored in the pad, and the right pad
1041 * may not be active here, so skip */
1042 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1049 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1050 (UV)CopLINE(cCOPo));
1051 if (CopSTASHPV(cCOPo))
1052 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1054 if (cCOPo->cop_label)
1055 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1059 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1060 if (cLOOPo->op_redoop)
1061 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1063 PerlIO_printf(file, "DONE\n");
1064 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1065 if (cLOOPo->op_nextop)
1066 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1068 PerlIO_printf(file, "DONE\n");
1069 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1070 if (cLOOPo->op_lastop)
1071 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1073 PerlIO_printf(file, "DONE\n");
1081 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1082 if (cLOGOPo->op_other)
1083 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1085 PerlIO_printf(file, "DONE\n");
1091 do_pmop_dump(level, file, cPMOPo);
1099 if (o->op_private & OPpREFCOUNTED)
1100 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1105 if (o->op_flags & OPf_KIDS) {
1107 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1108 do_op_dump(level, file, kid);
1110 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1114 Perl_op_dump(pTHX_ const OP *o)
1116 do_op_dump(0, Perl_debug_log, o);
1120 Perl_gv_dump(pTHX_ GV *gv)
1125 PerlIO_printf(Perl_debug_log, "{}\n");
1128 sv = sv_newmortal();
1129 PerlIO_printf(Perl_debug_log, "{\n");
1130 gv_fullname3(sv, gv, NULL);
1131 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1132 if (gv != GvEGV(gv)) {
1133 gv_efullname3(sv, GvEGV(gv), NULL);
1134 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1136 PerlIO_putc(Perl_debug_log, '\n');
1137 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1141 /* map magic types to the symbolic names
1142 * (with the PERL_MAGIC_ prefixed stripped)
1145 static const struct { const char type; const char *name; } magic_names[] = {
1146 { PERL_MAGIC_sv, "sv(\\0)" },
1147 { PERL_MAGIC_arylen, "arylen(#)" },
1148 { PERL_MAGIC_rhash, "rhash(%)" },
1149 { PERL_MAGIC_pos, "pos(.)" },
1150 { PERL_MAGIC_symtab, "symtab(:)" },
1151 { PERL_MAGIC_backref, "backref(<)" },
1152 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1153 { PERL_MAGIC_overload, "overload(A)" },
1154 { PERL_MAGIC_bm, "bm(B)" },
1155 { PERL_MAGIC_regdata, "regdata(D)" },
1156 { PERL_MAGIC_env, "env(E)" },
1157 { PERL_MAGIC_hints, "hints(H)" },
1158 { PERL_MAGIC_isa, "isa(I)" },
1159 { PERL_MAGIC_dbfile, "dbfile(L)" },
1160 { PERL_MAGIC_shared, "shared(N)" },
1161 { PERL_MAGIC_tied, "tied(P)" },
1162 { PERL_MAGIC_sig, "sig(S)" },
1163 { PERL_MAGIC_uvar, "uvar(U)" },
1164 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1165 { PERL_MAGIC_overload_table, "overload_table(c)" },
1166 { PERL_MAGIC_regdatum, "regdatum(d)" },
1167 { PERL_MAGIC_envelem, "envelem(e)" },
1168 { PERL_MAGIC_fm, "fm(f)" },
1169 { PERL_MAGIC_regex_global, "regex_global(g)" },
1170 { PERL_MAGIC_hintselem, "hintselem(h)" },
1171 { PERL_MAGIC_isaelem, "isaelem(i)" },
1172 { PERL_MAGIC_nkeys, "nkeys(k)" },
1173 { PERL_MAGIC_dbline, "dbline(l)" },
1174 { PERL_MAGIC_mutex, "mutex(m)" },
1175 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1176 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1177 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1178 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1179 { PERL_MAGIC_qr, "qr(r)" },
1180 { PERL_MAGIC_sigelem, "sigelem(s)" },
1181 { PERL_MAGIC_taint, "taint(t)" },
1182 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1183 { PERL_MAGIC_vec, "vec(v)" },
1184 { PERL_MAGIC_vstring, "vstring(V)" },
1185 { PERL_MAGIC_utf8, "utf8(w)" },
1186 { PERL_MAGIC_substr, "substr(x)" },
1187 { PERL_MAGIC_defelem, "defelem(y)" },
1188 { PERL_MAGIC_ext, "ext(~)" },
1189 /* this null string terminates the list */
1194 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1196 for (; mg; mg = mg->mg_moremagic) {
1197 Perl_dump_indent(aTHX_ level, file,
1198 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1199 if (mg->mg_virtual) {
1200 const MGVTBL * const v = mg->mg_virtual;
1202 if (v == &PL_vtbl_sv) s = "sv";
1203 else if (v == &PL_vtbl_env) s = "env";
1204 else if (v == &PL_vtbl_envelem) s = "envelem";
1205 else if (v == &PL_vtbl_sig) s = "sig";
1206 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1207 else if (v == &PL_vtbl_pack) s = "pack";
1208 else if (v == &PL_vtbl_packelem) s = "packelem";
1209 else if (v == &PL_vtbl_dbline) s = "dbline";
1210 else if (v == &PL_vtbl_isa) s = "isa";
1211 else if (v == &PL_vtbl_arylen) s = "arylen";
1212 else if (v == &PL_vtbl_mglob) s = "mglob";
1213 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1214 else if (v == &PL_vtbl_taint) s = "taint";
1215 else if (v == &PL_vtbl_substr) s = "substr";
1216 else if (v == &PL_vtbl_vec) s = "vec";
1217 else if (v == &PL_vtbl_pos) s = "pos";
1218 else if (v == &PL_vtbl_bm) s = "bm";
1219 else if (v == &PL_vtbl_fm) s = "fm";
1220 else if (v == &PL_vtbl_uvar) s = "uvar";
1221 else if (v == &PL_vtbl_defelem) s = "defelem";
1222 #ifdef USE_LOCALE_COLLATE
1223 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1225 else if (v == &PL_vtbl_amagic) s = "amagic";
1226 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1227 else if (v == &PL_vtbl_backref) s = "backref";
1228 else if (v == &PL_vtbl_utf8) s = "utf8";
1229 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1230 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1233 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1235 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1238 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1241 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1245 const char *name = NULL;
1246 for (n = 0; magic_names[n].name; n++) {
1247 if (mg->mg_type == magic_names[n].type) {
1248 name = magic_names[n].name;
1253 Perl_dump_indent(aTHX_ level, file,
1254 " MG_TYPE = PERL_MAGIC_%s\n", name);
1256 Perl_dump_indent(aTHX_ level, file,
1257 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1261 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1262 if (mg->mg_type == PERL_MAGIC_envelem &&
1263 mg->mg_flags & MGf_TAINTEDDIR)
1264 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1265 if (mg->mg_flags & MGf_REFCOUNTED)
1266 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1267 if (mg->mg_flags & MGf_GSKIP)
1268 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1269 if (mg->mg_type == PERL_MAGIC_regex_global &&
1270 mg->mg_flags & MGf_MINMATCH)
1271 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1274 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1275 PTR2UV(mg->mg_obj));
1276 if (mg->mg_type == PERL_MAGIC_qr) {
1277 regexp *re=(regexp *)mg->mg_obj;
1278 SV *dsv= sv_newmortal();
1279 const char * const s = pv_pretty(dsv, re->wrapped, re->wraplen,
1281 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELIPSES |
1282 ((re->extflags & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0))
1284 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1285 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1288 if (mg->mg_flags & MGf_REFCOUNTED)
1289 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1292 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1294 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1295 if (mg->mg_len >= 0) {
1296 if (mg->mg_type != PERL_MAGIC_utf8) {
1297 SV *sv = newSVpvs("");
1298 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1302 else if (mg->mg_len == HEf_SVKEY) {
1303 PerlIO_puts(file, " => HEf_SVKEY\n");
1304 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1308 PerlIO_puts(file, " ???? - please notify IZ");
1309 PerlIO_putc(file, '\n');
1311 if (mg->mg_type == PERL_MAGIC_utf8) {
1312 STRLEN *cache = (STRLEN *) mg->mg_ptr;
1315 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1316 Perl_dump_indent(aTHX_ level, file,
1317 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1320 (UV)cache[i * 2 + 1]);
1327 Perl_magic_dump(pTHX_ const MAGIC *mg)
1329 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1333 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1336 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1337 if (sv && (hvname = HvNAME_get(sv)))
1338 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1340 PerlIO_putc(file, '\n');
1344 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1346 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1347 if (sv && GvNAME(sv))
1348 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1350 PerlIO_putc(file, '\n');
1354 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1356 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1357 if (sv && GvNAME(sv)) {
1359 PerlIO_printf(file, "\t\"");
1360 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1361 PerlIO_printf(file, "%s\" :: \"", hvname);
1362 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1365 PerlIO_putc(file, '\n');
1369 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1378 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1382 flags = SvFLAGS(sv);
1385 d = Perl_newSVpvf(aTHX_
1386 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1387 PTR2UV(SvANY(sv)), PTR2UV(sv),
1388 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1389 (int)(PL_dumpindent*level), "");
1391 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1392 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1394 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1395 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1396 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1398 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1399 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1400 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1401 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1402 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1404 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1405 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1406 if (flags & SVf_POK) sv_catpv(d, "POK,");
1407 if (flags & SVf_ROK) {
1408 sv_catpv(d, "ROK,");
1409 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1411 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1412 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1413 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1414 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1416 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1417 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1418 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1419 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1420 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1421 if (SvPCS_IMPORTED(sv))
1422 sv_catpv(d, "PCS_IMPORTED,");
1424 sv_catpv(d, "SCREAM,");
1430 if (CvANON(sv)) sv_catpv(d, "ANON,");
1431 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1432 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1433 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1434 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1435 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1436 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1437 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1438 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1439 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1440 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1441 if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
1444 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1445 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1446 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1447 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1448 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1452 if (isGV_with_GP(sv)) {
1453 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1454 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1455 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1456 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1457 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1459 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1460 sv_catpv(d, "IMPORT");
1461 if (GvIMPORTED(sv) == GVf_IMPORTED)
1462 sv_catpv(d, "ALL,");
1465 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1466 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1467 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1468 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1472 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1473 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1477 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1478 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1481 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1482 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1485 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1490 /* SVphv_SHAREKEYS is also 0x20000000 */
1491 if ((type != SVt_PVHV) && SvUTF8(sv))
1492 sv_catpv(d, "UTF8");
1494 if (*(SvEND(d) - 1) == ',') {
1495 SvCUR_set(d, SvCUR(d) - 1);
1496 SvPVX(d)[SvCUR(d)] = '\0';
1501 #ifdef DEBUG_LEAKING_SCALARS
1502 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1503 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1505 sv->sv_debug_inpad ? "for" : "by",
1506 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1507 sv->sv_debug_cloned ? " (cloned)" : "");
1509 Perl_dump_indent(aTHX_ level, file, "SV = ");
1510 if (type < SVt_LAST) {
1511 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1513 if (type == SVt_NULL) {
1518 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1522 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1523 && type != SVt_PVCV && !isGV_with_GP(sv))
1524 || type == SVt_IV) {
1526 #ifdef PERL_OLD_COPY_ON_WRITE
1530 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1532 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1534 PerlIO_printf(file, " (OFFSET)");
1535 #ifdef PERL_OLD_COPY_ON_WRITE
1536 if (SvIsCOW_shared_hash(sv))
1537 PerlIO_printf(file, " (HASH)");
1538 else if (SvIsCOW_normal(sv))
1539 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1541 PerlIO_putc(file, '\n');
1543 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1544 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1545 (UV) COP_SEQ_RANGE_LOW(sv));
1546 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1547 (UV) COP_SEQ_RANGE_HIGH(sv));
1548 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1549 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)
1551 || type == SVt_NV) {
1552 STORE_NUMERIC_LOCAL_SET_STANDARD();
1553 /* %Vg doesn't work? --jhi */
1554 #ifdef USE_LONG_DOUBLE
1555 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1557 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1559 RESTORE_NUMERIC_LOCAL();
1562 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1564 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1566 if (type < SVt_PV) {
1570 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1571 if (SvPVX_const(sv)) {
1572 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1574 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1575 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1576 if (SvUTF8(sv)) /* the 8? \x{....} */
1577 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1578 PerlIO_printf(file, "\n");
1579 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1580 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1583 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1585 if (type >= SVt_PVMG) {
1586 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1587 HV *ost = SvOURSTASH(sv);
1589 do_hv_dump(level, file, " OURSTASH", ost);
1592 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1595 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1599 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1600 if (AvARRAY(sv) != AvALLOC(sv)) {
1601 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1602 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1605 PerlIO_putc(file, '\n');
1606 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1607 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1608 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1609 sv_setpvn(d, "", 0);
1610 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1611 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1612 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1613 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1614 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1616 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1617 SV** elt = av_fetch((AV*)sv,count,0);
1619 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1621 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1626 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1627 if (HvARRAY(sv) && HvKEYS(sv)) {
1628 /* Show distribution of HEs in the ARRAY */
1630 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1633 U32 pow2 = 2, keys = HvKEYS(sv);
1634 NV theoret, sum = 0;
1636 PerlIO_printf(file, " (");
1637 Zero(freq, FREQ_MAX + 1, int);
1638 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1641 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1643 if (count > FREQ_MAX)
1649 for (i = 0; i <= max; i++) {
1651 PerlIO_printf(file, "%d%s:%d", i,
1652 (i == FREQ_MAX) ? "+" : "",
1655 PerlIO_printf(file, ", ");
1658 PerlIO_putc(file, ')');
1659 /* The "quality" of a hash is defined as the total number of
1660 comparisons needed to access every element once, relative
1661 to the expected number needed for a random hash.
1663 The total number of comparisons is equal to the sum of
1664 the squares of the number of entries in each bucket.
1665 For a random hash of n keys into k buckets, the expected
1670 for (i = max; i > 0; i--) { /* Precision: count down. */
1671 sum += freq[i] * i * i;
1673 while ((keys = keys >> 1))
1675 theoret = HvKEYS(sv);
1676 theoret += theoret * (theoret-1)/pow2;
1677 PerlIO_putc(file, '\n');
1678 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1680 PerlIO_putc(file, '\n');
1681 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1682 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1683 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1684 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1685 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1687 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1688 if (mg && mg->mg_obj) {
1689 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1693 const char * const hvname = HvNAME_get(sv);
1695 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1698 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1700 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1702 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1706 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1708 HV * const hv = (HV*)sv;
1709 int count = maxnest - nest;
1712 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1717 const U32 hash = HeHASH(he);
1719 keysv = hv_iterkeysv(he);
1720 keypv = SvPV_const(keysv, len);
1721 elt = hv_iterval(hv, he);
1722 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1724 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1726 PerlIO_printf(file, "[REHASH] ");
1727 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1728 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1730 hv_iterinit(hv); /* Return to status quo */
1736 const char *const proto = SvPV_const(sv, len);
1737 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1742 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1743 if (!CvISXSUB(sv)) {
1745 Perl_dump_indent(aTHX_ level, file,
1746 " START = 0x%"UVxf" ===> %"IVdf"\n",
1747 PTR2UV(CvSTART(sv)),
1748 (IV)sequence_num(CvSTART(sv)));
1750 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1751 PTR2UV(CvROOT(sv)));
1752 if (CvROOT(sv) && dumpops) {
1753 do_op_dump(level+1, file, CvROOT(sv));
1756 SV *constant = cv_const_sv((CV *)sv);
1758 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1761 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1763 PTR2UV(CvXSUBANY(sv).any_ptr));
1764 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1767 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1768 (IV)CvXSUBANY(sv).any_i32);
1771 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1772 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1773 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1774 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1775 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1776 if (type == SVt_PVFM)
1777 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1778 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1779 if (nest < maxnest) {
1780 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1783 const CV * const outside = CvOUTSIDE(sv);
1784 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1787 : CvANON(outside) ? "ANON"
1788 : (outside == PL_main_cv) ? "MAIN"
1789 : CvUNIQUE(outside) ? "UNIQUE"
1790 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1792 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1793 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1797 if (type == SVt_PVLV) {
1798 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1799 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1800 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1801 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1802 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1803 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1807 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1808 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1809 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1810 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1812 if (!isGV_with_GP(sv))
1814 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1815 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1816 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1817 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1820 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1821 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1822 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1823 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1824 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1825 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1826 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1827 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1828 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1829 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1830 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1831 do_gv_dump (level, file, " EGV", GvEGV(sv));
1834 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1835 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1836 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1837 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1838 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1839 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1840 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1842 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1843 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1844 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1846 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1847 PTR2UV(IoTOP_GV(sv)));
1848 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1851 /* Source filters hide things that are not GVs in these three, so let's
1852 be careful out there. */
1854 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1855 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1856 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1858 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1859 PTR2UV(IoFMT_GV(sv)));
1860 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1863 if (IoBOTTOM_NAME(sv))
1864 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1865 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1866 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1868 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1869 PTR2UV(IoBOTTOM_GV(sv)));
1870 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1873 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1874 if (isPRINT(IoTYPE(sv)))
1875 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1877 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1878 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1885 Perl_sv_dump(pTHX_ SV *sv)
1888 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1892 Perl_runops_debug(pTHX)
1896 if (ckWARN_d(WARN_DEBUGGING))
1897 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1901 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1905 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1906 PerlIO_printf(Perl_debug_log,
1907 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1908 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1909 PTR2UV(*PL_watchaddr));
1910 if (DEBUG_s_TEST_) {
1911 if (DEBUG_v_TEST_) {
1912 PerlIO_printf(Perl_debug_log, "\n");
1920 if (DEBUG_t_TEST_) debop(PL_op);
1921 if (DEBUG_P_TEST_) debprof(PL_op);
1923 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1924 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1931 Perl_debop(pTHX_ const OP *o)
1934 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1937 Perl_deb(aTHX_ "%s", OP_NAME(o));
1938 switch (o->op_type) {
1940 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1945 SV * const sv = newSV(0);
1947 /* FIXME - is this making unwarranted assumptions about the
1948 UTF-8 cleanliness of the dump file handle? */
1951 gv_fullname3(sv, cGVOPo_gv, NULL);
1952 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1956 PerlIO_printf(Perl_debug_log, "(NULL)");
1962 /* print the lexical's name */
1963 CV * const cv = deb_curcv(cxstack_ix);
1966 AV * const padlist = CvPADLIST(cv);
1967 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1968 sv = *av_fetch(comppad, o->op_targ, FALSE);
1972 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1974 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1980 PerlIO_printf(Perl_debug_log, "\n");
1985 S_deb_curcv(pTHX_ I32 ix)
1988 const PERL_CONTEXT * const cx = &cxstack[ix];
1989 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1990 return cx->blk_sub.cv;
1991 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1993 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1998 return deb_curcv(ix - 1);
2002 Perl_watch(pTHX_ char **addr)
2005 PL_watchaddr = addr;
2007 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2008 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2012 S_debprof(pTHX_ const OP *o)
2015 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2017 if (!PL_profiledata)
2018 Newxz(PL_profiledata, MAXO, U32);
2019 ++PL_profiledata[o->op_type];
2023 Perl_debprofdump(pTHX)
2027 if (!PL_profiledata)
2029 for (i = 0; i < MAXO; i++) {
2030 if (PL_profiledata[i])
2031 PerlIO_printf(Perl_debug_log,
2032 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2039 * XML variants of most of the above routines
2043 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2046 PerlIO_printf(file, "\n ");
2047 va_start(args, pat);
2048 xmldump_vindent(level, file, pat, &args);
2054 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2057 va_start(args, pat);
2058 xmldump_vindent(level, file, pat, &args);
2063 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2065 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2066 PerlIO_vprintf(file, pat, *args);
2070 Perl_xmldump_all(pTHX)
2072 PerlIO_setlinebuf(PL_xmlfp);
2074 op_xmldump(PL_main_root);
2075 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2076 PerlIO_close(PL_xmlfp);
2081 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2086 if (!HvARRAY(stash))
2088 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2089 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2090 GV *gv = (GV*)HeVAL(entry);
2092 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2098 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2099 && (hv = GvHV(gv)) && hv != PL_defstash)
2100 xmldump_packsubs(hv); /* nested package */
2106 Perl_xmldump_sub(pTHX_ const GV *gv)
2108 SV *sv = sv_newmortal();
2110 gv_fullname3(sv, gv, Nullch);
2111 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2112 if (CvXSUB(GvCV(gv)))
2113 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2114 PTR2UV(CvXSUB(GvCV(gv))),
2115 (int)CvXSUBANY(GvCV(gv)).any_i32);
2116 else if (CvROOT(GvCV(gv)))
2117 op_xmldump(CvROOT(GvCV(gv)));
2119 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2123 Perl_xmldump_form(pTHX_ const GV *gv)
2125 SV *sv = sv_newmortal();
2127 gv_fullname3(sv, gv, Nullch);
2128 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2129 if (CvROOT(GvFORM(gv)))
2130 op_xmldump(CvROOT(GvFORM(gv)));
2132 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2136 Perl_xmldump_eval(pTHX)
2138 op_xmldump(PL_eval_root);
2142 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2144 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2148 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2156 sv_catpvn(dsv,"",0);
2157 dsvcur = SvCUR(dsv); /* in case we have to restart */
2162 c = utf8_to_uvchr((U8*)pv, &cl);
2164 SvCUR(dsv) = dsvcur;
2229 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2232 Perl_sv_catpvf(aTHX_ dsv, "<");
2235 Perl_sv_catpvf(aTHX_ dsv, ">");
2238 Perl_sv_catpvf(aTHX_ dsv, "&");
2241 Perl_sv_catpvf(aTHX_ dsv, """);
2245 if (c < 32 || c > 127) {
2246 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2249 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2253 if ((c >= 0xD800 && c <= 0xDB7F) ||
2254 (c >= 0xDC00 && c <= 0xDFFF) ||
2255 (c >= 0xFFF0 && c <= 0xFFFF) ||
2257 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2259 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2272 Perl_sv_xmlpeek(pTHX_ SV *sv)
2274 SV *t = sv_newmortal();
2279 sv_setpvn(t, "", 0);
2282 sv_catpv(t, "VOID=\"\"");
2285 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2286 sv_catpv(t, "WILD=\"\"");
2289 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2290 if (sv == &PL_sv_undef) {
2291 sv_catpv(t, "SV_UNDEF=\"1\"");
2292 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2293 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2297 else if (sv == &PL_sv_no) {
2298 sv_catpv(t, "SV_NO=\"1\"");
2299 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2300 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2301 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2302 SVp_POK|SVp_NOK)) &&
2307 else if (sv == &PL_sv_yes) {
2308 sv_catpv(t, "SV_YES=\"1\"");
2309 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2310 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2311 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2312 SVp_POK|SVp_NOK)) &&
2314 SvPVX(sv) && *SvPVX(sv) == '1' &&
2319 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2320 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2321 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2325 sv_catpv(t, " XXX=\"\" ");
2327 else if (SvREFCNT(sv) == 0) {
2328 sv_catpv(t, " refcnt=\"0\"");
2331 else if (DEBUG_R_TEST_) {
2334 /* is this SV on the tmps stack? */
2335 for (ix=PL_tmps_ix; ix>=0; ix--) {
2336 if (PL_tmps_stack[ix] == sv) {
2341 if (SvREFCNT(sv) > 1)
2342 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2345 sv_catpv(t, " DRT=\"<T>\"");
2349 sv_catpv(t, " ROK=\"\"");
2351 switch (SvTYPE(sv)) {
2353 sv_catpv(t, " FREED=\"1\"");
2357 sv_catpv(t, " UNDEF=\"1\"");
2360 sv_catpv(t, " IV=\"");
2363 sv_catpv(t, " NV=\"");
2366 sv_catpv(t, " RV=\"");
2369 sv_catpv(t, " PV=\"");
2372 sv_catpv(t, " PVIV=\"");
2375 sv_catpv(t, " PVNV=\"");
2378 sv_catpv(t, " PVMG=\"");
2381 sv_catpv(t, " PVLV=\"");
2384 sv_catpv(t, " AV=\"");
2387 sv_catpv(t, " HV=\"");
2391 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2393 sv_catpv(t, " CV=\"()\"");
2396 sv_catpv(t, " GV=\"");
2399 sv_catpv(t, " BIND=\"");
2402 sv_catpv(t, " FM=\"");
2405 sv_catpv(t, " IO=\"");
2414 else if (SvNOKp(sv)) {
2415 STORE_NUMERIC_LOCAL_SET_STANDARD();
2416 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2417 RESTORE_NUMERIC_LOCAL();
2419 else if (SvIOKp(sv)) {
2421 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2423 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2434 return SvPV(t, n_a);
2438 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2441 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2444 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2447 char *s = PM_GETRE(pm)->precomp;
2448 SV *tmpsv = newSVpvn("",0);
2450 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2451 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2453 SvREFCNT_dec(tmpsv);
2454 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2455 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2458 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2459 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2460 SV * const tmpsv = pm_description(pm);
2461 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2462 SvREFCNT_dec(tmpsv);
2466 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2467 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2468 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2469 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2470 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2471 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2474 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2478 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2480 do_pmop_xmldump(0, PL_xmlfp, pm);
2484 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2491 seq = sequence_num(o);
2492 Perl_xmldump_indent(aTHX_ level, file,
2493 "<op_%s seq=\"%"UVuf" -> ",
2498 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2499 sequence_num(o->op_next));
2501 PerlIO_printf(file, "DONE\"");
2504 if (o->op_type == OP_NULL)
2506 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2507 if (o->op_targ == OP_NEXTSTATE)
2510 PerlIO_printf(file, " line=\"%"UVuf"\"",
2511 (UV)CopLINE(cCOPo));
2512 if (CopSTASHPV(cCOPo))
2513 PerlIO_printf(file, " package=\"%s\"",
2515 if (cCOPo->cop_label)
2516 PerlIO_printf(file, " label=\"%s\"",
2521 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2524 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2527 SV *tmpsv = newSVpvn("", 0);
2528 switch (o->op_flags & OPf_WANT) {
2530 sv_catpv(tmpsv, ",VOID");
2532 case OPf_WANT_SCALAR:
2533 sv_catpv(tmpsv, ",SCALAR");
2536 sv_catpv(tmpsv, ",LIST");
2539 sv_catpv(tmpsv, ",UNKNOWN");
2542 if (o->op_flags & OPf_KIDS)
2543 sv_catpv(tmpsv, ",KIDS");
2544 if (o->op_flags & OPf_PARENS)
2545 sv_catpv(tmpsv, ",PARENS");
2546 if (o->op_flags & OPf_STACKED)
2547 sv_catpv(tmpsv, ",STACKED");
2548 if (o->op_flags & OPf_REF)
2549 sv_catpv(tmpsv, ",REF");
2550 if (o->op_flags & OPf_MOD)
2551 sv_catpv(tmpsv, ",MOD");
2552 if (o->op_flags & OPf_SPECIAL)
2553 sv_catpv(tmpsv, ",SPECIAL");
2554 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2555 SvREFCNT_dec(tmpsv);
2557 if (o->op_private) {
2558 SV *tmpsv = newSVpvn("", 0);
2559 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2560 if (o->op_private & OPpTARGET_MY)
2561 sv_catpv(tmpsv, ",TARGET_MY");
2563 else if (o->op_type == OP_LEAVESUB ||
2564 o->op_type == OP_LEAVE ||
2565 o->op_type == OP_LEAVESUBLV ||
2566 o->op_type == OP_LEAVEWRITE) {
2567 if (o->op_private & OPpREFCOUNTED)
2568 sv_catpv(tmpsv, ",REFCOUNTED");
2570 else if (o->op_type == OP_AASSIGN) {
2571 if (o->op_private & OPpASSIGN_COMMON)
2572 sv_catpv(tmpsv, ",COMMON");
2574 else if (o->op_type == OP_SASSIGN) {
2575 if (o->op_private & OPpASSIGN_BACKWARDS)
2576 sv_catpv(tmpsv, ",BACKWARDS");
2578 else if (o->op_type == OP_TRANS) {
2579 if (o->op_private & OPpTRANS_SQUASH)
2580 sv_catpv(tmpsv, ",SQUASH");
2581 if (o->op_private & OPpTRANS_DELETE)
2582 sv_catpv(tmpsv, ",DELETE");
2583 if (o->op_private & OPpTRANS_COMPLEMENT)
2584 sv_catpv(tmpsv, ",COMPLEMENT");
2585 if (o->op_private & OPpTRANS_IDENTICAL)
2586 sv_catpv(tmpsv, ",IDENTICAL");
2587 if (o->op_private & OPpTRANS_GROWS)
2588 sv_catpv(tmpsv, ",GROWS");
2590 else if (o->op_type == OP_REPEAT) {
2591 if (o->op_private & OPpREPEAT_DOLIST)
2592 sv_catpv(tmpsv, ",DOLIST");
2594 else if (o->op_type == OP_ENTERSUB ||
2595 o->op_type == OP_RV2SV ||
2596 o->op_type == OP_GVSV ||
2597 o->op_type == OP_RV2AV ||
2598 o->op_type == OP_RV2HV ||
2599 o->op_type == OP_RV2GV ||
2600 o->op_type == OP_AELEM ||
2601 o->op_type == OP_HELEM )
2603 if (o->op_type == OP_ENTERSUB) {
2604 if (o->op_private & OPpENTERSUB_AMPER)
2605 sv_catpv(tmpsv, ",AMPER");
2606 if (o->op_private & OPpENTERSUB_DB)
2607 sv_catpv(tmpsv, ",DB");
2608 if (o->op_private & OPpENTERSUB_HASTARG)
2609 sv_catpv(tmpsv, ",HASTARG");
2610 if (o->op_private & OPpENTERSUB_NOPAREN)
2611 sv_catpv(tmpsv, ",NOPAREN");
2612 if (o->op_private & OPpENTERSUB_INARGS)
2613 sv_catpv(tmpsv, ",INARGS");
2614 if (o->op_private & OPpENTERSUB_NOMOD)
2615 sv_catpv(tmpsv, ",NOMOD");
2618 switch (o->op_private & OPpDEREF) {
2620 sv_catpv(tmpsv, ",SV");
2623 sv_catpv(tmpsv, ",AV");
2626 sv_catpv(tmpsv, ",HV");
2629 if (o->op_private & OPpMAYBE_LVSUB)
2630 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2632 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2633 if (o->op_private & OPpLVAL_DEFER)
2634 sv_catpv(tmpsv, ",LVAL_DEFER");
2637 if (o->op_private & HINT_STRICT_REFS)
2638 sv_catpv(tmpsv, ",STRICT_REFS");
2639 if (o->op_private & OPpOUR_INTRO)
2640 sv_catpv(tmpsv, ",OUR_INTRO");
2643 else if (o->op_type == OP_CONST) {
2644 if (o->op_private & OPpCONST_BARE)
2645 sv_catpv(tmpsv, ",BARE");
2646 if (o->op_private & OPpCONST_STRICT)
2647 sv_catpv(tmpsv, ",STRICT");
2648 if (o->op_private & OPpCONST_ARYBASE)
2649 sv_catpv(tmpsv, ",ARYBASE");
2650 if (o->op_private & OPpCONST_WARNING)
2651 sv_catpv(tmpsv, ",WARNING");
2652 if (o->op_private & OPpCONST_ENTERED)
2653 sv_catpv(tmpsv, ",ENTERED");
2655 else if (o->op_type == OP_FLIP) {
2656 if (o->op_private & OPpFLIP_LINENUM)
2657 sv_catpv(tmpsv, ",LINENUM");
2659 else if (o->op_type == OP_FLOP) {
2660 if (o->op_private & OPpFLIP_LINENUM)
2661 sv_catpv(tmpsv, ",LINENUM");
2663 else if (o->op_type == OP_RV2CV) {
2664 if (o->op_private & OPpLVAL_INTRO)
2665 sv_catpv(tmpsv, ",INTRO");
2667 else if (o->op_type == OP_GV) {
2668 if (o->op_private & OPpEARLY_CV)
2669 sv_catpv(tmpsv, ",EARLY_CV");
2671 else if (o->op_type == OP_LIST) {
2672 if (o->op_private & OPpLIST_GUESSED)
2673 sv_catpv(tmpsv, ",GUESSED");
2675 else if (o->op_type == OP_DELETE) {
2676 if (o->op_private & OPpSLICE)
2677 sv_catpv(tmpsv, ",SLICE");
2679 else if (o->op_type == OP_EXISTS) {
2680 if (o->op_private & OPpEXISTS_SUB)
2681 sv_catpv(tmpsv, ",EXISTS_SUB");
2683 else if (o->op_type == OP_SORT) {
2684 if (o->op_private & OPpSORT_NUMERIC)
2685 sv_catpv(tmpsv, ",NUMERIC");
2686 if (o->op_private & OPpSORT_INTEGER)
2687 sv_catpv(tmpsv, ",INTEGER");
2688 if (o->op_private & OPpSORT_REVERSE)
2689 sv_catpv(tmpsv, ",REVERSE");
2691 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2692 if (o->op_private & OPpOPEN_IN_RAW)
2693 sv_catpv(tmpsv, ",IN_RAW");
2694 if (o->op_private & OPpOPEN_IN_CRLF)
2695 sv_catpv(tmpsv, ",IN_CRLF");
2696 if (o->op_private & OPpOPEN_OUT_RAW)
2697 sv_catpv(tmpsv, ",OUT_RAW");
2698 if (o->op_private & OPpOPEN_OUT_CRLF)
2699 sv_catpv(tmpsv, ",OUT_CRLF");
2701 else if (o->op_type == OP_EXIT) {
2702 if (o->op_private & OPpEXIT_VMSISH)
2703 sv_catpv(tmpsv, ",EXIT_VMSISH");
2704 if (o->op_private & OPpHUSH_VMSISH)
2705 sv_catpv(tmpsv, ",HUSH_VMSISH");
2707 else if (o->op_type == OP_DIE) {
2708 if (o->op_private & OPpHUSH_VMSISH)
2709 sv_catpv(tmpsv, ",HUSH_VMSISH");
2711 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2712 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2713 sv_catpv(tmpsv, ",FT_ACCESS");
2714 if (o->op_private & OPpFT_STACKED)
2715 sv_catpv(tmpsv, ",FT_STACKED");
2717 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2718 sv_catpv(tmpsv, ",INTRO");
2720 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2721 SvREFCNT_dec(tmpsv);
2724 switch (o->op_type) {
2726 if (o->op_flags & OPf_SPECIAL) {
2732 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2734 if (cSVOPo->op_sv) {
2735 SV *tmpsv1 = newSV(0);
2736 SV *tmpsv2 = newSVpvn("",0);
2744 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2745 s = SvPV(tmpsv1,len);
2746 sv_catxmlpvn(tmpsv2, s, len, 1);
2747 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2751 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2755 case OP_METHOD_NAMED:
2756 #ifndef USE_ITHREADS
2757 /* with ITHREADS, consts are stored in the pad, and the right pad
2758 * may not be active here, so skip */
2759 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2765 PerlIO_printf(file, ">\n");
2767 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2773 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2774 (UV)CopLINE(cCOPo));
2775 if (CopSTASHPV(cCOPo))
2776 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2778 if (cCOPo->cop_label)
2779 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2783 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2784 if (cLOOPo->op_redoop)
2785 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2787 PerlIO_printf(file, "DONE\"");
2788 S_xmldump_attr(aTHX_ level, file, "next=\"");
2789 if (cLOOPo->op_nextop)
2790 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2792 PerlIO_printf(file, "DONE\"");
2793 S_xmldump_attr(aTHX_ level, file, "last=\"");
2794 if (cLOOPo->op_lastop)
2795 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2797 PerlIO_printf(file, "DONE\"");
2805 S_xmldump_attr(aTHX_ level, file, "other=\"");
2806 if (cLOGOPo->op_other)
2807 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2809 PerlIO_printf(file, "DONE\"");
2817 if (o->op_private & OPpREFCOUNTED)
2818 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2824 if (PL_madskills && o->op_madprop) {
2825 SV *tmpsv = newSVpvn("", 0);
2826 MADPROP* mp = o->op_madprop;
2827 sv_utf8_upgrade(tmpsv);
2830 PerlIO_printf(file, ">\n");
2832 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2835 char tmp = mp->mad_key;
2836 sv_setpvn(tmpsv,"\"",1);
2838 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2839 sv_catpv(tmpsv, "\"");
2840 switch (mp->mad_type) {
2842 sv_catpv(tmpsv, "NULL");
2843 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2846 sv_catpv(tmpsv, " val=\"");
2847 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2848 sv_catpv(tmpsv, "\"");
2849 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2852 sv_catpv(tmpsv, " val=\"");
2853 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2854 sv_catpv(tmpsv, "\"");
2855 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2858 if ((OP*)mp->mad_val) {
2859 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2860 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2861 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2865 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2871 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2873 SvREFCNT_dec(tmpsv);
2876 switch (o->op_type) {
2883 PerlIO_printf(file, ">\n");
2885 do_pmop_xmldump(level, file, cPMOPo);
2891 if (o->op_flags & OPf_KIDS) {
2895 PerlIO_printf(file, ">\n");
2897 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2898 do_op_xmldump(level, file, kid);
2902 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2904 PerlIO_printf(file, " />\n");
2908 Perl_op_xmldump(pTHX_ const OP *o)
2910 do_op_xmldump(0, PL_xmlfp, o);
2916 * c-indentation-style: bsd
2918 * indent-tabs-mode: t
2921 * ex: set ts=8 sts=4 sw=4 noet: