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 /* This won't alter the UTF-8 flag */
224 sv_setpvn(dsv, "", 0);
227 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
230 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
231 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
232 const U8 c = (U8)u & 0xFF;
234 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
235 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
236 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
239 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
240 "%cx{%"UVxf"}", esc, u);
241 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
244 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
248 case '\\' : /* fallthrough */
249 case '%' : if ( c == esc ) {
255 case '\v' : octbuf[1] = 'v'; break;
256 case '\t' : octbuf[1] = 't'; break;
257 case '\r' : octbuf[1] = 'r'; break;
258 case '\n' : octbuf[1] = 'n'; break;
259 case '\f' : octbuf[1] = 'f'; break;
267 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
268 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
271 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
278 if ( max && (wrote + chsize > max) ) {
280 } else if (chsize > 1) {
281 sv_catpvn(dsv, octbuf, chsize);
284 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
285 128-255 can be appended raw to the dsv. If dsv happens to be
286 UTF-8 then we need catpvf to upgrade them for us.
287 Or add a new API call sv_catpvc(). Think about that name, and
288 how to keep it clear that it's unlike the s of catpvs, which is
289 really an array octets, not a string. */
290 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
293 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
301 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
302 |const STRLEN count|const STRLEN max\
303 |const char const *start_color| const char const *end_color\
306 Converts a string into something presentable, handling escaping via
307 pv_escape() and supporting quoting and ellipses.
309 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
310 double quoted with any double quotes in the string escaped. Otherwise
311 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
314 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
315 string were output then an ellipsis C<...> will be appended to the
316 string. Note that this happens AFTER it has been quoted.
318 If start_color is non-null then it will be inserted after the opening
319 quote (if there is one) but before the escaped text. If end_color
320 is non-null then it will be inserted after the escaped text but before
321 any quotes or ellipses.
323 Returns a pointer to the prettified text as held by dsv.
329 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
330 const STRLEN max, char const * const start_color, char const * const end_color,
333 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
337 sv_setpvn(dsv, "\"", 1);
338 else if ( flags & PERL_PV_PRETTY_LTGT )
339 sv_setpvn(dsv, "<", 1);
341 sv_setpvn(dsv, "", 0);
343 if ( start_color != NULL )
344 Perl_sv_catpv( aTHX_ dsv, start_color);
346 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
348 if ( end_color != NULL )
349 Perl_sv_catpv( aTHX_ dsv, end_color);
352 sv_catpvn( dsv, "\"", 1 );
353 else if ( flags & PERL_PV_PRETTY_LTGT )
354 sv_catpvn( dsv, ">", 1);
356 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
357 sv_catpvn( dsv, "...", 3 );
363 =for apidoc pv_display
365 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
366 STRLEN pvlim, U32 flags)
370 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
372 except that an additional "\0" will be appended to the string when
373 len > cur and pv[cur] is "\0".
375 Note that the final string may be up to 7 chars longer than pvlim.
381 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
383 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
384 if (len > cur && pv[cur] == '\0')
385 sv_catpvn( dsv, "\\0", 2 );
390 Perl_sv_peek(pTHX_ SV *sv)
393 SV * const t = sv_newmortal();
403 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
407 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
408 if (sv == &PL_sv_undef) {
409 sv_catpv(t, "SV_UNDEF");
410 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
411 SVs_GMG|SVs_SMG|SVs_RMG)) &&
415 else if (sv == &PL_sv_no) {
416 sv_catpv(t, "SV_NO");
417 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
418 SVs_GMG|SVs_SMG|SVs_RMG)) &&
419 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
425 else if (sv == &PL_sv_yes) {
426 sv_catpv(t, "SV_YES");
427 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
428 SVs_GMG|SVs_SMG|SVs_RMG)) &&
429 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
432 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
437 sv_catpv(t, "SV_PLACEHOLDER");
438 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
439 SVs_GMG|SVs_SMG|SVs_RMG)) &&
445 else if (SvREFCNT(sv) == 0) {
449 else if (DEBUG_R_TEST_) {
452 /* is this SV on the tmps stack? */
453 for (ix=PL_tmps_ix; ix>=0; ix--) {
454 if (PL_tmps_stack[ix] == sv) {
459 if (SvREFCNT(sv) > 1)
460 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
468 if (SvCUR(t) + unref > 10) {
469 SvCUR_set(t, unref + 3);
478 if (type == SVt_PVCV) {
479 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
481 } else if (type < SVt_LAST) {
482 sv_catpv(t, svshorttypenames[type]);
484 if (type == SVt_NULL)
487 sv_catpv(t, "FREED");
492 if (!SvPVX_const(sv))
493 sv_catpv(t, "(null)");
495 SV * const tmp = newSVpvs("");
498 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
499 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
501 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
502 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
507 else if (SvNOKp(sv)) {
508 STORE_NUMERIC_LOCAL_SET_STANDARD();
509 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
510 RESTORE_NUMERIC_LOCAL();
512 else if (SvIOKp(sv)) {
514 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
516 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
524 return SvPV_nolen(t);
528 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
533 Perl_dump_indent(aTHX_ level, file, "{}\n");
536 Perl_dump_indent(aTHX_ level, file, "{\n");
538 if (pm->op_pmflags & PMf_ONCE)
543 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
544 ch, PM_GETRE(pm)->precomp, ch,
545 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
547 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
548 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
549 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
550 op_dump(pm->op_pmreplrootu.op_pmreplroot);
552 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
553 SV * const tmpsv = pm_description(pm);
554 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
558 Perl_dump_indent(aTHX_ level-1, file, "}\n");
562 S_pm_description(pTHX_ const PMOP *pm)
564 SV * const desc = newSVpvs("");
565 const REGEXP * const regex = PM_GETRE(pm);
566 const U32 pmflags = pm->op_pmflags;
568 if (pmflags & PMf_ONCE)
569 sv_catpv(desc, ",ONCE");
571 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
572 sv_catpv(desc, ":USED");
574 if (pmflags & PMf_USED)
575 sv_catpv(desc, ":USED");
579 if (regex->extflags & RXf_TAINTED)
580 sv_catpv(desc, ",TAINTED");
581 if (regex->check_substr) {
582 if (!(regex->extflags & RXf_NOSCAN))
583 sv_catpv(desc, ",SCANFIRST");
584 if (regex->extflags & RXf_CHECK_ALL)
585 sv_catpv(desc, ",ALL");
587 if (regex->extflags & RXf_SKIPWHITE)
588 sv_catpv(desc, ",SKIPWHITE");
591 if (pmflags & PMf_CONST)
592 sv_catpv(desc, ",CONST");
593 if (pmflags & PMf_KEEP)
594 sv_catpv(desc, ",KEEP");
595 if (pmflags & PMf_GLOBAL)
596 sv_catpv(desc, ",GLOBAL");
597 if (pmflags & PMf_CONTINUE)
598 sv_catpv(desc, ",CONTINUE");
599 if (pmflags & PMf_RETAINT)
600 sv_catpv(desc, ",RETAINT");
601 if (pmflags & PMf_EVAL)
602 sv_catpv(desc, ",EVAL");
607 Perl_pmop_dump(pTHX_ PMOP *pm)
609 do_pmop_dump(0, Perl_debug_log, pm);
612 /* An op sequencer. We visit the ops in the order they're to execute. */
615 S_sequence(pTHX_ register const OP *o)
618 const OP *oldop = NULL;
631 for (; o; o = o->op_next) {
633 SV * const op = newSVuv(PTR2UV(o));
634 const char * const key = SvPV_const(op, len);
636 if (hv_exists(Sequence, key, len))
639 switch (o->op_type) {
641 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
642 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
651 if (oldop && o->op_next)
658 if (oldop && o->op_next)
660 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
673 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
674 sequence_tail(cLOGOPo->op_other);
679 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
680 sequence_tail(cLOOPo->op_redoop);
681 sequence_tail(cLOOPo->op_nextop);
682 sequence_tail(cLOOPo->op_lastop);
686 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
687 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
696 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
704 S_sequence_tail(pTHX_ const OP *o)
706 while (o && (o->op_type == OP_NULL))
712 S_sequence_num(pTHX_ const OP *o)
720 op = newSVuv(PTR2UV(o));
721 key = SvPV_const(op, len);
722 seq = hv_fetch(Sequence, key, len, 0);
723 return seq ? SvUV(*seq): 0;
727 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
731 const OPCODE optype = o->op_type;
734 Perl_dump_indent(aTHX_ level, file, "{\n");
736 seq = sequence_num(o);
738 PerlIO_printf(file, "%-4"UVuf, seq);
740 PerlIO_printf(file, " ");
742 "%*sTYPE = %s ===> ",
743 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
745 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
746 sequence_num(o->op_next));
748 PerlIO_printf(file, "DONE\n");
750 if (optype == OP_NULL) {
751 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
752 if (o->op_targ == OP_NEXTSTATE) {
754 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
756 if (CopSTASHPV(cCOPo))
757 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
759 if (cCOPo->cop_label)
760 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
765 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
768 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
770 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
771 SV * const tmpsv = newSVpvs("");
772 switch (o->op_flags & OPf_WANT) {
774 sv_catpv(tmpsv, ",VOID");
776 case OPf_WANT_SCALAR:
777 sv_catpv(tmpsv, ",SCALAR");
780 sv_catpv(tmpsv, ",LIST");
783 sv_catpv(tmpsv, ",UNKNOWN");
786 if (o->op_flags & OPf_KIDS)
787 sv_catpv(tmpsv, ",KIDS");
788 if (o->op_flags & OPf_PARENS)
789 sv_catpv(tmpsv, ",PARENS");
790 if (o->op_flags & OPf_STACKED)
791 sv_catpv(tmpsv, ",STACKED");
792 if (o->op_flags & OPf_REF)
793 sv_catpv(tmpsv, ",REF");
794 if (o->op_flags & OPf_MOD)
795 sv_catpv(tmpsv, ",MOD");
796 if (o->op_flags & OPf_SPECIAL)
797 sv_catpv(tmpsv, ",SPECIAL");
799 sv_catpv(tmpsv, ",LATEFREE");
801 sv_catpv(tmpsv, ",LATEFREED");
803 sv_catpv(tmpsv, ",ATTACHED");
804 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
808 SV * const tmpsv = newSVpvs("");
809 if (PL_opargs[optype] & OA_TARGLEX) {
810 if (o->op_private & OPpTARGET_MY)
811 sv_catpv(tmpsv, ",TARGET_MY");
813 else if (optype == OP_LEAVESUB ||
814 optype == OP_LEAVE ||
815 optype == OP_LEAVESUBLV ||
816 optype == OP_LEAVEWRITE) {
817 if (o->op_private & OPpREFCOUNTED)
818 sv_catpv(tmpsv, ",REFCOUNTED");
820 else if (optype == OP_AASSIGN) {
821 if (o->op_private & OPpASSIGN_COMMON)
822 sv_catpv(tmpsv, ",COMMON");
824 else if (optype == OP_SASSIGN) {
825 if (o->op_private & OPpASSIGN_BACKWARDS)
826 sv_catpv(tmpsv, ",BACKWARDS");
828 else if (optype == OP_TRANS) {
829 if (o->op_private & OPpTRANS_SQUASH)
830 sv_catpv(tmpsv, ",SQUASH");
831 if (o->op_private & OPpTRANS_DELETE)
832 sv_catpv(tmpsv, ",DELETE");
833 if (o->op_private & OPpTRANS_COMPLEMENT)
834 sv_catpv(tmpsv, ",COMPLEMENT");
835 if (o->op_private & OPpTRANS_IDENTICAL)
836 sv_catpv(tmpsv, ",IDENTICAL");
837 if (o->op_private & OPpTRANS_GROWS)
838 sv_catpv(tmpsv, ",GROWS");
840 else if (optype == OP_REPEAT) {
841 if (o->op_private & OPpREPEAT_DOLIST)
842 sv_catpv(tmpsv, ",DOLIST");
844 else if (optype == OP_ENTERSUB ||
845 optype == OP_RV2SV ||
847 optype == OP_RV2AV ||
848 optype == OP_RV2HV ||
849 optype == OP_RV2GV ||
850 optype == OP_AELEM ||
853 if (optype == OP_ENTERSUB) {
854 if (o->op_private & OPpENTERSUB_AMPER)
855 sv_catpv(tmpsv, ",AMPER");
856 if (o->op_private & OPpENTERSUB_DB)
857 sv_catpv(tmpsv, ",DB");
858 if (o->op_private & OPpENTERSUB_HASTARG)
859 sv_catpv(tmpsv, ",HASTARG");
860 if (o->op_private & OPpENTERSUB_NOPAREN)
861 sv_catpv(tmpsv, ",NOPAREN");
862 if (o->op_private & OPpENTERSUB_INARGS)
863 sv_catpv(tmpsv, ",INARGS");
864 if (o->op_private & OPpENTERSUB_NOMOD)
865 sv_catpv(tmpsv, ",NOMOD");
868 switch (o->op_private & OPpDEREF) {
870 sv_catpv(tmpsv, ",SV");
873 sv_catpv(tmpsv, ",AV");
876 sv_catpv(tmpsv, ",HV");
879 if (o->op_private & OPpMAYBE_LVSUB)
880 sv_catpv(tmpsv, ",MAYBE_LVSUB");
882 if (optype == OP_AELEM || optype == OP_HELEM) {
883 if (o->op_private & OPpLVAL_DEFER)
884 sv_catpv(tmpsv, ",LVAL_DEFER");
887 if (o->op_private & HINT_STRICT_REFS)
888 sv_catpv(tmpsv, ",STRICT_REFS");
889 if (o->op_private & OPpOUR_INTRO)
890 sv_catpv(tmpsv, ",OUR_INTRO");
893 else if (optype == OP_CONST) {
894 if (o->op_private & OPpCONST_BARE)
895 sv_catpv(tmpsv, ",BARE");
896 if (o->op_private & OPpCONST_STRICT)
897 sv_catpv(tmpsv, ",STRICT");
898 if (o->op_private & OPpCONST_ARYBASE)
899 sv_catpv(tmpsv, ",ARYBASE");
900 if (o->op_private & OPpCONST_WARNING)
901 sv_catpv(tmpsv, ",WARNING");
902 if (o->op_private & OPpCONST_ENTERED)
903 sv_catpv(tmpsv, ",ENTERED");
905 else if (optype == OP_FLIP) {
906 if (o->op_private & OPpFLIP_LINENUM)
907 sv_catpv(tmpsv, ",LINENUM");
909 else if (optype == OP_FLOP) {
910 if (o->op_private & OPpFLIP_LINENUM)
911 sv_catpv(tmpsv, ",LINENUM");
913 else if (optype == OP_RV2CV) {
914 if (o->op_private & OPpLVAL_INTRO)
915 sv_catpv(tmpsv, ",INTRO");
917 else if (optype == OP_GV) {
918 if (o->op_private & OPpEARLY_CV)
919 sv_catpv(tmpsv, ",EARLY_CV");
921 else if (optype == OP_LIST) {
922 if (o->op_private & OPpLIST_GUESSED)
923 sv_catpv(tmpsv, ",GUESSED");
925 else if (optype == OP_DELETE) {
926 if (o->op_private & OPpSLICE)
927 sv_catpv(tmpsv, ",SLICE");
929 else if (optype == OP_EXISTS) {
930 if (o->op_private & OPpEXISTS_SUB)
931 sv_catpv(tmpsv, ",EXISTS_SUB");
933 else if (optype == OP_SORT) {
934 if (o->op_private & OPpSORT_NUMERIC)
935 sv_catpv(tmpsv, ",NUMERIC");
936 if (o->op_private & OPpSORT_INTEGER)
937 sv_catpv(tmpsv, ",INTEGER");
938 if (o->op_private & OPpSORT_REVERSE)
939 sv_catpv(tmpsv, ",REVERSE");
941 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
942 if (o->op_private & OPpOPEN_IN_RAW)
943 sv_catpv(tmpsv, ",IN_RAW");
944 if (o->op_private & OPpOPEN_IN_CRLF)
945 sv_catpv(tmpsv, ",IN_CRLF");
946 if (o->op_private & OPpOPEN_OUT_RAW)
947 sv_catpv(tmpsv, ",OUT_RAW");
948 if (o->op_private & OPpOPEN_OUT_CRLF)
949 sv_catpv(tmpsv, ",OUT_CRLF");
951 else if (optype == OP_EXIT) {
952 if (o->op_private & OPpEXIT_VMSISH)
953 sv_catpv(tmpsv, ",EXIT_VMSISH");
954 if (o->op_private & OPpHUSH_VMSISH)
955 sv_catpv(tmpsv, ",HUSH_VMSISH");
957 else if (optype == OP_DIE) {
958 if (o->op_private & OPpHUSH_VMSISH)
959 sv_catpv(tmpsv, ",HUSH_VMSISH");
961 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
962 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
963 sv_catpv(tmpsv, ",FT_ACCESS");
964 if (o->op_private & OPpFT_STACKED)
965 sv_catpv(tmpsv, ",FT_STACKED");
967 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
968 sv_catpv(tmpsv, ",INTRO");
970 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
975 if (PL_madskills && o->op_madprop) {
976 SV * const tmpsv = newSVpvn("", 0);
977 MADPROP* mp = o->op_madprop;
978 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
981 const char tmp = mp->mad_key;
982 sv_setpvn(tmpsv,"'",1);
984 sv_catpvn(tmpsv, &tmp, 1);
985 sv_catpv(tmpsv, "'=");
986 switch (mp->mad_type) {
988 sv_catpv(tmpsv, "NULL");
989 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
992 sv_catpv(tmpsv, "<");
993 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
994 sv_catpv(tmpsv, ">");
995 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
998 if ((OP*)mp->mad_val) {
999 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1000 do_op_dump(level, file, (OP*)mp->mad_val);
1004 sv_catpv(tmpsv, "(UNK)");
1005 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1011 Perl_dump_indent(aTHX_ level, file, "}\n");
1013 SvREFCNT_dec(tmpsv);
1022 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1024 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1025 if (cSVOPo->op_sv) {
1026 SV * const tmpsv = newSV(0);
1030 /* FIXME - is this making unwarranted assumptions about the
1031 UTF-8 cleanliness of the dump file handle? */
1034 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1035 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1036 SvPV_nolen_const(tmpsv));
1040 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1045 case OP_METHOD_NAMED:
1046 #ifndef USE_ITHREADS
1047 /* with ITHREADS, consts are stored in the pad, and the right pad
1048 * may not be active here, so skip */
1049 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1056 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1057 (UV)CopLINE(cCOPo));
1058 if (CopSTASHPV(cCOPo))
1059 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1061 if (cCOPo->cop_label)
1062 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1066 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1067 if (cLOOPo->op_redoop)
1068 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1070 PerlIO_printf(file, "DONE\n");
1071 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1072 if (cLOOPo->op_nextop)
1073 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1075 PerlIO_printf(file, "DONE\n");
1076 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1077 if (cLOOPo->op_lastop)
1078 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1080 PerlIO_printf(file, "DONE\n");
1088 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1089 if (cLOGOPo->op_other)
1090 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1092 PerlIO_printf(file, "DONE\n");
1098 do_pmop_dump(level, file, cPMOPo);
1106 if (o->op_private & OPpREFCOUNTED)
1107 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1112 if (o->op_flags & OPf_KIDS) {
1114 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1115 do_op_dump(level, file, kid);
1117 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1121 Perl_op_dump(pTHX_ const OP *o)
1123 do_op_dump(0, Perl_debug_log, o);
1127 Perl_gv_dump(pTHX_ GV *gv)
1132 PerlIO_printf(Perl_debug_log, "{}\n");
1135 sv = sv_newmortal();
1136 PerlIO_printf(Perl_debug_log, "{\n");
1137 gv_fullname3(sv, gv, NULL);
1138 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1139 if (gv != GvEGV(gv)) {
1140 gv_efullname3(sv, GvEGV(gv), NULL);
1141 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1143 PerlIO_putc(Perl_debug_log, '\n');
1144 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1148 /* map magic types to the symbolic names
1149 * (with the PERL_MAGIC_ prefixed stripped)
1152 static const struct { const char type; const char *name; } magic_names[] = {
1153 { PERL_MAGIC_sv, "sv(\\0)" },
1154 { PERL_MAGIC_arylen, "arylen(#)" },
1155 { PERL_MAGIC_rhash, "rhash(%)" },
1156 { PERL_MAGIC_pos, "pos(.)" },
1157 { PERL_MAGIC_symtab, "symtab(:)" },
1158 { PERL_MAGIC_backref, "backref(<)" },
1159 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1160 { PERL_MAGIC_overload, "overload(A)" },
1161 { PERL_MAGIC_bm, "bm(B)" },
1162 { PERL_MAGIC_regdata, "regdata(D)" },
1163 { PERL_MAGIC_env, "env(E)" },
1164 { PERL_MAGIC_hints, "hints(H)" },
1165 { PERL_MAGIC_isa, "isa(I)" },
1166 { PERL_MAGIC_dbfile, "dbfile(L)" },
1167 { PERL_MAGIC_shared, "shared(N)" },
1168 { PERL_MAGIC_tied, "tied(P)" },
1169 { PERL_MAGIC_sig, "sig(S)" },
1170 { PERL_MAGIC_uvar, "uvar(U)" },
1171 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1172 { PERL_MAGIC_overload_table, "overload_table(c)" },
1173 { PERL_MAGIC_regdatum, "regdatum(d)" },
1174 { PERL_MAGIC_envelem, "envelem(e)" },
1175 { PERL_MAGIC_fm, "fm(f)" },
1176 { PERL_MAGIC_regex_global, "regex_global(g)" },
1177 { PERL_MAGIC_hintselem, "hintselem(h)" },
1178 { PERL_MAGIC_isaelem, "isaelem(i)" },
1179 { PERL_MAGIC_nkeys, "nkeys(k)" },
1180 { PERL_MAGIC_dbline, "dbline(l)" },
1181 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1182 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1183 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1184 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1185 { PERL_MAGIC_qr, "qr(r)" },
1186 { PERL_MAGIC_sigelem, "sigelem(s)" },
1187 { PERL_MAGIC_taint, "taint(t)" },
1188 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1189 { PERL_MAGIC_vec, "vec(v)" },
1190 { PERL_MAGIC_vstring, "vstring(V)" },
1191 { PERL_MAGIC_utf8, "utf8(w)" },
1192 { PERL_MAGIC_substr, "substr(x)" },
1193 { PERL_MAGIC_defelem, "defelem(y)" },
1194 { PERL_MAGIC_ext, "ext(~)" },
1195 /* this null string terminates the list */
1200 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1202 for (; mg; mg = mg->mg_moremagic) {
1203 Perl_dump_indent(aTHX_ level, file,
1204 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1205 if (mg->mg_virtual) {
1206 const MGVTBL * const v = mg->mg_virtual;
1208 if (v == &PL_vtbl_sv) s = "sv";
1209 else if (v == &PL_vtbl_env) s = "env";
1210 else if (v == &PL_vtbl_envelem) s = "envelem";
1211 else if (v == &PL_vtbl_sig) s = "sig";
1212 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1213 else if (v == &PL_vtbl_pack) s = "pack";
1214 else if (v == &PL_vtbl_packelem) s = "packelem";
1215 else if (v == &PL_vtbl_dbline) s = "dbline";
1216 else if (v == &PL_vtbl_isa) s = "isa";
1217 else if (v == &PL_vtbl_arylen) s = "arylen";
1218 else if (v == &PL_vtbl_mglob) s = "mglob";
1219 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1220 else if (v == &PL_vtbl_taint) s = "taint";
1221 else if (v == &PL_vtbl_substr) s = "substr";
1222 else if (v == &PL_vtbl_vec) s = "vec";
1223 else if (v == &PL_vtbl_pos) s = "pos";
1224 else if (v == &PL_vtbl_bm) s = "bm";
1225 else if (v == &PL_vtbl_fm) s = "fm";
1226 else if (v == &PL_vtbl_uvar) s = "uvar";
1227 else if (v == &PL_vtbl_defelem) s = "defelem";
1228 #ifdef USE_LOCALE_COLLATE
1229 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1231 else if (v == &PL_vtbl_amagic) s = "amagic";
1232 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1233 else if (v == &PL_vtbl_backref) s = "backref";
1234 else if (v == &PL_vtbl_utf8) s = "utf8";
1235 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1236 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1239 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1241 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1244 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1247 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1251 const char *name = NULL;
1252 for (n = 0; magic_names[n].name; n++) {
1253 if (mg->mg_type == magic_names[n].type) {
1254 name = magic_names[n].name;
1259 Perl_dump_indent(aTHX_ level, file,
1260 " MG_TYPE = PERL_MAGIC_%s\n", name);
1262 Perl_dump_indent(aTHX_ level, file,
1263 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1267 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1268 if (mg->mg_type == PERL_MAGIC_envelem &&
1269 mg->mg_flags & MGf_TAINTEDDIR)
1270 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1271 if (mg->mg_flags & MGf_REFCOUNTED)
1272 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1273 if (mg->mg_flags & MGf_GSKIP)
1274 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1275 if (mg->mg_type == PERL_MAGIC_regex_global &&
1276 mg->mg_flags & MGf_MINMATCH)
1277 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1280 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1281 PTR2UV(mg->mg_obj));
1282 if (mg->mg_type == PERL_MAGIC_qr) {
1283 const regexp * const re = (regexp *)mg->mg_obj;
1284 SV * const dsv = sv_newmortal();
1285 const char * const s = pv_pretty(dsv, re->wrapped, re->wraplen,
1287 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1288 ((re->extflags & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0))
1290 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1291 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1294 if (mg->mg_flags & MGf_REFCOUNTED)
1295 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1298 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1300 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1301 if (mg->mg_len >= 0) {
1302 if (mg->mg_type != PERL_MAGIC_utf8) {
1303 SV * const sv = newSVpvs("");
1304 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1308 else if (mg->mg_len == HEf_SVKEY) {
1309 PerlIO_puts(file, " => HEf_SVKEY\n");
1310 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1314 PerlIO_puts(file, " ???? - please notify IZ");
1315 PerlIO_putc(file, '\n');
1317 if (mg->mg_type == PERL_MAGIC_utf8) {
1318 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1321 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1322 Perl_dump_indent(aTHX_ level, file,
1323 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1326 (UV)cache[i * 2 + 1]);
1333 Perl_magic_dump(pTHX_ const MAGIC *mg)
1335 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1339 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1342 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1343 if (sv && (hvname = HvNAME_get(sv)))
1344 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1346 PerlIO_putc(file, '\n');
1350 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1352 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1353 if (sv && GvNAME(sv))
1354 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1356 PerlIO_putc(file, '\n');
1360 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1362 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1363 if (sv && GvNAME(sv)) {
1365 PerlIO_printf(file, "\t\"");
1366 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1367 PerlIO_printf(file, "%s\" :: \"", hvname);
1368 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1371 PerlIO_putc(file, '\n');
1375 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1384 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1388 flags = SvFLAGS(sv);
1391 d = Perl_newSVpvf(aTHX_
1392 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1393 PTR2UV(SvANY(sv)), PTR2UV(sv),
1394 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1395 (int)(PL_dumpindent*level), "");
1397 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1398 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1400 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1401 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1402 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1404 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1405 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1406 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1407 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1408 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1410 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1411 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1412 if (flags & SVf_POK) sv_catpv(d, "POK,");
1413 if (flags & SVf_ROK) {
1414 sv_catpv(d, "ROK,");
1415 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1417 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1418 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1419 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1420 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1422 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1423 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1424 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1425 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1426 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1427 if (SvPCS_IMPORTED(sv))
1428 sv_catpv(d, "PCS_IMPORTED,");
1430 sv_catpv(d, "SCREAM,");
1436 if (CvANON(sv)) sv_catpv(d, "ANON,");
1437 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1438 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1439 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1440 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1441 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1442 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1443 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1444 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1445 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1446 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1449 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1450 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1451 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1452 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1453 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1457 if (isGV_with_GP(sv)) {
1458 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1459 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1460 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1461 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1462 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1464 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1465 sv_catpv(d, "IMPORT");
1466 if (GvIMPORTED(sv) == GVf_IMPORTED)
1467 sv_catpv(d, "ALL,");
1470 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1471 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1472 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1473 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1477 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1478 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1482 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1483 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1486 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1487 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1490 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1495 /* SVphv_SHAREKEYS is also 0x20000000 */
1496 if ((type != SVt_PVHV) && SvUTF8(sv))
1497 sv_catpv(d, "UTF8");
1499 if (*(SvEND(d) - 1) == ',') {
1500 SvCUR_set(d, SvCUR(d) - 1);
1501 SvPVX(d)[SvCUR(d)] = '\0';
1506 #ifdef DEBUG_LEAKING_SCALARS
1507 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1508 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1510 sv->sv_debug_inpad ? "for" : "by",
1511 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1512 sv->sv_debug_cloned ? " (cloned)" : "");
1514 Perl_dump_indent(aTHX_ level, file, "SV = ");
1515 if (type < SVt_LAST) {
1516 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1518 if (type == SVt_NULL) {
1523 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1527 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1528 && type != SVt_PVCV && !isGV_with_GP(sv))
1529 || type == SVt_IV) {
1531 #ifdef PERL_OLD_COPY_ON_WRITE
1535 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1537 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1539 PerlIO_printf(file, " (OFFSET)");
1540 #ifdef PERL_OLD_COPY_ON_WRITE
1541 if (SvIsCOW_shared_hash(sv))
1542 PerlIO_printf(file, " (HASH)");
1543 else if (SvIsCOW_normal(sv))
1544 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1546 PerlIO_putc(file, '\n');
1548 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1549 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1550 (UV) COP_SEQ_RANGE_LOW(sv));
1551 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1552 (UV) COP_SEQ_RANGE_HIGH(sv));
1553 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1554 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)
1556 || type == SVt_NV) {
1557 STORE_NUMERIC_LOCAL_SET_STANDARD();
1558 /* %Vg doesn't work? --jhi */
1559 #ifdef USE_LONG_DOUBLE
1560 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1562 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1564 RESTORE_NUMERIC_LOCAL();
1567 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1569 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1571 if (type < SVt_PV) {
1575 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1576 if (SvPVX_const(sv)) {
1577 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1579 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1580 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1581 if (SvUTF8(sv)) /* the 6? \x{....} */
1582 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1583 PerlIO_printf(file, "\n");
1584 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1585 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1588 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1590 if (type >= SVt_PVMG) {
1591 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1592 HV * const ost = SvOURSTASH(sv);
1594 do_hv_dump(level, file, " OURSTASH", ost);
1597 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1600 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1604 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1605 if (AvARRAY(sv) != AvALLOC(sv)) {
1606 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1607 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1610 PerlIO_putc(file, '\n');
1611 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1612 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1613 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1614 sv_setpvn(d, "", 0);
1615 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1616 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1617 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1618 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1619 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1621 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1622 SV** const elt = av_fetch((AV*)sv,count,0);
1624 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1626 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1631 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1632 if (HvARRAY(sv) && HvKEYS(sv)) {
1633 /* Show distribution of HEs in the ARRAY */
1635 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1638 U32 pow2 = 2, keys = HvKEYS(sv);
1639 NV theoret, sum = 0;
1641 PerlIO_printf(file, " (");
1642 Zero(freq, FREQ_MAX + 1, int);
1643 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1646 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1648 if (count > FREQ_MAX)
1654 for (i = 0; i <= max; i++) {
1656 PerlIO_printf(file, "%d%s:%d", i,
1657 (i == FREQ_MAX) ? "+" : "",
1660 PerlIO_printf(file, ", ");
1663 PerlIO_putc(file, ')');
1664 /* The "quality" of a hash is defined as the total number of
1665 comparisons needed to access every element once, relative
1666 to the expected number needed for a random hash.
1668 The total number of comparisons is equal to the sum of
1669 the squares of the number of entries in each bucket.
1670 For a random hash of n keys into k buckets, the expected
1675 for (i = max; i > 0; i--) { /* Precision: count down. */
1676 sum += freq[i] * i * i;
1678 while ((keys = keys >> 1))
1680 theoret = HvKEYS(sv);
1681 theoret += theoret * (theoret-1)/pow2;
1682 PerlIO_putc(file, '\n');
1683 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1685 PerlIO_putc(file, '\n');
1686 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1687 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1688 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1689 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1690 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1692 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1693 if (mg && mg->mg_obj) {
1694 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1698 const char * const hvname = HvNAME_get(sv);
1700 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1703 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1705 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1707 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1711 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1713 HV * const hv = (HV*)sv;
1714 int count = maxnest - nest;
1717 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1720 const U32 hash = HeHASH(he);
1721 SV * const keysv = hv_iterkeysv(he);
1722 const char * const keypv = SvPV_const(keysv, len);
1723 SV * const elt = hv_iterval(hv, he);
1725 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1727 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1729 PerlIO_printf(file, "[REHASH] ");
1730 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1731 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1733 hv_iterinit(hv); /* Return to status quo */
1739 const char *const proto = SvPV_const(sv, len);
1740 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1745 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1746 if (!CvISXSUB(sv)) {
1748 Perl_dump_indent(aTHX_ level, file,
1749 " START = 0x%"UVxf" ===> %"IVdf"\n",
1750 PTR2UV(CvSTART(sv)),
1751 (IV)sequence_num(CvSTART(sv)));
1753 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1754 PTR2UV(CvROOT(sv)));
1755 if (CvROOT(sv) && dumpops) {
1756 do_op_dump(level+1, file, CvROOT(sv));
1759 SV * const constant = cv_const_sv((CV *)sv);
1761 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1764 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1766 PTR2UV(CvXSUBANY(sv).any_ptr));
1767 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1770 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1771 (IV)CvXSUBANY(sv).any_i32);
1774 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1775 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1776 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1777 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1778 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1779 if (type == SVt_PVFM)
1780 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1781 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1782 if (nest < maxnest) {
1783 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1786 const CV * const outside = CvOUTSIDE(sv);
1787 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1790 : CvANON(outside) ? "ANON"
1791 : (outside == PL_main_cv) ? "MAIN"
1792 : CvUNIQUE(outside) ? "UNIQUE"
1793 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1795 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1796 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1800 if (type == SVt_PVLV) {
1801 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1802 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1803 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1804 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1805 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1806 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1810 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1811 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1812 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1813 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1815 if (!isGV_with_GP(sv))
1817 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1818 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1819 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1820 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1823 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1824 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1825 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1826 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1827 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1828 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1829 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1830 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1831 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1832 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1833 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1834 do_gv_dump (level, file, " EGV", GvEGV(sv));
1837 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1838 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1839 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1840 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1841 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1842 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1843 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1845 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1846 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1847 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1849 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1850 PTR2UV(IoTOP_GV(sv)));
1851 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1854 /* Source filters hide things that are not GVs in these three, so let's
1855 be careful out there. */
1857 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1858 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1859 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1861 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1862 PTR2UV(IoFMT_GV(sv)));
1863 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1866 if (IoBOTTOM_NAME(sv))
1867 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1868 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1869 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1871 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1872 PTR2UV(IoBOTTOM_GV(sv)));
1873 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1876 if (isPRINT(IoTYPE(sv)))
1877 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1879 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1880 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1887 Perl_sv_dump(pTHX_ SV *sv)
1891 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1893 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1897 Perl_runops_debug(pTHX)
1901 if (ckWARN_d(WARN_DEBUGGING))
1902 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1906 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1910 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1911 PerlIO_printf(Perl_debug_log,
1912 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1913 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1914 PTR2UV(*PL_watchaddr));
1915 if (DEBUG_s_TEST_) {
1916 if (DEBUG_v_TEST_) {
1917 PerlIO_printf(Perl_debug_log, "\n");
1925 if (DEBUG_t_TEST_) debop(PL_op);
1926 if (DEBUG_P_TEST_) debprof(PL_op);
1928 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1929 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1936 Perl_debop(pTHX_ const OP *o)
1939 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1942 Perl_deb(aTHX_ "%s", OP_NAME(o));
1943 switch (o->op_type) {
1945 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1950 SV * const sv = newSV(0);
1952 /* FIXME - is this making unwarranted assumptions about the
1953 UTF-8 cleanliness of the dump file handle? */
1956 gv_fullname3(sv, cGVOPo_gv, NULL);
1957 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1961 PerlIO_printf(Perl_debug_log, "(NULL)");
1967 /* print the lexical's name */
1968 CV * const cv = deb_curcv(cxstack_ix);
1971 AV * const padlist = CvPADLIST(cv);
1972 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1973 sv = *av_fetch(comppad, o->op_targ, FALSE);
1977 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1979 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1985 PerlIO_printf(Perl_debug_log, "\n");
1990 S_deb_curcv(pTHX_ const I32 ix)
1993 const PERL_CONTEXT * const cx = &cxstack[ix];
1994 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1995 return cx->blk_sub.cv;
1996 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1998 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2003 return deb_curcv(ix - 1);
2007 Perl_watch(pTHX_ char **addr)
2010 PL_watchaddr = addr;
2012 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2013 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2017 S_debprof(pTHX_ const OP *o)
2020 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2022 if (!PL_profiledata)
2023 Newxz(PL_profiledata, MAXO, U32);
2024 ++PL_profiledata[o->op_type];
2028 Perl_debprofdump(pTHX)
2032 if (!PL_profiledata)
2034 for (i = 0; i < MAXO; i++) {
2035 if (PL_profiledata[i])
2036 PerlIO_printf(Perl_debug_log,
2037 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2044 * XML variants of most of the above routines
2048 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2051 PerlIO_printf(file, "\n ");
2052 va_start(args, pat);
2053 xmldump_vindent(level, file, pat, &args);
2059 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2062 va_start(args, pat);
2063 xmldump_vindent(level, file, pat, &args);
2068 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2070 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2071 PerlIO_vprintf(file, pat, *args);
2075 Perl_xmldump_all(pTHX)
2077 PerlIO_setlinebuf(PL_xmlfp);
2079 op_xmldump(PL_main_root);
2080 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2081 PerlIO_close(PL_xmlfp);
2086 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2091 if (!HvARRAY(stash))
2093 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2094 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2095 GV *gv = (GV*)HeVAL(entry);
2097 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2103 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2104 && (hv = GvHV(gv)) && hv != PL_defstash)
2105 xmldump_packsubs(hv); /* nested package */
2111 Perl_xmldump_sub(pTHX_ const GV *gv)
2113 SV * const sv = sv_newmortal();
2115 gv_fullname3(sv, gv, Nullch);
2116 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2117 if (CvXSUB(GvCV(gv)))
2118 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2119 PTR2UV(CvXSUB(GvCV(gv))),
2120 (int)CvXSUBANY(GvCV(gv)).any_i32);
2121 else if (CvROOT(GvCV(gv)))
2122 op_xmldump(CvROOT(GvCV(gv)));
2124 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2128 Perl_xmldump_form(pTHX_ const GV *gv)
2130 SV * const sv = sv_newmortal();
2132 gv_fullname3(sv, gv, Nullch);
2133 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2134 if (CvROOT(GvFORM(gv)))
2135 op_xmldump(CvROOT(GvFORM(gv)));
2137 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2141 Perl_xmldump_eval(pTHX)
2143 op_xmldump(PL_eval_root);
2147 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2149 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2153 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2156 const char * const e = pv + len;
2157 const char * const start = pv;
2161 sv_catpvn(dsv,"",0);
2162 dsvcur = SvCUR(dsv); /* in case we have to restart */
2167 c = utf8_to_uvchr((U8*)pv, &cl);
2169 SvCUR(dsv) = dsvcur;
2234 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2237 sv_catpvs(dsv, "<");
2240 sv_catpvs(dsv, ">");
2243 sv_catpvs(dsv, "&");
2246 sv_catpvs(dsv, """);
2250 if (c < 32 || c > 127) {
2251 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2254 const char string = (char) c;
2255 sv_catpvn(dsv, &string, 1);
2259 if ((c >= 0xD800 && c <= 0xDB7F) ||
2260 (c >= 0xDC00 && c <= 0xDFFF) ||
2261 (c >= 0xFFF0 && c <= 0xFFFF) ||
2263 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2265 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2278 Perl_sv_xmlpeek(pTHX_ SV *sv)
2280 SV * const t = sv_newmortal();
2285 sv_setpvn(t, "", 0);
2288 sv_catpv(t, "VOID=\"\"");
2291 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2292 sv_catpv(t, "WILD=\"\"");
2295 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2296 if (sv == &PL_sv_undef) {
2297 sv_catpv(t, "SV_UNDEF=\"1\"");
2298 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2299 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2303 else if (sv == &PL_sv_no) {
2304 sv_catpv(t, "SV_NO=\"1\"");
2305 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2306 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2307 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2308 SVp_POK|SVp_NOK)) &&
2313 else if (sv == &PL_sv_yes) {
2314 sv_catpv(t, "SV_YES=\"1\"");
2315 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2316 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2317 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2318 SVp_POK|SVp_NOK)) &&
2320 SvPVX(sv) && *SvPVX(sv) == '1' &&
2325 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2326 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2327 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2331 sv_catpv(t, " XXX=\"\" ");
2333 else if (SvREFCNT(sv) == 0) {
2334 sv_catpv(t, " refcnt=\"0\"");
2337 else if (DEBUG_R_TEST_) {
2340 /* is this SV on the tmps stack? */
2341 for (ix=PL_tmps_ix; ix>=0; ix--) {
2342 if (PL_tmps_stack[ix] == sv) {
2347 if (SvREFCNT(sv) > 1)
2348 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2351 sv_catpv(t, " DRT=\"<T>\"");
2355 sv_catpv(t, " ROK=\"\"");
2357 switch (SvTYPE(sv)) {
2359 sv_catpv(t, " FREED=\"1\"");
2363 sv_catpv(t, " UNDEF=\"1\"");
2366 sv_catpv(t, " IV=\"");
2369 sv_catpv(t, " NV=\"");
2372 sv_catpv(t, " RV=\"");
2375 sv_catpv(t, " PV=\"");
2378 sv_catpv(t, " PVIV=\"");
2381 sv_catpv(t, " PVNV=\"");
2384 sv_catpv(t, " PVMG=\"");
2387 sv_catpv(t, " PVLV=\"");
2390 sv_catpv(t, " AV=\"");
2393 sv_catpv(t, " HV=\"");
2397 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2399 sv_catpv(t, " CV=\"()\"");
2402 sv_catpv(t, " GV=\"");
2405 sv_catpv(t, " BIND=\"");
2408 sv_catpv(t, " FM=\"");
2411 sv_catpv(t, " IO=\"");
2420 else if (SvNOKp(sv)) {
2421 STORE_NUMERIC_LOCAL_SET_STANDARD();
2422 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2423 RESTORE_NUMERIC_LOCAL();
2425 else if (SvIOKp(sv)) {
2427 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2429 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2438 return SvPV(t, n_a);
2442 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2445 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2448 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2451 const char * const s = PM_GETRE(pm)->precomp;
2452 SV * const tmpsv = newSVpvn("",0);
2454 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2455 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2457 SvREFCNT_dec(tmpsv);
2458 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2459 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2462 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2463 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2464 SV * const tmpsv = pm_description(pm);
2465 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2466 SvREFCNT_dec(tmpsv);
2470 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2471 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2472 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2473 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2474 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2475 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2478 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2482 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2484 do_pmop_xmldump(0, PL_xmlfp, pm);
2488 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2495 seq = sequence_num(o);
2496 Perl_xmldump_indent(aTHX_ level, file,
2497 "<op_%s seq=\"%"UVuf" -> ",
2502 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2503 sequence_num(o->op_next));
2505 PerlIO_printf(file, "DONE\"");
2508 if (o->op_type == OP_NULL)
2510 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2511 if (o->op_targ == OP_NEXTSTATE)
2514 PerlIO_printf(file, " line=\"%"UVuf"\"",
2515 (UV)CopLINE(cCOPo));
2516 if (CopSTASHPV(cCOPo))
2517 PerlIO_printf(file, " package=\"%s\"",
2519 if (cCOPo->cop_label)
2520 PerlIO_printf(file, " label=\"%s\"",
2525 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2528 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2531 SV * const tmpsv = newSVpvn("", 0);
2532 switch (o->op_flags & OPf_WANT) {
2534 sv_catpv(tmpsv, ",VOID");
2536 case OPf_WANT_SCALAR:
2537 sv_catpv(tmpsv, ",SCALAR");
2540 sv_catpv(tmpsv, ",LIST");
2543 sv_catpv(tmpsv, ",UNKNOWN");
2546 if (o->op_flags & OPf_KIDS)
2547 sv_catpv(tmpsv, ",KIDS");
2548 if (o->op_flags & OPf_PARENS)
2549 sv_catpv(tmpsv, ",PARENS");
2550 if (o->op_flags & OPf_STACKED)
2551 sv_catpv(tmpsv, ",STACKED");
2552 if (o->op_flags & OPf_REF)
2553 sv_catpv(tmpsv, ",REF");
2554 if (o->op_flags & OPf_MOD)
2555 sv_catpv(tmpsv, ",MOD");
2556 if (o->op_flags & OPf_SPECIAL)
2557 sv_catpv(tmpsv, ",SPECIAL");
2558 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2559 SvREFCNT_dec(tmpsv);
2561 if (o->op_private) {
2562 SV * const tmpsv = newSVpvn("", 0);
2563 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2564 if (o->op_private & OPpTARGET_MY)
2565 sv_catpv(tmpsv, ",TARGET_MY");
2567 else if (o->op_type == OP_LEAVESUB ||
2568 o->op_type == OP_LEAVE ||
2569 o->op_type == OP_LEAVESUBLV ||
2570 o->op_type == OP_LEAVEWRITE) {
2571 if (o->op_private & OPpREFCOUNTED)
2572 sv_catpv(tmpsv, ",REFCOUNTED");
2574 else if (o->op_type == OP_AASSIGN) {
2575 if (o->op_private & OPpASSIGN_COMMON)
2576 sv_catpv(tmpsv, ",COMMON");
2578 else if (o->op_type == OP_SASSIGN) {
2579 if (o->op_private & OPpASSIGN_BACKWARDS)
2580 sv_catpv(tmpsv, ",BACKWARDS");
2582 else if (o->op_type == OP_TRANS) {
2583 if (o->op_private & OPpTRANS_SQUASH)
2584 sv_catpv(tmpsv, ",SQUASH");
2585 if (o->op_private & OPpTRANS_DELETE)
2586 sv_catpv(tmpsv, ",DELETE");
2587 if (o->op_private & OPpTRANS_COMPLEMENT)
2588 sv_catpv(tmpsv, ",COMPLEMENT");
2589 if (o->op_private & OPpTRANS_IDENTICAL)
2590 sv_catpv(tmpsv, ",IDENTICAL");
2591 if (o->op_private & OPpTRANS_GROWS)
2592 sv_catpv(tmpsv, ",GROWS");
2594 else if (o->op_type == OP_REPEAT) {
2595 if (o->op_private & OPpREPEAT_DOLIST)
2596 sv_catpv(tmpsv, ",DOLIST");
2598 else if (o->op_type == OP_ENTERSUB ||
2599 o->op_type == OP_RV2SV ||
2600 o->op_type == OP_GVSV ||
2601 o->op_type == OP_RV2AV ||
2602 o->op_type == OP_RV2HV ||
2603 o->op_type == OP_RV2GV ||
2604 o->op_type == OP_AELEM ||
2605 o->op_type == OP_HELEM )
2607 if (o->op_type == OP_ENTERSUB) {
2608 if (o->op_private & OPpENTERSUB_AMPER)
2609 sv_catpv(tmpsv, ",AMPER");
2610 if (o->op_private & OPpENTERSUB_DB)
2611 sv_catpv(tmpsv, ",DB");
2612 if (o->op_private & OPpENTERSUB_HASTARG)
2613 sv_catpv(tmpsv, ",HASTARG");
2614 if (o->op_private & OPpENTERSUB_NOPAREN)
2615 sv_catpv(tmpsv, ",NOPAREN");
2616 if (o->op_private & OPpENTERSUB_INARGS)
2617 sv_catpv(tmpsv, ",INARGS");
2618 if (o->op_private & OPpENTERSUB_NOMOD)
2619 sv_catpv(tmpsv, ",NOMOD");
2622 switch (o->op_private & OPpDEREF) {
2624 sv_catpv(tmpsv, ",SV");
2627 sv_catpv(tmpsv, ",AV");
2630 sv_catpv(tmpsv, ",HV");
2633 if (o->op_private & OPpMAYBE_LVSUB)
2634 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2636 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2637 if (o->op_private & OPpLVAL_DEFER)
2638 sv_catpv(tmpsv, ",LVAL_DEFER");
2641 if (o->op_private & HINT_STRICT_REFS)
2642 sv_catpv(tmpsv, ",STRICT_REFS");
2643 if (o->op_private & OPpOUR_INTRO)
2644 sv_catpv(tmpsv, ",OUR_INTRO");
2647 else if (o->op_type == OP_CONST) {
2648 if (o->op_private & OPpCONST_BARE)
2649 sv_catpv(tmpsv, ",BARE");
2650 if (o->op_private & OPpCONST_STRICT)
2651 sv_catpv(tmpsv, ",STRICT");
2652 if (o->op_private & OPpCONST_ARYBASE)
2653 sv_catpv(tmpsv, ",ARYBASE");
2654 if (o->op_private & OPpCONST_WARNING)
2655 sv_catpv(tmpsv, ",WARNING");
2656 if (o->op_private & OPpCONST_ENTERED)
2657 sv_catpv(tmpsv, ",ENTERED");
2659 else if (o->op_type == OP_FLIP) {
2660 if (o->op_private & OPpFLIP_LINENUM)
2661 sv_catpv(tmpsv, ",LINENUM");
2663 else if (o->op_type == OP_FLOP) {
2664 if (o->op_private & OPpFLIP_LINENUM)
2665 sv_catpv(tmpsv, ",LINENUM");
2667 else if (o->op_type == OP_RV2CV) {
2668 if (o->op_private & OPpLVAL_INTRO)
2669 sv_catpv(tmpsv, ",INTRO");
2671 else if (o->op_type == OP_GV) {
2672 if (o->op_private & OPpEARLY_CV)
2673 sv_catpv(tmpsv, ",EARLY_CV");
2675 else if (o->op_type == OP_LIST) {
2676 if (o->op_private & OPpLIST_GUESSED)
2677 sv_catpv(tmpsv, ",GUESSED");
2679 else if (o->op_type == OP_DELETE) {
2680 if (o->op_private & OPpSLICE)
2681 sv_catpv(tmpsv, ",SLICE");
2683 else if (o->op_type == OP_EXISTS) {
2684 if (o->op_private & OPpEXISTS_SUB)
2685 sv_catpv(tmpsv, ",EXISTS_SUB");
2687 else if (o->op_type == OP_SORT) {
2688 if (o->op_private & OPpSORT_NUMERIC)
2689 sv_catpv(tmpsv, ",NUMERIC");
2690 if (o->op_private & OPpSORT_INTEGER)
2691 sv_catpv(tmpsv, ",INTEGER");
2692 if (o->op_private & OPpSORT_REVERSE)
2693 sv_catpv(tmpsv, ",REVERSE");
2695 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2696 if (o->op_private & OPpOPEN_IN_RAW)
2697 sv_catpv(tmpsv, ",IN_RAW");
2698 if (o->op_private & OPpOPEN_IN_CRLF)
2699 sv_catpv(tmpsv, ",IN_CRLF");
2700 if (o->op_private & OPpOPEN_OUT_RAW)
2701 sv_catpv(tmpsv, ",OUT_RAW");
2702 if (o->op_private & OPpOPEN_OUT_CRLF)
2703 sv_catpv(tmpsv, ",OUT_CRLF");
2705 else if (o->op_type == OP_EXIT) {
2706 if (o->op_private & OPpEXIT_VMSISH)
2707 sv_catpv(tmpsv, ",EXIT_VMSISH");
2708 if (o->op_private & OPpHUSH_VMSISH)
2709 sv_catpv(tmpsv, ",HUSH_VMSISH");
2711 else if (o->op_type == OP_DIE) {
2712 if (o->op_private & OPpHUSH_VMSISH)
2713 sv_catpv(tmpsv, ",HUSH_VMSISH");
2715 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2716 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2717 sv_catpv(tmpsv, ",FT_ACCESS");
2718 if (o->op_private & OPpFT_STACKED)
2719 sv_catpv(tmpsv, ",FT_STACKED");
2721 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2722 sv_catpv(tmpsv, ",INTRO");
2724 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2725 SvREFCNT_dec(tmpsv);
2728 switch (o->op_type) {
2730 if (o->op_flags & OPf_SPECIAL) {
2736 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2738 if (cSVOPo->op_sv) {
2739 SV * const tmpsv1 = newSV(0);
2740 SV * const tmpsv2 = newSVpvn("",0);
2748 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2749 s = SvPV(tmpsv1,len);
2750 sv_catxmlpvn(tmpsv2, s, len, 1);
2751 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2755 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2759 case OP_METHOD_NAMED:
2760 #ifndef USE_ITHREADS
2761 /* with ITHREADS, consts are stored in the pad, and the right pad
2762 * may not be active here, so skip */
2763 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2769 PerlIO_printf(file, ">\n");
2771 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2777 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2778 (UV)CopLINE(cCOPo));
2779 if (CopSTASHPV(cCOPo))
2780 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2782 if (cCOPo->cop_label)
2783 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2787 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2788 if (cLOOPo->op_redoop)
2789 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2791 PerlIO_printf(file, "DONE\"");
2792 S_xmldump_attr(aTHX_ level, file, "next=\"");
2793 if (cLOOPo->op_nextop)
2794 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2796 PerlIO_printf(file, "DONE\"");
2797 S_xmldump_attr(aTHX_ level, file, "last=\"");
2798 if (cLOOPo->op_lastop)
2799 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2801 PerlIO_printf(file, "DONE\"");
2809 S_xmldump_attr(aTHX_ level, file, "other=\"");
2810 if (cLOGOPo->op_other)
2811 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2813 PerlIO_printf(file, "DONE\"");
2821 if (o->op_private & OPpREFCOUNTED)
2822 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2828 if (PL_madskills && o->op_madprop) {
2829 char prevkey = '\0';
2830 SV * const tmpsv = newSVpvn("", 0);
2831 const MADPROP* mp = o->op_madprop;
2833 sv_utf8_upgrade(tmpsv);
2836 PerlIO_printf(file, ">\n");
2838 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2841 char tmp = mp->mad_key;
2842 sv_setpvn(tmpsv,"\"",1);
2844 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2845 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2846 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2849 sv_catpv(tmpsv, "\"");
2850 switch (mp->mad_type) {
2852 sv_catpv(tmpsv, "NULL");
2853 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2856 sv_catpv(tmpsv, " val=\"");
2857 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2858 sv_catpv(tmpsv, "\"");
2859 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2862 sv_catpv(tmpsv, " val=\"");
2863 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2864 sv_catpv(tmpsv, "\"");
2865 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2868 if ((OP*)mp->mad_val) {
2869 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2870 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2871 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2875 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2881 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2883 SvREFCNT_dec(tmpsv);
2886 switch (o->op_type) {
2893 PerlIO_printf(file, ">\n");
2895 do_pmop_xmldump(level, file, cPMOPo);
2901 if (o->op_flags & OPf_KIDS) {
2905 PerlIO_printf(file, ">\n");
2907 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2908 do_op_xmldump(level, file, kid);
2912 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2914 PerlIO_printf(file, " />\n");
2918 Perl_op_xmldump(pTHX_ const OP *o)
2920 do_op_xmldump(0, PL_xmlfp, o);
2926 * c-indentation-style: bsd
2928 * indent-tabs-mode: t
2931 * ex: set ts=8 sts=4 sw=4 noet: