3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'"
16 /* This file contains utility routines to dump the contents of SV and OP
17 * structures, as used by command-line options like -Dt and -Dx, and
20 * It also holds the debugging version of the runops function.
24 #define PERL_IN_DUMP_C
30 static const char* const svtypenames[SVt_LAST] = {
50 static const char* const svshorttypenames[SVt_LAST] = {
69 #define Sequence PL_op_sequence
72 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
76 dump_vindent(level, file, pat, &args);
81 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
84 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
85 PerlIO_vprintf(file, pat, *args);
92 PerlIO_setlinebuf(Perl_debug_log);
94 op_dump(PL_main_root);
95 dump_packsubs(PL_defstash);
99 Perl_dump_packsubs(pTHX_ const HV *stash)
106 for (i = 0; i <= (I32) HvMAX(stash); i++) {
108 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
109 const GV * const gv = (GV*)HeVAL(entry);
110 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
116 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
117 const HV * const hv = GvHV(gv);
118 if (hv && (hv != PL_defstash))
119 dump_packsubs(hv); /* nested package */
126 Perl_dump_sub(pTHX_ const GV *gv)
128 SV * const sv = sv_newmortal();
130 gv_fullname3(sv, gv, NULL);
131 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
132 if (CvISXSUB(GvCV(gv)))
133 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
134 PTR2UV(CvXSUB(GvCV(gv))),
135 (int)CvXSUBANY(GvCV(gv)).any_i32);
136 else if (CvROOT(GvCV(gv)))
137 op_dump(CvROOT(GvCV(gv)));
139 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
143 Perl_dump_form(pTHX_ const GV *gv)
145 SV * const sv = sv_newmortal();
147 gv_fullname3(sv, gv, NULL);
148 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
149 if (CvROOT(GvFORM(gv)))
150 op_dump(CvROOT(GvFORM(gv)));
152 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
159 op_dump(PL_eval_root);
164 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
165 |const STRLEN count|const STRLEN max
166 |STRLEN const *escaped, const U32 flags
168 Escapes at most the first "count" chars of pv and puts the results into
169 dsv such that the size of the escaped string will not exceed "max" chars
170 and will not contain any incomplete escape sequences.
172 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
173 will also be escaped.
175 Normally the SV will be cleared before the escaped string is prepared,
176 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
178 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
179 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
180 using C<is_utf8_string()> to determine if it is Unicode.
182 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
183 using C<\x01F1> style escapes, otherwise only chars above 255 will be
184 escaped using this style, other non printable chars will use octal or
185 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
186 then all chars below 255 will be treated as printable and
187 will be output as literals.
189 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
190 string will be escaped, regardles of max. If the string is utf8 and
191 the chars value is >255 then it will be returned as a plain hex
192 sequence. Thus the output will either be a single char,
193 an octal escape sequence, a special escape like C<\n> or a 3 or
194 more digit hex value.
196 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
197 not a '\\'. This is because regexes very often contain backslashed
198 sequences, whereas '%' is not a particularly common character in patterns.
200 Returns a pointer to the escaped text as held by dsv.
204 #define PV_ESCAPE_OCTBUFSIZE 32
207 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
208 const STRLEN count, const STRLEN max,
209 STRLEN * const escaped, const U32 flags )
211 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
212 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
213 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
214 STRLEN wrote = 0; /* chars written so far */
215 STRLEN chsize = 0; /* size of data to be written */
216 STRLEN readsize = 1; /* size of data just read */
217 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
218 const char *pv = str;
219 const char * const end = pv + count; /* end of string */
222 if (!flags & PERL_PV_ESCAPE_NOCLEAR)
223 sv_setpvn(dsv, "", 0);
225 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
228 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
229 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
230 const U8 c = (U8)u & 0xFF;
232 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
233 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
234 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
237 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
238 "%cx{%"UVxf"}", esc, u);
239 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
242 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
246 case '\\' : /* fallthrough */
247 case '%' : if ( c == esc ) {
253 case '\v' : octbuf[1] = 'v'; break;
254 case '\t' : octbuf[1] = 't'; break;
255 case '\r' : octbuf[1] = 'r'; break;
256 case '\n' : octbuf[1] = 'n'; break;
257 case '\f' : octbuf[1] = 'f'; break;
265 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
266 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
269 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
276 if ( max && (wrote + chsize > max) ) {
278 } else if (chsize > 1) {
279 sv_catpvn(dsv, octbuf, chsize);
282 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
285 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
293 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
294 |const STRLEN count|const STRLEN max\
295 |const char const *start_color| const char const *end_color\
298 Converts a string into something presentable, handling escaping via
299 pv_escape() and supporting quoting and ellipses.
301 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
302 double quoted with any double quotes in the string escaped. Otherwise
303 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
306 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
307 string were output then an ellipsis C<...> will be appended to the
308 string. Note that this happens AFTER it has been quoted.
310 If start_color is non-null then it will be inserted after the opening
311 quote (if there is one) but before the escaped text. If end_color
312 is non-null then it will be inserted after the escaped text but before
313 any quotes or ellipses.
315 Returns a pointer to the prettified text as held by dsv.
321 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
322 const STRLEN max, char const * const start_color, char const * const end_color,
325 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
329 sv_setpvn(dsv, "\"", 1);
330 else if ( flags & PERL_PV_PRETTY_LTGT )
331 sv_setpvn(dsv, "<", 1);
333 sv_setpvn(dsv, "", 0);
335 if ( start_color != NULL )
336 Perl_sv_catpv( aTHX_ dsv, start_color);
338 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
340 if ( end_color != NULL )
341 Perl_sv_catpv( aTHX_ dsv, end_color);
344 sv_catpvn( dsv, "\"", 1 );
345 else if ( flags & PERL_PV_PRETTY_LTGT )
346 sv_catpvn( dsv, ">", 1);
348 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
349 sv_catpvn( dsv, "...", 3 );
355 =for apidoc pv_display
357 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
358 STRLEN pvlim, U32 flags)
362 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
364 except that an additional "\0" will be appended to the string when
365 len > cur and pv[cur] is "\0".
367 Note that the final string may be up to 7 chars longer than pvlim.
373 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
375 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
376 if (len > cur && pv[cur] == '\0')
377 sv_catpvn( dsv, "\\0", 2 );
382 Perl_sv_peek(pTHX_ SV *sv)
385 SV * const t = sv_newmortal();
395 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
399 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
400 if (sv == &PL_sv_undef) {
401 sv_catpv(t, "SV_UNDEF");
402 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
403 SVs_GMG|SVs_SMG|SVs_RMG)) &&
407 else if (sv == &PL_sv_no) {
408 sv_catpv(t, "SV_NO");
409 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
410 SVs_GMG|SVs_SMG|SVs_RMG)) &&
411 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
417 else if (sv == &PL_sv_yes) {
418 sv_catpv(t, "SV_YES");
419 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
420 SVs_GMG|SVs_SMG|SVs_RMG)) &&
421 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
424 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
429 sv_catpv(t, "SV_PLACEHOLDER");
430 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
431 SVs_GMG|SVs_SMG|SVs_RMG)) &&
437 else if (SvREFCNT(sv) == 0) {
441 else if (DEBUG_R_TEST_) {
444 /* is this SV on the tmps stack? */
445 for (ix=PL_tmps_ix; ix>=0; ix--) {
446 if (PL_tmps_stack[ix] == sv) {
451 if (SvREFCNT(sv) > 1)
452 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
460 if (SvCUR(t) + unref > 10) {
461 SvCUR_set(t, unref + 3);
470 if (type == SVt_PVCV) {
471 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
473 } else if (type < SVt_LAST) {
474 sv_catpv(t, svshorttypenames[type]);
476 if (type == SVt_NULL)
479 sv_catpv(t, "FREED");
484 if (!SvPVX_const(sv))
485 sv_catpv(t, "(null)");
487 SV * const tmp = newSVpvs("");
490 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
491 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
493 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
494 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
499 else if (SvNOKp(sv)) {
500 STORE_NUMERIC_LOCAL_SET_STANDARD();
501 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
502 RESTORE_NUMERIC_LOCAL();
504 else if (SvIOKp(sv)) {
506 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
508 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
516 return SvPV_nolen(t);
520 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
525 Perl_dump_indent(aTHX_ level, file, "{}\n");
528 Perl_dump_indent(aTHX_ level, file, "{\n");
530 if (pm->op_pmflags & PMf_ONCE)
535 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
536 ch, PM_GETRE(pm)->precomp, ch,
537 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
539 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
540 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
541 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
542 op_dump(pm->op_pmreplrootu.op_pmreplroot);
544 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
545 SV * const tmpsv = pm_description(pm);
546 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
550 Perl_dump_indent(aTHX_ level-1, file, "}\n");
554 S_pm_description(pTHX_ const PMOP *pm)
556 SV * const desc = newSVpvs("");
557 const REGEXP * const regex = PM_GETRE(pm);
558 const U32 pmflags = pm->op_pmflags;
560 if (pmflags & PMf_ONCE)
561 sv_catpv(desc, ",ONCE");
563 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
564 sv_catpv(desc, ":USED");
566 if (pmflags & PMf_USED)
567 sv_catpv(desc, ":USED");
571 if (regex->extflags & RXf_TAINTED)
572 sv_catpv(desc, ",TAINTED");
573 if (regex->check_substr) {
574 if (!(regex->extflags & RXf_NOSCAN))
575 sv_catpv(desc, ",SCANFIRST");
576 if (regex->extflags & RXf_CHECK_ALL)
577 sv_catpv(desc, ",ALL");
579 if (regex->extflags & RXf_SKIPWHITE)
580 sv_catpv(desc, ",SKIPWHITE");
583 if (pmflags & PMf_CONST)
584 sv_catpv(desc, ",CONST");
585 if (pmflags & PMf_KEEP)
586 sv_catpv(desc, ",KEEP");
587 if (pmflags & PMf_GLOBAL)
588 sv_catpv(desc, ",GLOBAL");
589 if (pmflags & PMf_CONTINUE)
590 sv_catpv(desc, ",CONTINUE");
591 if (pmflags & PMf_RETAINT)
592 sv_catpv(desc, ",RETAINT");
593 if (pmflags & PMf_EVAL)
594 sv_catpv(desc, ",EVAL");
599 Perl_pmop_dump(pTHX_ PMOP *pm)
601 do_pmop_dump(0, Perl_debug_log, pm);
604 /* An op sequencer. We visit the ops in the order they're to execute. */
607 S_sequence(pTHX_ register const OP *o)
610 const OP *oldop = NULL;
623 for (; o; o = o->op_next) {
625 SV * const op = newSVuv(PTR2UV(o));
626 const char * const key = SvPV_const(op, len);
628 if (hv_exists(Sequence, key, len))
631 switch (o->op_type) {
633 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
634 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
643 if (oldop && o->op_next)
650 if (oldop && o->op_next)
652 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
665 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
666 sequence_tail(cLOGOPo->op_other);
671 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
672 sequence_tail(cLOOPo->op_redoop);
673 sequence_tail(cLOOPo->op_nextop);
674 sequence_tail(cLOOPo->op_lastop);
678 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
679 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
688 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
696 S_sequence_tail(pTHX_ const OP *o)
698 while (o && (o->op_type == OP_NULL))
704 S_sequence_num(pTHX_ const OP *o)
712 op = newSVuv(PTR2UV(o));
713 key = SvPV_const(op, len);
714 seq = hv_fetch(Sequence, key, len, 0);
715 return seq ? SvUV(*seq): 0;
719 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
723 const OPCODE optype = o->op_type;
726 Perl_dump_indent(aTHX_ level, file, "{\n");
728 seq = sequence_num(o);
730 PerlIO_printf(file, "%-4"UVuf, seq);
732 PerlIO_printf(file, " ");
734 "%*sTYPE = %s ===> ",
735 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
737 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
738 sequence_num(o->op_next));
740 PerlIO_printf(file, "DONE\n");
742 if (optype == OP_NULL) {
743 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
744 if (o->op_targ == OP_NEXTSTATE) {
746 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
748 if (CopSTASHPV(cCOPo))
749 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
751 if (cCOPo->cop_label)
752 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
757 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
760 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
762 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
763 SV * const tmpsv = newSVpvs("");
764 switch (o->op_flags & OPf_WANT) {
766 sv_catpv(tmpsv, ",VOID");
768 case OPf_WANT_SCALAR:
769 sv_catpv(tmpsv, ",SCALAR");
772 sv_catpv(tmpsv, ",LIST");
775 sv_catpv(tmpsv, ",UNKNOWN");
778 if (o->op_flags & OPf_KIDS)
779 sv_catpv(tmpsv, ",KIDS");
780 if (o->op_flags & OPf_PARENS)
781 sv_catpv(tmpsv, ",PARENS");
782 if (o->op_flags & OPf_STACKED)
783 sv_catpv(tmpsv, ",STACKED");
784 if (o->op_flags & OPf_REF)
785 sv_catpv(tmpsv, ",REF");
786 if (o->op_flags & OPf_MOD)
787 sv_catpv(tmpsv, ",MOD");
788 if (o->op_flags & OPf_SPECIAL)
789 sv_catpv(tmpsv, ",SPECIAL");
791 sv_catpv(tmpsv, ",LATEFREE");
793 sv_catpv(tmpsv, ",LATEFREED");
795 sv_catpv(tmpsv, ",ATTACHED");
796 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
800 SV * const tmpsv = newSVpvs("");
801 if (PL_opargs[optype] & OA_TARGLEX) {
802 if (o->op_private & OPpTARGET_MY)
803 sv_catpv(tmpsv, ",TARGET_MY");
805 else if (optype == OP_LEAVESUB ||
806 optype == OP_LEAVE ||
807 optype == OP_LEAVESUBLV ||
808 optype == OP_LEAVEWRITE) {
809 if (o->op_private & OPpREFCOUNTED)
810 sv_catpv(tmpsv, ",REFCOUNTED");
812 else if (optype == OP_AASSIGN) {
813 if (o->op_private & OPpASSIGN_COMMON)
814 sv_catpv(tmpsv, ",COMMON");
816 else if (optype == OP_SASSIGN) {
817 if (o->op_private & OPpASSIGN_BACKWARDS)
818 sv_catpv(tmpsv, ",BACKWARDS");
820 else if (optype == OP_TRANS) {
821 if (o->op_private & OPpTRANS_SQUASH)
822 sv_catpv(tmpsv, ",SQUASH");
823 if (o->op_private & OPpTRANS_DELETE)
824 sv_catpv(tmpsv, ",DELETE");
825 if (o->op_private & OPpTRANS_COMPLEMENT)
826 sv_catpv(tmpsv, ",COMPLEMENT");
827 if (o->op_private & OPpTRANS_IDENTICAL)
828 sv_catpv(tmpsv, ",IDENTICAL");
829 if (o->op_private & OPpTRANS_GROWS)
830 sv_catpv(tmpsv, ",GROWS");
832 else if (optype == OP_REPEAT) {
833 if (o->op_private & OPpREPEAT_DOLIST)
834 sv_catpv(tmpsv, ",DOLIST");
836 else if (optype == OP_ENTERSUB ||
837 optype == OP_RV2SV ||
839 optype == OP_RV2AV ||
840 optype == OP_RV2HV ||
841 optype == OP_RV2GV ||
842 optype == OP_AELEM ||
845 if (optype == OP_ENTERSUB) {
846 if (o->op_private & OPpENTERSUB_AMPER)
847 sv_catpv(tmpsv, ",AMPER");
848 if (o->op_private & OPpENTERSUB_DB)
849 sv_catpv(tmpsv, ",DB");
850 if (o->op_private & OPpENTERSUB_HASTARG)
851 sv_catpv(tmpsv, ",HASTARG");
852 if (o->op_private & OPpENTERSUB_NOPAREN)
853 sv_catpv(tmpsv, ",NOPAREN");
854 if (o->op_private & OPpENTERSUB_INARGS)
855 sv_catpv(tmpsv, ",INARGS");
856 if (o->op_private & OPpENTERSUB_NOMOD)
857 sv_catpv(tmpsv, ",NOMOD");
860 switch (o->op_private & OPpDEREF) {
862 sv_catpv(tmpsv, ",SV");
865 sv_catpv(tmpsv, ",AV");
868 sv_catpv(tmpsv, ",HV");
871 if (o->op_private & OPpMAYBE_LVSUB)
872 sv_catpv(tmpsv, ",MAYBE_LVSUB");
874 if (optype == OP_AELEM || optype == OP_HELEM) {
875 if (o->op_private & OPpLVAL_DEFER)
876 sv_catpv(tmpsv, ",LVAL_DEFER");
879 if (o->op_private & HINT_STRICT_REFS)
880 sv_catpv(tmpsv, ",STRICT_REFS");
881 if (o->op_private & OPpOUR_INTRO)
882 sv_catpv(tmpsv, ",OUR_INTRO");
885 else if (optype == OP_CONST) {
886 if (o->op_private & OPpCONST_BARE)
887 sv_catpv(tmpsv, ",BARE");
888 if (o->op_private & OPpCONST_STRICT)
889 sv_catpv(tmpsv, ",STRICT");
890 if (o->op_private & OPpCONST_ARYBASE)
891 sv_catpv(tmpsv, ",ARYBASE");
892 if (o->op_private & OPpCONST_WARNING)
893 sv_catpv(tmpsv, ",WARNING");
894 if (o->op_private & OPpCONST_ENTERED)
895 sv_catpv(tmpsv, ",ENTERED");
897 else if (optype == OP_FLIP) {
898 if (o->op_private & OPpFLIP_LINENUM)
899 sv_catpv(tmpsv, ",LINENUM");
901 else if (optype == OP_FLOP) {
902 if (o->op_private & OPpFLIP_LINENUM)
903 sv_catpv(tmpsv, ",LINENUM");
905 else if (optype == OP_RV2CV) {
906 if (o->op_private & OPpLVAL_INTRO)
907 sv_catpv(tmpsv, ",INTRO");
909 else if (optype == OP_GV) {
910 if (o->op_private & OPpEARLY_CV)
911 sv_catpv(tmpsv, ",EARLY_CV");
913 else if (optype == OP_LIST) {
914 if (o->op_private & OPpLIST_GUESSED)
915 sv_catpv(tmpsv, ",GUESSED");
917 else if (optype == OP_DELETE) {
918 if (o->op_private & OPpSLICE)
919 sv_catpv(tmpsv, ",SLICE");
921 else if (optype == OP_EXISTS) {
922 if (o->op_private & OPpEXISTS_SUB)
923 sv_catpv(tmpsv, ",EXISTS_SUB");
925 else if (optype == OP_SORT) {
926 if (o->op_private & OPpSORT_NUMERIC)
927 sv_catpv(tmpsv, ",NUMERIC");
928 if (o->op_private & OPpSORT_INTEGER)
929 sv_catpv(tmpsv, ",INTEGER");
930 if (o->op_private & OPpSORT_REVERSE)
931 sv_catpv(tmpsv, ",REVERSE");
933 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
934 if (o->op_private & OPpOPEN_IN_RAW)
935 sv_catpv(tmpsv, ",IN_RAW");
936 if (o->op_private & OPpOPEN_IN_CRLF)
937 sv_catpv(tmpsv, ",IN_CRLF");
938 if (o->op_private & OPpOPEN_OUT_RAW)
939 sv_catpv(tmpsv, ",OUT_RAW");
940 if (o->op_private & OPpOPEN_OUT_CRLF)
941 sv_catpv(tmpsv, ",OUT_CRLF");
943 else if (optype == OP_EXIT) {
944 if (o->op_private & OPpEXIT_VMSISH)
945 sv_catpv(tmpsv, ",EXIT_VMSISH");
946 if (o->op_private & OPpHUSH_VMSISH)
947 sv_catpv(tmpsv, ",HUSH_VMSISH");
949 else if (optype == OP_DIE) {
950 if (o->op_private & OPpHUSH_VMSISH)
951 sv_catpv(tmpsv, ",HUSH_VMSISH");
953 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
954 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
955 sv_catpv(tmpsv, ",FT_ACCESS");
956 if (o->op_private & OPpFT_STACKED)
957 sv_catpv(tmpsv, ",FT_STACKED");
959 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
960 sv_catpv(tmpsv, ",INTRO");
962 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
967 if (PL_madskills && o->op_madprop) {
968 SV * const tmpsv = newSVpvn("", 0);
969 MADPROP* mp = o->op_madprop;
970 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
973 const char tmp = mp->mad_key;
974 sv_setpvn(tmpsv,"'",1);
976 sv_catpvn(tmpsv, &tmp, 1);
977 sv_catpv(tmpsv, "'=");
978 switch (mp->mad_type) {
980 sv_catpv(tmpsv, "NULL");
981 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
984 sv_catpv(tmpsv, "<");
985 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
986 sv_catpv(tmpsv, ">");
987 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
990 if ((OP*)mp->mad_val) {
991 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
992 do_op_dump(level, file, (OP*)mp->mad_val);
996 sv_catpv(tmpsv, "(UNK)");
997 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1003 Perl_dump_indent(aTHX_ level, file, "}\n");
1005 SvREFCNT_dec(tmpsv);
1014 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1016 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1017 if (cSVOPo->op_sv) {
1018 SV * const tmpsv = newSV(0);
1022 /* FIXME - is this making unwarranted assumptions about the
1023 UTF-8 cleanliness of the dump file handle? */
1026 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1027 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1028 SvPV_nolen_const(tmpsv));
1032 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1037 case OP_METHOD_NAMED:
1038 #ifndef USE_ITHREADS
1039 /* with ITHREADS, consts are stored in the pad, and the right pad
1040 * may not be active here, so skip */
1041 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1048 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1049 (UV)CopLINE(cCOPo));
1050 if (CopSTASHPV(cCOPo))
1051 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1053 if (cCOPo->cop_label)
1054 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1058 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1059 if (cLOOPo->op_redoop)
1060 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1062 PerlIO_printf(file, "DONE\n");
1063 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1064 if (cLOOPo->op_nextop)
1065 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1067 PerlIO_printf(file, "DONE\n");
1068 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1069 if (cLOOPo->op_lastop)
1070 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1072 PerlIO_printf(file, "DONE\n");
1080 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1081 if (cLOGOPo->op_other)
1082 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1084 PerlIO_printf(file, "DONE\n");
1090 do_pmop_dump(level, file, cPMOPo);
1098 if (o->op_private & OPpREFCOUNTED)
1099 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1104 if (o->op_flags & OPf_KIDS) {
1106 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1107 do_op_dump(level, file, kid);
1109 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1113 Perl_op_dump(pTHX_ const OP *o)
1115 do_op_dump(0, Perl_debug_log, o);
1119 Perl_gv_dump(pTHX_ GV *gv)
1124 PerlIO_printf(Perl_debug_log, "{}\n");
1127 sv = sv_newmortal();
1128 PerlIO_printf(Perl_debug_log, "{\n");
1129 gv_fullname3(sv, gv, NULL);
1130 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1131 if (gv != GvEGV(gv)) {
1132 gv_efullname3(sv, GvEGV(gv), NULL);
1133 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1135 PerlIO_putc(Perl_debug_log, '\n');
1136 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1140 /* map magic types to the symbolic names
1141 * (with the PERL_MAGIC_ prefixed stripped)
1144 static const struct { const char type; const char *name; } magic_names[] = {
1145 { PERL_MAGIC_sv, "sv(\\0)" },
1146 { PERL_MAGIC_arylen, "arylen(#)" },
1147 { PERL_MAGIC_rhash, "rhash(%)" },
1148 { PERL_MAGIC_pos, "pos(.)" },
1149 { PERL_MAGIC_symtab, "symtab(:)" },
1150 { PERL_MAGIC_backref, "backref(<)" },
1151 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1152 { PERL_MAGIC_overload, "overload(A)" },
1153 { PERL_MAGIC_bm, "bm(B)" },
1154 { PERL_MAGIC_regdata, "regdata(D)" },
1155 { PERL_MAGIC_env, "env(E)" },
1156 { PERL_MAGIC_hints, "hints(H)" },
1157 { PERL_MAGIC_isa, "isa(I)" },
1158 { PERL_MAGIC_dbfile, "dbfile(L)" },
1159 { PERL_MAGIC_shared, "shared(N)" },
1160 { PERL_MAGIC_tied, "tied(P)" },
1161 { PERL_MAGIC_sig, "sig(S)" },
1162 { PERL_MAGIC_uvar, "uvar(U)" },
1163 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1164 { PERL_MAGIC_overload_table, "overload_table(c)" },
1165 { PERL_MAGIC_regdatum, "regdatum(d)" },
1166 { PERL_MAGIC_envelem, "envelem(e)" },
1167 { PERL_MAGIC_fm, "fm(f)" },
1168 { PERL_MAGIC_regex_global, "regex_global(g)" },
1169 { PERL_MAGIC_hintselem, "hintselem(h)" },
1170 { PERL_MAGIC_isaelem, "isaelem(i)" },
1171 { PERL_MAGIC_nkeys, "nkeys(k)" },
1172 { PERL_MAGIC_dbline, "dbline(l)" },
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 const regexp * const re = (regexp *)mg->mg_obj;
1276 SV * const 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_ELLIPSES |
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 * const 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 const STRLEN * const 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,");
1441 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1442 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1443 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1444 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1445 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1449 if (isGV_with_GP(sv)) {
1450 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1451 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1452 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1453 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1454 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1456 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1457 sv_catpv(d, "IMPORT");
1458 if (GvIMPORTED(sv) == GVf_IMPORTED)
1459 sv_catpv(d, "ALL,");
1462 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1463 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1464 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1465 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1469 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1470 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1474 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1475 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1478 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1479 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1482 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1487 /* SVphv_SHAREKEYS is also 0x20000000 */
1488 if ((type != SVt_PVHV) && SvUTF8(sv))
1489 sv_catpv(d, "UTF8");
1491 if (*(SvEND(d) - 1) == ',') {
1492 SvCUR_set(d, SvCUR(d) - 1);
1493 SvPVX(d)[SvCUR(d)] = '\0';
1498 #ifdef DEBUG_LEAKING_SCALARS
1499 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1500 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1502 sv->sv_debug_inpad ? "for" : "by",
1503 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1504 sv->sv_debug_cloned ? " (cloned)" : "");
1506 Perl_dump_indent(aTHX_ level, file, "SV = ");
1507 if (type < SVt_LAST) {
1508 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1510 if (type == SVt_NULL) {
1515 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1519 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1520 && type != SVt_PVCV && !isGV_with_GP(sv))
1521 || type == SVt_IV) {
1523 #ifdef PERL_OLD_COPY_ON_WRITE
1527 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1529 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1531 PerlIO_printf(file, " (OFFSET)");
1532 #ifdef PERL_OLD_COPY_ON_WRITE
1533 if (SvIsCOW_shared_hash(sv))
1534 PerlIO_printf(file, " (HASH)");
1535 else if (SvIsCOW_normal(sv))
1536 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1538 PerlIO_putc(file, '\n');
1540 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1541 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1542 (UV) COP_SEQ_RANGE_LOW(sv));
1543 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1544 (UV) COP_SEQ_RANGE_HIGH(sv));
1545 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1546 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)
1548 || type == SVt_NV) {
1549 STORE_NUMERIC_LOCAL_SET_STANDARD();
1550 /* %Vg doesn't work? --jhi */
1551 #ifdef USE_LONG_DOUBLE
1552 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1554 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1556 RESTORE_NUMERIC_LOCAL();
1559 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1561 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1563 if (type < SVt_PV) {
1567 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1568 if (SvPVX_const(sv)) {
1569 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1571 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1572 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1573 if (SvUTF8(sv)) /* the 6? \x{....} */
1574 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1575 PerlIO_printf(file, "\n");
1576 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1577 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1580 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1582 if (type >= SVt_PVMG) {
1583 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1584 HV * const ost = SvOURSTASH(sv);
1586 do_hv_dump(level, file, " OURSTASH", ost);
1589 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1592 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1596 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1597 if (AvARRAY(sv) != AvALLOC(sv)) {
1598 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1599 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1602 PerlIO_putc(file, '\n');
1603 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1604 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1605 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1606 sv_setpvn(d, "", 0);
1607 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1608 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1609 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1610 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1611 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1613 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1614 SV** const elt = av_fetch((AV*)sv,count,0);
1616 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1618 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1623 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1624 if (HvARRAY(sv) && HvKEYS(sv)) {
1625 /* Show distribution of HEs in the ARRAY */
1627 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1630 U32 pow2 = 2, keys = HvKEYS(sv);
1631 NV theoret, sum = 0;
1633 PerlIO_printf(file, " (");
1634 Zero(freq, FREQ_MAX + 1, int);
1635 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1638 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1640 if (count > FREQ_MAX)
1646 for (i = 0; i <= max; i++) {
1648 PerlIO_printf(file, "%d%s:%d", i,
1649 (i == FREQ_MAX) ? "+" : "",
1652 PerlIO_printf(file, ", ");
1655 PerlIO_putc(file, ')');
1656 /* The "quality" of a hash is defined as the total number of
1657 comparisons needed to access every element once, relative
1658 to the expected number needed for a random hash.
1660 The total number of comparisons is equal to the sum of
1661 the squares of the number of entries in each bucket.
1662 For a random hash of n keys into k buckets, the expected
1667 for (i = max; i > 0; i--) { /* Precision: count down. */
1668 sum += freq[i] * i * i;
1670 while ((keys = keys >> 1))
1672 theoret = HvKEYS(sv);
1673 theoret += theoret * (theoret-1)/pow2;
1674 PerlIO_putc(file, '\n');
1675 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1677 PerlIO_putc(file, '\n');
1678 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1679 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1680 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1681 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1682 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1684 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1685 if (mg && mg->mg_obj) {
1686 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1690 const char * const hvname = HvNAME_get(sv);
1692 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1695 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1697 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1699 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1703 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1705 HV * const hv = (HV*)sv;
1706 int count = maxnest - nest;
1709 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1712 const U32 hash = HeHASH(he);
1713 SV * const keysv = hv_iterkeysv(he);
1714 const char * const keypv = SvPV_const(keysv, len);
1715 SV * const elt = hv_iterval(hv, he);
1717 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1719 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1721 PerlIO_printf(file, "[REHASH] ");
1722 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1723 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1725 hv_iterinit(hv); /* Return to status quo */
1731 const char *const proto = SvPV_const(sv, len);
1732 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1737 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1738 if (!CvISXSUB(sv)) {
1740 Perl_dump_indent(aTHX_ level, file,
1741 " START = 0x%"UVxf" ===> %"IVdf"\n",
1742 PTR2UV(CvSTART(sv)),
1743 (IV)sequence_num(CvSTART(sv)));
1745 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1746 PTR2UV(CvROOT(sv)));
1747 if (CvROOT(sv) && dumpops) {
1748 do_op_dump(level+1, file, CvROOT(sv));
1751 SV * const constant = cv_const_sv((CV *)sv);
1753 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1756 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1758 PTR2UV(CvXSUBANY(sv).any_ptr));
1759 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1762 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1763 (IV)CvXSUBANY(sv).any_i32);
1766 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1767 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1768 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1769 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1770 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1771 if (type == SVt_PVFM)
1772 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1773 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1774 if (nest < maxnest) {
1775 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1778 const CV * const outside = CvOUTSIDE(sv);
1779 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1782 : CvANON(outside) ? "ANON"
1783 : (outside == PL_main_cv) ? "MAIN"
1784 : CvUNIQUE(outside) ? "UNIQUE"
1785 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1787 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1788 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1792 if (type == SVt_PVLV) {
1793 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1794 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1795 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1796 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1797 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1798 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1802 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1803 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1804 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1805 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1807 if (!isGV_with_GP(sv))
1809 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1810 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1811 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1812 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1815 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1816 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1817 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1818 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1819 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1820 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1821 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1822 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1823 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1824 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1825 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1826 do_gv_dump (level, file, " EGV", GvEGV(sv));
1829 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1830 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1831 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1832 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1833 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1834 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1835 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1837 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1838 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1839 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1841 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1842 PTR2UV(IoTOP_GV(sv)));
1843 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1846 /* Source filters hide things that are not GVs in these three, so let's
1847 be careful out there. */
1849 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1850 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1851 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1853 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1854 PTR2UV(IoFMT_GV(sv)));
1855 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1858 if (IoBOTTOM_NAME(sv))
1859 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1860 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1861 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1863 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1864 PTR2UV(IoBOTTOM_GV(sv)));
1865 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1868 if (isPRINT(IoTYPE(sv)))
1869 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1871 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1872 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1879 Perl_sv_dump(pTHX_ SV *sv)
1882 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1886 Perl_runops_debug(pTHX)
1890 if (ckWARN_d(WARN_DEBUGGING))
1891 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1895 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1899 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1900 PerlIO_printf(Perl_debug_log,
1901 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1902 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1903 PTR2UV(*PL_watchaddr));
1904 if (DEBUG_s_TEST_) {
1905 if (DEBUG_v_TEST_) {
1906 PerlIO_printf(Perl_debug_log, "\n");
1914 if (DEBUG_t_TEST_) debop(PL_op);
1915 if (DEBUG_P_TEST_) debprof(PL_op);
1917 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1918 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1925 Perl_debop(pTHX_ const OP *o)
1928 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1931 Perl_deb(aTHX_ "%s", OP_NAME(o));
1932 switch (o->op_type) {
1934 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1939 SV * const sv = newSV(0);
1941 /* FIXME - is this making unwarranted assumptions about the
1942 UTF-8 cleanliness of the dump file handle? */
1945 gv_fullname3(sv, cGVOPo_gv, NULL);
1946 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1950 PerlIO_printf(Perl_debug_log, "(NULL)");
1956 /* print the lexical's name */
1957 CV * const cv = deb_curcv(cxstack_ix);
1960 AV * const padlist = CvPADLIST(cv);
1961 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1962 sv = *av_fetch(comppad, o->op_targ, FALSE);
1966 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1968 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1974 PerlIO_printf(Perl_debug_log, "\n");
1979 S_deb_curcv(pTHX_ const I32 ix)
1982 const PERL_CONTEXT * const cx = &cxstack[ix];
1983 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1984 return cx->blk_sub.cv;
1985 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1987 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1992 return deb_curcv(ix - 1);
1996 Perl_watch(pTHX_ char **addr)
1999 PL_watchaddr = addr;
2001 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2002 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2006 S_debprof(pTHX_ const OP *o)
2009 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2011 if (!PL_profiledata)
2012 Newxz(PL_profiledata, MAXO, U32);
2013 ++PL_profiledata[o->op_type];
2017 Perl_debprofdump(pTHX)
2021 if (!PL_profiledata)
2023 for (i = 0; i < MAXO; i++) {
2024 if (PL_profiledata[i])
2025 PerlIO_printf(Perl_debug_log,
2026 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2033 * XML variants of most of the above routines
2037 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2040 PerlIO_printf(file, "\n ");
2041 va_start(args, pat);
2042 xmldump_vindent(level, file, pat, &args);
2048 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2051 va_start(args, pat);
2052 xmldump_vindent(level, file, pat, &args);
2057 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2059 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2060 PerlIO_vprintf(file, pat, *args);
2064 Perl_xmldump_all(pTHX)
2066 PerlIO_setlinebuf(PL_xmlfp);
2068 op_xmldump(PL_main_root);
2069 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2070 PerlIO_close(PL_xmlfp);
2075 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2080 if (!HvARRAY(stash))
2082 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2083 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2084 GV *gv = (GV*)HeVAL(entry);
2086 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2092 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2093 && (hv = GvHV(gv)) && hv != PL_defstash)
2094 xmldump_packsubs(hv); /* nested package */
2100 Perl_xmldump_sub(pTHX_ const GV *gv)
2102 SV * const sv = sv_newmortal();
2104 gv_fullname3(sv, gv, Nullch);
2105 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2106 if (CvXSUB(GvCV(gv)))
2107 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2108 PTR2UV(CvXSUB(GvCV(gv))),
2109 (int)CvXSUBANY(GvCV(gv)).any_i32);
2110 else if (CvROOT(GvCV(gv)))
2111 op_xmldump(CvROOT(GvCV(gv)));
2113 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2117 Perl_xmldump_form(pTHX_ const GV *gv)
2119 SV * const sv = sv_newmortal();
2121 gv_fullname3(sv, gv, Nullch);
2122 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2123 if (CvROOT(GvFORM(gv)))
2124 op_xmldump(CvROOT(GvFORM(gv)));
2126 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2130 Perl_xmldump_eval(pTHX)
2132 op_xmldump(PL_eval_root);
2136 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2138 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2142 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2145 const char * const e = pv + len;
2146 const char * const start = pv;
2150 sv_catpvn(dsv,"",0);
2151 dsvcur = SvCUR(dsv); /* in case we have to restart */
2156 c = utf8_to_uvchr((U8*)pv, &cl);
2158 SvCUR(dsv) = dsvcur;
2223 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2226 Perl_sv_catpvf(aTHX_ dsv, "<");
2229 Perl_sv_catpvf(aTHX_ dsv, ">");
2232 Perl_sv_catpvf(aTHX_ dsv, "&");
2235 Perl_sv_catpvf(aTHX_ dsv, """);
2239 if (c < 32 || c > 127) {
2240 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2243 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2247 if ((c >= 0xD800 && c <= 0xDB7F) ||
2248 (c >= 0xDC00 && c <= 0xDFFF) ||
2249 (c >= 0xFFF0 && c <= 0xFFFF) ||
2251 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2253 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2266 Perl_sv_xmlpeek(pTHX_ SV *sv)
2268 SV * const t = sv_newmortal();
2273 sv_setpvn(t, "", 0);
2276 sv_catpv(t, "VOID=\"\"");
2279 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2280 sv_catpv(t, "WILD=\"\"");
2283 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2284 if (sv == &PL_sv_undef) {
2285 sv_catpv(t, "SV_UNDEF=\"1\"");
2286 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2287 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2291 else if (sv == &PL_sv_no) {
2292 sv_catpv(t, "SV_NO=\"1\"");
2293 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2294 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2295 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2296 SVp_POK|SVp_NOK)) &&
2301 else if (sv == &PL_sv_yes) {
2302 sv_catpv(t, "SV_YES=\"1\"");
2303 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2304 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2305 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2306 SVp_POK|SVp_NOK)) &&
2308 SvPVX(sv) && *SvPVX(sv) == '1' &&
2313 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2314 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2315 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2319 sv_catpv(t, " XXX=\"\" ");
2321 else if (SvREFCNT(sv) == 0) {
2322 sv_catpv(t, " refcnt=\"0\"");
2325 else if (DEBUG_R_TEST_) {
2328 /* is this SV on the tmps stack? */
2329 for (ix=PL_tmps_ix; ix>=0; ix--) {
2330 if (PL_tmps_stack[ix] == sv) {
2335 if (SvREFCNT(sv) > 1)
2336 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2339 sv_catpv(t, " DRT=\"<T>\"");
2343 sv_catpv(t, " ROK=\"\"");
2345 switch (SvTYPE(sv)) {
2347 sv_catpv(t, " FREED=\"1\"");
2351 sv_catpv(t, " UNDEF=\"1\"");
2354 sv_catpv(t, " IV=\"");
2357 sv_catpv(t, " NV=\"");
2360 sv_catpv(t, " RV=\"");
2363 sv_catpv(t, " PV=\"");
2366 sv_catpv(t, " PVIV=\"");
2369 sv_catpv(t, " PVNV=\"");
2372 sv_catpv(t, " PVMG=\"");
2375 sv_catpv(t, " PVLV=\"");
2378 sv_catpv(t, " AV=\"");
2381 sv_catpv(t, " HV=\"");
2385 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2387 sv_catpv(t, " CV=\"()\"");
2390 sv_catpv(t, " GV=\"");
2393 sv_catpv(t, " BIND=\"");
2396 sv_catpv(t, " FM=\"");
2399 sv_catpv(t, " IO=\"");
2408 else if (SvNOKp(sv)) {
2409 STORE_NUMERIC_LOCAL_SET_STANDARD();
2410 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2411 RESTORE_NUMERIC_LOCAL();
2413 else if (SvIOKp(sv)) {
2415 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2417 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2426 return SvPV(t, n_a);
2430 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2433 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2436 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2439 const char * const s = PM_GETRE(pm)->precomp;
2440 SV * const tmpsv = newSVpvn("",0);
2442 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2443 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2445 SvREFCNT_dec(tmpsv);
2446 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2447 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2450 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2451 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2452 SV * const tmpsv = pm_description(pm);
2453 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2454 SvREFCNT_dec(tmpsv);
2458 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2459 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2460 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2461 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2462 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2463 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2466 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2470 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2472 do_pmop_xmldump(0, PL_xmlfp, pm);
2476 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2483 seq = sequence_num(o);
2484 Perl_xmldump_indent(aTHX_ level, file,
2485 "<op_%s seq=\"%"UVuf" -> ",
2490 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2491 sequence_num(o->op_next));
2493 PerlIO_printf(file, "DONE\"");
2496 if (o->op_type == OP_NULL)
2498 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2499 if (o->op_targ == OP_NEXTSTATE)
2502 PerlIO_printf(file, " line=\"%"UVuf"\"",
2503 (UV)CopLINE(cCOPo));
2504 if (CopSTASHPV(cCOPo))
2505 PerlIO_printf(file, " package=\"%s\"",
2507 if (cCOPo->cop_label)
2508 PerlIO_printf(file, " label=\"%s\"",
2513 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2516 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2519 SV * const tmpsv = newSVpvn("", 0);
2520 switch (o->op_flags & OPf_WANT) {
2522 sv_catpv(tmpsv, ",VOID");
2524 case OPf_WANT_SCALAR:
2525 sv_catpv(tmpsv, ",SCALAR");
2528 sv_catpv(tmpsv, ",LIST");
2531 sv_catpv(tmpsv, ",UNKNOWN");
2534 if (o->op_flags & OPf_KIDS)
2535 sv_catpv(tmpsv, ",KIDS");
2536 if (o->op_flags & OPf_PARENS)
2537 sv_catpv(tmpsv, ",PARENS");
2538 if (o->op_flags & OPf_STACKED)
2539 sv_catpv(tmpsv, ",STACKED");
2540 if (o->op_flags & OPf_REF)
2541 sv_catpv(tmpsv, ",REF");
2542 if (o->op_flags & OPf_MOD)
2543 sv_catpv(tmpsv, ",MOD");
2544 if (o->op_flags & OPf_SPECIAL)
2545 sv_catpv(tmpsv, ",SPECIAL");
2546 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2547 SvREFCNT_dec(tmpsv);
2549 if (o->op_private) {
2550 SV * const tmpsv = newSVpvn("", 0);
2551 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2552 if (o->op_private & OPpTARGET_MY)
2553 sv_catpv(tmpsv, ",TARGET_MY");
2555 else if (o->op_type == OP_LEAVESUB ||
2556 o->op_type == OP_LEAVE ||
2557 o->op_type == OP_LEAVESUBLV ||
2558 o->op_type == OP_LEAVEWRITE) {
2559 if (o->op_private & OPpREFCOUNTED)
2560 sv_catpv(tmpsv, ",REFCOUNTED");
2562 else if (o->op_type == OP_AASSIGN) {
2563 if (o->op_private & OPpASSIGN_COMMON)
2564 sv_catpv(tmpsv, ",COMMON");
2566 else if (o->op_type == OP_SASSIGN) {
2567 if (o->op_private & OPpASSIGN_BACKWARDS)
2568 sv_catpv(tmpsv, ",BACKWARDS");
2570 else if (o->op_type == OP_TRANS) {
2571 if (o->op_private & OPpTRANS_SQUASH)
2572 sv_catpv(tmpsv, ",SQUASH");
2573 if (o->op_private & OPpTRANS_DELETE)
2574 sv_catpv(tmpsv, ",DELETE");
2575 if (o->op_private & OPpTRANS_COMPLEMENT)
2576 sv_catpv(tmpsv, ",COMPLEMENT");
2577 if (o->op_private & OPpTRANS_IDENTICAL)
2578 sv_catpv(tmpsv, ",IDENTICAL");
2579 if (o->op_private & OPpTRANS_GROWS)
2580 sv_catpv(tmpsv, ",GROWS");
2582 else if (o->op_type == OP_REPEAT) {
2583 if (o->op_private & OPpREPEAT_DOLIST)
2584 sv_catpv(tmpsv, ",DOLIST");
2586 else if (o->op_type == OP_ENTERSUB ||
2587 o->op_type == OP_RV2SV ||
2588 o->op_type == OP_GVSV ||
2589 o->op_type == OP_RV2AV ||
2590 o->op_type == OP_RV2HV ||
2591 o->op_type == OP_RV2GV ||
2592 o->op_type == OP_AELEM ||
2593 o->op_type == OP_HELEM )
2595 if (o->op_type == OP_ENTERSUB) {
2596 if (o->op_private & OPpENTERSUB_AMPER)
2597 sv_catpv(tmpsv, ",AMPER");
2598 if (o->op_private & OPpENTERSUB_DB)
2599 sv_catpv(tmpsv, ",DB");
2600 if (o->op_private & OPpENTERSUB_HASTARG)
2601 sv_catpv(tmpsv, ",HASTARG");
2602 if (o->op_private & OPpENTERSUB_NOPAREN)
2603 sv_catpv(tmpsv, ",NOPAREN");
2604 if (o->op_private & OPpENTERSUB_INARGS)
2605 sv_catpv(tmpsv, ",INARGS");
2606 if (o->op_private & OPpENTERSUB_NOMOD)
2607 sv_catpv(tmpsv, ",NOMOD");
2610 switch (o->op_private & OPpDEREF) {
2612 sv_catpv(tmpsv, ",SV");
2615 sv_catpv(tmpsv, ",AV");
2618 sv_catpv(tmpsv, ",HV");
2621 if (o->op_private & OPpMAYBE_LVSUB)
2622 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2624 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2625 if (o->op_private & OPpLVAL_DEFER)
2626 sv_catpv(tmpsv, ",LVAL_DEFER");
2629 if (o->op_private & HINT_STRICT_REFS)
2630 sv_catpv(tmpsv, ",STRICT_REFS");
2631 if (o->op_private & OPpOUR_INTRO)
2632 sv_catpv(tmpsv, ",OUR_INTRO");
2635 else if (o->op_type == OP_CONST) {
2636 if (o->op_private & OPpCONST_BARE)
2637 sv_catpv(tmpsv, ",BARE");
2638 if (o->op_private & OPpCONST_STRICT)
2639 sv_catpv(tmpsv, ",STRICT");
2640 if (o->op_private & OPpCONST_ARYBASE)
2641 sv_catpv(tmpsv, ",ARYBASE");
2642 if (o->op_private & OPpCONST_WARNING)
2643 sv_catpv(tmpsv, ",WARNING");
2644 if (o->op_private & OPpCONST_ENTERED)
2645 sv_catpv(tmpsv, ",ENTERED");
2647 else if (o->op_type == OP_FLIP) {
2648 if (o->op_private & OPpFLIP_LINENUM)
2649 sv_catpv(tmpsv, ",LINENUM");
2651 else if (o->op_type == OP_FLOP) {
2652 if (o->op_private & OPpFLIP_LINENUM)
2653 sv_catpv(tmpsv, ",LINENUM");
2655 else if (o->op_type == OP_RV2CV) {
2656 if (o->op_private & OPpLVAL_INTRO)
2657 sv_catpv(tmpsv, ",INTRO");
2659 else if (o->op_type == OP_GV) {
2660 if (o->op_private & OPpEARLY_CV)
2661 sv_catpv(tmpsv, ",EARLY_CV");
2663 else if (o->op_type == OP_LIST) {
2664 if (o->op_private & OPpLIST_GUESSED)
2665 sv_catpv(tmpsv, ",GUESSED");
2667 else if (o->op_type == OP_DELETE) {
2668 if (o->op_private & OPpSLICE)
2669 sv_catpv(tmpsv, ",SLICE");
2671 else if (o->op_type == OP_EXISTS) {
2672 if (o->op_private & OPpEXISTS_SUB)
2673 sv_catpv(tmpsv, ",EXISTS_SUB");
2675 else if (o->op_type == OP_SORT) {
2676 if (o->op_private & OPpSORT_NUMERIC)
2677 sv_catpv(tmpsv, ",NUMERIC");
2678 if (o->op_private & OPpSORT_INTEGER)
2679 sv_catpv(tmpsv, ",INTEGER");
2680 if (o->op_private & OPpSORT_REVERSE)
2681 sv_catpv(tmpsv, ",REVERSE");
2683 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2684 if (o->op_private & OPpOPEN_IN_RAW)
2685 sv_catpv(tmpsv, ",IN_RAW");
2686 if (o->op_private & OPpOPEN_IN_CRLF)
2687 sv_catpv(tmpsv, ",IN_CRLF");
2688 if (o->op_private & OPpOPEN_OUT_RAW)
2689 sv_catpv(tmpsv, ",OUT_RAW");
2690 if (o->op_private & OPpOPEN_OUT_CRLF)
2691 sv_catpv(tmpsv, ",OUT_CRLF");
2693 else if (o->op_type == OP_EXIT) {
2694 if (o->op_private & OPpEXIT_VMSISH)
2695 sv_catpv(tmpsv, ",EXIT_VMSISH");
2696 if (o->op_private & OPpHUSH_VMSISH)
2697 sv_catpv(tmpsv, ",HUSH_VMSISH");
2699 else if (o->op_type == OP_DIE) {
2700 if (o->op_private & OPpHUSH_VMSISH)
2701 sv_catpv(tmpsv, ",HUSH_VMSISH");
2703 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2704 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2705 sv_catpv(tmpsv, ",FT_ACCESS");
2706 if (o->op_private & OPpFT_STACKED)
2707 sv_catpv(tmpsv, ",FT_STACKED");
2709 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2710 sv_catpv(tmpsv, ",INTRO");
2712 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2713 SvREFCNT_dec(tmpsv);
2716 switch (o->op_type) {
2718 if (o->op_flags & OPf_SPECIAL) {
2724 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2726 if (cSVOPo->op_sv) {
2727 SV * const tmpsv1 = newSV(0);
2728 SV * const tmpsv2 = newSVpvn("",0);
2736 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2737 s = SvPV(tmpsv1,len);
2738 sv_catxmlpvn(tmpsv2, s, len, 1);
2739 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2743 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2747 case OP_METHOD_NAMED:
2748 #ifndef USE_ITHREADS
2749 /* with ITHREADS, consts are stored in the pad, and the right pad
2750 * may not be active here, so skip */
2751 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2757 PerlIO_printf(file, ">\n");
2759 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2765 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2766 (UV)CopLINE(cCOPo));
2767 if (CopSTASHPV(cCOPo))
2768 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2770 if (cCOPo->cop_label)
2771 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2775 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2776 if (cLOOPo->op_redoop)
2777 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2779 PerlIO_printf(file, "DONE\"");
2780 S_xmldump_attr(aTHX_ level, file, "next=\"");
2781 if (cLOOPo->op_nextop)
2782 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2784 PerlIO_printf(file, "DONE\"");
2785 S_xmldump_attr(aTHX_ level, file, "last=\"");
2786 if (cLOOPo->op_lastop)
2787 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2789 PerlIO_printf(file, "DONE\"");
2797 S_xmldump_attr(aTHX_ level, file, "other=\"");
2798 if (cLOGOPo->op_other)
2799 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2801 PerlIO_printf(file, "DONE\"");
2809 if (o->op_private & OPpREFCOUNTED)
2810 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2816 if (PL_madskills && o->op_madprop) {
2817 char prevkey = '\0';
2818 SV * const tmpsv = newSVpvn("", 0);
2819 const MADPROP* mp = o->op_madprop;
2821 sv_utf8_upgrade(tmpsv);
2824 PerlIO_printf(file, ">\n");
2826 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2829 char tmp = mp->mad_key;
2830 sv_setpvn(tmpsv,"\"",1);
2832 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2833 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2834 sv_catxmlpvn(tmpsv, &prevkey, 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: