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");
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);
677 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
678 sequence_tail(cPMOPo->op_pmstashstartu.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
2041 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2044 PerlIO_printf(file, "\n ");
2045 va_start(args, pat);
2046 xmldump_vindent(level, file, pat, &args);
2052 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2055 va_start(args, pat);
2056 xmldump_vindent(level, file, pat, &args);
2061 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2063 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2064 PerlIO_vprintf(file, pat, *args);
2068 Perl_xmldump_all(pTHX)
2070 PerlIO_setlinebuf(PL_xmlfp);
2072 op_xmldump(PL_main_root);
2073 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2074 PerlIO_close(PL_xmlfp);
2079 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2084 if (!HvARRAY(stash))
2086 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2087 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2088 GV *gv = (GV*)HeVAL(entry);
2090 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2096 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2097 && (hv = GvHV(gv)) && hv != PL_defstash)
2098 xmldump_packsubs(hv); /* nested package */
2104 Perl_xmldump_sub(pTHX_ const GV *gv)
2106 SV *sv = sv_newmortal();
2108 gv_fullname3(sv, gv, Nullch);
2109 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2110 if (CvXSUB(GvCV(gv)))
2111 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2112 PTR2UV(CvXSUB(GvCV(gv))),
2113 (int)CvXSUBANY(GvCV(gv)).any_i32);
2114 else if (CvROOT(GvCV(gv)))
2115 op_xmldump(CvROOT(GvCV(gv)));
2117 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2121 Perl_xmldump_form(pTHX_ const GV *gv)
2123 SV *sv = sv_newmortal();
2125 gv_fullname3(sv, gv, Nullch);
2126 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2127 if (CvROOT(GvFORM(gv)))
2128 op_xmldump(CvROOT(GvFORM(gv)));
2130 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2134 Perl_xmldump_eval(pTHX)
2136 op_xmldump(PL_eval_root);
2140 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2142 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2146 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2154 sv_catpvn(dsv,"",0);
2155 dsvcur = SvCUR(dsv); /* in case we have to restart */
2160 c = utf8_to_uvchr((U8*)pv, &cl);
2162 SvCUR(dsv) = dsvcur;
2227 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2230 Perl_sv_catpvf(aTHX_ dsv, "<");
2233 Perl_sv_catpvf(aTHX_ dsv, ">");
2236 Perl_sv_catpvf(aTHX_ dsv, "&");
2239 Perl_sv_catpvf(aTHX_ dsv, """);
2243 if (c < 32 || c > 127) {
2244 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2247 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2251 if ((c >= 0xD800 && c <= 0xDB7F) ||
2252 (c >= 0xDC00 && c <= 0xDFFF) ||
2253 (c >= 0xFFF0 && c <= 0xFFFF) ||
2255 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2257 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2270 Perl_sv_xmlpeek(pTHX_ SV *sv)
2272 SV *t = sv_newmortal();
2277 sv_setpvn(t, "", 0);
2280 sv_catpv(t, "VOID=\"\"");
2283 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2284 sv_catpv(t, "WILD=\"\"");
2287 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2288 if (sv == &PL_sv_undef) {
2289 sv_catpv(t, "SV_UNDEF=\"1\"");
2290 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2291 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2295 else if (sv == &PL_sv_no) {
2296 sv_catpv(t, "SV_NO=\"1\"");
2297 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2298 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2299 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2300 SVp_POK|SVp_NOK)) &&
2305 else if (sv == &PL_sv_yes) {
2306 sv_catpv(t, "SV_YES=\"1\"");
2307 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2308 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2309 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2310 SVp_POK|SVp_NOK)) &&
2312 SvPVX(sv) && *SvPVX(sv) == '1' &&
2317 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2318 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2319 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2323 sv_catpv(t, " XXX=\"\" ");
2325 else if (SvREFCNT(sv) == 0) {
2326 sv_catpv(t, " refcnt=\"0\"");
2329 else if (DEBUG_R_TEST_) {
2332 /* is this SV on the tmps stack? */
2333 for (ix=PL_tmps_ix; ix>=0; ix--) {
2334 if (PL_tmps_stack[ix] == sv) {
2339 if (SvREFCNT(sv) > 1)
2340 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2343 sv_catpv(t, " DRT=\"<T>\"");
2347 sv_catpv(t, " ROK=\"\"");
2349 switch (SvTYPE(sv)) {
2351 sv_catpv(t, " FREED=\"1\"");
2355 sv_catpv(t, " UNDEF=\"1\"");
2358 sv_catpv(t, " IV=\"");
2361 sv_catpv(t, " NV=\"");
2364 sv_catpv(t, " RV=\"");
2367 sv_catpv(t, " PV=\"");
2370 sv_catpv(t, " PVIV=\"");
2373 sv_catpv(t, " PVNV=\"");
2376 sv_catpv(t, " PVMG=\"");
2379 sv_catpv(t, " PVLV=\"");
2382 sv_catpv(t, " AV=\"");
2385 sv_catpv(t, " HV=\"");
2389 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2391 sv_catpv(t, " CV=\"()\"");
2394 sv_catpv(t, " GV=\"");
2397 sv_catpv(t, " BIND=\"");
2400 sv_catpv(t, " FM=\"");
2403 sv_catpv(t, " IO=\"");
2412 else if (SvNOKp(sv)) {
2413 STORE_NUMERIC_LOCAL_SET_STANDARD();
2414 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2415 RESTORE_NUMERIC_LOCAL();
2417 else if (SvIOKp(sv)) {
2419 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2421 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2432 return SvPV(t, n_a);
2436 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2439 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2442 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2445 char *s = PM_GETRE(pm)->precomp;
2446 SV *tmpsv = newSVpvn("",0);
2448 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2449 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2451 SvREFCNT_dec(tmpsv);
2452 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2453 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2456 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2457 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2458 SV * const tmpsv = pm_description(pm);
2459 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2460 SvREFCNT_dec(tmpsv);
2464 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2465 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2466 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2467 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2468 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2469 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2472 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2476 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2478 do_pmop_xmldump(0, PL_xmlfp, pm);
2482 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2489 seq = sequence_num(o);
2490 Perl_xmldump_indent(aTHX_ level, file,
2491 "<op_%s seq=\"%"UVuf" -> ",
2496 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2497 sequence_num(o->op_next));
2499 PerlIO_printf(file, "DONE\"");
2502 if (o->op_type == OP_NULL)
2504 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2505 if (o->op_targ == OP_NEXTSTATE)
2508 PerlIO_printf(file, " line=\"%"UVuf"\"",
2509 (UV)CopLINE(cCOPo));
2510 if (CopSTASHPV(cCOPo))
2511 PerlIO_printf(file, " package=\"%s\"",
2513 if (cCOPo->cop_label)
2514 PerlIO_printf(file, " label=\"%s\"",
2519 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2522 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2525 SV *tmpsv = newSVpvn("", 0);
2526 switch (o->op_flags & OPf_WANT) {
2528 sv_catpv(tmpsv, ",VOID");
2530 case OPf_WANT_SCALAR:
2531 sv_catpv(tmpsv, ",SCALAR");
2534 sv_catpv(tmpsv, ",LIST");
2537 sv_catpv(tmpsv, ",UNKNOWN");
2540 if (o->op_flags & OPf_KIDS)
2541 sv_catpv(tmpsv, ",KIDS");
2542 if (o->op_flags & OPf_PARENS)
2543 sv_catpv(tmpsv, ",PARENS");
2544 if (o->op_flags & OPf_STACKED)
2545 sv_catpv(tmpsv, ",STACKED");
2546 if (o->op_flags & OPf_REF)
2547 sv_catpv(tmpsv, ",REF");
2548 if (o->op_flags & OPf_MOD)
2549 sv_catpv(tmpsv, ",MOD");
2550 if (o->op_flags & OPf_SPECIAL)
2551 sv_catpv(tmpsv, ",SPECIAL");
2552 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2553 SvREFCNT_dec(tmpsv);
2555 if (o->op_private) {
2556 SV *tmpsv = newSVpvn("", 0);
2557 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2558 if (o->op_private & OPpTARGET_MY)
2559 sv_catpv(tmpsv, ",TARGET_MY");
2561 else if (o->op_type == OP_LEAVESUB ||
2562 o->op_type == OP_LEAVE ||
2563 o->op_type == OP_LEAVESUBLV ||
2564 o->op_type == OP_LEAVEWRITE) {
2565 if (o->op_private & OPpREFCOUNTED)
2566 sv_catpv(tmpsv, ",REFCOUNTED");
2568 else if (o->op_type == OP_AASSIGN) {
2569 if (o->op_private & OPpASSIGN_COMMON)
2570 sv_catpv(tmpsv, ",COMMON");
2572 else if (o->op_type == OP_SASSIGN) {
2573 if (o->op_private & OPpASSIGN_BACKWARDS)
2574 sv_catpv(tmpsv, ",BACKWARDS");
2576 else if (o->op_type == OP_TRANS) {
2577 if (o->op_private & OPpTRANS_SQUASH)
2578 sv_catpv(tmpsv, ",SQUASH");
2579 if (o->op_private & OPpTRANS_DELETE)
2580 sv_catpv(tmpsv, ",DELETE");
2581 if (o->op_private & OPpTRANS_COMPLEMENT)
2582 sv_catpv(tmpsv, ",COMPLEMENT");
2583 if (o->op_private & OPpTRANS_IDENTICAL)
2584 sv_catpv(tmpsv, ",IDENTICAL");
2585 if (o->op_private & OPpTRANS_GROWS)
2586 sv_catpv(tmpsv, ",GROWS");
2588 else if (o->op_type == OP_REPEAT) {
2589 if (o->op_private & OPpREPEAT_DOLIST)
2590 sv_catpv(tmpsv, ",DOLIST");
2592 else if (o->op_type == OP_ENTERSUB ||
2593 o->op_type == OP_RV2SV ||
2594 o->op_type == OP_GVSV ||
2595 o->op_type == OP_RV2AV ||
2596 o->op_type == OP_RV2HV ||
2597 o->op_type == OP_RV2GV ||
2598 o->op_type == OP_AELEM ||
2599 o->op_type == OP_HELEM )
2601 if (o->op_type == OP_ENTERSUB) {
2602 if (o->op_private & OPpENTERSUB_AMPER)
2603 sv_catpv(tmpsv, ",AMPER");
2604 if (o->op_private & OPpENTERSUB_DB)
2605 sv_catpv(tmpsv, ",DB");
2606 if (o->op_private & OPpENTERSUB_HASTARG)
2607 sv_catpv(tmpsv, ",HASTARG");
2608 if (o->op_private & OPpENTERSUB_NOPAREN)
2609 sv_catpv(tmpsv, ",NOPAREN");
2610 if (o->op_private & OPpENTERSUB_INARGS)
2611 sv_catpv(tmpsv, ",INARGS");
2612 if (o->op_private & OPpENTERSUB_NOMOD)
2613 sv_catpv(tmpsv, ",NOMOD");
2616 switch (o->op_private & OPpDEREF) {
2618 sv_catpv(tmpsv, ",SV");
2621 sv_catpv(tmpsv, ",AV");
2624 sv_catpv(tmpsv, ",HV");
2627 if (o->op_private & OPpMAYBE_LVSUB)
2628 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2630 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2631 if (o->op_private & OPpLVAL_DEFER)
2632 sv_catpv(tmpsv, ",LVAL_DEFER");
2635 if (o->op_private & HINT_STRICT_REFS)
2636 sv_catpv(tmpsv, ",STRICT_REFS");
2637 if (o->op_private & OPpOUR_INTRO)
2638 sv_catpv(tmpsv, ",OUR_INTRO");
2641 else if (o->op_type == OP_CONST) {
2642 if (o->op_private & OPpCONST_BARE)
2643 sv_catpv(tmpsv, ",BARE");
2644 if (o->op_private & OPpCONST_STRICT)
2645 sv_catpv(tmpsv, ",STRICT");
2646 if (o->op_private & OPpCONST_ARYBASE)
2647 sv_catpv(tmpsv, ",ARYBASE");
2648 if (o->op_private & OPpCONST_WARNING)
2649 sv_catpv(tmpsv, ",WARNING");
2650 if (o->op_private & OPpCONST_ENTERED)
2651 sv_catpv(tmpsv, ",ENTERED");
2653 else if (o->op_type == OP_FLIP) {
2654 if (o->op_private & OPpFLIP_LINENUM)
2655 sv_catpv(tmpsv, ",LINENUM");
2657 else if (o->op_type == OP_FLOP) {
2658 if (o->op_private & OPpFLIP_LINENUM)
2659 sv_catpv(tmpsv, ",LINENUM");
2661 else if (o->op_type == OP_RV2CV) {
2662 if (o->op_private & OPpLVAL_INTRO)
2663 sv_catpv(tmpsv, ",INTRO");
2665 else if (o->op_type == OP_GV) {
2666 if (o->op_private & OPpEARLY_CV)
2667 sv_catpv(tmpsv, ",EARLY_CV");
2669 else if (o->op_type == OP_LIST) {
2670 if (o->op_private & OPpLIST_GUESSED)
2671 sv_catpv(tmpsv, ",GUESSED");
2673 else if (o->op_type == OP_DELETE) {
2674 if (o->op_private & OPpSLICE)
2675 sv_catpv(tmpsv, ",SLICE");
2677 else if (o->op_type == OP_EXISTS) {
2678 if (o->op_private & OPpEXISTS_SUB)
2679 sv_catpv(tmpsv, ",EXISTS_SUB");
2681 else if (o->op_type == OP_SORT) {
2682 if (o->op_private & OPpSORT_NUMERIC)
2683 sv_catpv(tmpsv, ",NUMERIC");
2684 if (o->op_private & OPpSORT_INTEGER)
2685 sv_catpv(tmpsv, ",INTEGER");
2686 if (o->op_private & OPpSORT_REVERSE)
2687 sv_catpv(tmpsv, ",REVERSE");
2689 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2690 if (o->op_private & OPpOPEN_IN_RAW)
2691 sv_catpv(tmpsv, ",IN_RAW");
2692 if (o->op_private & OPpOPEN_IN_CRLF)
2693 sv_catpv(tmpsv, ",IN_CRLF");
2694 if (o->op_private & OPpOPEN_OUT_RAW)
2695 sv_catpv(tmpsv, ",OUT_RAW");
2696 if (o->op_private & OPpOPEN_OUT_CRLF)
2697 sv_catpv(tmpsv, ",OUT_CRLF");
2699 else if (o->op_type == OP_EXIT) {
2700 if (o->op_private & OPpEXIT_VMSISH)
2701 sv_catpv(tmpsv, ",EXIT_VMSISH");
2702 if (o->op_private & OPpHUSH_VMSISH)
2703 sv_catpv(tmpsv, ",HUSH_VMSISH");
2705 else if (o->op_type == OP_DIE) {
2706 if (o->op_private & OPpHUSH_VMSISH)
2707 sv_catpv(tmpsv, ",HUSH_VMSISH");
2709 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2710 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2711 sv_catpv(tmpsv, ",FT_ACCESS");
2712 if (o->op_private & OPpFT_STACKED)
2713 sv_catpv(tmpsv, ",FT_STACKED");
2715 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2716 sv_catpv(tmpsv, ",INTRO");
2718 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2719 SvREFCNT_dec(tmpsv);
2722 switch (o->op_type) {
2724 if (o->op_flags & OPf_SPECIAL) {
2730 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2732 if (cSVOPo->op_sv) {
2733 SV *tmpsv1 = newSV(0);
2734 SV *tmpsv2 = newSVpvn("",0);
2742 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2743 s = SvPV(tmpsv1,len);
2744 sv_catxmlpvn(tmpsv2, s, len, 1);
2745 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2749 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2753 case OP_METHOD_NAMED:
2754 #ifndef USE_ITHREADS
2755 /* with ITHREADS, consts are stored in the pad, and the right pad
2756 * may not be active here, so skip */
2757 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2763 PerlIO_printf(file, ">\n");
2765 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2771 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2772 (UV)CopLINE(cCOPo));
2773 if (CopSTASHPV(cCOPo))
2774 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2776 if (cCOPo->cop_label)
2777 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2781 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2782 if (cLOOPo->op_redoop)
2783 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2785 PerlIO_printf(file, "DONE\"");
2786 S_xmldump_attr(aTHX_ level, file, "next=\"");
2787 if (cLOOPo->op_nextop)
2788 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2790 PerlIO_printf(file, "DONE\"");
2791 S_xmldump_attr(aTHX_ level, file, "last=\"");
2792 if (cLOOPo->op_lastop)
2793 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2795 PerlIO_printf(file, "DONE\"");
2803 S_xmldump_attr(aTHX_ level, file, "other=\"");
2804 if (cLOGOPo->op_other)
2805 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2807 PerlIO_printf(file, "DONE\"");
2815 if (o->op_private & OPpREFCOUNTED)
2816 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2822 if (PL_madskills && o->op_madprop) {
2823 SV *tmpsv = newSVpvn("", 0);
2824 MADPROP* mp = o->op_madprop;
2825 sv_utf8_upgrade(tmpsv);
2828 PerlIO_printf(file, ">\n");
2830 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2833 char tmp = mp->mad_key;
2834 sv_setpvn(tmpsv,"\"",1);
2836 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2837 sv_catpv(tmpsv, "\"");
2838 switch (mp->mad_type) {
2840 sv_catpv(tmpsv, "NULL");
2841 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2844 sv_catpv(tmpsv, " val=\"");
2845 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2846 sv_catpv(tmpsv, "\"");
2847 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2850 sv_catpv(tmpsv, " val=\"");
2851 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2852 sv_catpv(tmpsv, "\"");
2853 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2856 if ((OP*)mp->mad_val) {
2857 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2858 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2859 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2863 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2869 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2871 SvREFCNT_dec(tmpsv);
2874 switch (o->op_type) {
2881 PerlIO_printf(file, ">\n");
2883 do_pmop_xmldump(level, file, cPMOPo);
2889 if (o->op_flags & OPf_KIDS) {
2893 PerlIO_printf(file, ">\n");
2895 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2896 do_op_xmldump(level, file, kid);
2900 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2902 PerlIO_printf(file, " />\n");
2906 Perl_op_xmldump(pTHX_ const OP *o)
2908 do_op_xmldump(0, PL_xmlfp, o);
2914 * c-indentation-style: bsd
2916 * indent-tabs-mode: t
2919 * ex: set ts=8 sts=4 sw=4 noet: