3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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] = {
70 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
74 dump_vindent(level, file, pat, &args);
79 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
81 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
82 PerlIO_vprintf(file, pat, *args);
88 PerlIO_setlinebuf(Perl_debug_log);
90 op_dump(PL_main_root);
91 dump_packsubs(PL_defstash);
95 Perl_dump_packsubs(pTHX_ HV *stash)
101 for (i = 0; i <= (I32) HvMAX(stash); i++) {
103 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
104 const GV *gv = (GV*)HeVAL(entry);
106 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
112 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
113 && (hv = GvHV(gv)) && hv != PL_defstash)
114 dump_packsubs((HV *) hv); /* nested package */
120 Perl_dump_sub(pTHX_ GV *gv)
122 SV * const sv = sv_newmortal();
124 gv_fullname3(sv, gv, NULL);
125 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
126 if (CvISXSUB(GvCV(gv)))
127 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
128 PTR2UV(CvXSUB(GvCV(gv))),
129 (int)CvXSUBANY(GvCV(gv)).any_i32);
130 else if (CvROOT(GvCV(gv)))
131 op_dump(CvROOT(GvCV(gv)));
133 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
137 Perl_dump_form(pTHX_ GV *gv)
139 SV * const sv = sv_newmortal();
141 gv_fullname3(sv, gv, NULL);
142 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
143 if (CvROOT(GvFORM(gv)))
144 op_dump(CvROOT(GvFORM(gv)));
146 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
152 op_dump(PL_eval_root);
157 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
158 |const STRLEN count|const STRLEN max
159 |STRLEN const *escaped, const U32 flags
161 Escapes at most the first "count" chars of pv and puts the results into
162 dsv such that the size of the escaped string will not exceed "max" chars
163 and will not contain any incomplete escape sequences.
165 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
166 will also be escaped.
168 Normally the SV will be cleared before the escaped string is prepared,
169 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
171 If PERL_PV_ESCAPE_UNI is set then the input string is treated as unicode,
172 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
173 using C<is_utf8_string()> to determine if it is unicode.
175 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
176 using C<\x01F1> style escapes, otherwise only chars above 255 will be
177 escaped using this style, other non printable chars will use octal or
178 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
179 then all chars below 255 will be treated as printable and
180 will be output as literals.
182 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
183 string will be escaped, regardles of max. If the string is utf8 and
184 the chars value is >255 then it will be returned as a plain hex
185 sequence. Thus the output will either be a single char,
186 an octal escape sequence, a special escape like C<\n> or a 3 or
187 more digit hex value.
189 Returns a pointer to the escaped text as held by dsv.
193 #define PV_ESCAPE_OCTBUFSIZE 32
196 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
197 const STRLEN count, const STRLEN max,
198 STRLEN * const escaped, const U32 flags )
200 char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
201 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
202 STRLEN wrote = 0; /* chars written so far */
203 STRLEN chsize = 0; /* size of data to be written */
204 STRLEN readsize = 1; /* size of data just read */
205 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
206 const char *pv = str;
207 const char *end = pv + count; /* end of string */
209 if (!flags & PERL_PV_ESCAPE_NOCLEAR)
210 sv_setpvn(dsv, "", 0);
212 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
215 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
216 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
217 const U8 c = (U8)u & 0xFF;
219 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
220 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
221 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
224 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
226 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
229 if ( (c == dq) || (c == '\\') || !isPRINT(c) ) {
232 case '\\' : octbuf[1] = '\\'; break;
233 case '\v' : octbuf[1] = 'v'; break;
234 case '\t' : octbuf[1] = 't'; break;
235 case '\r' : octbuf[1] = 'r'; break;
236 case '\n' : octbuf[1] = 'n'; break;
237 case '\f' : octbuf[1] = 'f'; break;
245 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
246 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
249 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
256 if ( max && (wrote + chsize > max) ) {
258 } else if (chsize > 1) {
259 sv_catpvn(dsv, octbuf, chsize);
262 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
265 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
273 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
274 |const STRLEN count|const STRLEN max\
275 |const char const *start_color| const char const *end_color\
278 Converts a string into something presentable, handling escaping via
279 pv_escape() and supporting quoting and elipses.
281 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
282 double quoted with any double quotes in the string escaped. Otherwise
283 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
286 If the PERL_PV_PRETTY_ELIPSES flag is set and not all characters in
287 string were output then an elipses C<...> will be appended to the
288 string. Note that this happens AFTER it has been quoted.
290 If start_color is non-null then it will be inserted after the opening
291 quote (if there is one) but before the escaped text. If end_color
292 is non-null then it will be inserted after the escaped text but before
293 any quotes or elipses.
295 Returns a pointer to the prettified text as held by dsv.
301 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
302 const STRLEN max, char const * const start_color, char const * const end_color,
305 U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
309 sv_setpvn(dsv, "\"", 1);
310 else if ( flags & PERL_PV_PRETTY_LTGT )
311 sv_setpvn(dsv, "<", 1);
313 sv_setpvn(dsv, "", 0);
315 if ( start_color != NULL )
316 Perl_sv_catpv( aTHX_ dsv, start_color);
318 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
320 if ( end_color != NULL )
321 Perl_sv_catpv( aTHX_ dsv, end_color);
324 sv_catpvn( dsv, "\"", 1 );
325 else if ( flags & PERL_PV_PRETTY_LTGT )
326 sv_catpvn( dsv, ">", 1);
328 if ( (flags & PERL_PV_PRETTY_ELIPSES) && ( escaped < count ) )
329 sv_catpvn( dsv, "...", 3 );
335 =for apidoc pv_display
337 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
338 STRLEN pvlim, U32 flags)
342 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
344 except that an additional "\0" will be appended to the string when
345 len > cur and pv[cur] is "\0".
347 Note that the final string may be up to 7 chars longer than pvlim.
353 Perl_pv_display(pTHX_ SV *dsv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
355 pv_pretty( dsv, (char *)pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
356 if (len > cur && pv[cur] == '\0')
357 sv_catpvn( dsv, "\\0", 2 );
362 Perl_sv_peek(pTHX_ SV *sv)
364 SV * const t = sv_newmortal();
374 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
378 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
379 if (sv == &PL_sv_undef) {
380 sv_catpv(t, "SV_UNDEF");
381 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
382 SVs_GMG|SVs_SMG|SVs_RMG)) &&
386 else if (sv == &PL_sv_no) {
387 sv_catpv(t, "SV_NO");
388 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
389 SVs_GMG|SVs_SMG|SVs_RMG)) &&
390 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
396 else if (sv == &PL_sv_yes) {
397 sv_catpv(t, "SV_YES");
398 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
399 SVs_GMG|SVs_SMG|SVs_RMG)) &&
400 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
403 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
408 sv_catpv(t, "SV_PLACEHOLDER");
409 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
410 SVs_GMG|SVs_SMG|SVs_RMG)) &&
416 else if (SvREFCNT(sv) == 0) {
420 else if (DEBUG_R_TEST_) {
423 /* is this SV on the tmps stack? */
424 for (ix=PL_tmps_ix; ix>=0; ix--) {
425 if (PL_tmps_stack[ix] == sv) {
430 if (SvREFCNT(sv) > 1)
431 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
439 if (SvCUR(t) + unref > 10) {
440 SvCUR_set(t, unref + 3);
449 if (type == SVt_PVCV) {
450 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
452 } else if (type < SVt_LAST) {
453 sv_catpv(t, svshorttypenames[type]);
455 if (type == SVt_NULL)
458 sv_catpv(t, "FREED");
463 if (!SvPVX_const(sv))
464 sv_catpv(t, "(null)");
466 SV * const tmp = newSVpvs("");
469 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, (char *)SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
470 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, (char *)SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
472 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
473 sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv),
478 else if (SvNOKp(sv)) {
479 STORE_NUMERIC_LOCAL_SET_STANDARD();
480 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
481 RESTORE_NUMERIC_LOCAL();
483 else if (SvIOKp(sv)) {
485 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
487 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
497 return SvPV_nolen(t);
501 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm)
506 Perl_dump_indent(aTHX_ level, file, "{}\n");
509 Perl_dump_indent(aTHX_ level, file, "{\n");
511 if (pm->op_pmflags & PMf_ONCE)
516 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
517 ch, PM_GETRE(pm)->precomp, ch,
518 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
520 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
521 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
522 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
523 op_dump(pm->op_pmreplroot);
525 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
526 SV * const tmpsv = pm_description(pm);
527 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
531 Perl_dump_indent(aTHX_ level-1, file, "}\n");
535 S_pm_description(pTHX_ const PMOP *pm)
537 SV * const desc = newSVpvs("");
538 const REGEXP * regex = PM_GETRE(pm);
539 const U32 pmflags = pm->op_pmflags;
541 if (pm->op_pmdynflags & PMdf_USED)
542 sv_catpv(desc, ",USED");
543 if (pm->op_pmdynflags & PMdf_TAINTED)
544 sv_catpv(desc, ",TAINTED");
546 if (pmflags & PMf_ONCE)
547 sv_catpv(desc, ",ONCE");
548 if (regex && regex->check_substr) {
549 if (!(regex->reganch & ROPT_NOSCAN))
550 sv_catpv(desc, ",SCANFIRST");
551 if (regex->reganch & ROPT_CHECK_ALL)
552 sv_catpv(desc, ",ALL");
554 if (pmflags & PMf_SKIPWHITE)
555 sv_catpv(desc, ",SKIPWHITE");
556 if (pmflags & PMf_CONST)
557 sv_catpv(desc, ",CONST");
558 if (pmflags & PMf_KEEP)
559 sv_catpv(desc, ",KEEP");
560 if (pmflags & PMf_GLOBAL)
561 sv_catpv(desc, ",GLOBAL");
562 if (pmflags & PMf_CONTINUE)
563 sv_catpv(desc, ",CONTINUE");
564 if (pmflags & PMf_RETAINT)
565 sv_catpv(desc, ",RETAINT");
566 if (pmflags & PMf_EVAL)
567 sv_catpv(desc, ",EVAL");
572 Perl_pmop_dump(pTHX_ PMOP *pm)
574 do_pmop_dump(0, Perl_debug_log, pm);
578 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
580 const OPCODE optype = o->op_type;
582 Perl_dump_indent(aTHX_ level, file, "{\n");
585 PerlIO_printf(file, "%-4d", o->op_seq);
587 PerlIO_printf(file, " ");
589 "%*sTYPE = %s ===> ",
590 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
593 PerlIO_printf(file, "%d\n", o->op_next->op_seq);
595 PerlIO_printf(file, "(%d)\n", o->op_next->op_seq);
598 PerlIO_printf(file, "DONE\n");
600 if (optype == OP_NULL) {
601 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
602 if (o->op_targ == OP_NEXTSTATE) {
604 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
606 if (CopSTASHPV(cCOPo))
607 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
609 if (cCOPo->cop_label)
610 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
615 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
618 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
621 SV * const tmpsv = newSVpvs("");
622 switch (o->op_flags & OPf_WANT) {
624 sv_catpv(tmpsv, ",VOID");
626 case OPf_WANT_SCALAR:
627 sv_catpv(tmpsv, ",SCALAR");
630 sv_catpv(tmpsv, ",LIST");
633 sv_catpv(tmpsv, ",UNKNOWN");
636 if (o->op_flags & OPf_KIDS)
637 sv_catpv(tmpsv, ",KIDS");
638 if (o->op_flags & OPf_PARENS)
639 sv_catpv(tmpsv, ",PARENS");
640 if (o->op_flags & OPf_STACKED)
641 sv_catpv(tmpsv, ",STACKED");
642 if (o->op_flags & OPf_REF)
643 sv_catpv(tmpsv, ",REF");
644 if (o->op_flags & OPf_MOD)
645 sv_catpv(tmpsv, ",MOD");
646 if (o->op_flags & OPf_SPECIAL)
647 sv_catpv(tmpsv, ",SPECIAL");
648 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
652 SV * const tmpsv = newSVpvs("");
653 if (PL_opargs[optype] & OA_TARGLEX) {
654 if (o->op_private & OPpTARGET_MY)
655 sv_catpv(tmpsv, ",TARGET_MY");
657 else if (optype == OP_LEAVESUB ||
658 optype == OP_LEAVE ||
659 optype == OP_LEAVESUBLV ||
660 optype == OP_LEAVEWRITE) {
661 if (o->op_private & OPpREFCOUNTED)
662 sv_catpv(tmpsv, ",REFCOUNTED");
664 else if (optype == OP_AASSIGN) {
665 if (o->op_private & OPpASSIGN_COMMON)
666 sv_catpv(tmpsv, ",COMMON");
667 if (o->op_private & OPpASSIGN_HASH)
668 sv_catpv(tmpsv, ",HASH");
670 else if (optype == OP_SASSIGN) {
671 if (o->op_private & OPpASSIGN_BACKWARDS)
672 sv_catpv(tmpsv, ",BACKWARDS");
674 else if (optype == OP_TRANS) {
675 if (o->op_private & OPpTRANS_SQUASH)
676 sv_catpv(tmpsv, ",SQUASH");
677 if (o->op_private & OPpTRANS_DELETE)
678 sv_catpv(tmpsv, ",DELETE");
679 if (o->op_private & OPpTRANS_COMPLEMENT)
680 sv_catpv(tmpsv, ",COMPLEMENT");
681 if (o->op_private & OPpTRANS_IDENTICAL)
682 sv_catpv(tmpsv, ",IDENTICAL");
683 if (o->op_private & OPpTRANS_GROWS)
684 sv_catpv(tmpsv, ",GROWS");
686 else if (optype == OP_REPEAT) {
687 if (o->op_private & OPpREPEAT_DOLIST)
688 sv_catpv(tmpsv, ",DOLIST");
690 else if (optype == OP_ENTERSUB ||
691 optype == OP_RV2SV ||
693 optype == OP_RV2AV ||
694 optype == OP_RV2HV ||
695 optype == OP_RV2GV ||
696 optype == OP_AELEM ||
699 if (optype == OP_ENTERSUB) {
700 if (o->op_private & OPpENTERSUB_AMPER)
701 sv_catpv(tmpsv, ",AMPER");
702 if (o->op_private & OPpENTERSUB_DB)
703 sv_catpv(tmpsv, ",DB");
704 if (o->op_private & OPpENTERSUB_HASTARG)
705 sv_catpv(tmpsv, ",HASTARG");
706 if (o->op_private & OPpENTERSUB_NOPAREN)
707 sv_catpv(tmpsv, ",NOPAREN");
708 if (o->op_private & OPpENTERSUB_INARGS)
709 sv_catpv(tmpsv, ",INARGS");
710 if (o->op_private & OPpENTERSUB_NOMOD)
711 sv_catpv(tmpsv, ",NOMOD");
714 switch (o->op_private & OPpDEREF) {
716 sv_catpv(tmpsv, ",SV");
719 sv_catpv(tmpsv, ",AV");
722 sv_catpv(tmpsv, ",HV");
725 if (o->op_private & OPpMAYBE_LVSUB)
726 sv_catpv(tmpsv, ",MAYBE_LVSUB");
728 if (optype == OP_AELEM || optype == OP_HELEM) {
729 if (o->op_private & OPpLVAL_DEFER)
730 sv_catpv(tmpsv, ",LVAL_DEFER");
733 if (o->op_private & HINT_STRICT_REFS)
734 sv_catpv(tmpsv, ",STRICT_REFS");
735 if (o->op_private & OPpOUR_INTRO)
736 sv_catpv(tmpsv, ",OUR_INTRO");
739 else if (optype == OP_CONST) {
740 if (o->op_private & OPpCONST_BARE)
741 sv_catpv(tmpsv, ",BARE");
742 if (o->op_private & OPpCONST_STRICT)
743 sv_catpv(tmpsv, ",STRICT");
744 if (o->op_private & OPpCONST_ARYBASE)
745 sv_catpv(tmpsv, ",ARYBASE");
746 if (o->op_private & OPpCONST_WARNING)
747 sv_catpv(tmpsv, ",WARNING");
748 if (o->op_private & OPpCONST_ENTERED)
749 sv_catpv(tmpsv, ",ENTERED");
751 else if (optype == OP_FLIP) {
752 if (o->op_private & OPpFLIP_LINENUM)
753 sv_catpv(tmpsv, ",LINENUM");
755 else if (optype == OP_FLOP) {
756 if (o->op_private & OPpFLIP_LINENUM)
757 sv_catpv(tmpsv, ",LINENUM");
759 else if (optype == OP_RV2CV) {
760 if (o->op_private & OPpLVAL_INTRO)
761 sv_catpv(tmpsv, ",INTRO");
763 else if (optype == OP_GV) {
764 if (o->op_private & OPpEARLY_CV)
765 sv_catpv(tmpsv, ",EARLY_CV");
767 else if (optype == OP_LIST) {
768 if (o->op_private & OPpLIST_GUESSED)
769 sv_catpv(tmpsv, ",GUESSED");
771 else if (optype == OP_DELETE) {
772 if (o->op_private & OPpSLICE)
773 sv_catpv(tmpsv, ",SLICE");
775 else if (optype == OP_EXISTS) {
776 if (o->op_private & OPpEXISTS_SUB)
777 sv_catpv(tmpsv, ",EXISTS_SUB");
779 else if (optype == OP_SORT) {
780 if (o->op_private & OPpSORT_NUMERIC)
781 sv_catpv(tmpsv, ",NUMERIC");
782 if (o->op_private & OPpSORT_INTEGER)
783 sv_catpv(tmpsv, ",INTEGER");
784 if (o->op_private & OPpSORT_REVERSE)
785 sv_catpv(tmpsv, ",REVERSE");
787 else if (optype == OP_THREADSV) {
788 if (o->op_private & OPpDONE_SVREF)
789 sv_catpv(tmpsv, ",SVREF");
791 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
792 if (o->op_private & OPpOPEN_IN_RAW)
793 sv_catpv(tmpsv, ",IN_RAW");
794 if (o->op_private & OPpOPEN_IN_CRLF)
795 sv_catpv(tmpsv, ",IN_CRLF");
796 if (o->op_private & OPpOPEN_OUT_RAW)
797 sv_catpv(tmpsv, ",OUT_RAW");
798 if (o->op_private & OPpOPEN_OUT_CRLF)
799 sv_catpv(tmpsv, ",OUT_CRLF");
801 else if (optype == OP_EXIT) {
802 if (o->op_private & OPpEXIT_VMSISH)
803 sv_catpv(tmpsv, ",EXIT_VMSISH");
804 if (o->op_private & OPpHUSH_VMSISH)
805 sv_catpv(tmpsv, ",HUSH_VMSISH");
807 else if (optype == OP_DIE) {
808 if (o->op_private & OPpHUSH_VMSISH)
809 sv_catpv(tmpsv, ",HUSH_VMSISH");
811 else if (OP_IS_FILETEST_ACCESS(o)) {
812 if (o->op_private & OPpFT_ACCESS)
813 sv_catpv(tmpsv, ",FT_ACCESS");
815 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
816 sv_catpv(tmpsv, ",INTRO");
818 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
827 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
829 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
831 SV * const tmpsv = newSV(0);
834 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
835 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
836 SvPV_nolen_const(tmpsv));
840 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
845 case OP_METHOD_NAMED:
847 /* with ITHREADS, consts are stored in the pad, and the right pad
848 * may not be active here, so skip */
849 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
856 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
858 if (CopSTASHPV(cCOPo))
859 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
861 if (cCOPo->cop_label)
862 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
866 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
867 if (cLOOPo->op_redoop)
868 PerlIO_printf(file, "%d\n", cLOOPo->op_redoop->op_seq);
870 PerlIO_printf(file, "DONE\n");
871 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
872 if (cLOOPo->op_nextop)
873 PerlIO_printf(file, "%d\n", cLOOPo->op_nextop->op_seq);
875 PerlIO_printf(file, "DONE\n");
876 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
877 if (cLOOPo->op_lastop)
878 PerlIO_printf(file, "%d\n", cLOOPo->op_lastop->op_seq);
880 PerlIO_printf(file, "DONE\n");
888 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
889 if (cLOGOPo->op_other)
890 PerlIO_printf(file, "%d\n", cLOGOPo->op_other->op_seq);
892 PerlIO_printf(file, "DONE\n");
898 do_pmop_dump(level, file, cPMOPo);
906 if (o->op_private & OPpREFCOUNTED)
907 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
912 if (o->op_flags & OPf_KIDS) {
914 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
915 do_op_dump(level, file, kid);
917 Perl_dump_indent(aTHX_ level-1, file, "}\n");
921 Perl_op_dump(pTHX_ OP *o)
923 do_op_dump(0, Perl_debug_log, o);
927 Perl_gv_dump(pTHX_ GV *gv)
932 PerlIO_printf(Perl_debug_log, "{}\n");
936 PerlIO_printf(Perl_debug_log, "{\n");
937 gv_fullname3(sv, gv, NULL);
938 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
939 if (gv != GvEGV(gv)) {
940 gv_efullname3(sv, GvEGV(gv), NULL);
941 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
943 PerlIO_putc(Perl_debug_log, '\n');
944 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
948 /* map magic types to the symbolic names
949 * (with the PERL_MAGIC_ prefixed stripped)
952 static const struct { const char type; const char *name; } magic_names[] = {
953 { PERL_MAGIC_sv, "sv(\\0)" },
954 { PERL_MAGIC_arylen, "arylen(#)" },
955 { PERL_MAGIC_glob, "glob(*)" },
956 { PERL_MAGIC_pos, "pos(.)" },
957 { PERL_MAGIC_backref, "backref(<)" },
958 { PERL_MAGIC_overload, "overload(A)" },
959 { PERL_MAGIC_bm, "bm(B)" },
960 { PERL_MAGIC_regdata, "regdata(D)" },
961 { PERL_MAGIC_env, "env(E)" },
962 { PERL_MAGIC_isa, "isa(I)" },
963 { PERL_MAGIC_dbfile, "dbfile(L)" },
964 { PERL_MAGIC_shared, "shared(N)" },
965 { PERL_MAGIC_tied, "tied(P)" },
966 { PERL_MAGIC_sig, "sig(S)" },
967 { PERL_MAGIC_uvar, "uvar(U)" },
968 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
969 { PERL_MAGIC_overload_table, "overload_table(c)" },
970 { PERL_MAGIC_regdatum, "regdatum(d)" },
971 { PERL_MAGIC_envelem, "envelem(e)" },
972 { PERL_MAGIC_fm, "fm(f)" },
973 { PERL_MAGIC_regex_global, "regex_global(g)" },
974 { PERL_MAGIC_isaelem, "isaelem(i)" },
975 { PERL_MAGIC_nkeys, "nkeys(k)" },
976 { PERL_MAGIC_dbline, "dbline(l)" },
977 { PERL_MAGIC_mutex, "mutex(m)" },
978 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
979 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
980 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
981 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
982 { PERL_MAGIC_qr, "qr(r)" },
983 { PERL_MAGIC_sigelem, "sigelem(s)" },
984 { PERL_MAGIC_taint, "taint(t)" },
985 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
986 { PERL_MAGIC_vec, "vec(v)" },
987 { PERL_MAGIC_vstring, "v-string(V)" },
988 { PERL_MAGIC_utf8, "utf8(w)" },
989 { PERL_MAGIC_substr, "substr(x)" },
990 { PERL_MAGIC_defelem, "defelem(y)" },
991 { PERL_MAGIC_ext, "ext(~)" },
992 /* this null string terminates the list */
997 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
999 for (; mg; mg = mg->mg_moremagic) {
1000 Perl_dump_indent(aTHX_ level, file,
1001 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1002 if (mg->mg_virtual) {
1003 const MGVTBL * const v = mg->mg_virtual;
1005 if (v == &PL_vtbl_sv) s = "sv";
1006 else if (v == &PL_vtbl_env) s = "env";
1007 else if (v == &PL_vtbl_envelem) s = "envelem";
1008 else if (v == &PL_vtbl_sig) s = "sig";
1009 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1010 else if (v == &PL_vtbl_pack) s = "pack";
1011 else if (v == &PL_vtbl_packelem) s = "packelem";
1012 else if (v == &PL_vtbl_dbline) s = "dbline";
1013 else if (v == &PL_vtbl_isa) s = "isa";
1014 else if (v == &PL_vtbl_arylen) s = "arylen";
1015 else if (v == &PL_vtbl_glob) s = "glob";
1016 else if (v == &PL_vtbl_mglob) s = "mglob";
1017 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1018 else if (v == &PL_vtbl_taint) s = "taint";
1019 else if (v == &PL_vtbl_substr) s = "substr";
1020 else if (v == &PL_vtbl_vec) s = "vec";
1021 else if (v == &PL_vtbl_pos) s = "pos";
1022 else if (v == &PL_vtbl_bm) s = "bm";
1023 else if (v == &PL_vtbl_fm) s = "fm";
1024 else if (v == &PL_vtbl_uvar) s = "uvar";
1025 else if (v == &PL_vtbl_defelem) s = "defelem";
1026 #ifdef USE_LOCALE_COLLATE
1027 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1029 else if (v == &PL_vtbl_amagic) s = "amagic";
1030 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1031 else if (v == &PL_vtbl_backref) s = "backref";
1032 else if (v == &PL_vtbl_utf8) s = "utf8";
1035 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1037 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1040 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1043 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1047 const char *name = NULL;
1048 for (n = 0; magic_names[n].name; n++) {
1049 if (mg->mg_type == magic_names[n].type) {
1050 name = magic_names[n].name;
1055 Perl_dump_indent(aTHX_ level, file,
1056 " MG_TYPE = PERL_MAGIC_%s\n", name);
1058 Perl_dump_indent(aTHX_ level, file,
1059 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1063 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1064 if (mg->mg_type == PERL_MAGIC_envelem &&
1065 mg->mg_flags & MGf_TAINTEDDIR)
1066 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1067 if (mg->mg_flags & MGf_REFCOUNTED)
1068 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1069 if (mg->mg_flags & MGf_GSKIP)
1070 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1071 if (mg->mg_type == PERL_MAGIC_regex_global &&
1072 mg->mg_flags & MGf_MINMATCH)
1073 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1076 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1077 if (mg->mg_flags & MGf_REFCOUNTED)
1078 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1081 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1083 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1084 if (mg->mg_len >= 0) {
1085 if (mg->mg_type != PERL_MAGIC_utf8) {
1086 SV *sv = newSVpvs("");
1087 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1091 else if (mg->mg_len == HEf_SVKEY) {
1092 PerlIO_puts(file, " => HEf_SVKEY\n");
1093 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1097 PerlIO_puts(file, " ???? - please notify IZ");
1098 PerlIO_putc(file, '\n');
1100 if (mg->mg_type == PERL_MAGIC_utf8) {
1101 STRLEN *cache = (STRLEN *) mg->mg_ptr;
1104 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1105 Perl_dump_indent(aTHX_ level, file,
1106 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1109 (UV)cache[i * 2 + 1]);
1116 Perl_magic_dump(pTHX_ MAGIC *mg)
1118 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1122 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, char *name, HV *sv)
1125 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1126 if (sv && (hvname = HvNAME_get(sv)))
1127 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1129 PerlIO_putc(file, '\n');
1133 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv)
1135 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1136 if (sv && GvNAME(sv))
1137 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1139 PerlIO_putc(file, '\n');
1143 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv)
1145 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1146 if (sv && GvNAME(sv)) {
1148 PerlIO_printf(file, "\t\"");
1149 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1150 PerlIO_printf(file, "%s\" :: \"", hvname);
1151 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1154 PerlIO_putc(file, '\n');
1158 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1166 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1170 flags = SvFLAGS(sv);
1173 d = Perl_newSVpvf(aTHX_
1174 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1175 PTR2UV(SvANY(sv)), PTR2UV(sv),
1176 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1177 (int)(PL_dumpindent*level), "");
1179 if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,");
1180 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1181 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1182 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1183 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1184 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1185 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1186 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1188 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1189 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1190 if (flags & SVf_POK) sv_catpv(d, "POK,");
1191 if (flags & SVf_ROK) {
1192 sv_catpv(d, "ROK,");
1193 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1195 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1196 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1197 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1199 if (flags & SVf_AMAGIC && type != SVt_PVHV)
1200 sv_catpv(d, "OVERLOAD,");
1201 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1202 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1203 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1204 if (flags & SVp_SCREAM && type != SVt_PVHV)
1205 sv_catpv(d, "SCREAM,");
1210 if (CvANON(sv)) sv_catpv(d, "ANON,");
1211 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1212 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1213 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1214 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1215 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1216 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1217 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1218 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1219 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1220 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1223 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1224 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1225 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1226 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1227 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1230 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1231 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1232 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1233 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1234 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1235 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1236 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1237 if (GvIMPORTED(sv)) {
1238 sv_catpv(d, "IMPORT");
1239 if (GvIMPORTED(sv) == GVf_IMPORTED)
1240 sv_catpv(d, "ALL,");
1243 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1244 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1245 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1246 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1253 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1254 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1257 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1258 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1261 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1264 /* SVphv_SHAREKEYS is also 0x20000000 */
1265 if ((type != SVt_PVHV) && SvUTF8(sv))
1266 sv_catpv(d, "UTF8");
1268 if (*(SvEND(d) - 1) == ',') {
1269 SvCUR_set(d, SvCUR(d) - 1);
1270 SvPVX(d)[SvCUR(d)] = '\0';
1275 Perl_dump_indent(aTHX_ level, file, "SV = ");
1276 if (type < SVt_LAST) {
1277 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1279 if (type == SVt_NULL) {
1284 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1288 if (type >= SVt_PVIV || type == SVt_IV) {
1290 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1292 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1294 PerlIO_printf(file, " (OFFSET)");
1295 PerlIO_putc(file, '\n');
1297 if (type >= SVt_PVNV || type == SVt_NV) {
1298 STORE_NUMERIC_LOCAL_SET_STANDARD();
1299 /* %Vg doesn't work? --jhi */
1300 #ifdef USE_LONG_DOUBLE
1301 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1303 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1305 RESTORE_NUMERIC_LOCAL();
1308 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1310 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1312 if (type < SVt_PV) {
1316 if (type <= SVt_PVLV || type == SVt_PVGV) {
1317 if (SvPVX_const(sv)) {
1318 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1320 PerlIO_printf(file, "( %s . ) ", pv_display(d, (char *)SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1321 PerlIO_printf(file, "%s", pv_display(d, (char *)SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1322 if (SvUTF8(sv)) /* the 8? \x{....} */
1323 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1324 PerlIO_printf(file, "\n");
1325 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1326 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1329 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1331 if (type >= SVt_PVMG) {
1333 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1335 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1339 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1340 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1341 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1342 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1343 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1344 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1348 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1349 if (AvARRAY(sv) != AvALLOC(sv)) {
1350 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1351 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1354 PerlIO_putc(file, '\n');
1355 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1356 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1357 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", PTR2UV(AvARYLEN(sv)));
1358 flags = AvFLAGS(sv);
1359 sv_setpvn(d, "", 0);
1360 if (flags & AVf_REAL) sv_catpv(d, ",REAL");
1361 if (flags & AVf_REIFY) sv_catpv(d, ",REIFY");
1362 if (flags & AVf_REUSED) sv_catpv(d, ",REUSED");
1363 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1364 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1365 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1367 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1368 SV** elt = av_fetch((AV*)sv,count,0);
1370 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1372 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1377 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1378 if (HvARRAY(sv) && HvKEYS(sv)) {
1379 /* Show distribution of HEs in the ARRAY */
1381 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1384 U32 pow2 = 2, keys = HvKEYS(sv);
1385 NV theoret, sum = 0;
1387 PerlIO_printf(file, " (");
1388 Zero(freq, FREQ_MAX + 1, int);
1389 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1392 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1394 if (count > FREQ_MAX)
1400 for (i = 0; i <= max; i++) {
1402 PerlIO_printf(file, "%d%s:%d", i,
1403 (i == FREQ_MAX) ? "+" : "",
1406 PerlIO_printf(file, ", ");
1409 PerlIO_putc(file, ')');
1410 /* The "quality" of a hash is defined as the total number of
1411 comparisons needed to access every element once, relative
1412 to the expected number needed for a random hash.
1414 The total number of comparisons is equal to the sum of
1415 the squares of the number of entries in each bucket.
1416 For a random hash of n keys into k buckets, the expected
1421 for (i = max; i > 0; i--) { /* Precision: count down. */
1422 sum += freq[i] * i * i;
1424 while ((keys = keys >> 1))
1426 theoret = HvKEYS(sv);
1427 theoret += theoret * (theoret-1)/pow2;
1428 PerlIO_putc(file, '\n');
1429 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1431 PerlIO_putc(file, '\n');
1432 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1433 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1434 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1435 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1436 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1438 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(HvPMROOT(sv)));
1440 const char * const hvname = HvNAME_get(sv);
1442 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1444 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1446 HV * const hv = (HV*)sv;
1447 int count = maxnest - nest;
1450 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1455 const U32 hash = HeHASH(he);
1457 keysv = hv_iterkeysv(he);
1458 keypv = SvPV_const(keysv, len);
1459 elt = hv_iterval(hv, he);
1460 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, (char *)keypv, len, 0, pvlim));
1462 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1464 PerlIO_printf(file, "[REHASH] ");
1465 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1466 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1468 hv_iterinit(hv); /* Return to status quo */
1474 const char *const proto = SvPV_const(sv, len);
1475 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1480 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1482 Perl_dump_indent(aTHX_ level, file, " START = 0x%"UVxf" ===> %"IVdf"\n", PTR2UV(CvSTART(sv)), (IV)CvSTART(sv)->op_seq);
1483 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n", PTR2UV(CvROOT(sv)));
1484 if (CvROOT(sv) && dumpops)
1485 do_op_dump(level+1, file, CvROOT(sv));
1486 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1488 SV *constant = cv_const_sv((CV *)sv);
1492 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1494 PTR2UV(CvXSUBANY(sv).any_ptr));
1495 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1498 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1499 (IV)CvXSUBANY(sv).any_i32);
1502 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1503 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1504 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1505 #ifdef USE_5005THREADS
1506 Perl_dump_indent(aTHX_ level, file, " MUTEXP = 0x%"UVxf"\n", PTR2UV(CvMUTEXP(sv)));
1507 Perl_dump_indent(aTHX_ level, file, " OWNER = 0x%"UVxf"\n", PTR2UV(CvOWNER(sv)));
1508 #endif /* USE_5005THREADS */
1509 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1510 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1511 if (type == SVt_PVFM)
1512 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1513 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1514 if (nest < maxnest) {
1515 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1518 const CV * const outside = CvOUTSIDE(sv);
1519 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1522 : CvANON(outside) ? "ANON"
1523 : (outside == PL_main_cv) ? "MAIN"
1524 : CvUNIQUE(outside) ? "UNIQUE"
1525 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1527 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1528 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1531 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1532 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1533 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1534 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1537 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1538 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1539 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1540 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1541 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1542 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1543 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1544 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1545 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf"\n", (UV)GvGPFLAGS(sv));
1546 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1547 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1548 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1549 do_gv_dump (level, file, " EGV", GvEGV(sv));
1552 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1553 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1554 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1555 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1556 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1557 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1558 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1560 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1561 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1562 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1564 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1565 PTR2UV(IoTOP_GV(sv)));
1566 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1569 /* Source filters hide things that are not GVs in these three, so let's
1570 be careful out there. */
1572 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1573 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1574 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1576 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1577 PTR2UV(IoFMT_GV(sv)));
1578 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1581 if (IoBOTTOM_NAME(sv))
1582 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1583 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1584 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1586 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1587 PTR2UV(IoBOTTOM_GV(sv)));
1588 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1591 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1592 if (isPRINT(IoTYPE(sv)))
1593 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1595 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1596 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1603 Perl_sv_dump(pTHX_ SV *sv)
1605 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1609 Perl_runops_debug(pTHX)
1612 if (ckWARN_d(WARN_DEBUGGING))
1613 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1620 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1621 PerlIO_printf(Perl_debug_log,
1622 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1623 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1624 PTR2UV(*PL_watchaddr));
1625 if (DEBUG_s_TEST_) {
1626 if (DEBUG_v_TEST_) {
1627 PerlIO_printf(Perl_debug_log, "\n");
1635 if (DEBUG_t_TEST_) debop(PL_op);
1636 if (DEBUG_P_TEST_) debprof(PL_op);
1638 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1645 Perl_debop(pTHX_ OP *o)
1647 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1650 Perl_deb(aTHX_ "%s", OP_NAME(o));
1651 switch (o->op_type) {
1653 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1658 SV * const sv = newSV(0);
1659 gv_fullname3(sv, cGVOPo_gv, NULL);
1660 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1664 PerlIO_printf(Perl_debug_log, "(NULL)");
1670 /* print the lexical's name */
1671 CV * const cv = deb_curcv(cxstack_ix);
1674 AV * const padlist = CvPADLIST(cv);
1675 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1676 sv = *av_fetch(comppad, o->op_targ, FALSE);
1680 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1682 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1688 PerlIO_printf(Perl_debug_log, "\n");
1693 S_deb_curcv(pTHX_ I32 ix)
1695 const PERL_CONTEXT * const cx = &cxstack[ix];
1696 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1697 return cx->blk_sub.cv;
1698 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1700 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1705 return deb_curcv(ix - 1);
1709 Perl_watch(pTHX_ char **addr)
1711 PL_watchaddr = addr;
1713 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1714 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1718 S_debprof(pTHX_ const OP *o)
1720 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1722 if (!PL_profiledata)
1723 Newxz(PL_profiledata, MAXO, U32);
1724 ++PL_profiledata[o->op_type];
1728 Perl_debprofdump(pTHX)
1731 if (!PL_profiledata)
1733 for (i = 0; i < MAXO; i++) {
1734 if (PL_profiledata[i])
1735 PerlIO_printf(Perl_debug_log,
1736 "%5lu %s\n", (unsigned long)PL_profiledata[i],
1743 * c-indentation-style: bsd
1745 * indent-tabs-mode: t
1748 * ex: set ts=8 sts=4 sw=4 noet: