3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'"
16 /* This file contains utility routines to dump the contents of SV and OP
17 * structures, as used by command-line options like -Dt and -Dx, and
20 * It also holds the debugging version of the runops function.
24 #define PERL_IN_DUMP_C
30 static const char* const svtypenames[SVt_LAST] = {
50 static const char* const svshorttypenames[SVt_LAST] = {
69 #define Sequence PL_op_sequence
72 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
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",
782 if (cCOPo->cop_label)
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 (cCOPo->cop_label)
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))
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)) {
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 = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1758 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1760 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1764 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1766 HV * const hv = (HV*)sv;
1767 int count = maxnest - nest;
1770 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1773 const U32 hash = HeHASH(he);
1774 SV * const keysv = hv_iterkeysv(he);
1775 const char * const keypv = SvPV_const(keysv, len);
1776 SV * const elt = hv_iterval(hv, he);
1778 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1780 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1782 PerlIO_printf(file, "[REHASH] ");
1783 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1784 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1786 hv_iterinit(hv); /* Return to status quo */
1792 const char *const proto = SvPV_const(sv, len);
1793 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1798 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1799 if (!CvISXSUB(sv)) {
1801 Perl_dump_indent(aTHX_ level, file,
1802 " START = 0x%"UVxf" ===> %"IVdf"\n",
1803 PTR2UV(CvSTART(sv)),
1804 (IV)sequence_num(CvSTART(sv)));
1806 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1807 PTR2UV(CvROOT(sv)));
1808 if (CvROOT(sv) && dumpops) {
1809 do_op_dump(level+1, file, CvROOT(sv));
1812 SV * const constant = cv_const_sv((CV *)sv);
1814 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1817 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1819 PTR2UV(CvXSUBANY(sv).any_ptr));
1820 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1823 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1824 (IV)CvXSUBANY(sv).any_i32);
1827 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1828 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1829 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1830 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1831 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1832 if (type == SVt_PVFM)
1833 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1834 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1835 if (nest < maxnest) {
1836 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1839 const CV * const outside = CvOUTSIDE(sv);
1840 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1843 : CvANON(outside) ? "ANON"
1844 : (outside == PL_main_cv) ? "MAIN"
1845 : CvUNIQUE(outside) ? "UNIQUE"
1846 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1848 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1849 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1853 if (type == SVt_PVLV) {
1854 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1855 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1856 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1857 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1858 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1859 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1863 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1864 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1865 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1866 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1868 if (!isGV_with_GP(sv))
1870 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1871 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1872 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1873 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1876 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1877 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1878 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1879 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1880 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1881 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1882 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1883 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1884 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1885 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1886 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1887 do_gv_dump (level, file, " EGV", GvEGV(sv));
1890 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1891 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1892 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1893 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1894 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1895 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1896 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1898 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1899 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1900 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1902 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1903 PTR2UV(IoTOP_GV(sv)));
1904 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1907 /* Source filters hide things that are not GVs in these three, so let's
1908 be careful out there. */
1910 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1911 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1912 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1914 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1915 PTR2UV(IoFMT_GV(sv)));
1916 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1919 if (IoBOTTOM_NAME(sv))
1920 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1921 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1922 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1924 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1925 PTR2UV(IoBOTTOM_GV(sv)));
1926 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1929 if (isPRINT(IoTYPE(sv)))
1930 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1932 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1933 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1940 Perl_sv_dump(pTHX_ SV *sv)
1944 PERL_ARGS_ASSERT_SV_DUMP;
1947 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1949 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1953 Perl_runops_debug(pTHX)
1957 if (ckWARN_d(WARN_DEBUGGING))
1958 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1962 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1966 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1967 PerlIO_printf(Perl_debug_log,
1968 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1969 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1970 PTR2UV(*PL_watchaddr));
1971 if (DEBUG_s_TEST_) {
1972 if (DEBUG_v_TEST_) {
1973 PerlIO_printf(Perl_debug_log, "\n");
1981 if (DEBUG_t_TEST_) debop(PL_op);
1982 if (DEBUG_P_TEST_) debprof(PL_op);
1984 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1985 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1992 Perl_debop(pTHX_ const OP *o)
1996 PERL_ARGS_ASSERT_DEBOP;
1998 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2001 Perl_deb(aTHX_ "%s", OP_NAME(o));
2002 switch (o->op_type) {
2005 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2010 SV * const sv = newSV(0);
2012 /* FIXME - is this making unwarranted assumptions about the
2013 UTF-8 cleanliness of the dump file handle? */
2016 gv_fullname3(sv, cGVOPo_gv, NULL);
2017 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2021 PerlIO_printf(Perl_debug_log, "(NULL)");
2027 /* print the lexical's name */
2028 CV * const cv = deb_curcv(cxstack_ix);
2031 AV * const padlist = CvPADLIST(cv);
2032 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
2033 sv = *av_fetch(comppad, o->op_targ, FALSE);
2037 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2039 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2045 PerlIO_printf(Perl_debug_log, "\n");
2050 S_deb_curcv(pTHX_ const I32 ix)
2053 const PERL_CONTEXT * const cx = &cxstack[ix];
2054 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2055 return cx->blk_sub.cv;
2056 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2058 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2063 return deb_curcv(ix - 1);
2067 Perl_watch(pTHX_ char **addr)
2071 PERL_ARGS_ASSERT_WATCH;
2073 PL_watchaddr = addr;
2075 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2076 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2080 S_debprof(pTHX_ const OP *o)
2084 PERL_ARGS_ASSERT_DEBPROF;
2086 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2088 if (!PL_profiledata)
2089 Newxz(PL_profiledata, MAXO, U32);
2090 ++PL_profiledata[o->op_type];
2094 Perl_debprofdump(pTHX)
2098 if (!PL_profiledata)
2100 for (i = 0; i < MAXO; i++) {
2101 if (PL_profiledata[i])
2102 PerlIO_printf(Perl_debug_log,
2103 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2110 * XML variants of most of the above routines
2114 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2118 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2120 PerlIO_printf(file, "\n ");
2121 va_start(args, pat);
2122 xmldump_vindent(level, file, pat, &args);
2128 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2131 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2132 va_start(args, pat);
2133 xmldump_vindent(level, file, pat, &args);
2138 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2140 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2142 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2143 PerlIO_vprintf(file, pat, *args);
2147 Perl_xmldump_all(pTHX)
2149 PerlIO_setlinebuf(PL_xmlfp);
2151 op_xmldump(PL_main_root);
2152 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2153 PerlIO_close(PL_xmlfp);
2158 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2163 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2165 if (!HvARRAY(stash))
2167 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2168 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2169 GV *gv = (GV*)HeVAL(entry);
2171 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2177 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2178 && (hv = GvHV(gv)) && hv != PL_defstash)
2179 xmldump_packsubs(hv); /* nested package */
2185 Perl_xmldump_sub(pTHX_ const GV *gv)
2187 SV * const sv = sv_newmortal();
2189 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2191 gv_fullname3(sv, gv, NULL);
2192 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2193 if (CvXSUB(GvCV(gv)))
2194 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2195 PTR2UV(CvXSUB(GvCV(gv))),
2196 (int)CvXSUBANY(GvCV(gv)).any_i32);
2197 else if (CvROOT(GvCV(gv)))
2198 op_xmldump(CvROOT(GvCV(gv)));
2200 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2204 Perl_xmldump_form(pTHX_ const GV *gv)
2206 SV * const sv = sv_newmortal();
2208 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2210 gv_fullname3(sv, gv, NULL);
2211 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2212 if (CvROOT(GvFORM(gv)))
2213 op_xmldump(CvROOT(GvFORM(gv)));
2215 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2219 Perl_xmldump_eval(pTHX)
2221 op_xmldump(PL_eval_root);
2225 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2227 PERL_ARGS_ASSERT_SV_CATXMLSV;
2228 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2232 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2235 const char * const e = pv + len;
2236 const char * const start = pv;
2240 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2242 sv_catpvn(dsv,"",0);
2243 dsvcur = SvCUR(dsv); /* in case we have to restart */
2248 c = utf8_to_uvchr((U8*)pv, &cl);
2250 SvCUR(dsv) = dsvcur;
2315 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2318 sv_catpvs(dsv, "<");
2321 sv_catpvs(dsv, ">");
2324 sv_catpvs(dsv, "&");
2327 sv_catpvs(dsv, """);
2331 if (c < 32 || c > 127) {
2332 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2335 const char string = (char) c;
2336 sv_catpvn(dsv, &string, 1);
2340 if ((c >= 0xD800 && c <= 0xDB7F) ||
2341 (c >= 0xDC00 && c <= 0xDFFF) ||
2342 (c >= 0xFFF0 && c <= 0xFFFF) ||
2344 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2346 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2359 Perl_sv_xmlpeek(pTHX_ SV *sv)
2361 SV * const t = sv_newmortal();
2365 PERL_ARGS_ASSERT_SV_XMLPEEK;
2368 sv_setpvn(t, "", 0);
2371 sv_catpv(t, "VOID=\"\"");
2374 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2375 sv_catpv(t, "WILD=\"\"");
2378 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2379 if (sv == &PL_sv_undef) {
2380 sv_catpv(t, "SV_UNDEF=\"1\"");
2381 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2382 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2386 else if (sv == &PL_sv_no) {
2387 sv_catpv(t, "SV_NO=\"1\"");
2388 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2389 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2390 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2391 SVp_POK|SVp_NOK)) &&
2396 else if (sv == &PL_sv_yes) {
2397 sv_catpv(t, "SV_YES=\"1\"");
2398 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2399 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2400 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2401 SVp_POK|SVp_NOK)) &&
2403 SvPVX(sv) && *SvPVX(sv) == '1' &&
2408 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2409 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2410 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2414 sv_catpv(t, " XXX=\"\" ");
2416 else if (SvREFCNT(sv) == 0) {
2417 sv_catpv(t, " refcnt=\"0\"");
2420 else if (DEBUG_R_TEST_) {
2423 /* is this SV on the tmps stack? */
2424 for (ix=PL_tmps_ix; ix>=0; ix--) {
2425 if (PL_tmps_stack[ix] == sv) {
2430 if (SvREFCNT(sv) > 1)
2431 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2434 sv_catpv(t, " DRT=\"<T>\"");
2438 sv_catpv(t, " ROK=\"\"");
2440 switch (SvTYPE(sv)) {
2442 sv_catpv(t, " FREED=\"1\"");
2446 sv_catpv(t, " UNDEF=\"1\"");
2449 sv_catpv(t, " IV=\"");
2452 sv_catpv(t, " NV=\"");
2455 sv_catpv(t, " PV=\"");
2458 sv_catpv(t, " PVIV=\"");
2461 sv_catpv(t, " PVNV=\"");
2464 sv_catpv(t, " PVMG=\"");
2467 sv_catpv(t, " PVLV=\"");
2470 sv_catpv(t, " AV=\"");
2473 sv_catpv(t, " HV=\"");
2477 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2479 sv_catpv(t, " CV=\"()\"");
2482 sv_catpv(t, " GV=\"");
2485 sv_catpv(t, " BIND=\"");
2488 sv_catpv(t, " ORANGE=\"");
2491 sv_catpv(t, " FM=\"");
2494 sv_catpv(t, " IO=\"");
2503 else if (SvNOKp(sv)) {
2504 STORE_NUMERIC_LOCAL_SET_STANDARD();
2505 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2506 RESTORE_NUMERIC_LOCAL();
2508 else if (SvIOKp(sv)) {
2510 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2512 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2521 return SvPV(t, n_a);
2525 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2527 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2530 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2533 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2536 REGEXP *const r = PM_GETRE(pm);
2537 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2538 sv_catxmlsv(tmpsv, (SV*)r);
2539 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2541 SvREFCNT_dec(tmpsv);
2542 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2543 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2546 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2547 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2548 SV * const tmpsv = pm_description(pm);
2549 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2550 SvREFCNT_dec(tmpsv);
2554 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2555 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2556 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2557 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2558 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2559 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2562 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2566 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2568 do_pmop_xmldump(0, PL_xmlfp, pm);
2572 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2577 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2582 seq = sequence_num(o);
2583 Perl_xmldump_indent(aTHX_ level, file,
2584 "<op_%s seq=\"%"UVuf" -> ",
2589 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2590 sequence_num(o->op_next));
2592 PerlIO_printf(file, "DONE\"");
2595 if (o->op_type == OP_NULL)
2597 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2598 if (o->op_targ == OP_NEXTSTATE)
2601 PerlIO_printf(file, " line=\"%"UVuf"\"",
2602 (UV)CopLINE(cCOPo));
2603 if (CopSTASHPV(cCOPo))
2604 PerlIO_printf(file, " package=\"%s\"",
2606 if (cCOPo->cop_label)
2607 PerlIO_printf(file, " label=\"%s\"",
2612 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2615 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2618 SV * const tmpsv = newSVpvn("", 0);
2619 switch (o->op_flags & OPf_WANT) {
2621 sv_catpv(tmpsv, ",VOID");
2623 case OPf_WANT_SCALAR:
2624 sv_catpv(tmpsv, ",SCALAR");
2627 sv_catpv(tmpsv, ",LIST");
2630 sv_catpv(tmpsv, ",UNKNOWN");
2633 if (o->op_flags & OPf_KIDS)
2634 sv_catpv(tmpsv, ",KIDS");
2635 if (o->op_flags & OPf_PARENS)
2636 sv_catpv(tmpsv, ",PARENS");
2637 if (o->op_flags & OPf_STACKED)
2638 sv_catpv(tmpsv, ",STACKED");
2639 if (o->op_flags & OPf_REF)
2640 sv_catpv(tmpsv, ",REF");
2641 if (o->op_flags & OPf_MOD)
2642 sv_catpv(tmpsv, ",MOD");
2643 if (o->op_flags & OPf_SPECIAL)
2644 sv_catpv(tmpsv, ",SPECIAL");
2645 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2646 SvREFCNT_dec(tmpsv);
2648 if (o->op_private) {
2649 SV * const tmpsv = newSVpvn("", 0);
2650 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2651 if (o->op_private & OPpTARGET_MY)
2652 sv_catpv(tmpsv, ",TARGET_MY");
2654 else if (o->op_type == OP_LEAVESUB ||
2655 o->op_type == OP_LEAVE ||
2656 o->op_type == OP_LEAVESUBLV ||
2657 o->op_type == OP_LEAVEWRITE) {
2658 if (o->op_private & OPpREFCOUNTED)
2659 sv_catpv(tmpsv, ",REFCOUNTED");
2661 else if (o->op_type == OP_AASSIGN) {
2662 if (o->op_private & OPpASSIGN_COMMON)
2663 sv_catpv(tmpsv, ",COMMON");
2665 else if (o->op_type == OP_SASSIGN) {
2666 if (o->op_private & OPpASSIGN_BACKWARDS)
2667 sv_catpv(tmpsv, ",BACKWARDS");
2669 else if (o->op_type == OP_TRANS) {
2670 if (o->op_private & OPpTRANS_SQUASH)
2671 sv_catpv(tmpsv, ",SQUASH");
2672 if (o->op_private & OPpTRANS_DELETE)
2673 sv_catpv(tmpsv, ",DELETE");
2674 if (o->op_private & OPpTRANS_COMPLEMENT)
2675 sv_catpv(tmpsv, ",COMPLEMENT");
2676 if (o->op_private & OPpTRANS_IDENTICAL)
2677 sv_catpv(tmpsv, ",IDENTICAL");
2678 if (o->op_private & OPpTRANS_GROWS)
2679 sv_catpv(tmpsv, ",GROWS");
2681 else if (o->op_type == OP_REPEAT) {
2682 if (o->op_private & OPpREPEAT_DOLIST)
2683 sv_catpv(tmpsv, ",DOLIST");
2685 else if (o->op_type == OP_ENTERSUB ||
2686 o->op_type == OP_RV2SV ||
2687 o->op_type == OP_GVSV ||
2688 o->op_type == OP_RV2AV ||
2689 o->op_type == OP_RV2HV ||
2690 o->op_type == OP_RV2GV ||
2691 o->op_type == OP_AELEM ||
2692 o->op_type == OP_HELEM )
2694 if (o->op_type == OP_ENTERSUB) {
2695 if (o->op_private & OPpENTERSUB_AMPER)
2696 sv_catpv(tmpsv, ",AMPER");
2697 if (o->op_private & OPpENTERSUB_DB)
2698 sv_catpv(tmpsv, ",DB");
2699 if (o->op_private & OPpENTERSUB_HASTARG)
2700 sv_catpv(tmpsv, ",HASTARG");
2701 if (o->op_private & OPpENTERSUB_NOPAREN)
2702 sv_catpv(tmpsv, ",NOPAREN");
2703 if (o->op_private & OPpENTERSUB_INARGS)
2704 sv_catpv(tmpsv, ",INARGS");
2705 if (o->op_private & OPpENTERSUB_NOMOD)
2706 sv_catpv(tmpsv, ",NOMOD");
2709 switch (o->op_private & OPpDEREF) {
2711 sv_catpv(tmpsv, ",SV");
2714 sv_catpv(tmpsv, ",AV");
2717 sv_catpv(tmpsv, ",HV");
2720 if (o->op_private & OPpMAYBE_LVSUB)
2721 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2723 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2724 if (o->op_private & OPpLVAL_DEFER)
2725 sv_catpv(tmpsv, ",LVAL_DEFER");
2728 if (o->op_private & HINT_STRICT_REFS)
2729 sv_catpv(tmpsv, ",STRICT_REFS");
2730 if (o->op_private & OPpOUR_INTRO)
2731 sv_catpv(tmpsv, ",OUR_INTRO");
2734 else if (o->op_type == OP_CONST) {
2735 if (o->op_private & OPpCONST_BARE)
2736 sv_catpv(tmpsv, ",BARE");
2737 if (o->op_private & OPpCONST_STRICT)
2738 sv_catpv(tmpsv, ",STRICT");
2739 if (o->op_private & OPpCONST_ARYBASE)
2740 sv_catpv(tmpsv, ",ARYBASE");
2741 if (o->op_private & OPpCONST_WARNING)
2742 sv_catpv(tmpsv, ",WARNING");
2743 if (o->op_private & OPpCONST_ENTERED)
2744 sv_catpv(tmpsv, ",ENTERED");
2746 else if (o->op_type == OP_FLIP) {
2747 if (o->op_private & OPpFLIP_LINENUM)
2748 sv_catpv(tmpsv, ",LINENUM");
2750 else if (o->op_type == OP_FLOP) {
2751 if (o->op_private & OPpFLIP_LINENUM)
2752 sv_catpv(tmpsv, ",LINENUM");
2754 else if (o->op_type == OP_RV2CV) {
2755 if (o->op_private & OPpLVAL_INTRO)
2756 sv_catpv(tmpsv, ",INTRO");
2758 else if (o->op_type == OP_GV) {
2759 if (o->op_private & OPpEARLY_CV)
2760 sv_catpv(tmpsv, ",EARLY_CV");
2762 else if (o->op_type == OP_LIST) {
2763 if (o->op_private & OPpLIST_GUESSED)
2764 sv_catpv(tmpsv, ",GUESSED");
2766 else if (o->op_type == OP_DELETE) {
2767 if (o->op_private & OPpSLICE)
2768 sv_catpv(tmpsv, ",SLICE");
2770 else if (o->op_type == OP_EXISTS) {
2771 if (o->op_private & OPpEXISTS_SUB)
2772 sv_catpv(tmpsv, ",EXISTS_SUB");
2774 else if (o->op_type == OP_SORT) {
2775 if (o->op_private & OPpSORT_NUMERIC)
2776 sv_catpv(tmpsv, ",NUMERIC");
2777 if (o->op_private & OPpSORT_INTEGER)
2778 sv_catpv(tmpsv, ",INTEGER");
2779 if (o->op_private & OPpSORT_REVERSE)
2780 sv_catpv(tmpsv, ",REVERSE");
2782 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2783 if (o->op_private & OPpOPEN_IN_RAW)
2784 sv_catpv(tmpsv, ",IN_RAW");
2785 if (o->op_private & OPpOPEN_IN_CRLF)
2786 sv_catpv(tmpsv, ",IN_CRLF");
2787 if (o->op_private & OPpOPEN_OUT_RAW)
2788 sv_catpv(tmpsv, ",OUT_RAW");
2789 if (o->op_private & OPpOPEN_OUT_CRLF)
2790 sv_catpv(tmpsv, ",OUT_CRLF");
2792 else if (o->op_type == OP_EXIT) {
2793 if (o->op_private & OPpEXIT_VMSISH)
2794 sv_catpv(tmpsv, ",EXIT_VMSISH");
2795 if (o->op_private & OPpHUSH_VMSISH)
2796 sv_catpv(tmpsv, ",HUSH_VMSISH");
2798 else if (o->op_type == OP_DIE) {
2799 if (o->op_private & OPpHUSH_VMSISH)
2800 sv_catpv(tmpsv, ",HUSH_VMSISH");
2802 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2803 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2804 sv_catpv(tmpsv, ",FT_ACCESS");
2805 if (o->op_private & OPpFT_STACKED)
2806 sv_catpv(tmpsv, ",FT_STACKED");
2808 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2809 sv_catpv(tmpsv, ",INTRO");
2811 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2812 SvREFCNT_dec(tmpsv);
2815 switch (o->op_type) {
2817 if (o->op_flags & OPf_SPECIAL) {
2823 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2825 if (cSVOPo->op_sv) {
2826 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2827 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2833 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
2834 s = SvPV(tmpsv1,len);
2835 sv_catxmlpvn(tmpsv2, s, len, 1);
2836 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2840 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2845 case OP_METHOD_NAMED:
2846 #ifndef USE_ITHREADS
2847 /* with ITHREADS, consts are stored in the pad, and the right pad
2848 * may not be active here, so skip */
2849 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2855 PerlIO_printf(file, ">\n");
2857 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2862 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2863 (UV)CopLINE(cCOPo));
2864 if (CopSTASHPV(cCOPo))
2865 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2867 if (cCOPo->cop_label)
2868 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2872 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2873 if (cLOOPo->op_redoop)
2874 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2876 PerlIO_printf(file, "DONE\"");
2877 S_xmldump_attr(aTHX_ level, file, "next=\"");
2878 if (cLOOPo->op_nextop)
2879 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2881 PerlIO_printf(file, "DONE\"");
2882 S_xmldump_attr(aTHX_ level, file, "last=\"");
2883 if (cLOOPo->op_lastop)
2884 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2886 PerlIO_printf(file, "DONE\"");
2894 S_xmldump_attr(aTHX_ level, file, "other=\"");
2895 if (cLOGOPo->op_other)
2896 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2898 PerlIO_printf(file, "DONE\"");
2906 if (o->op_private & OPpREFCOUNTED)
2907 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2913 if (PL_madskills && o->op_madprop) {
2914 char prevkey = '\0';
2915 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2916 const MADPROP* mp = o->op_madprop;
2920 PerlIO_printf(file, ">\n");
2922 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2925 char tmp = mp->mad_key;
2926 sv_setpvn(tmpsv,"\"",1);
2928 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2929 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2930 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2933 sv_catpv(tmpsv, "\"");
2934 switch (mp->mad_type) {
2936 sv_catpv(tmpsv, "NULL");
2937 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2940 sv_catpv(tmpsv, " val=\"");
2941 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2942 sv_catpv(tmpsv, "\"");
2943 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2946 sv_catpv(tmpsv, " val=\"");
2947 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2948 sv_catpv(tmpsv, "\"");
2949 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2952 if ((OP*)mp->mad_val) {
2953 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2954 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2955 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2959 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2965 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2967 SvREFCNT_dec(tmpsv);
2970 switch (o->op_type) {
2977 PerlIO_printf(file, ">\n");
2979 do_pmop_xmldump(level, file, cPMOPo);
2985 if (o->op_flags & OPf_KIDS) {
2989 PerlIO_printf(file, ">\n");
2991 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2992 do_op_xmldump(level, file, kid);
2996 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2998 PerlIO_printf(file, " />\n");
3002 Perl_op_xmldump(pTHX_ const OP *o)
3004 PERL_ARGS_ASSERT_OP_XMLDUMP;
3006 do_op_xmldump(0, PL_xmlfp, o);
3012 * c-indentation-style: bsd
3014 * indent-tabs-mode: t
3017 * ex: set ts=8 sts=4 sw=4 noet: