3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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, ...)
75 PERL_ARGS_ASSERT_DUMP_INDENT;
77 dump_vindent(level, file, pat, &args);
82 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
85 PERL_ARGS_ASSERT_DUMP_VINDENT;
86 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
87 PerlIO_vprintf(file, pat, *args);
94 PerlIO_setlinebuf(Perl_debug_log);
96 op_dump(PL_main_root);
97 dump_packsubs(PL_defstash);
101 Perl_dump_packsubs(pTHX_ const HV *stash)
106 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
110 for (i = 0; i <= (I32) HvMAX(stash); i++) {
112 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
113 const GV * const gv = (GV*)HeVAL(entry);
114 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
120 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
121 const HV * const hv = GvHV(gv);
122 if (hv && (hv != PL_defstash))
123 dump_packsubs(hv); /* nested package */
130 Perl_dump_sub(pTHX_ const GV *gv)
132 SV * const sv = sv_newmortal();
134 PERL_ARGS_ASSERT_DUMP_SUB;
136 gv_fullname3(sv, gv, NULL);
137 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
138 if (CvISXSUB(GvCV(gv)))
139 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
140 PTR2UV(CvXSUB(GvCV(gv))),
141 (int)CvXSUBANY(GvCV(gv)).any_i32);
142 else if (CvROOT(GvCV(gv)))
143 op_dump(CvROOT(GvCV(gv)));
145 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
149 Perl_dump_form(pTHX_ const GV *gv)
151 SV * const sv = sv_newmortal();
153 PERL_ARGS_ASSERT_DUMP_FORM;
155 gv_fullname3(sv, gv, NULL);
156 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
157 if (CvROOT(GvFORM(gv)))
158 op_dump(CvROOT(GvFORM(gv)));
160 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
167 op_dump(PL_eval_root);
172 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
173 |const STRLEN count|const STRLEN max
174 |STRLEN const *escaped, const U32 flags
176 Escapes at most the first "count" chars of pv and puts the results into
177 dsv such that the size of the escaped string will not exceed "max" chars
178 and will not contain any incomplete escape sequences.
180 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
181 will also be escaped.
183 Normally the SV will be cleared before the escaped string is prepared,
184 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
186 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
187 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
188 using C<is_utf8_string()> to determine if it is Unicode.
190 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
191 using C<\x01F1> style escapes, otherwise only chars above 255 will be
192 escaped using this style, other non printable chars will use octal or
193 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
194 then all chars below 255 will be treated as printable and
195 will be output as literals.
197 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
198 string will be escaped, regardles of max. If the string is utf8 and
199 the chars value is >255 then it will be returned as a plain hex
200 sequence. Thus the output will either be a single char,
201 an octal escape sequence, a special escape like C<\n> or a 3 or
202 more digit hex value.
204 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
205 not a '\\'. This is because regexes very often contain backslashed
206 sequences, whereas '%' is not a particularly common character in patterns.
208 Returns a pointer to the escaped text as held by dsv.
212 #define PV_ESCAPE_OCTBUFSIZE 32
215 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
216 const STRLEN count, const STRLEN max,
217 STRLEN * const escaped, const U32 flags )
219 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
220 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
221 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
222 STRLEN wrote = 0; /* chars written so far */
223 STRLEN chsize = 0; /* size of data to be written */
224 STRLEN readsize = 1; /* size of data just read */
225 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
226 const char *pv = str;
227 const char * const end = pv + count; /* end of string */
230 PERL_ARGS_ASSERT_PV_ESCAPE;
232 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
233 /* This won't alter the UTF-8 flag */
234 sv_setpvn(dsv, "", 0);
237 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
240 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
241 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
242 const U8 c = (U8)u & 0xFF;
244 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
245 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
246 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
249 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
250 "%cx{%"UVxf"}", esc, u);
251 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
254 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
258 case '\\' : /* fallthrough */
259 case '%' : if ( c == esc ) {
265 case '\v' : octbuf[1] = 'v'; break;
266 case '\t' : octbuf[1] = 't'; break;
267 case '\r' : octbuf[1] = 'r'; break;
268 case '\n' : octbuf[1] = 'n'; break;
269 case '\f' : octbuf[1] = 'f'; break;
277 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
278 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
281 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
288 if ( max && (wrote + chsize > max) ) {
290 } else if (chsize > 1) {
291 sv_catpvn(dsv, octbuf, chsize);
294 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
295 128-255 can be appended raw to the dsv. If dsv happens to be
296 UTF-8 then we need catpvf to upgrade them for us.
297 Or add a new API call sv_catpvc(). Think about that name, and
298 how to keep it clear that it's unlike the s of catpvs, which is
299 really an array octets, not a string. */
300 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
303 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
311 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
312 |const STRLEN count|const STRLEN max\
313 |const char const *start_color| const char const *end_color\
316 Converts a string into something presentable, handling escaping via
317 pv_escape() and supporting quoting and ellipses.
319 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
320 double quoted with any double quotes in the string escaped. Otherwise
321 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
324 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
325 string were output then an ellipsis C<...> will be appended to the
326 string. Note that this happens AFTER it has been quoted.
328 If start_color is non-null then it will be inserted after the opening
329 quote (if there is one) but before the escaped text. If end_color
330 is non-null then it will be inserted after the escaped text but before
331 any quotes or ellipses.
333 Returns a pointer to the prettified text as held by dsv.
339 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
340 const STRLEN max, char const * const start_color, char const * const end_color,
343 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
346 PERL_ARGS_ASSERT_PV_PRETTY;
348 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
349 /* This won't alter the UTF-8 flag */
350 sv_setpvn(dsv, "", 0);
354 sv_catpvn(dsv, "\"", 1);
355 else if ( flags & PERL_PV_PRETTY_LTGT )
356 sv_catpvn(dsv, "<", 1);
358 if ( start_color != NULL )
359 Perl_sv_catpv( aTHX_ dsv, start_color);
361 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
363 if ( end_color != NULL )
364 Perl_sv_catpv( aTHX_ dsv, end_color);
367 sv_catpvn( dsv, "\"", 1 );
368 else if ( flags & PERL_PV_PRETTY_LTGT )
369 sv_catpvn( dsv, ">", 1);
371 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
372 sv_catpvn( dsv, "...", 3 );
378 =for apidoc pv_display
380 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
381 STRLEN pvlim, U32 flags)
385 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
387 except that an additional "\0" will be appended to the string when
388 len > cur and pv[cur] is "\0".
390 Note that the final string may be up to 7 chars longer than pvlim.
396 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
398 PERL_ARGS_ASSERT_PV_DISPLAY;
400 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
401 if (len > cur && pv[cur] == '\0')
402 sv_catpvn( dsv, "\\0", 2 );
407 Perl_sv_peek(pTHX_ SV *sv)
410 SV * const t = sv_newmortal();
420 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
424 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
425 if (sv == &PL_sv_undef) {
426 sv_catpv(t, "SV_UNDEF");
427 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
428 SVs_GMG|SVs_SMG|SVs_RMG)) &&
432 else if (sv == &PL_sv_no) {
433 sv_catpv(t, "SV_NO");
434 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
435 SVs_GMG|SVs_SMG|SVs_RMG)) &&
436 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
442 else if (sv == &PL_sv_yes) {
443 sv_catpv(t, "SV_YES");
444 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
445 SVs_GMG|SVs_SMG|SVs_RMG)) &&
446 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
449 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
454 sv_catpv(t, "SV_PLACEHOLDER");
455 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
456 SVs_GMG|SVs_SMG|SVs_RMG)) &&
462 else if (SvREFCNT(sv) == 0) {
466 else if (DEBUG_R_TEST_) {
469 /* is this SV on the tmps stack? */
470 for (ix=PL_tmps_ix; ix>=0; ix--) {
471 if (PL_tmps_stack[ix] == sv) {
476 if (SvREFCNT(sv) > 1)
477 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
485 if (SvCUR(t) + unref > 10) {
486 SvCUR_set(t, unref + 3);
495 if (type == SVt_PVCV) {
496 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
498 } else if (type < SVt_LAST) {
499 sv_catpv(t, svshorttypenames[type]);
501 if (type == SVt_NULL)
504 sv_catpv(t, "FREED");
509 if (!SvPVX_const(sv))
510 sv_catpv(t, "(null)");
512 SV * const tmp = newSVpvs("");
515 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
516 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
518 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
519 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
524 else if (SvNOKp(sv)) {
525 STORE_NUMERIC_LOCAL_SET_STANDARD();
526 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
527 RESTORE_NUMERIC_LOCAL();
529 else if (SvIOKp(sv)) {
531 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
533 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
541 return SvPV_nolen(t);
545 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
549 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
552 Perl_dump_indent(aTHX_ level, file, "{}\n");
555 Perl_dump_indent(aTHX_ level, file, "{\n");
557 if (pm->op_pmflags & PMf_ONCE)
562 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
563 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
564 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
566 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
567 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
568 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
569 op_dump(pm->op_pmreplrootu.op_pmreplroot);
571 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
572 SV * const tmpsv = pm_description(pm);
573 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
577 Perl_dump_indent(aTHX_ level-1, file, "}\n");
581 S_pm_description(pTHX_ const PMOP *pm)
583 SV * const desc = newSVpvs("");
584 const REGEXP * const regex = PM_GETRE(pm);
585 const U32 pmflags = pm->op_pmflags;
587 PERL_ARGS_ASSERT_PM_DESCRIPTION;
589 if (pmflags & PMf_ONCE)
590 sv_catpv(desc, ",ONCE");
592 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
593 sv_catpv(desc, ":USED");
595 if (pmflags & PMf_USED)
596 sv_catpv(desc, ":USED");
600 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
601 sv_catpv(desc, ",TAINTED");
602 if (RX_CHECK_SUBSTR(regex)) {
603 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
604 sv_catpv(desc, ",SCANFIRST");
605 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
606 sv_catpv(desc, ",ALL");
608 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
609 sv_catpv(desc, ",SKIPWHITE");
612 if (pmflags & PMf_CONST)
613 sv_catpv(desc, ",CONST");
614 if (pmflags & PMf_KEEP)
615 sv_catpv(desc, ",KEEP");
616 if (pmflags & PMf_GLOBAL)
617 sv_catpv(desc, ",GLOBAL");
618 if (pmflags & PMf_CONTINUE)
619 sv_catpv(desc, ",CONTINUE");
620 if (pmflags & PMf_RETAINT)
621 sv_catpv(desc, ",RETAINT");
622 if (pmflags & PMf_EVAL)
623 sv_catpv(desc, ",EVAL");
628 Perl_pmop_dump(pTHX_ PMOP *pm)
630 do_pmop_dump(0, Perl_debug_log, pm);
633 /* An op sequencer. We visit the ops in the order they're to execute. */
636 S_sequence(pTHX_ register const OP *o)
639 const OP *oldop = NULL;
652 for (; o; o = o->op_next) {
654 SV * const op = newSVuv(PTR2UV(o));
655 const char * const key = SvPV_const(op, len);
657 if (hv_exists(Sequence, key, len))
660 switch (o->op_type) {
662 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
663 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
672 if (oldop && o->op_next)
679 if (oldop && o->op_next)
681 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
694 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
695 sequence_tail(cLOGOPo->op_other);
700 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
701 sequence_tail(cLOOPo->op_redoop);
702 sequence_tail(cLOOPo->op_nextop);
703 sequence_tail(cLOOPo->op_lastop);
707 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
708 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
717 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
725 S_sequence_tail(pTHX_ const OP *o)
727 while (o && (o->op_type == OP_NULL))
733 S_sequence_num(pTHX_ const OP *o)
741 op = newSVuv(PTR2UV(o));
742 key = SvPV_const(op, len);
743 seq = hv_fetch(Sequence, key, len, 0);
744 return seq ? SvUV(*seq): 0;
748 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
752 const OPCODE optype = o->op_type;
754 PERL_ARGS_ASSERT_DO_OP_DUMP;
757 Perl_dump_indent(aTHX_ level, file, "{\n");
759 seq = sequence_num(o);
761 PerlIO_printf(file, "%-4"UVuf, seq);
763 PerlIO_printf(file, " ");
765 "%*sTYPE = %s ===> ",
766 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
768 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
769 sequence_num(o->op_next));
771 PerlIO_printf(file, "DONE\n");
773 if (optype == OP_NULL) {
774 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
775 if (o->op_targ == OP_NEXTSTATE) {
777 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
779 if (CopSTASHPV(cCOPo))
780 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
783 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
788 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
791 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
793 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
794 SV * const tmpsv = newSVpvs("");
795 switch (o->op_flags & OPf_WANT) {
797 sv_catpv(tmpsv, ",VOID");
799 case OPf_WANT_SCALAR:
800 sv_catpv(tmpsv, ",SCALAR");
803 sv_catpv(tmpsv, ",LIST");
806 sv_catpv(tmpsv, ",UNKNOWN");
809 if (o->op_flags & OPf_KIDS)
810 sv_catpv(tmpsv, ",KIDS");
811 if (o->op_flags & OPf_PARENS)
812 sv_catpv(tmpsv, ",PARENS");
813 if (o->op_flags & OPf_STACKED)
814 sv_catpv(tmpsv, ",STACKED");
815 if (o->op_flags & OPf_REF)
816 sv_catpv(tmpsv, ",REF");
817 if (o->op_flags & OPf_MOD)
818 sv_catpv(tmpsv, ",MOD");
819 if (o->op_flags & OPf_SPECIAL)
820 sv_catpv(tmpsv, ",SPECIAL");
822 sv_catpv(tmpsv, ",LATEFREE");
824 sv_catpv(tmpsv, ",LATEFREED");
826 sv_catpv(tmpsv, ",ATTACHED");
827 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
831 SV * const tmpsv = newSVpvs("");
832 if (PL_opargs[optype] & OA_TARGLEX) {
833 if (o->op_private & OPpTARGET_MY)
834 sv_catpv(tmpsv, ",TARGET_MY");
836 else if (optype == OP_LEAVESUB ||
837 optype == OP_LEAVE ||
838 optype == OP_LEAVESUBLV ||
839 optype == OP_LEAVEWRITE) {
840 if (o->op_private & OPpREFCOUNTED)
841 sv_catpv(tmpsv, ",REFCOUNTED");
843 else if (optype == OP_AASSIGN) {
844 if (o->op_private & OPpASSIGN_COMMON)
845 sv_catpv(tmpsv, ",COMMON");
847 else if (optype == OP_SASSIGN) {
848 if (o->op_private & OPpASSIGN_BACKWARDS)
849 sv_catpv(tmpsv, ",BACKWARDS");
851 else if (optype == OP_TRANS) {
852 if (o->op_private & OPpTRANS_SQUASH)
853 sv_catpv(tmpsv, ",SQUASH");
854 if (o->op_private & OPpTRANS_DELETE)
855 sv_catpv(tmpsv, ",DELETE");
856 if (o->op_private & OPpTRANS_COMPLEMENT)
857 sv_catpv(tmpsv, ",COMPLEMENT");
858 if (o->op_private & OPpTRANS_IDENTICAL)
859 sv_catpv(tmpsv, ",IDENTICAL");
860 if (o->op_private & OPpTRANS_GROWS)
861 sv_catpv(tmpsv, ",GROWS");
863 else if (optype == OP_REPEAT) {
864 if (o->op_private & OPpREPEAT_DOLIST)
865 sv_catpv(tmpsv, ",DOLIST");
867 else if (optype == OP_ENTERSUB ||
868 optype == OP_RV2SV ||
870 optype == OP_RV2AV ||
871 optype == OP_RV2HV ||
872 optype == OP_RV2GV ||
873 optype == OP_AELEM ||
876 if (optype == OP_ENTERSUB) {
877 if (o->op_private & OPpENTERSUB_AMPER)
878 sv_catpv(tmpsv, ",AMPER");
879 if (o->op_private & OPpENTERSUB_DB)
880 sv_catpv(tmpsv, ",DB");
881 if (o->op_private & OPpENTERSUB_HASTARG)
882 sv_catpv(tmpsv, ",HASTARG");
883 if (o->op_private & OPpENTERSUB_NOPAREN)
884 sv_catpv(tmpsv, ",NOPAREN");
885 if (o->op_private & OPpENTERSUB_INARGS)
886 sv_catpv(tmpsv, ",INARGS");
887 if (o->op_private & OPpENTERSUB_NOMOD)
888 sv_catpv(tmpsv, ",NOMOD");
891 switch (o->op_private & OPpDEREF) {
893 sv_catpv(tmpsv, ",SV");
896 sv_catpv(tmpsv, ",AV");
899 sv_catpv(tmpsv, ",HV");
902 if (o->op_private & OPpMAYBE_LVSUB)
903 sv_catpv(tmpsv, ",MAYBE_LVSUB");
905 if (optype == OP_AELEM || optype == OP_HELEM) {
906 if (o->op_private & OPpLVAL_DEFER)
907 sv_catpv(tmpsv, ",LVAL_DEFER");
910 if (o->op_private & HINT_STRICT_REFS)
911 sv_catpv(tmpsv, ",STRICT_REFS");
912 if (o->op_private & OPpOUR_INTRO)
913 sv_catpv(tmpsv, ",OUR_INTRO");
916 else if (optype == OP_CONST) {
917 if (o->op_private & OPpCONST_BARE)
918 sv_catpv(tmpsv, ",BARE");
919 if (o->op_private & OPpCONST_STRICT)
920 sv_catpv(tmpsv, ",STRICT");
921 if (o->op_private & OPpCONST_ARYBASE)
922 sv_catpv(tmpsv, ",ARYBASE");
923 if (o->op_private & OPpCONST_WARNING)
924 sv_catpv(tmpsv, ",WARNING");
925 if (o->op_private & OPpCONST_ENTERED)
926 sv_catpv(tmpsv, ",ENTERED");
928 else if (optype == OP_FLIP) {
929 if (o->op_private & OPpFLIP_LINENUM)
930 sv_catpv(tmpsv, ",LINENUM");
932 else if (optype == OP_FLOP) {
933 if (o->op_private & OPpFLIP_LINENUM)
934 sv_catpv(tmpsv, ",LINENUM");
936 else if (optype == OP_RV2CV) {
937 if (o->op_private & OPpLVAL_INTRO)
938 sv_catpv(tmpsv, ",INTRO");
940 else if (optype == OP_GV) {
941 if (o->op_private & OPpEARLY_CV)
942 sv_catpv(tmpsv, ",EARLY_CV");
944 else if (optype == OP_LIST) {
945 if (o->op_private & OPpLIST_GUESSED)
946 sv_catpv(tmpsv, ",GUESSED");
948 else if (optype == OP_DELETE) {
949 if (o->op_private & OPpSLICE)
950 sv_catpv(tmpsv, ",SLICE");
952 else if (optype == OP_EXISTS) {
953 if (o->op_private & OPpEXISTS_SUB)
954 sv_catpv(tmpsv, ",EXISTS_SUB");
956 else if (optype == OP_SORT) {
957 if (o->op_private & OPpSORT_NUMERIC)
958 sv_catpv(tmpsv, ",NUMERIC");
959 if (o->op_private & OPpSORT_INTEGER)
960 sv_catpv(tmpsv, ",INTEGER");
961 if (o->op_private & OPpSORT_REVERSE)
962 sv_catpv(tmpsv, ",REVERSE");
964 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
965 if (o->op_private & OPpOPEN_IN_RAW)
966 sv_catpv(tmpsv, ",IN_RAW");
967 if (o->op_private & OPpOPEN_IN_CRLF)
968 sv_catpv(tmpsv, ",IN_CRLF");
969 if (o->op_private & OPpOPEN_OUT_RAW)
970 sv_catpv(tmpsv, ",OUT_RAW");
971 if (o->op_private & OPpOPEN_OUT_CRLF)
972 sv_catpv(tmpsv, ",OUT_CRLF");
974 else if (optype == OP_EXIT) {
975 if (o->op_private & OPpEXIT_VMSISH)
976 sv_catpv(tmpsv, ",EXIT_VMSISH");
977 if (o->op_private & OPpHUSH_VMSISH)
978 sv_catpv(tmpsv, ",HUSH_VMSISH");
980 else if (optype == OP_DIE) {
981 if (o->op_private & OPpHUSH_VMSISH)
982 sv_catpv(tmpsv, ",HUSH_VMSISH");
984 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
985 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
986 sv_catpv(tmpsv, ",FT_ACCESS");
987 if (o->op_private & OPpFT_STACKED)
988 sv_catpv(tmpsv, ",FT_STACKED");
990 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
991 sv_catpv(tmpsv, ",INTRO");
993 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
998 if (PL_madskills && o->op_madprop) {
999 SV * const tmpsv = newSVpvn("", 0);
1000 MADPROP* mp = o->op_madprop;
1001 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1004 const char tmp = mp->mad_key;
1005 sv_setpvn(tmpsv,"'",1);
1007 sv_catpvn(tmpsv, &tmp, 1);
1008 sv_catpv(tmpsv, "'=");
1009 switch (mp->mad_type) {
1011 sv_catpv(tmpsv, "NULL");
1012 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1015 sv_catpv(tmpsv, "<");
1016 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1017 sv_catpv(tmpsv, ">");
1018 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1021 if ((OP*)mp->mad_val) {
1022 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1023 do_op_dump(level, file, (OP*)mp->mad_val);
1027 sv_catpv(tmpsv, "(UNK)");
1028 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1034 Perl_dump_indent(aTHX_ level, file, "}\n");
1036 SvREFCNT_dec(tmpsv);
1045 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1047 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1048 if (cSVOPo->op_sv) {
1049 SV * const tmpsv = newSV(0);
1053 /* FIXME - is this making unwarranted assumptions about the
1054 UTF-8 cleanliness of the dump file handle? */
1057 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1058 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1059 SvPV_nolen_const(tmpsv));
1063 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1069 case OP_METHOD_NAMED:
1070 #ifndef USE_ITHREADS
1071 /* with ITHREADS, consts are stored in the pad, and the right pad
1072 * may not be active here, so skip */
1073 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1079 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1080 (UV)CopLINE(cCOPo));
1081 if (CopSTASHPV(cCOPo))
1082 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1084 if (CopLABEL(cCOPo))
1085 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1089 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1090 if (cLOOPo->op_redoop)
1091 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1093 PerlIO_printf(file, "DONE\n");
1094 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1095 if (cLOOPo->op_nextop)
1096 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1098 PerlIO_printf(file, "DONE\n");
1099 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1100 if (cLOOPo->op_lastop)
1101 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1103 PerlIO_printf(file, "DONE\n");
1111 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1112 if (cLOGOPo->op_other)
1113 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1115 PerlIO_printf(file, "DONE\n");
1121 do_pmop_dump(level, file, cPMOPo);
1129 if (o->op_private & OPpREFCOUNTED)
1130 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1135 if (o->op_flags & OPf_KIDS) {
1137 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1138 do_op_dump(level, file, kid);
1140 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1144 Perl_op_dump(pTHX_ const OP *o)
1146 PERL_ARGS_ASSERT_OP_DUMP;
1147 do_op_dump(0, Perl_debug_log, o);
1151 Perl_gv_dump(pTHX_ GV *gv)
1155 PERL_ARGS_ASSERT_GV_DUMP;
1158 PerlIO_printf(Perl_debug_log, "{}\n");
1161 sv = sv_newmortal();
1162 PerlIO_printf(Perl_debug_log, "{\n");
1163 gv_fullname3(sv, gv, NULL);
1164 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1165 if (gv != GvEGV(gv)) {
1166 gv_efullname3(sv, GvEGV(gv), NULL);
1167 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1169 PerlIO_putc(Perl_debug_log, '\n');
1170 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1174 /* map magic types to the symbolic names
1175 * (with the PERL_MAGIC_ prefixed stripped)
1178 static const struct { const char type; const char *name; } magic_names[] = {
1179 { PERL_MAGIC_sv, "sv(\\0)" },
1180 { PERL_MAGIC_arylen, "arylen(#)" },
1181 { PERL_MAGIC_rhash, "rhash(%)" },
1182 { PERL_MAGIC_pos, "pos(.)" },
1183 { PERL_MAGIC_symtab, "symtab(:)" },
1184 { PERL_MAGIC_backref, "backref(<)" },
1185 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1186 { PERL_MAGIC_overload, "overload(A)" },
1187 { PERL_MAGIC_bm, "bm(B)" },
1188 { PERL_MAGIC_regdata, "regdata(D)" },
1189 { PERL_MAGIC_env, "env(E)" },
1190 { PERL_MAGIC_hints, "hints(H)" },
1191 { PERL_MAGIC_isa, "isa(I)" },
1192 { PERL_MAGIC_dbfile, "dbfile(L)" },
1193 { PERL_MAGIC_shared, "shared(N)" },
1194 { PERL_MAGIC_tied, "tied(P)" },
1195 { PERL_MAGIC_sig, "sig(S)" },
1196 { PERL_MAGIC_uvar, "uvar(U)" },
1197 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1198 { PERL_MAGIC_overload_table, "overload_table(c)" },
1199 { PERL_MAGIC_regdatum, "regdatum(d)" },
1200 { PERL_MAGIC_envelem, "envelem(e)" },
1201 { PERL_MAGIC_fm, "fm(f)" },
1202 { PERL_MAGIC_regex_global, "regex_global(g)" },
1203 { PERL_MAGIC_hintselem, "hintselem(h)" },
1204 { PERL_MAGIC_isaelem, "isaelem(i)" },
1205 { PERL_MAGIC_nkeys, "nkeys(k)" },
1206 { PERL_MAGIC_dbline, "dbline(l)" },
1207 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1208 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1209 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1210 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1211 { PERL_MAGIC_qr, "qr(r)" },
1212 { PERL_MAGIC_sigelem, "sigelem(s)" },
1213 { PERL_MAGIC_taint, "taint(t)" },
1214 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1215 { PERL_MAGIC_vec, "vec(v)" },
1216 { PERL_MAGIC_vstring, "vstring(V)" },
1217 { PERL_MAGIC_utf8, "utf8(w)" },
1218 { PERL_MAGIC_substr, "substr(x)" },
1219 { PERL_MAGIC_defelem, "defelem(y)" },
1220 { PERL_MAGIC_ext, "ext(~)" },
1221 /* this null string terminates the list */
1226 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1228 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1230 for (; mg; mg = mg->mg_moremagic) {
1231 Perl_dump_indent(aTHX_ level, file,
1232 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1233 if (mg->mg_virtual) {
1234 const MGVTBL * const v = mg->mg_virtual;
1236 if (v == &PL_vtbl_sv) s = "sv";
1237 else if (v == &PL_vtbl_env) s = "env";
1238 else if (v == &PL_vtbl_envelem) s = "envelem";
1239 else if (v == &PL_vtbl_sig) s = "sig";
1240 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1241 else if (v == &PL_vtbl_pack) s = "pack";
1242 else if (v == &PL_vtbl_packelem) s = "packelem";
1243 else if (v == &PL_vtbl_dbline) s = "dbline";
1244 else if (v == &PL_vtbl_isa) s = "isa";
1245 else if (v == &PL_vtbl_arylen) s = "arylen";
1246 else if (v == &PL_vtbl_mglob) s = "mglob";
1247 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1248 else if (v == &PL_vtbl_taint) s = "taint";
1249 else if (v == &PL_vtbl_substr) s = "substr";
1250 else if (v == &PL_vtbl_vec) s = "vec";
1251 else if (v == &PL_vtbl_pos) s = "pos";
1252 else if (v == &PL_vtbl_bm) s = "bm";
1253 else if (v == &PL_vtbl_fm) s = "fm";
1254 else if (v == &PL_vtbl_uvar) s = "uvar";
1255 else if (v == &PL_vtbl_defelem) s = "defelem";
1256 #ifdef USE_LOCALE_COLLATE
1257 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1259 else if (v == &PL_vtbl_amagic) s = "amagic";
1260 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1261 else if (v == &PL_vtbl_backref) s = "backref";
1262 else if (v == &PL_vtbl_utf8) s = "utf8";
1263 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1264 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1267 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1269 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1272 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1275 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1279 const char *name = NULL;
1280 for (n = 0; magic_names[n].name; n++) {
1281 if (mg->mg_type == magic_names[n].type) {
1282 name = magic_names[n].name;
1287 Perl_dump_indent(aTHX_ level, file,
1288 " MG_TYPE = PERL_MAGIC_%s\n", name);
1290 Perl_dump_indent(aTHX_ level, file,
1291 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1295 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1296 if (mg->mg_type == PERL_MAGIC_envelem &&
1297 mg->mg_flags & MGf_TAINTEDDIR)
1298 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1299 if (mg->mg_flags & MGf_REFCOUNTED)
1300 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1301 if (mg->mg_flags & MGf_GSKIP)
1302 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1303 if (mg->mg_type == PERL_MAGIC_regex_global &&
1304 mg->mg_flags & MGf_MINMATCH)
1305 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1308 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1309 PTR2UV(mg->mg_obj));
1310 if (mg->mg_type == PERL_MAGIC_qr) {
1311 REGEXP* const re = (REGEXP *)mg->mg_obj;
1312 SV * const dsv = sv_newmortal();
1313 const char * const s
1314 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1316 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1317 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1319 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1320 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1323 if (mg->mg_flags & MGf_REFCOUNTED)
1324 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1327 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1329 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1330 if (mg->mg_len >= 0) {
1331 if (mg->mg_type != PERL_MAGIC_utf8) {
1332 SV * const sv = newSVpvs("");
1333 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1337 else if (mg->mg_len == HEf_SVKEY) {
1338 PerlIO_puts(file, " => HEf_SVKEY\n");
1339 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1343 PerlIO_puts(file, " ???? - please notify IZ");
1344 PerlIO_putc(file, '\n');
1346 if (mg->mg_type == PERL_MAGIC_utf8) {
1347 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1350 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1351 Perl_dump_indent(aTHX_ level, file,
1352 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1355 (UV)cache[i * 2 + 1]);
1362 Perl_magic_dump(pTHX_ const MAGIC *mg)
1364 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1368 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1372 PERL_ARGS_ASSERT_DO_HV_DUMP;
1374 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1375 if (sv && (hvname = HvNAME_get(sv)))
1376 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1378 PerlIO_putc(file, '\n');
1382 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1384 PERL_ARGS_ASSERT_DO_GV_DUMP;
1386 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1387 if (sv && GvNAME(sv))
1388 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1390 PerlIO_putc(file, '\n');
1394 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1396 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1398 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1399 if (sv && GvNAME(sv)) {
1401 PerlIO_printf(file, "\t\"");
1402 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1403 PerlIO_printf(file, "%s\" :: \"", hvname);
1404 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1407 PerlIO_putc(file, '\n');
1411 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1419 PERL_ARGS_ASSERT_DO_SV_DUMP;
1422 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1426 flags = SvFLAGS(sv);
1429 d = Perl_newSVpvf(aTHX_
1430 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1431 PTR2UV(SvANY(sv)), PTR2UV(sv),
1432 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1433 (int)(PL_dumpindent*level), "");
1435 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1436 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1438 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1439 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1440 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1442 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1443 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1444 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1445 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1446 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1448 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1449 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1450 if (flags & SVf_POK) sv_catpv(d, "POK,");
1451 if (flags & SVf_ROK) {
1452 sv_catpv(d, "ROK,");
1453 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1455 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1456 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1457 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1458 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1460 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1461 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1462 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1463 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1464 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1465 if (SvPCS_IMPORTED(sv))
1466 sv_catpv(d, "PCS_IMPORTED,");
1468 sv_catpv(d, "SCREAM,");
1474 if (CvANON(sv)) sv_catpv(d, "ANON,");
1475 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1476 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1477 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1478 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1479 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1480 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1481 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1482 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1483 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1484 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1487 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1488 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1489 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1490 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1491 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1495 if (isGV_with_GP(sv)) {
1496 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1497 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1498 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1499 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1500 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1502 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1503 sv_catpv(d, "IMPORT");
1504 if (GvIMPORTED(sv) == GVf_IMPORTED)
1505 sv_catpv(d, "ALL,");
1508 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1509 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1510 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1511 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1515 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1516 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1520 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1521 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1524 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1525 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1528 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1533 /* SVphv_SHAREKEYS is also 0x20000000 */
1534 if ((type != SVt_PVHV) && SvUTF8(sv))
1535 sv_catpv(d, "UTF8");
1537 if (*(SvEND(d) - 1) == ',') {
1538 SvCUR_set(d, SvCUR(d) - 1);
1539 SvPVX(d)[SvCUR(d)] = '\0';
1544 #ifdef DEBUG_LEAKING_SCALARS
1545 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1546 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1548 sv->sv_debug_inpad ? "for" : "by",
1549 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1550 sv->sv_debug_cloned ? " (cloned)" : "");
1552 Perl_dump_indent(aTHX_ level, file, "SV = ");
1553 if (type < SVt_LAST) {
1554 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1556 if (type == SVt_NULL) {
1561 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1565 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1566 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM)
1567 || (type == SVt_IV && !SvROK(sv))) {
1569 #ifdef PERL_OLD_COPY_ON_WRITE
1573 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1575 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1576 #ifdef PERL_OLD_COPY_ON_WRITE
1577 if (SvIsCOW_shared_hash(sv))
1578 PerlIO_printf(file, " (HASH)");
1579 else if (SvIsCOW_normal(sv))
1580 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1582 PerlIO_putc(file, '\n');
1584 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1585 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1586 (UV) COP_SEQ_RANGE_LOW(sv));
1587 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1588 (UV) COP_SEQ_RANGE_HIGH(sv));
1589 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1590 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1591 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1592 || type == SVt_NV) {
1593 STORE_NUMERIC_LOCAL_SET_STANDARD();
1594 /* %Vg doesn't work? --jhi */
1595 #ifdef USE_LONG_DOUBLE
1596 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1598 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1600 RESTORE_NUMERIC_LOCAL();
1603 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1605 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1607 if (type < SVt_PV) {
1611 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1612 if (SvPVX_const(sv)) {
1615 SvOOK_offset(sv, delta);
1616 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1621 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1623 PerlIO_printf(file, "( %s . ) ",
1624 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1627 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1628 if (SvUTF8(sv)) /* the 6? \x{....} */
1629 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1630 PerlIO_printf(file, "\n");
1631 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1632 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1635 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1637 if (type == SVt_REGEXP) {
1639 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1640 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1643 if (type >= SVt_PVMG) {
1644 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1645 HV * const ost = SvOURSTASH(sv);
1647 do_hv_dump(level, file, " OURSTASH", ost);
1650 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1653 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1657 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1658 if (AvARRAY(sv) != AvALLOC(sv)) {
1659 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1660 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1663 PerlIO_putc(file, '\n');
1664 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1665 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1666 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1667 sv_setpvn(d, "", 0);
1668 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1669 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1670 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1671 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1672 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1674 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1675 SV** const elt = av_fetch((AV*)sv,count,0);
1677 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1679 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1684 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1685 if (HvARRAY(sv) && HvKEYS(sv)) {
1686 /* Show distribution of HEs in the ARRAY */
1688 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1691 U32 pow2 = 2, keys = HvKEYS(sv);
1692 NV theoret, sum = 0;
1694 PerlIO_printf(file, " (");
1695 Zero(freq, FREQ_MAX + 1, int);
1696 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1699 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1701 if (count > FREQ_MAX)
1707 for (i = 0; i <= max; i++) {
1709 PerlIO_printf(file, "%d%s:%d", i,
1710 (i == FREQ_MAX) ? "+" : "",
1713 PerlIO_printf(file, ", ");
1716 PerlIO_putc(file, ')');
1717 /* The "quality" of a hash is defined as the total number of
1718 comparisons needed to access every element once, relative
1719 to the expected number needed for a random hash.
1721 The total number of comparisons is equal to the sum of
1722 the squares of the number of entries in each bucket.
1723 For a random hash of n keys into k buckets, the expected
1728 for (i = max; i > 0; i--) { /* Precision: count down. */
1729 sum += freq[i] * i * i;
1731 while ((keys = keys >> 1))
1733 theoret = HvKEYS(sv);
1734 theoret += theoret * (theoret-1)/pow2;
1735 PerlIO_putc(file, '\n');
1736 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1738 PerlIO_putc(file, '\n');
1739 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1740 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1741 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1742 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1743 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1745 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1746 if (mg && mg->mg_obj) {
1747 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1751 const char * const hvname = HvNAME_get(sv);
1753 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1756 const AV * const backrefs
1757 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1759 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1761 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1765 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1767 HV * const hv = MUTABLE_HV(sv);
1768 int count = maxnest - nest;
1771 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1774 const U32 hash = HeHASH(he);
1775 SV * const keysv = hv_iterkeysv(he);
1776 const char * const keypv = SvPV_const(keysv, len);
1777 SV * const elt = hv_iterval(hv, he);
1779 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1781 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1783 PerlIO_printf(file, "[REHASH] ");
1784 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1785 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1787 hv_iterinit(hv); /* Return to status quo */
1793 const char *const proto = SvPV_const(sv, len);
1794 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1799 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1800 if (!CvISXSUB(sv)) {
1802 Perl_dump_indent(aTHX_ level, file,
1803 " START = 0x%"UVxf" ===> %"IVdf"\n",
1804 PTR2UV(CvSTART(sv)),
1805 (IV)sequence_num(CvSTART(sv)));
1807 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1808 PTR2UV(CvROOT(sv)));
1809 if (CvROOT(sv) && dumpops) {
1810 do_op_dump(level+1, file, CvROOT(sv));
1813 SV * const constant = cv_const_sv((CV *)sv);
1815 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1818 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1820 PTR2UV(CvXSUBANY(sv).any_ptr));
1821 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1824 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1825 (IV)CvXSUBANY(sv).any_i32);
1828 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1829 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1830 if (type == SVt_PVCV)
1831 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1832 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1833 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1834 if (type == SVt_PVFM)
1835 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1836 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1837 if (nest < maxnest) {
1838 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1841 const CV * const outside = CvOUTSIDE(sv);
1842 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1845 : CvANON(outside) ? "ANON"
1846 : (outside == PL_main_cv) ? "MAIN"
1847 : CvUNIQUE(outside) ? "UNIQUE"
1848 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1850 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1851 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1855 if (type == SVt_PVLV) {
1856 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1857 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1858 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1859 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1860 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1861 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1865 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1866 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1867 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1868 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1870 if (!isGV_with_GP(sv))
1872 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1873 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1874 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1875 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1878 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1879 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1880 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1881 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1882 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1883 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1884 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1885 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1886 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1887 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1888 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1889 do_gv_dump (level, file, " EGV", GvEGV(sv));
1892 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1893 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1894 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1895 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1896 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1897 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1898 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1900 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1901 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1902 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1904 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1905 PTR2UV(IoTOP_GV(sv)));
1906 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1909 /* Source filters hide things that are not GVs in these three, so let's
1910 be careful out there. */
1912 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1913 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1914 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1916 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1917 PTR2UV(IoFMT_GV(sv)));
1918 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1921 if (IoBOTTOM_NAME(sv))
1922 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1923 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1924 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1926 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1927 PTR2UV(IoBOTTOM_GV(sv)));
1928 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1931 if (isPRINT(IoTYPE(sv)))
1932 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1934 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1935 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1942 Perl_sv_dump(pTHX_ SV *sv)
1946 PERL_ARGS_ASSERT_SV_DUMP;
1949 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1951 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1955 Perl_runops_debug(pTHX)
1959 if (ckWARN_d(WARN_DEBUGGING))
1960 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1964 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1968 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1969 PerlIO_printf(Perl_debug_log,
1970 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1971 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1972 PTR2UV(*PL_watchaddr));
1973 if (DEBUG_s_TEST_) {
1974 if (DEBUG_v_TEST_) {
1975 PerlIO_printf(Perl_debug_log, "\n");
1983 if (DEBUG_t_TEST_) debop(PL_op);
1984 if (DEBUG_P_TEST_) debprof(PL_op);
1986 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1987 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1994 Perl_debop(pTHX_ const OP *o)
1998 PERL_ARGS_ASSERT_DEBOP;
2000 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2003 Perl_deb(aTHX_ "%s", OP_NAME(o));
2004 switch (o->op_type) {
2007 /* With ITHREADS, consts are stored in the pad, and the right pad
2008 * may not be active here, so check.
2009 * Looks like only during compiling the pads are illegal.
2012 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2014 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2019 SV * const sv = newSV(0);
2021 /* FIXME - is this making unwarranted assumptions about the
2022 UTF-8 cleanliness of the dump file handle? */
2025 gv_fullname3(sv, cGVOPo_gv, NULL);
2026 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2030 PerlIO_printf(Perl_debug_log, "(NULL)");
2036 /* print the lexical's name */
2037 CV * const cv = deb_curcv(cxstack_ix);
2040 AV * const padlist = CvPADLIST(cv);
2041 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
2042 sv = *av_fetch(comppad, o->op_targ, FALSE);
2046 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2048 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2054 PerlIO_printf(Perl_debug_log, "\n");
2059 S_deb_curcv(pTHX_ const I32 ix)
2062 const PERL_CONTEXT * const cx = &cxstack[ix];
2063 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2064 return cx->blk_sub.cv;
2065 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2067 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2072 return deb_curcv(ix - 1);
2076 Perl_watch(pTHX_ char **addr)
2080 PERL_ARGS_ASSERT_WATCH;
2082 PL_watchaddr = addr;
2084 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2085 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2089 S_debprof(pTHX_ const OP *o)
2093 PERL_ARGS_ASSERT_DEBPROF;
2095 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2097 if (!PL_profiledata)
2098 Newxz(PL_profiledata, MAXO, U32);
2099 ++PL_profiledata[o->op_type];
2103 Perl_debprofdump(pTHX)
2107 if (!PL_profiledata)
2109 for (i = 0; i < MAXO; i++) {
2110 if (PL_profiledata[i])
2111 PerlIO_printf(Perl_debug_log,
2112 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2119 * XML variants of most of the above routines
2123 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2127 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2129 PerlIO_printf(file, "\n ");
2130 va_start(args, pat);
2131 xmldump_vindent(level, file, pat, &args);
2137 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2140 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2141 va_start(args, pat);
2142 xmldump_vindent(level, file, pat, &args);
2147 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2149 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2151 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2152 PerlIO_vprintf(file, pat, *args);
2156 Perl_xmldump_all(pTHX)
2158 PerlIO_setlinebuf(PL_xmlfp);
2160 op_xmldump(PL_main_root);
2161 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2162 PerlIO_close(PL_xmlfp);
2167 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2172 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2174 if (!HvARRAY(stash))
2176 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2177 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2178 GV *gv = (GV*)HeVAL(entry);
2180 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2186 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2187 && (hv = GvHV(gv)) && hv != PL_defstash)
2188 xmldump_packsubs(hv); /* nested package */
2194 Perl_xmldump_sub(pTHX_ const GV *gv)
2196 SV * const sv = sv_newmortal();
2198 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2200 gv_fullname3(sv, gv, NULL);
2201 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2202 if (CvXSUB(GvCV(gv)))
2203 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2204 PTR2UV(CvXSUB(GvCV(gv))),
2205 (int)CvXSUBANY(GvCV(gv)).any_i32);
2206 else if (CvROOT(GvCV(gv)))
2207 op_xmldump(CvROOT(GvCV(gv)));
2209 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2213 Perl_xmldump_form(pTHX_ const GV *gv)
2215 SV * const sv = sv_newmortal();
2217 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2219 gv_fullname3(sv, gv, NULL);
2220 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2221 if (CvROOT(GvFORM(gv)))
2222 op_xmldump(CvROOT(GvFORM(gv)));
2224 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2228 Perl_xmldump_eval(pTHX)
2230 op_xmldump(PL_eval_root);
2234 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2236 PERL_ARGS_ASSERT_SV_CATXMLSV;
2237 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2241 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2244 const char * const e = pv + len;
2245 const char * const start = pv;
2249 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2251 sv_catpvn(dsv,"",0);
2252 dsvcur = SvCUR(dsv); /* in case we have to restart */
2257 c = utf8_to_uvchr((U8*)pv, &cl);
2259 SvCUR(dsv) = dsvcur;
2324 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2327 sv_catpvs(dsv, "<");
2330 sv_catpvs(dsv, ">");
2333 sv_catpvs(dsv, "&");
2336 sv_catpvs(dsv, """);
2340 if (c < 32 || c > 127) {
2341 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2344 const char string = (char) c;
2345 sv_catpvn(dsv, &string, 1);
2349 if ((c >= 0xD800 && c <= 0xDB7F) ||
2350 (c >= 0xDC00 && c <= 0xDFFF) ||
2351 (c >= 0xFFF0 && c <= 0xFFFF) ||
2353 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2355 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2368 Perl_sv_xmlpeek(pTHX_ SV *sv)
2370 SV * const t = sv_newmortal();
2374 PERL_ARGS_ASSERT_SV_XMLPEEK;
2377 sv_setpvn(t, "", 0);
2380 sv_catpv(t, "VOID=\"\"");
2383 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2384 sv_catpv(t, "WILD=\"\"");
2387 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2388 if (sv == &PL_sv_undef) {
2389 sv_catpv(t, "SV_UNDEF=\"1\"");
2390 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2391 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2395 else if (sv == &PL_sv_no) {
2396 sv_catpv(t, "SV_NO=\"1\"");
2397 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2398 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2399 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2400 SVp_POK|SVp_NOK)) &&
2405 else if (sv == &PL_sv_yes) {
2406 sv_catpv(t, "SV_YES=\"1\"");
2407 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2408 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2409 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2410 SVp_POK|SVp_NOK)) &&
2412 SvPVX(sv) && *SvPVX(sv) == '1' &&
2417 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2418 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2419 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2423 sv_catpv(t, " XXX=\"\" ");
2425 else if (SvREFCNT(sv) == 0) {
2426 sv_catpv(t, " refcnt=\"0\"");
2429 else if (DEBUG_R_TEST_) {
2432 /* is this SV on the tmps stack? */
2433 for (ix=PL_tmps_ix; ix>=0; ix--) {
2434 if (PL_tmps_stack[ix] == sv) {
2439 if (SvREFCNT(sv) > 1)
2440 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2443 sv_catpv(t, " DRT=\"<T>\"");
2447 sv_catpv(t, " ROK=\"\"");
2449 switch (SvTYPE(sv)) {
2451 sv_catpv(t, " FREED=\"1\"");
2455 sv_catpv(t, " UNDEF=\"1\"");
2458 sv_catpv(t, " IV=\"");
2461 sv_catpv(t, " NV=\"");
2464 sv_catpv(t, " PV=\"");
2467 sv_catpv(t, " PVIV=\"");
2470 sv_catpv(t, " PVNV=\"");
2473 sv_catpv(t, " PVMG=\"");
2476 sv_catpv(t, " PVLV=\"");
2479 sv_catpv(t, " AV=\"");
2482 sv_catpv(t, " HV=\"");
2486 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2488 sv_catpv(t, " CV=\"()\"");
2491 sv_catpv(t, " GV=\"");
2494 sv_catpv(t, " BIND=\"");
2497 sv_catpv(t, " ORANGE=\"");
2500 sv_catpv(t, " FM=\"");
2503 sv_catpv(t, " IO=\"");
2512 else if (SvNOKp(sv)) {
2513 STORE_NUMERIC_LOCAL_SET_STANDARD();
2514 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2515 RESTORE_NUMERIC_LOCAL();
2517 else if (SvIOKp(sv)) {
2519 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2521 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2530 return SvPV(t, n_a);
2534 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2536 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2539 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2542 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2545 REGEXP *const r = PM_GETRE(pm);
2546 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2547 sv_catxmlsv(tmpsv, (SV*)r);
2548 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2550 SvREFCNT_dec(tmpsv);
2551 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2552 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2555 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2556 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2557 SV * const tmpsv = pm_description(pm);
2558 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2559 SvREFCNT_dec(tmpsv);
2563 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2564 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2565 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2566 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2567 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2568 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2571 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2575 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2577 do_pmop_xmldump(0, PL_xmlfp, pm);
2581 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2586 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2591 seq = sequence_num(o);
2592 Perl_xmldump_indent(aTHX_ level, file,
2593 "<op_%s seq=\"%"UVuf" -> ",
2598 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2599 sequence_num(o->op_next));
2601 PerlIO_printf(file, "DONE\"");
2604 if (o->op_type == OP_NULL)
2606 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2607 if (o->op_targ == OP_NEXTSTATE)
2610 PerlIO_printf(file, " line=\"%"UVuf"\"",
2611 (UV)CopLINE(cCOPo));
2612 if (CopSTASHPV(cCOPo))
2613 PerlIO_printf(file, " package=\"%s\"",
2615 if (CopLABEL(cCOPo))
2616 PerlIO_printf(file, " label=\"%s\"",
2621 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2624 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2627 SV * const tmpsv = newSVpvn("", 0);
2628 switch (o->op_flags & OPf_WANT) {
2630 sv_catpv(tmpsv, ",VOID");
2632 case OPf_WANT_SCALAR:
2633 sv_catpv(tmpsv, ",SCALAR");
2636 sv_catpv(tmpsv, ",LIST");
2639 sv_catpv(tmpsv, ",UNKNOWN");
2642 if (o->op_flags & OPf_KIDS)
2643 sv_catpv(tmpsv, ",KIDS");
2644 if (o->op_flags & OPf_PARENS)
2645 sv_catpv(tmpsv, ",PARENS");
2646 if (o->op_flags & OPf_STACKED)
2647 sv_catpv(tmpsv, ",STACKED");
2648 if (o->op_flags & OPf_REF)
2649 sv_catpv(tmpsv, ",REF");
2650 if (o->op_flags & OPf_MOD)
2651 sv_catpv(tmpsv, ",MOD");
2652 if (o->op_flags & OPf_SPECIAL)
2653 sv_catpv(tmpsv, ",SPECIAL");
2654 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2655 SvREFCNT_dec(tmpsv);
2657 if (o->op_private) {
2658 SV * const tmpsv = newSVpvn("", 0);
2659 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2660 if (o->op_private & OPpTARGET_MY)
2661 sv_catpv(tmpsv, ",TARGET_MY");
2663 else if (o->op_type == OP_LEAVESUB ||
2664 o->op_type == OP_LEAVE ||
2665 o->op_type == OP_LEAVESUBLV ||
2666 o->op_type == OP_LEAVEWRITE) {
2667 if (o->op_private & OPpREFCOUNTED)
2668 sv_catpv(tmpsv, ",REFCOUNTED");
2670 else if (o->op_type == OP_AASSIGN) {
2671 if (o->op_private & OPpASSIGN_COMMON)
2672 sv_catpv(tmpsv, ",COMMON");
2674 else if (o->op_type == OP_SASSIGN) {
2675 if (o->op_private & OPpASSIGN_BACKWARDS)
2676 sv_catpv(tmpsv, ",BACKWARDS");
2678 else if (o->op_type == OP_TRANS) {
2679 if (o->op_private & OPpTRANS_SQUASH)
2680 sv_catpv(tmpsv, ",SQUASH");
2681 if (o->op_private & OPpTRANS_DELETE)
2682 sv_catpv(tmpsv, ",DELETE");
2683 if (o->op_private & OPpTRANS_COMPLEMENT)
2684 sv_catpv(tmpsv, ",COMPLEMENT");
2685 if (o->op_private & OPpTRANS_IDENTICAL)
2686 sv_catpv(tmpsv, ",IDENTICAL");
2687 if (o->op_private & OPpTRANS_GROWS)
2688 sv_catpv(tmpsv, ",GROWS");
2690 else if (o->op_type == OP_REPEAT) {
2691 if (o->op_private & OPpREPEAT_DOLIST)
2692 sv_catpv(tmpsv, ",DOLIST");
2694 else if (o->op_type == OP_ENTERSUB ||
2695 o->op_type == OP_RV2SV ||
2696 o->op_type == OP_GVSV ||
2697 o->op_type == OP_RV2AV ||
2698 o->op_type == OP_RV2HV ||
2699 o->op_type == OP_RV2GV ||
2700 o->op_type == OP_AELEM ||
2701 o->op_type == OP_HELEM )
2703 if (o->op_type == OP_ENTERSUB) {
2704 if (o->op_private & OPpENTERSUB_AMPER)
2705 sv_catpv(tmpsv, ",AMPER");
2706 if (o->op_private & OPpENTERSUB_DB)
2707 sv_catpv(tmpsv, ",DB");
2708 if (o->op_private & OPpENTERSUB_HASTARG)
2709 sv_catpv(tmpsv, ",HASTARG");
2710 if (o->op_private & OPpENTERSUB_NOPAREN)
2711 sv_catpv(tmpsv, ",NOPAREN");
2712 if (o->op_private & OPpENTERSUB_INARGS)
2713 sv_catpv(tmpsv, ",INARGS");
2714 if (o->op_private & OPpENTERSUB_NOMOD)
2715 sv_catpv(tmpsv, ",NOMOD");
2718 switch (o->op_private & OPpDEREF) {
2720 sv_catpv(tmpsv, ",SV");
2723 sv_catpv(tmpsv, ",AV");
2726 sv_catpv(tmpsv, ",HV");
2729 if (o->op_private & OPpMAYBE_LVSUB)
2730 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2732 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2733 if (o->op_private & OPpLVAL_DEFER)
2734 sv_catpv(tmpsv, ",LVAL_DEFER");
2737 if (o->op_private & HINT_STRICT_REFS)
2738 sv_catpv(tmpsv, ",STRICT_REFS");
2739 if (o->op_private & OPpOUR_INTRO)
2740 sv_catpv(tmpsv, ",OUR_INTRO");
2743 else if (o->op_type == OP_CONST) {
2744 if (o->op_private & OPpCONST_BARE)
2745 sv_catpv(tmpsv, ",BARE");
2746 if (o->op_private & OPpCONST_STRICT)
2747 sv_catpv(tmpsv, ",STRICT");
2748 if (o->op_private & OPpCONST_ARYBASE)
2749 sv_catpv(tmpsv, ",ARYBASE");
2750 if (o->op_private & OPpCONST_WARNING)
2751 sv_catpv(tmpsv, ",WARNING");
2752 if (o->op_private & OPpCONST_ENTERED)
2753 sv_catpv(tmpsv, ",ENTERED");
2755 else if (o->op_type == OP_FLIP) {
2756 if (o->op_private & OPpFLIP_LINENUM)
2757 sv_catpv(tmpsv, ",LINENUM");
2759 else if (o->op_type == OP_FLOP) {
2760 if (o->op_private & OPpFLIP_LINENUM)
2761 sv_catpv(tmpsv, ",LINENUM");
2763 else if (o->op_type == OP_RV2CV) {
2764 if (o->op_private & OPpLVAL_INTRO)
2765 sv_catpv(tmpsv, ",INTRO");
2767 else if (o->op_type == OP_GV) {
2768 if (o->op_private & OPpEARLY_CV)
2769 sv_catpv(tmpsv, ",EARLY_CV");
2771 else if (o->op_type == OP_LIST) {
2772 if (o->op_private & OPpLIST_GUESSED)
2773 sv_catpv(tmpsv, ",GUESSED");
2775 else if (o->op_type == OP_DELETE) {
2776 if (o->op_private & OPpSLICE)
2777 sv_catpv(tmpsv, ",SLICE");
2779 else if (o->op_type == OP_EXISTS) {
2780 if (o->op_private & OPpEXISTS_SUB)
2781 sv_catpv(tmpsv, ",EXISTS_SUB");
2783 else if (o->op_type == OP_SORT) {
2784 if (o->op_private & OPpSORT_NUMERIC)
2785 sv_catpv(tmpsv, ",NUMERIC");
2786 if (o->op_private & OPpSORT_INTEGER)
2787 sv_catpv(tmpsv, ",INTEGER");
2788 if (o->op_private & OPpSORT_REVERSE)
2789 sv_catpv(tmpsv, ",REVERSE");
2791 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2792 if (o->op_private & OPpOPEN_IN_RAW)
2793 sv_catpv(tmpsv, ",IN_RAW");
2794 if (o->op_private & OPpOPEN_IN_CRLF)
2795 sv_catpv(tmpsv, ",IN_CRLF");
2796 if (o->op_private & OPpOPEN_OUT_RAW)
2797 sv_catpv(tmpsv, ",OUT_RAW");
2798 if (o->op_private & OPpOPEN_OUT_CRLF)
2799 sv_catpv(tmpsv, ",OUT_CRLF");
2801 else if (o->op_type == OP_EXIT) {
2802 if (o->op_private & OPpEXIT_VMSISH)
2803 sv_catpv(tmpsv, ",EXIT_VMSISH");
2804 if (o->op_private & OPpHUSH_VMSISH)
2805 sv_catpv(tmpsv, ",HUSH_VMSISH");
2807 else if (o->op_type == OP_DIE) {
2808 if (o->op_private & OPpHUSH_VMSISH)
2809 sv_catpv(tmpsv, ",HUSH_VMSISH");
2811 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2812 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2813 sv_catpv(tmpsv, ",FT_ACCESS");
2814 if (o->op_private & OPpFT_STACKED)
2815 sv_catpv(tmpsv, ",FT_STACKED");
2817 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2818 sv_catpv(tmpsv, ",INTRO");
2820 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2821 SvREFCNT_dec(tmpsv);
2824 switch (o->op_type) {
2826 if (o->op_flags & OPf_SPECIAL) {
2832 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2834 if (cSVOPo->op_sv) {
2835 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2836 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2842 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
2843 s = SvPV(tmpsv1,len);
2844 sv_catxmlpvn(tmpsv2, s, len, 1);
2845 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2849 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2854 case OP_METHOD_NAMED:
2855 #ifndef USE_ITHREADS
2856 /* with ITHREADS, consts are stored in the pad, and the right pad
2857 * may not be active here, so skip */
2858 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2864 PerlIO_printf(file, ">\n");
2866 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2871 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2872 (UV)CopLINE(cCOPo));
2873 if (CopSTASHPV(cCOPo))
2874 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2876 if (CopLABEL(cCOPo))
2877 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2881 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2882 if (cLOOPo->op_redoop)
2883 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2885 PerlIO_printf(file, "DONE\"");
2886 S_xmldump_attr(aTHX_ level, file, "next=\"");
2887 if (cLOOPo->op_nextop)
2888 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2890 PerlIO_printf(file, "DONE\"");
2891 S_xmldump_attr(aTHX_ level, file, "last=\"");
2892 if (cLOOPo->op_lastop)
2893 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2895 PerlIO_printf(file, "DONE\"");
2903 S_xmldump_attr(aTHX_ level, file, "other=\"");
2904 if (cLOGOPo->op_other)
2905 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2907 PerlIO_printf(file, "DONE\"");
2915 if (o->op_private & OPpREFCOUNTED)
2916 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2922 if (PL_madskills && o->op_madprop) {
2923 char prevkey = '\0';
2924 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2925 const MADPROP* mp = o->op_madprop;
2929 PerlIO_printf(file, ">\n");
2931 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2934 char tmp = mp->mad_key;
2935 sv_setpvn(tmpsv,"\"",1);
2937 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2938 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2939 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2942 sv_catpv(tmpsv, "\"");
2943 switch (mp->mad_type) {
2945 sv_catpv(tmpsv, "NULL");
2946 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2949 sv_catpv(tmpsv, " val=\"");
2950 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2951 sv_catpv(tmpsv, "\"");
2952 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2955 sv_catpv(tmpsv, " val=\"");
2956 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2957 sv_catpv(tmpsv, "\"");
2958 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2961 if ((OP*)mp->mad_val) {
2962 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2963 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2964 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2968 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2974 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2976 SvREFCNT_dec(tmpsv);
2979 switch (o->op_type) {
2986 PerlIO_printf(file, ">\n");
2988 do_pmop_xmldump(level, file, cPMOPo);
2994 if (o->op_flags & OPf_KIDS) {
2998 PerlIO_printf(file, ">\n");
3000 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3001 do_op_xmldump(level, file, kid);
3005 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3007 PerlIO_printf(file, " />\n");
3011 Perl_op_xmldump(pTHX_ const OP *o)
3013 PERL_ARGS_ASSERT_OP_XMLDUMP;
3015 do_op_xmldump(0, PL_xmlfp, o);
3021 * c-indentation-style: bsd
3023 * indent-tabs-mode: t
3026 * ex: set ts=8 sts=4 sw=4 noet: