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 elipses.
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_ELIPSES flag is set and not all characters in
307 string were output then an elipses 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 elipses.
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_ELIPSES) && ( 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, 8 * sv_len_utf8(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 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
643 if (oldop && o->op_next)
650 if (oldop && o->op_next)
652 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
665 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
666 sequence_tail(cLOGOPo->op_other);
671 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 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
679 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
688 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_mutex, "mutex(m)" },
1174 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1175 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1176 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1177 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1178 { PERL_MAGIC_qr, "qr(r)" },
1179 { PERL_MAGIC_sigelem, "sigelem(s)" },
1180 { PERL_MAGIC_taint, "taint(t)" },
1181 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1182 { PERL_MAGIC_vec, "vec(v)" },
1183 { PERL_MAGIC_vstring, "vstring(V)" },
1184 { PERL_MAGIC_utf8, "utf8(w)" },
1185 { PERL_MAGIC_substr, "substr(x)" },
1186 { PERL_MAGIC_defelem, "defelem(y)" },
1187 { PERL_MAGIC_ext, "ext(~)" },
1188 /* this null string terminates the list */
1193 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1195 for (; mg; mg = mg->mg_moremagic) {
1196 Perl_dump_indent(aTHX_ level, file,
1197 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1198 if (mg->mg_virtual) {
1199 const MGVTBL * const v = mg->mg_virtual;
1201 if (v == &PL_vtbl_sv) s = "sv";
1202 else if (v == &PL_vtbl_env) s = "env";
1203 else if (v == &PL_vtbl_envelem) s = "envelem";
1204 else if (v == &PL_vtbl_sig) s = "sig";
1205 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1206 else if (v == &PL_vtbl_pack) s = "pack";
1207 else if (v == &PL_vtbl_packelem) s = "packelem";
1208 else if (v == &PL_vtbl_dbline) s = "dbline";
1209 else if (v == &PL_vtbl_isa) s = "isa";
1210 else if (v == &PL_vtbl_arylen) s = "arylen";
1211 else if (v == &PL_vtbl_mglob) s = "mglob";
1212 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1213 else if (v == &PL_vtbl_taint) s = "taint";
1214 else if (v == &PL_vtbl_substr) s = "substr";
1215 else if (v == &PL_vtbl_vec) s = "vec";
1216 else if (v == &PL_vtbl_pos) s = "pos";
1217 else if (v == &PL_vtbl_bm) s = "bm";
1218 else if (v == &PL_vtbl_fm) s = "fm";
1219 else if (v == &PL_vtbl_uvar) s = "uvar";
1220 else if (v == &PL_vtbl_defelem) s = "defelem";
1221 #ifdef USE_LOCALE_COLLATE
1222 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1224 else if (v == &PL_vtbl_amagic) s = "amagic";
1225 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1226 else if (v == &PL_vtbl_backref) s = "backref";
1227 else if (v == &PL_vtbl_utf8) s = "utf8";
1228 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1229 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1232 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1234 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1237 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1240 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1244 const char *name = NULL;
1245 for (n = 0; magic_names[n].name; n++) {
1246 if (mg->mg_type == magic_names[n].type) {
1247 name = magic_names[n].name;
1252 Perl_dump_indent(aTHX_ level, file,
1253 " MG_TYPE = PERL_MAGIC_%s\n", name);
1255 Perl_dump_indent(aTHX_ level, file,
1256 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1260 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1261 if (mg->mg_type == PERL_MAGIC_envelem &&
1262 mg->mg_flags & MGf_TAINTEDDIR)
1263 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1264 if (mg->mg_flags & MGf_REFCOUNTED)
1265 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1266 if (mg->mg_flags & MGf_GSKIP)
1267 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1268 if (mg->mg_type == PERL_MAGIC_regex_global &&
1269 mg->mg_flags & MGf_MINMATCH)
1270 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1273 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1274 PTR2UV(mg->mg_obj));
1275 if (mg->mg_type == PERL_MAGIC_qr) {
1276 const regexp * const re = (regexp *)mg->mg_obj;
1277 SV * const dsv = sv_newmortal();
1278 const char * const s = pv_pretty(dsv, re->wrapped, re->wraplen,
1280 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELIPSES |
1281 ((re->extflags & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0))
1283 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1284 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1287 if (mg->mg_flags & MGf_REFCOUNTED)
1288 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1291 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1293 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1294 if (mg->mg_len >= 0) {
1295 if (mg->mg_type != PERL_MAGIC_utf8) {
1296 SV * const sv = newSVpvs("");
1297 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1301 else if (mg->mg_len == HEf_SVKEY) {
1302 PerlIO_puts(file, " => HEf_SVKEY\n");
1303 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1307 PerlIO_puts(file, " ???? - please notify IZ");
1308 PerlIO_putc(file, '\n');
1310 if (mg->mg_type == PERL_MAGIC_utf8) {
1311 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1314 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1315 Perl_dump_indent(aTHX_ level, file,
1316 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1319 (UV)cache[i * 2 + 1]);
1326 Perl_magic_dump(pTHX_ const MAGIC *mg)
1328 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1332 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1335 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1336 if (sv && (hvname = HvNAME_get(sv)))
1337 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1339 PerlIO_putc(file, '\n');
1343 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1345 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1346 if (sv && GvNAME(sv))
1347 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1349 PerlIO_putc(file, '\n');
1353 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1355 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1356 if (sv && GvNAME(sv)) {
1358 PerlIO_printf(file, "\t\"");
1359 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1360 PerlIO_printf(file, "%s\" :: \"", hvname);
1361 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1364 PerlIO_putc(file, '\n');
1368 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1377 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1381 flags = SvFLAGS(sv);
1384 d = Perl_newSVpvf(aTHX_
1385 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1386 PTR2UV(SvANY(sv)), PTR2UV(sv),
1387 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1388 (int)(PL_dumpindent*level), "");
1390 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1391 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1393 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1394 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1395 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1397 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1398 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1399 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1400 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1401 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1403 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1404 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1405 if (flags & SVf_POK) sv_catpv(d, "POK,");
1406 if (flags & SVf_ROK) {
1407 sv_catpv(d, "ROK,");
1408 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1410 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1411 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1412 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1413 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1415 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1416 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1417 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1418 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1419 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1420 if (SvPCS_IMPORTED(sv))
1421 sv_catpv(d, "PCS_IMPORTED,");
1423 sv_catpv(d, "SCREAM,");
1429 if (CvANON(sv)) sv_catpv(d, "ANON,");
1430 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1431 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1432 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1433 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1434 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1435 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1436 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1437 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1438 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1439 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1440 if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
1443 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1444 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1445 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1446 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1447 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1451 if (isGV_with_GP(sv)) {
1452 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1453 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1454 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1455 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1456 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1458 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1459 sv_catpv(d, "IMPORT");
1460 if (GvIMPORTED(sv) == GVf_IMPORTED)
1461 sv_catpv(d, "ALL,");
1464 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1465 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1466 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1467 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1471 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1472 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1476 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1477 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1480 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1481 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1484 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1489 /* SVphv_SHAREKEYS is also 0x20000000 */
1490 if ((type != SVt_PVHV) && SvUTF8(sv))
1491 sv_catpv(d, "UTF8");
1493 if (*(SvEND(d) - 1) == ',') {
1494 SvCUR_set(d, SvCUR(d) - 1);
1495 SvPVX(d)[SvCUR(d)] = '\0';
1500 #ifdef DEBUG_LEAKING_SCALARS
1501 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1502 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1504 sv->sv_debug_inpad ? "for" : "by",
1505 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1506 sv->sv_debug_cloned ? " (cloned)" : "");
1508 Perl_dump_indent(aTHX_ level, file, "SV = ");
1509 if (type < SVt_LAST) {
1510 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1512 if (type == SVt_NULL) {
1517 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1521 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1522 && type != SVt_PVCV && !isGV_with_GP(sv))
1523 || type == SVt_IV) {
1525 #ifdef PERL_OLD_COPY_ON_WRITE
1529 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1531 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1533 PerlIO_printf(file, " (OFFSET)");
1534 #ifdef PERL_OLD_COPY_ON_WRITE
1535 if (SvIsCOW_shared_hash(sv))
1536 PerlIO_printf(file, " (HASH)");
1537 else if (SvIsCOW_normal(sv))
1538 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1540 PerlIO_putc(file, '\n');
1542 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1543 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1544 (UV) COP_SEQ_RANGE_LOW(sv));
1545 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1546 (UV) COP_SEQ_RANGE_HIGH(sv));
1547 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1548 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)
1550 || type == SVt_NV) {
1551 STORE_NUMERIC_LOCAL_SET_STANDARD();
1552 /* %Vg doesn't work? --jhi */
1553 #ifdef USE_LONG_DOUBLE
1554 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1556 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1558 RESTORE_NUMERIC_LOCAL();
1561 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1563 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1565 if (type < SVt_PV) {
1569 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1570 if (SvPVX_const(sv)) {
1571 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1573 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1574 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1575 if (SvUTF8(sv)) /* the 8? \x{....} */
1576 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1577 PerlIO_printf(file, "\n");
1578 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1579 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1582 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1584 if (type >= SVt_PVMG) {
1585 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1586 HV * const ost = SvOURSTASH(sv);
1588 do_hv_dump(level, file, " OURSTASH", ost);
1591 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1594 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1598 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1599 if (AvARRAY(sv) != AvALLOC(sv)) {
1600 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1601 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1604 PerlIO_putc(file, '\n');
1605 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1606 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1607 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1608 sv_setpvn(d, "", 0);
1609 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1610 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1611 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1612 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1613 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1615 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1616 SV** const elt = av_fetch((AV*)sv,count,0);
1618 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1620 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1625 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1626 if (HvARRAY(sv) && HvKEYS(sv)) {
1627 /* Show distribution of HEs in the ARRAY */
1629 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1632 U32 pow2 = 2, keys = HvKEYS(sv);
1633 NV theoret, sum = 0;
1635 PerlIO_printf(file, " (");
1636 Zero(freq, FREQ_MAX + 1, int);
1637 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1640 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1642 if (count > FREQ_MAX)
1648 for (i = 0; i <= max; i++) {
1650 PerlIO_printf(file, "%d%s:%d", i,
1651 (i == FREQ_MAX) ? "+" : "",
1654 PerlIO_printf(file, ", ");
1657 PerlIO_putc(file, ')');
1658 /* The "quality" of a hash is defined as the total number of
1659 comparisons needed to access every element once, relative
1660 to the expected number needed for a random hash.
1662 The total number of comparisons is equal to the sum of
1663 the squares of the number of entries in each bucket.
1664 For a random hash of n keys into k buckets, the expected
1669 for (i = max; i > 0; i--) { /* Precision: count down. */
1670 sum += freq[i] * i * i;
1672 while ((keys = keys >> 1))
1674 theoret = HvKEYS(sv);
1675 theoret += theoret * (theoret-1)/pow2;
1676 PerlIO_putc(file, '\n');
1677 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1679 PerlIO_putc(file, '\n');
1680 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1681 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1682 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1683 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1684 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1686 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1687 if (mg && mg->mg_obj) {
1688 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1692 const char * const hvname = HvNAME_get(sv);
1694 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1697 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1699 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1701 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1705 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1707 HV * const hv = (HV*)sv;
1708 int count = maxnest - nest;
1711 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1714 const U32 hash = HeHASH(he);
1715 SV * const keysv = hv_iterkeysv(he);
1716 const char * const keypv = SvPV_const(keysv, len);
1717 SV * const elt = hv_iterval(hv, he);
1719 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1721 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1723 PerlIO_printf(file, "[REHASH] ");
1724 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1725 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1727 hv_iterinit(hv); /* Return to status quo */
1733 const char *const proto = SvPV_const(sv, len);
1734 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1739 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1740 if (!CvISXSUB(sv)) {
1742 Perl_dump_indent(aTHX_ level, file,
1743 " START = 0x%"UVxf" ===> %"IVdf"\n",
1744 PTR2UV(CvSTART(sv)),
1745 (IV)sequence_num(CvSTART(sv)));
1747 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1748 PTR2UV(CvROOT(sv)));
1749 if (CvROOT(sv) && dumpops) {
1750 do_op_dump(level+1, file, CvROOT(sv));
1753 SV * const constant = cv_const_sv((CV *)sv);
1755 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1758 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1760 PTR2UV(CvXSUBANY(sv).any_ptr));
1761 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1764 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1765 (IV)CvXSUBANY(sv).any_i32);
1768 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1769 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1770 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1771 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1772 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1773 if (type == SVt_PVFM)
1774 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1775 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1776 if (nest < maxnest) {
1777 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1780 const CV * const outside = CvOUTSIDE(sv);
1781 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1784 : CvANON(outside) ? "ANON"
1785 : (outside == PL_main_cv) ? "MAIN"
1786 : CvUNIQUE(outside) ? "UNIQUE"
1787 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1789 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1790 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1794 if (type == SVt_PVLV) {
1795 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1796 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1797 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1798 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1799 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1800 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1804 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1805 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1806 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1807 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1809 if (!isGV_with_GP(sv))
1811 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1812 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1813 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1814 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1817 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1818 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1819 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1820 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1821 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1822 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1823 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1824 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1825 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1826 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1827 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1828 do_gv_dump (level, file, " EGV", GvEGV(sv));
1831 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1832 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1833 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1834 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1835 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1836 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1837 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1839 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1840 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1841 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1843 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1844 PTR2UV(IoTOP_GV(sv)));
1845 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1848 /* Source filters hide things that are not GVs in these three, so let's
1849 be careful out there. */
1851 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1852 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1853 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1855 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1856 PTR2UV(IoFMT_GV(sv)));
1857 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1860 if (IoBOTTOM_NAME(sv))
1861 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1862 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1863 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1865 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1866 PTR2UV(IoBOTTOM_GV(sv)));
1867 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1870 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1871 if (isPRINT(IoTYPE(sv)))
1872 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1874 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1875 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1882 Perl_sv_dump(pTHX_ SV *sv)
1885 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1889 Perl_runops_debug(pTHX)
1893 if (ckWARN_d(WARN_DEBUGGING))
1894 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1898 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1902 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1903 PerlIO_printf(Perl_debug_log,
1904 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1905 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1906 PTR2UV(*PL_watchaddr));
1907 if (DEBUG_s_TEST_) {
1908 if (DEBUG_v_TEST_) {
1909 PerlIO_printf(Perl_debug_log, "\n");
1917 if (DEBUG_t_TEST_) debop(PL_op);
1918 if (DEBUG_P_TEST_) debprof(PL_op);
1920 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1921 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1928 Perl_debop(pTHX_ const OP *o)
1931 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1934 Perl_deb(aTHX_ "%s", OP_NAME(o));
1935 switch (o->op_type) {
1937 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1942 SV * const sv = newSV(0);
1944 /* FIXME - is this making unwarranted assumptions about the
1945 UTF-8 cleanliness of the dump file handle? */
1948 gv_fullname3(sv, cGVOPo_gv, NULL);
1949 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1953 PerlIO_printf(Perl_debug_log, "(NULL)");
1959 /* print the lexical's name */
1960 CV * const cv = deb_curcv(cxstack_ix);
1963 AV * const padlist = CvPADLIST(cv);
1964 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1965 sv = *av_fetch(comppad, o->op_targ, FALSE);
1969 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1971 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1977 PerlIO_printf(Perl_debug_log, "\n");
1982 S_deb_curcv(pTHX_ const I32 ix)
1985 const PERL_CONTEXT * const cx = &cxstack[ix];
1986 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1987 return cx->blk_sub.cv;
1988 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1990 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1995 return deb_curcv(ix - 1);
1999 Perl_watch(pTHX_ char **addr)
2002 PL_watchaddr = addr;
2004 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2005 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2009 S_debprof(pTHX_ const OP *o)
2012 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2014 if (!PL_profiledata)
2015 Newxz(PL_profiledata, MAXO, U32);
2016 ++PL_profiledata[o->op_type];
2020 Perl_debprofdump(pTHX)
2024 if (!PL_profiledata)
2026 for (i = 0; i < MAXO; i++) {
2027 if (PL_profiledata[i])
2028 PerlIO_printf(Perl_debug_log,
2029 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2036 * XML variants of most of the above routines
2040 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2043 PerlIO_printf(file, "\n ");
2044 va_start(args, pat);
2045 xmldump_vindent(level, file, pat, &args);
2051 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2054 va_start(args, pat);
2055 xmldump_vindent(level, file, pat, &args);
2060 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2062 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2063 PerlIO_vprintf(file, pat, *args);
2067 Perl_xmldump_all(pTHX)
2069 PerlIO_setlinebuf(PL_xmlfp);
2071 op_xmldump(PL_main_root);
2072 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2073 PerlIO_close(PL_xmlfp);
2078 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2083 if (!HvARRAY(stash))
2085 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2086 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2087 GV *gv = (GV*)HeVAL(entry);
2089 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2095 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2096 && (hv = GvHV(gv)) && hv != PL_defstash)
2097 xmldump_packsubs(hv); /* nested package */
2103 Perl_xmldump_sub(pTHX_ const GV *gv)
2105 SV * const sv = sv_newmortal();
2107 gv_fullname3(sv, gv, Nullch);
2108 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2109 if (CvXSUB(GvCV(gv)))
2110 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2111 PTR2UV(CvXSUB(GvCV(gv))),
2112 (int)CvXSUBANY(GvCV(gv)).any_i32);
2113 else if (CvROOT(GvCV(gv)))
2114 op_xmldump(CvROOT(GvCV(gv)));
2116 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2120 Perl_xmldump_form(pTHX_ const GV *gv)
2122 SV * const sv = sv_newmortal();
2124 gv_fullname3(sv, gv, Nullch);
2125 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2126 if (CvROOT(GvFORM(gv)))
2127 op_xmldump(CvROOT(GvFORM(gv)));
2129 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2133 Perl_xmldump_eval(pTHX)
2135 op_xmldump(PL_eval_root);
2139 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2141 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2145 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2148 const char * const e = pv + len;
2153 sv_catpvn(dsv,"",0);
2154 dsvcur = SvCUR(dsv); /* in case we have to restart */
2159 c = utf8_to_uvchr((U8*)pv, &cl);
2161 SvCUR(dsv) = dsvcur;
2226 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2229 Perl_sv_catpvf(aTHX_ dsv, "<");
2232 Perl_sv_catpvf(aTHX_ dsv, ">");
2235 Perl_sv_catpvf(aTHX_ dsv, "&");
2238 Perl_sv_catpvf(aTHX_ dsv, """);
2242 if (c < 32 || c > 127) {
2243 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2246 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2250 if ((c >= 0xD800 && c <= 0xDB7F) ||
2251 (c >= 0xDC00 && c <= 0xDFFF) ||
2252 (c >= 0xFFF0 && c <= 0xFFFF) ||
2254 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2256 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2269 Perl_sv_xmlpeek(pTHX_ SV *sv)
2271 SV * const t = sv_newmortal();
2276 sv_setpvn(t, "", 0);
2279 sv_catpv(t, "VOID=\"\"");
2282 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2283 sv_catpv(t, "WILD=\"\"");
2286 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2287 if (sv == &PL_sv_undef) {
2288 sv_catpv(t, "SV_UNDEF=\"1\"");
2289 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2290 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2294 else if (sv == &PL_sv_no) {
2295 sv_catpv(t, "SV_NO=\"1\"");
2296 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2297 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2298 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2299 SVp_POK|SVp_NOK)) &&
2304 else if (sv == &PL_sv_yes) {
2305 sv_catpv(t, "SV_YES=\"1\"");
2306 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2307 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2308 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2309 SVp_POK|SVp_NOK)) &&
2311 SvPVX(sv) && *SvPVX(sv) == '1' &&
2316 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2317 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2318 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2322 sv_catpv(t, " XXX=\"\" ");
2324 else if (SvREFCNT(sv) == 0) {
2325 sv_catpv(t, " refcnt=\"0\"");
2328 else if (DEBUG_R_TEST_) {
2331 /* is this SV on the tmps stack? */
2332 for (ix=PL_tmps_ix; ix>=0; ix--) {
2333 if (PL_tmps_stack[ix] == sv) {
2338 if (SvREFCNT(sv) > 1)
2339 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2342 sv_catpv(t, " DRT=\"<T>\"");
2346 sv_catpv(t, " ROK=\"\"");
2348 switch (SvTYPE(sv)) {
2350 sv_catpv(t, " FREED=\"1\"");
2354 sv_catpv(t, " UNDEF=\"1\"");
2357 sv_catpv(t, " IV=\"");
2360 sv_catpv(t, " NV=\"");
2363 sv_catpv(t, " RV=\"");
2366 sv_catpv(t, " PV=\"");
2369 sv_catpv(t, " PVIV=\"");
2372 sv_catpv(t, " PVNV=\"");
2375 sv_catpv(t, " PVMG=\"");
2378 sv_catpv(t, " PVLV=\"");
2381 sv_catpv(t, " AV=\"");
2384 sv_catpv(t, " HV=\"");
2388 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2390 sv_catpv(t, " CV=\"()\"");
2393 sv_catpv(t, " GV=\"");
2396 sv_catpv(t, " BIND=\"");
2399 sv_catpv(t, " FM=\"");
2402 sv_catpv(t, " IO=\"");
2411 else if (SvNOKp(sv)) {
2412 STORE_NUMERIC_LOCAL_SET_STANDARD();
2413 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2414 RESTORE_NUMERIC_LOCAL();
2416 else if (SvIOKp(sv)) {
2418 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2420 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2429 return SvPV(t, n_a);
2433 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2436 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2439 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2442 const char * const s = PM_GETRE(pm)->precomp;
2443 SV * const tmpsv = newSVpvn("",0);
2445 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2446 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2448 SvREFCNT_dec(tmpsv);
2449 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2450 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2453 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2454 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2455 SV * const tmpsv = pm_description(pm);
2456 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2457 SvREFCNT_dec(tmpsv);
2461 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2462 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2463 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2464 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2465 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2466 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2469 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2473 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2475 do_pmop_xmldump(0, PL_xmlfp, pm);
2479 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2486 seq = sequence_num(o);
2487 Perl_xmldump_indent(aTHX_ level, file,
2488 "<op_%s seq=\"%"UVuf" -> ",
2493 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2494 sequence_num(o->op_next));
2496 PerlIO_printf(file, "DONE\"");
2499 if (o->op_type == OP_NULL)
2501 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2502 if (o->op_targ == OP_NEXTSTATE)
2505 PerlIO_printf(file, " line=\"%"UVuf"\"",
2506 (UV)CopLINE(cCOPo));
2507 if (CopSTASHPV(cCOPo))
2508 PerlIO_printf(file, " package=\"%s\"",
2510 if (cCOPo->cop_label)
2511 PerlIO_printf(file, " label=\"%s\"",
2516 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2519 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2522 SV * const tmpsv = newSVpvn("", 0);
2523 switch (o->op_flags & OPf_WANT) {
2525 sv_catpv(tmpsv, ",VOID");
2527 case OPf_WANT_SCALAR:
2528 sv_catpv(tmpsv, ",SCALAR");
2531 sv_catpv(tmpsv, ",LIST");
2534 sv_catpv(tmpsv, ",UNKNOWN");
2537 if (o->op_flags & OPf_KIDS)
2538 sv_catpv(tmpsv, ",KIDS");
2539 if (o->op_flags & OPf_PARENS)
2540 sv_catpv(tmpsv, ",PARENS");
2541 if (o->op_flags & OPf_STACKED)
2542 sv_catpv(tmpsv, ",STACKED");
2543 if (o->op_flags & OPf_REF)
2544 sv_catpv(tmpsv, ",REF");
2545 if (o->op_flags & OPf_MOD)
2546 sv_catpv(tmpsv, ",MOD");
2547 if (o->op_flags & OPf_SPECIAL)
2548 sv_catpv(tmpsv, ",SPECIAL");
2549 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2550 SvREFCNT_dec(tmpsv);
2552 if (o->op_private) {
2553 SV * const tmpsv = newSVpvn("", 0);
2554 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2555 if (o->op_private & OPpTARGET_MY)
2556 sv_catpv(tmpsv, ",TARGET_MY");
2558 else if (o->op_type == OP_LEAVESUB ||
2559 o->op_type == OP_LEAVE ||
2560 o->op_type == OP_LEAVESUBLV ||
2561 o->op_type == OP_LEAVEWRITE) {
2562 if (o->op_private & OPpREFCOUNTED)
2563 sv_catpv(tmpsv, ",REFCOUNTED");
2565 else if (o->op_type == OP_AASSIGN) {
2566 if (o->op_private & OPpASSIGN_COMMON)
2567 sv_catpv(tmpsv, ",COMMON");
2569 else if (o->op_type == OP_SASSIGN) {
2570 if (o->op_private & OPpASSIGN_BACKWARDS)
2571 sv_catpv(tmpsv, ",BACKWARDS");
2573 else if (o->op_type == OP_TRANS) {
2574 if (o->op_private & OPpTRANS_SQUASH)
2575 sv_catpv(tmpsv, ",SQUASH");
2576 if (o->op_private & OPpTRANS_DELETE)
2577 sv_catpv(tmpsv, ",DELETE");
2578 if (o->op_private & OPpTRANS_COMPLEMENT)
2579 sv_catpv(tmpsv, ",COMPLEMENT");
2580 if (o->op_private & OPpTRANS_IDENTICAL)
2581 sv_catpv(tmpsv, ",IDENTICAL");
2582 if (o->op_private & OPpTRANS_GROWS)
2583 sv_catpv(tmpsv, ",GROWS");
2585 else if (o->op_type == OP_REPEAT) {
2586 if (o->op_private & OPpREPEAT_DOLIST)
2587 sv_catpv(tmpsv, ",DOLIST");
2589 else if (o->op_type == OP_ENTERSUB ||
2590 o->op_type == OP_RV2SV ||
2591 o->op_type == OP_GVSV ||
2592 o->op_type == OP_RV2AV ||
2593 o->op_type == OP_RV2HV ||
2594 o->op_type == OP_RV2GV ||
2595 o->op_type == OP_AELEM ||
2596 o->op_type == OP_HELEM )
2598 if (o->op_type == OP_ENTERSUB) {
2599 if (o->op_private & OPpENTERSUB_AMPER)
2600 sv_catpv(tmpsv, ",AMPER");
2601 if (o->op_private & OPpENTERSUB_DB)
2602 sv_catpv(tmpsv, ",DB");
2603 if (o->op_private & OPpENTERSUB_HASTARG)
2604 sv_catpv(tmpsv, ",HASTARG");
2605 if (o->op_private & OPpENTERSUB_NOPAREN)
2606 sv_catpv(tmpsv, ",NOPAREN");
2607 if (o->op_private & OPpENTERSUB_INARGS)
2608 sv_catpv(tmpsv, ",INARGS");
2609 if (o->op_private & OPpENTERSUB_NOMOD)
2610 sv_catpv(tmpsv, ",NOMOD");
2613 switch (o->op_private & OPpDEREF) {
2615 sv_catpv(tmpsv, ",SV");
2618 sv_catpv(tmpsv, ",AV");
2621 sv_catpv(tmpsv, ",HV");
2624 if (o->op_private & OPpMAYBE_LVSUB)
2625 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2627 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2628 if (o->op_private & OPpLVAL_DEFER)
2629 sv_catpv(tmpsv, ",LVAL_DEFER");
2632 if (o->op_private & HINT_STRICT_REFS)
2633 sv_catpv(tmpsv, ",STRICT_REFS");
2634 if (o->op_private & OPpOUR_INTRO)
2635 sv_catpv(tmpsv, ",OUR_INTRO");
2638 else if (o->op_type == OP_CONST) {
2639 if (o->op_private & OPpCONST_BARE)
2640 sv_catpv(tmpsv, ",BARE");
2641 if (o->op_private & OPpCONST_STRICT)
2642 sv_catpv(tmpsv, ",STRICT");
2643 if (o->op_private & OPpCONST_ARYBASE)
2644 sv_catpv(tmpsv, ",ARYBASE");
2645 if (o->op_private & OPpCONST_WARNING)
2646 sv_catpv(tmpsv, ",WARNING");
2647 if (o->op_private & OPpCONST_ENTERED)
2648 sv_catpv(tmpsv, ",ENTERED");
2650 else if (o->op_type == OP_FLIP) {
2651 if (o->op_private & OPpFLIP_LINENUM)
2652 sv_catpv(tmpsv, ",LINENUM");
2654 else if (o->op_type == OP_FLOP) {
2655 if (o->op_private & OPpFLIP_LINENUM)
2656 sv_catpv(tmpsv, ",LINENUM");
2658 else if (o->op_type == OP_RV2CV) {
2659 if (o->op_private & OPpLVAL_INTRO)
2660 sv_catpv(tmpsv, ",INTRO");
2662 else if (o->op_type == OP_GV) {
2663 if (o->op_private & OPpEARLY_CV)
2664 sv_catpv(tmpsv, ",EARLY_CV");
2666 else if (o->op_type == OP_LIST) {
2667 if (o->op_private & OPpLIST_GUESSED)
2668 sv_catpv(tmpsv, ",GUESSED");
2670 else if (o->op_type == OP_DELETE) {
2671 if (o->op_private & OPpSLICE)
2672 sv_catpv(tmpsv, ",SLICE");
2674 else if (o->op_type == OP_EXISTS) {
2675 if (o->op_private & OPpEXISTS_SUB)
2676 sv_catpv(tmpsv, ",EXISTS_SUB");
2678 else if (o->op_type == OP_SORT) {
2679 if (o->op_private & OPpSORT_NUMERIC)
2680 sv_catpv(tmpsv, ",NUMERIC");
2681 if (o->op_private & OPpSORT_INTEGER)
2682 sv_catpv(tmpsv, ",INTEGER");
2683 if (o->op_private & OPpSORT_REVERSE)
2684 sv_catpv(tmpsv, ",REVERSE");
2686 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2687 if (o->op_private & OPpOPEN_IN_RAW)
2688 sv_catpv(tmpsv, ",IN_RAW");
2689 if (o->op_private & OPpOPEN_IN_CRLF)
2690 sv_catpv(tmpsv, ",IN_CRLF");
2691 if (o->op_private & OPpOPEN_OUT_RAW)
2692 sv_catpv(tmpsv, ",OUT_RAW");
2693 if (o->op_private & OPpOPEN_OUT_CRLF)
2694 sv_catpv(tmpsv, ",OUT_CRLF");
2696 else if (o->op_type == OP_EXIT) {
2697 if (o->op_private & OPpEXIT_VMSISH)
2698 sv_catpv(tmpsv, ",EXIT_VMSISH");
2699 if (o->op_private & OPpHUSH_VMSISH)
2700 sv_catpv(tmpsv, ",HUSH_VMSISH");
2702 else if (o->op_type == OP_DIE) {
2703 if (o->op_private & OPpHUSH_VMSISH)
2704 sv_catpv(tmpsv, ",HUSH_VMSISH");
2706 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2707 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2708 sv_catpv(tmpsv, ",FT_ACCESS");
2709 if (o->op_private & OPpFT_STACKED)
2710 sv_catpv(tmpsv, ",FT_STACKED");
2712 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2713 sv_catpv(tmpsv, ",INTRO");
2715 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2716 SvREFCNT_dec(tmpsv);
2719 switch (o->op_type) {
2721 if (o->op_flags & OPf_SPECIAL) {
2727 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2729 if (cSVOPo->op_sv) {
2730 SV * const tmpsv1 = newSV(0);
2731 SV * const tmpsv2 = newSVpvn("",0);
2739 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2740 s = SvPV(tmpsv1,len);
2741 sv_catxmlpvn(tmpsv2, s, len, 1);
2742 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2746 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2750 case OP_METHOD_NAMED:
2751 #ifndef USE_ITHREADS
2752 /* with ITHREADS, consts are stored in the pad, and the right pad
2753 * may not be active here, so skip */
2754 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2760 PerlIO_printf(file, ">\n");
2762 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2768 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2769 (UV)CopLINE(cCOPo));
2770 if (CopSTASHPV(cCOPo))
2771 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2773 if (cCOPo->cop_label)
2774 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2778 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2779 if (cLOOPo->op_redoop)
2780 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2782 PerlIO_printf(file, "DONE\"");
2783 S_xmldump_attr(aTHX_ level, file, "next=\"");
2784 if (cLOOPo->op_nextop)
2785 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2787 PerlIO_printf(file, "DONE\"");
2788 S_xmldump_attr(aTHX_ level, file, "last=\"");
2789 if (cLOOPo->op_lastop)
2790 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2792 PerlIO_printf(file, "DONE\"");
2800 S_xmldump_attr(aTHX_ level, file, "other=\"");
2801 if (cLOGOPo->op_other)
2802 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2804 PerlIO_printf(file, "DONE\"");
2812 if (o->op_private & OPpREFCOUNTED)
2813 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2819 if (PL_madskills && o->op_madprop) {
2820 char prevkey = '\0';
2821 SV * const tmpsv = newSVpvn("", 0);
2822 const MADPROP* const mp = o->op_madprop;
2824 sv_utf8_upgrade(tmpsv);
2827 PerlIO_printf(file, ">\n");
2829 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2832 char tmp = mp->mad_key;
2833 sv_setpvn(tmpsv,"\"",1);
2835 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2836 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2837 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2840 sv_catpv(tmpsv, "\"");
2841 switch (mp->mad_type) {
2843 sv_catpv(tmpsv, "NULL");
2844 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2847 sv_catpv(tmpsv, " val=\"");
2848 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2849 sv_catpv(tmpsv, "\"");
2850 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2853 sv_catpv(tmpsv, " val=\"");
2854 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2855 sv_catpv(tmpsv, "\"");
2856 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2859 if ((OP*)mp->mad_val) {
2860 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2861 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2862 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2866 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2872 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2874 SvREFCNT_dec(tmpsv);
2877 switch (o->op_type) {
2884 PerlIO_printf(file, ">\n");
2886 do_pmop_xmldump(level, file, cPMOPo);
2892 if (o->op_flags & OPf_KIDS) {
2896 PerlIO_printf(file, ">\n");
2898 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2899 do_op_xmldump(level, file, kid);
2903 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2905 PerlIO_printf(file, " />\n");
2909 Perl_op_xmldump(pTHX_ const OP *o)
2911 do_op_xmldump(0, PL_xmlfp, o);
2917 * c-indentation-style: bsd
2919 * indent-tabs-mode: t
2922 * ex: set ts=8 sts=4 sw=4 noet: