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 pv_escape
174 Escapes at most the first "count" chars of pv and puts the results into
175 dsv such that the size of the escaped string will not exceed "max" chars
176 and will not contain any incomplete escape sequences.
178 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
179 will also be escaped.
181 Normally the SV will be cleared before the escaped string is prepared,
182 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
184 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
185 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
186 using C<is_utf8_string()> to determine if it is Unicode.
188 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
189 using C<\x01F1> style escapes, otherwise only chars above 255 will be
190 escaped using this style, other non printable chars will use octal or
191 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
192 then all chars below 255 will be treated as printable and
193 will be output as literals.
195 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
196 string will be escaped, regardles of max. If the string is utf8 and
197 the chars value is >255 then it will be returned as a plain hex
198 sequence. Thus the output will either be a single char,
199 an octal escape sequence, a special escape like C<\n> or a 3 or
200 more digit hex value.
202 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
203 not a '\\'. This is because regexes very often contain backslashed
204 sequences, whereas '%' is not a particularly common character in patterns.
206 Returns a pointer to the escaped text as held by dsv.
210 #define PV_ESCAPE_OCTBUFSIZE 32
213 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
214 const STRLEN count, const STRLEN max,
215 STRLEN * const escaped, const U32 flags )
217 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
218 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
219 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
220 STRLEN wrote = 0; /* chars written so far */
221 STRLEN chsize = 0; /* size of data to be written */
222 STRLEN readsize = 1; /* size of data just read */
223 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
224 const char *pv = str;
225 const char * const end = pv + count; /* end of string */
228 PERL_ARGS_ASSERT_PV_ESCAPE;
230 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
231 /* This won't alter the UTF-8 flag */
235 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
238 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
239 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
240 const U8 c = (U8)u & 0xFF;
242 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
243 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
244 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
247 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
248 "%cx{%"UVxf"}", esc, u);
249 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
252 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
256 case '\\' : /* fallthrough */
257 case '%' : if ( c == esc ) {
263 case '\v' : octbuf[1] = 'v'; break;
264 case '\t' : octbuf[1] = 't'; break;
265 case '\r' : octbuf[1] = 'r'; break;
266 case '\n' : octbuf[1] = 'n'; break;
267 case '\f' : octbuf[1] = 'f'; break;
275 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
276 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
279 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
286 if ( max && (wrote + chsize > max) ) {
288 } else if (chsize > 1) {
289 sv_catpvn(dsv, octbuf, chsize);
292 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
293 128-255 can be appended raw to the dsv. If dsv happens to be
294 UTF-8 then we need catpvf to upgrade them for us.
295 Or add a new API call sv_catpvc(). Think about that name, and
296 how to keep it clear that it's unlike the s of catpvs, which is
297 really an array octets, not a string. */
298 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
301 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
309 =for apidoc pv_pretty
311 Converts a string into something presentable, handling escaping via
312 pv_escape() and supporting quoting and ellipses.
314 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
315 double quoted with any double quotes in the string escaped. Otherwise
316 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
319 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
320 string were output then an ellipsis C<...> will be appended to the
321 string. Note that this happens AFTER it has been quoted.
323 If start_color is non-null then it will be inserted after the opening
324 quote (if there is one) but before the escaped text. If end_color
325 is non-null then it will be inserted after the escaped text but before
326 any quotes or ellipses.
328 Returns a pointer to the prettified text as held by dsv.
334 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
335 const STRLEN max, char const * const start_color, char const * const end_color,
338 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
341 PERL_ARGS_ASSERT_PV_PRETTY;
343 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
344 /* This won't alter the UTF-8 flag */
349 sv_catpvs(dsv, "\"");
350 else if ( flags & PERL_PV_PRETTY_LTGT )
353 if ( start_color != NULL )
354 sv_catpv(dsv, start_color);
356 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
358 if ( end_color != NULL )
359 sv_catpv(dsv, end_color);
362 sv_catpvs( dsv, "\"");
363 else if ( flags & PERL_PV_PRETTY_LTGT )
366 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
367 sv_catpvs(dsv, "...");
373 =for apidoc pv_display
377 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
379 except that an additional "\0" will be appended to the string when
380 len > cur and pv[cur] is "\0".
382 Note that the final string may be up to 7 chars longer than pvlim.
388 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
390 PERL_ARGS_ASSERT_PV_DISPLAY;
392 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
393 if (len > cur && pv[cur] == '\0')
394 sv_catpvs( dsv, "\\0");
399 Perl_sv_peek(pTHX_ SV *sv)
402 SV * const t = sv_newmortal();
412 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
416 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
417 if (sv == &PL_sv_undef) {
418 sv_catpv(t, "SV_UNDEF");
419 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
420 SVs_GMG|SVs_SMG|SVs_RMG)) &&
424 else if (sv == &PL_sv_no) {
425 sv_catpv(t, "SV_NO");
426 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
427 SVs_GMG|SVs_SMG|SVs_RMG)) &&
428 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
434 else if (sv == &PL_sv_yes) {
435 sv_catpv(t, "SV_YES");
436 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
437 SVs_GMG|SVs_SMG|SVs_RMG)) &&
438 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
441 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
446 sv_catpv(t, "SV_PLACEHOLDER");
447 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
448 SVs_GMG|SVs_SMG|SVs_RMG)) &&
454 else if (SvREFCNT(sv) == 0) {
458 else if (DEBUG_R_TEST_) {
461 /* is this SV on the tmps stack? */
462 for (ix=PL_tmps_ix; ix>=0; ix--) {
463 if (PL_tmps_stack[ix] == sv) {
468 if (SvREFCNT(sv) > 1)
469 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
477 if (SvCUR(t) + unref > 10) {
478 SvCUR_set(t, unref + 3);
487 if (type == SVt_PVCV) {
488 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
490 } else if (type < SVt_LAST) {
491 sv_catpv(t, svshorttypenames[type]);
493 if (type == SVt_NULL)
496 sv_catpv(t, "FREED");
501 if (!SvPVX_const(sv))
502 sv_catpv(t, "(null)");
504 SV * const tmp = newSVpvs("");
507 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
508 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
510 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
511 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
516 else if (SvNOKp(sv)) {
517 STORE_NUMERIC_LOCAL_SET_STANDARD();
518 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
519 RESTORE_NUMERIC_LOCAL();
521 else if (SvIOKp(sv)) {
523 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
525 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
533 return SvPV_nolen(t);
537 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
541 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
544 Perl_dump_indent(aTHX_ level, file, "{}\n");
547 Perl_dump_indent(aTHX_ level, file, "{\n");
549 if (pm->op_pmflags & PMf_ONCE)
554 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
555 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
556 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
558 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
559 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
560 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
561 op_dump(pm->op_pmreplrootu.op_pmreplroot);
563 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
564 SV * const tmpsv = pm_description(pm);
565 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
569 Perl_dump_indent(aTHX_ level-1, file, "}\n");
573 S_pm_description(pTHX_ const PMOP *pm)
575 SV * const desc = newSVpvs("");
576 const REGEXP * const regex = PM_GETRE(pm);
577 const U32 pmflags = pm->op_pmflags;
579 PERL_ARGS_ASSERT_PM_DESCRIPTION;
581 if (pmflags & PMf_ONCE)
582 sv_catpv(desc, ",ONCE");
584 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
585 sv_catpv(desc, ":USED");
587 if (pmflags & PMf_USED)
588 sv_catpv(desc, ":USED");
592 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
593 sv_catpv(desc, ",TAINTED");
594 if (RX_CHECK_SUBSTR(regex)) {
595 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
596 sv_catpv(desc, ",SCANFIRST");
597 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
598 sv_catpv(desc, ",ALL");
600 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
601 sv_catpv(desc, ",SKIPWHITE");
604 if (pmflags & PMf_CONST)
605 sv_catpv(desc, ",CONST");
606 if (pmflags & PMf_KEEP)
607 sv_catpv(desc, ",KEEP");
608 if (pmflags & PMf_GLOBAL)
609 sv_catpv(desc, ",GLOBAL");
610 if (pmflags & PMf_CONTINUE)
611 sv_catpv(desc, ",CONTINUE");
612 if (pmflags & PMf_RETAINT)
613 sv_catpv(desc, ",RETAINT");
614 if (pmflags & PMf_EVAL)
615 sv_catpv(desc, ",EVAL");
620 Perl_pmop_dump(pTHX_ PMOP *pm)
622 do_pmop_dump(0, Perl_debug_log, pm);
625 /* An op sequencer. We visit the ops in the order they're to execute. */
628 S_sequence(pTHX_ register const OP *o)
631 const OP *oldop = NULL;
644 for (; o; o = o->op_next) {
646 SV * const op = newSVuv(PTR2UV(o));
647 const char * const key = SvPV_const(op, len);
649 if (hv_exists(Sequence, key, len))
652 switch (o->op_type) {
654 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
655 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
664 if (oldop && o->op_next)
671 if (oldop && o->op_next)
673 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
686 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
687 sequence_tail(cLOGOPo->op_other);
692 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
693 sequence_tail(cLOOPo->op_redoop);
694 sequence_tail(cLOOPo->op_nextop);
695 sequence_tail(cLOOPo->op_lastop);
699 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
700 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
709 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
717 S_sequence_tail(pTHX_ const OP *o)
719 while (o && (o->op_type == OP_NULL))
725 S_sequence_num(pTHX_ const OP *o)
733 op = newSVuv(PTR2UV(o));
734 key = SvPV_const(op, len);
735 seq = hv_fetch(Sequence, key, len, 0);
736 return seq ? SvUV(*seq): 0;
740 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
744 const OPCODE optype = o->op_type;
746 PERL_ARGS_ASSERT_DO_OP_DUMP;
749 Perl_dump_indent(aTHX_ level, file, "{\n");
751 seq = sequence_num(o);
753 PerlIO_printf(file, "%-4"UVuf, seq);
755 PerlIO_printf(file, " ");
757 "%*sTYPE = %s ===> ",
758 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
760 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
761 sequence_num(o->op_next));
763 PerlIO_printf(file, "DONE\n");
765 if (optype == OP_NULL) {
766 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
767 if (o->op_targ == OP_NEXTSTATE) {
769 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
771 if (CopSTASHPV(cCOPo))
772 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
775 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
780 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
783 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
785 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
786 SV * const tmpsv = newSVpvs("");
787 switch (o->op_flags & OPf_WANT) {
789 sv_catpv(tmpsv, ",VOID");
791 case OPf_WANT_SCALAR:
792 sv_catpv(tmpsv, ",SCALAR");
795 sv_catpv(tmpsv, ",LIST");
798 sv_catpv(tmpsv, ",UNKNOWN");
801 if (o->op_flags & OPf_KIDS)
802 sv_catpv(tmpsv, ",KIDS");
803 if (o->op_flags & OPf_PARENS)
804 sv_catpv(tmpsv, ",PARENS");
805 if (o->op_flags & OPf_STACKED)
806 sv_catpv(tmpsv, ",STACKED");
807 if (o->op_flags & OPf_REF)
808 sv_catpv(tmpsv, ",REF");
809 if (o->op_flags & OPf_MOD)
810 sv_catpv(tmpsv, ",MOD");
811 if (o->op_flags & OPf_SPECIAL)
812 sv_catpv(tmpsv, ",SPECIAL");
814 sv_catpv(tmpsv, ",LATEFREE");
816 sv_catpv(tmpsv, ",LATEFREED");
818 sv_catpv(tmpsv, ",ATTACHED");
819 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
823 SV * const tmpsv = newSVpvs("");
824 if (PL_opargs[optype] & OA_TARGLEX) {
825 if (o->op_private & OPpTARGET_MY)
826 sv_catpv(tmpsv, ",TARGET_MY");
828 else if (optype == OP_LEAVESUB ||
829 optype == OP_LEAVE ||
830 optype == OP_LEAVESUBLV ||
831 optype == OP_LEAVEWRITE) {
832 if (o->op_private & OPpREFCOUNTED)
833 sv_catpv(tmpsv, ",REFCOUNTED");
835 else if (optype == OP_AASSIGN) {
836 if (o->op_private & OPpASSIGN_COMMON)
837 sv_catpv(tmpsv, ",COMMON");
839 else if (optype == OP_SASSIGN) {
840 if (o->op_private & OPpASSIGN_BACKWARDS)
841 sv_catpv(tmpsv, ",BACKWARDS");
843 else if (optype == OP_TRANS) {
844 if (o->op_private & OPpTRANS_SQUASH)
845 sv_catpv(tmpsv, ",SQUASH");
846 if (o->op_private & OPpTRANS_DELETE)
847 sv_catpv(tmpsv, ",DELETE");
848 if (o->op_private & OPpTRANS_COMPLEMENT)
849 sv_catpv(tmpsv, ",COMPLEMENT");
850 if (o->op_private & OPpTRANS_IDENTICAL)
851 sv_catpv(tmpsv, ",IDENTICAL");
852 if (o->op_private & OPpTRANS_GROWS)
853 sv_catpv(tmpsv, ",GROWS");
855 else if (optype == OP_REPEAT) {
856 if (o->op_private & OPpREPEAT_DOLIST)
857 sv_catpv(tmpsv, ",DOLIST");
859 else if (optype == OP_ENTERSUB ||
860 optype == OP_RV2SV ||
862 optype == OP_RV2AV ||
863 optype == OP_RV2HV ||
864 optype == OP_RV2GV ||
865 optype == OP_AELEM ||
868 if (optype == OP_ENTERSUB) {
869 if (o->op_private & OPpENTERSUB_AMPER)
870 sv_catpv(tmpsv, ",AMPER");
871 if (o->op_private & OPpENTERSUB_DB)
872 sv_catpv(tmpsv, ",DB");
873 if (o->op_private & OPpENTERSUB_HASTARG)
874 sv_catpv(tmpsv, ",HASTARG");
875 if (o->op_private & OPpENTERSUB_NOPAREN)
876 sv_catpv(tmpsv, ",NOPAREN");
877 if (o->op_private & OPpENTERSUB_INARGS)
878 sv_catpv(tmpsv, ",INARGS");
879 if (o->op_private & OPpENTERSUB_NOMOD)
880 sv_catpv(tmpsv, ",NOMOD");
883 switch (o->op_private & OPpDEREF) {
885 sv_catpv(tmpsv, ",SV");
888 sv_catpv(tmpsv, ",AV");
891 sv_catpv(tmpsv, ",HV");
894 if (o->op_private & OPpMAYBE_LVSUB)
895 sv_catpv(tmpsv, ",MAYBE_LVSUB");
897 if (optype == OP_AELEM || optype == OP_HELEM) {
898 if (o->op_private & OPpLVAL_DEFER)
899 sv_catpv(tmpsv, ",LVAL_DEFER");
902 if (o->op_private & HINT_STRICT_REFS)
903 sv_catpv(tmpsv, ",STRICT_REFS");
904 if (o->op_private & OPpOUR_INTRO)
905 sv_catpv(tmpsv, ",OUR_INTRO");
908 else if (optype == OP_CONST) {
909 if (o->op_private & OPpCONST_BARE)
910 sv_catpv(tmpsv, ",BARE");
911 if (o->op_private & OPpCONST_STRICT)
912 sv_catpv(tmpsv, ",STRICT");
913 if (o->op_private & OPpCONST_ARYBASE)
914 sv_catpv(tmpsv, ",ARYBASE");
915 if (o->op_private & OPpCONST_WARNING)
916 sv_catpv(tmpsv, ",WARNING");
917 if (o->op_private & OPpCONST_ENTERED)
918 sv_catpv(tmpsv, ",ENTERED");
920 else if (optype == OP_FLIP) {
921 if (o->op_private & OPpFLIP_LINENUM)
922 sv_catpv(tmpsv, ",LINENUM");
924 else if (optype == OP_FLOP) {
925 if (o->op_private & OPpFLIP_LINENUM)
926 sv_catpv(tmpsv, ",LINENUM");
928 else if (optype == OP_RV2CV) {
929 if (o->op_private & OPpLVAL_INTRO)
930 sv_catpv(tmpsv, ",INTRO");
932 else if (optype == OP_GV) {
933 if (o->op_private & OPpEARLY_CV)
934 sv_catpv(tmpsv, ",EARLY_CV");
936 else if (optype == OP_LIST) {
937 if (o->op_private & OPpLIST_GUESSED)
938 sv_catpv(tmpsv, ",GUESSED");
940 else if (optype == OP_DELETE) {
941 if (o->op_private & OPpSLICE)
942 sv_catpv(tmpsv, ",SLICE");
944 else if (optype == OP_EXISTS) {
945 if (o->op_private & OPpEXISTS_SUB)
946 sv_catpv(tmpsv, ",EXISTS_SUB");
948 else if (optype == OP_SORT) {
949 if (o->op_private & OPpSORT_NUMERIC)
950 sv_catpv(tmpsv, ",NUMERIC");
951 if (o->op_private & OPpSORT_INTEGER)
952 sv_catpv(tmpsv, ",INTEGER");
953 if (o->op_private & OPpSORT_REVERSE)
954 sv_catpv(tmpsv, ",REVERSE");
956 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
957 if (o->op_private & OPpOPEN_IN_RAW)
958 sv_catpv(tmpsv, ",IN_RAW");
959 if (o->op_private & OPpOPEN_IN_CRLF)
960 sv_catpv(tmpsv, ",IN_CRLF");
961 if (o->op_private & OPpOPEN_OUT_RAW)
962 sv_catpv(tmpsv, ",OUT_RAW");
963 if (o->op_private & OPpOPEN_OUT_CRLF)
964 sv_catpv(tmpsv, ",OUT_CRLF");
966 else if (optype == OP_EXIT) {
967 if (o->op_private & OPpEXIT_VMSISH)
968 sv_catpv(tmpsv, ",EXIT_VMSISH");
969 if (o->op_private & OPpHUSH_VMSISH)
970 sv_catpv(tmpsv, ",HUSH_VMSISH");
972 else if (optype == OP_DIE) {
973 if (o->op_private & OPpHUSH_VMSISH)
974 sv_catpv(tmpsv, ",HUSH_VMSISH");
976 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
977 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
978 sv_catpv(tmpsv, ",FT_ACCESS");
979 if (o->op_private & OPpFT_STACKED)
980 sv_catpv(tmpsv, ",FT_STACKED");
982 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
983 sv_catpv(tmpsv, ",INTRO");
985 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
990 if (PL_madskills && o->op_madprop) {
991 SV * const tmpsv = newSVpvs("");
992 MADPROP* mp = o->op_madprop;
993 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
996 const char tmp = mp->mad_key;
997 sv_setpvs(tmpsv,"'");
999 sv_catpvn(tmpsv, &tmp, 1);
1000 sv_catpv(tmpsv, "'=");
1001 switch (mp->mad_type) {
1003 sv_catpv(tmpsv, "NULL");
1004 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1007 sv_catpv(tmpsv, "<");
1008 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1009 sv_catpv(tmpsv, ">");
1010 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1013 if ((OP*)mp->mad_val) {
1014 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1015 do_op_dump(level, file, (OP*)mp->mad_val);
1019 sv_catpv(tmpsv, "(UNK)");
1020 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1026 Perl_dump_indent(aTHX_ level, file, "}\n");
1028 SvREFCNT_dec(tmpsv);
1037 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1039 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1040 if (cSVOPo->op_sv) {
1041 SV * const tmpsv = newSV(0);
1045 /* FIXME - is this making unwarranted assumptions about the
1046 UTF-8 cleanliness of the dump file handle? */
1049 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1050 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1051 SvPV_nolen_const(tmpsv));
1055 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1061 case OP_METHOD_NAMED:
1062 #ifndef USE_ITHREADS
1063 /* with ITHREADS, consts are stored in the pad, and the right pad
1064 * may not be active here, so skip */
1065 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1071 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1072 (UV)CopLINE(cCOPo));
1073 if (CopSTASHPV(cCOPo))
1074 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1076 if (CopLABEL(cCOPo))
1077 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1081 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1082 if (cLOOPo->op_redoop)
1083 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1085 PerlIO_printf(file, "DONE\n");
1086 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1087 if (cLOOPo->op_nextop)
1088 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1090 PerlIO_printf(file, "DONE\n");
1091 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1092 if (cLOOPo->op_lastop)
1093 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1095 PerlIO_printf(file, "DONE\n");
1103 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1104 if (cLOGOPo->op_other)
1105 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1107 PerlIO_printf(file, "DONE\n");
1113 do_pmop_dump(level, file, cPMOPo);
1121 if (o->op_private & OPpREFCOUNTED)
1122 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1127 if (o->op_flags & OPf_KIDS) {
1129 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1130 do_op_dump(level, file, kid);
1132 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1136 Perl_op_dump(pTHX_ const OP *o)
1138 PERL_ARGS_ASSERT_OP_DUMP;
1139 do_op_dump(0, Perl_debug_log, o);
1143 Perl_gv_dump(pTHX_ GV *gv)
1147 PERL_ARGS_ASSERT_GV_DUMP;
1150 PerlIO_printf(Perl_debug_log, "{}\n");
1153 sv = sv_newmortal();
1154 PerlIO_printf(Perl_debug_log, "{\n");
1155 gv_fullname3(sv, gv, NULL);
1156 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1157 if (gv != GvEGV(gv)) {
1158 gv_efullname3(sv, GvEGV(gv), NULL);
1159 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1161 PerlIO_putc(Perl_debug_log, '\n');
1162 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1166 /* map magic types to the symbolic names
1167 * (with the PERL_MAGIC_ prefixed stripped)
1170 static const struct { const char type; const char *name; } magic_names[] = {
1171 { PERL_MAGIC_sv, "sv(\\0)" },
1172 { PERL_MAGIC_arylen, "arylen(#)" },
1173 { PERL_MAGIC_rhash, "rhash(%)" },
1174 { PERL_MAGIC_pos, "pos(.)" },
1175 { PERL_MAGIC_symtab, "symtab(:)" },
1176 { PERL_MAGIC_backref, "backref(<)" },
1177 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1178 { PERL_MAGIC_overload, "overload(A)" },
1179 { PERL_MAGIC_bm, "bm(B)" },
1180 { PERL_MAGIC_regdata, "regdata(D)" },
1181 { PERL_MAGIC_env, "env(E)" },
1182 { PERL_MAGIC_hints, "hints(H)" },
1183 { PERL_MAGIC_isa, "isa(I)" },
1184 { PERL_MAGIC_dbfile, "dbfile(L)" },
1185 { PERL_MAGIC_shared, "shared(N)" },
1186 { PERL_MAGIC_tied, "tied(P)" },
1187 { PERL_MAGIC_sig, "sig(S)" },
1188 { PERL_MAGIC_uvar, "uvar(U)" },
1189 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1190 { PERL_MAGIC_overload_table, "overload_table(c)" },
1191 { PERL_MAGIC_regdatum, "regdatum(d)" },
1192 { PERL_MAGIC_envelem, "envelem(e)" },
1193 { PERL_MAGIC_fm, "fm(f)" },
1194 { PERL_MAGIC_regex_global, "regex_global(g)" },
1195 { PERL_MAGIC_hintselem, "hintselem(h)" },
1196 { PERL_MAGIC_isaelem, "isaelem(i)" },
1197 { PERL_MAGIC_nkeys, "nkeys(k)" },
1198 { PERL_MAGIC_dbline, "dbline(l)" },
1199 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1200 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1201 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1202 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1203 { PERL_MAGIC_qr, "qr(r)" },
1204 { PERL_MAGIC_sigelem, "sigelem(s)" },
1205 { PERL_MAGIC_taint, "taint(t)" },
1206 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1207 { PERL_MAGIC_vec, "vec(v)" },
1208 { PERL_MAGIC_vstring, "vstring(V)" },
1209 { PERL_MAGIC_utf8, "utf8(w)" },
1210 { PERL_MAGIC_substr, "substr(x)" },
1211 { PERL_MAGIC_defelem, "defelem(y)" },
1212 { PERL_MAGIC_ext, "ext(~)" },
1213 /* this null string terminates the list */
1218 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1220 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1222 for (; mg; mg = mg->mg_moremagic) {
1223 Perl_dump_indent(aTHX_ level, file,
1224 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1225 if (mg->mg_virtual) {
1226 const MGVTBL * const v = mg->mg_virtual;
1228 if (v == &PL_vtbl_sv) s = "sv";
1229 else if (v == &PL_vtbl_env) s = "env";
1230 else if (v == &PL_vtbl_envelem) s = "envelem";
1231 else if (v == &PL_vtbl_sig) s = "sig";
1232 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1233 else if (v == &PL_vtbl_pack) s = "pack";
1234 else if (v == &PL_vtbl_packelem) s = "packelem";
1235 else if (v == &PL_vtbl_dbline) s = "dbline";
1236 else if (v == &PL_vtbl_isa) s = "isa";
1237 else if (v == &PL_vtbl_arylen) s = "arylen";
1238 else if (v == &PL_vtbl_mglob) s = "mglob";
1239 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1240 else if (v == &PL_vtbl_taint) s = "taint";
1241 else if (v == &PL_vtbl_substr) s = "substr";
1242 else if (v == &PL_vtbl_vec) s = "vec";
1243 else if (v == &PL_vtbl_pos) s = "pos";
1244 else if (v == &PL_vtbl_bm) s = "bm";
1245 else if (v == &PL_vtbl_fm) s = "fm";
1246 else if (v == &PL_vtbl_uvar) s = "uvar";
1247 else if (v == &PL_vtbl_defelem) s = "defelem";
1248 #ifdef USE_LOCALE_COLLATE
1249 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1251 else if (v == &PL_vtbl_amagic) s = "amagic";
1252 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1253 else if (v == &PL_vtbl_backref) s = "backref";
1254 else if (v == &PL_vtbl_utf8) s = "utf8";
1255 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1256 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1259 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1261 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1264 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1267 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1271 const char *name = NULL;
1272 for (n = 0; magic_names[n].name; n++) {
1273 if (mg->mg_type == magic_names[n].type) {
1274 name = magic_names[n].name;
1279 Perl_dump_indent(aTHX_ level, file,
1280 " MG_TYPE = PERL_MAGIC_%s\n", name);
1282 Perl_dump_indent(aTHX_ level, file,
1283 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1287 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1288 if (mg->mg_type == PERL_MAGIC_envelem &&
1289 mg->mg_flags & MGf_TAINTEDDIR)
1290 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1291 if (mg->mg_flags & MGf_REFCOUNTED)
1292 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1293 if (mg->mg_flags & MGf_GSKIP)
1294 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1295 if (mg->mg_type == PERL_MAGIC_regex_global &&
1296 mg->mg_flags & MGf_MINMATCH)
1297 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1300 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1301 PTR2UV(mg->mg_obj));
1302 if (mg->mg_type == PERL_MAGIC_qr) {
1303 REGEXP* const re = (REGEXP *)mg->mg_obj;
1304 SV * const dsv = sv_newmortal();
1305 const char * const s
1306 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1308 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1309 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1311 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1312 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1315 if (mg->mg_flags & MGf_REFCOUNTED)
1316 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1319 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1321 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1322 if (mg->mg_len >= 0) {
1323 if (mg->mg_type != PERL_MAGIC_utf8) {
1324 SV * const sv = newSVpvs("");
1325 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1329 else if (mg->mg_len == HEf_SVKEY) {
1330 PerlIO_puts(file, " => HEf_SVKEY\n");
1331 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1332 maxnest, dumpops, pvlim); /* MG is already +1 */
1336 PerlIO_puts(file, " ???? - please notify IZ");
1337 PerlIO_putc(file, '\n');
1339 if (mg->mg_type == PERL_MAGIC_utf8) {
1340 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1343 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1344 Perl_dump_indent(aTHX_ level, file,
1345 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1348 (UV)cache[i * 2 + 1]);
1355 Perl_magic_dump(pTHX_ const MAGIC *mg)
1357 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1361 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1365 PERL_ARGS_ASSERT_DO_HV_DUMP;
1367 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1368 if (sv && (hvname = HvNAME_get(sv)))
1369 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1371 PerlIO_putc(file, '\n');
1375 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1377 PERL_ARGS_ASSERT_DO_GV_DUMP;
1379 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1380 if (sv && GvNAME(sv))
1381 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1383 PerlIO_putc(file, '\n');
1387 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1389 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1391 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1392 if (sv && GvNAME(sv)) {
1394 PerlIO_printf(file, "\t\"");
1395 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1396 PerlIO_printf(file, "%s\" :: \"", hvname);
1397 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1400 PerlIO_putc(file, '\n');
1404 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1412 PERL_ARGS_ASSERT_DO_SV_DUMP;
1415 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1419 flags = SvFLAGS(sv);
1422 d = Perl_newSVpvf(aTHX_
1423 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1424 PTR2UV(SvANY(sv)), PTR2UV(sv),
1425 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1426 (int)(PL_dumpindent*level), "");
1428 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1429 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1431 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1432 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1433 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1435 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1436 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1437 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1438 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1439 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1441 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1442 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1443 if (flags & SVf_POK) sv_catpv(d, "POK,");
1444 if (flags & SVf_ROK) {
1445 sv_catpv(d, "ROK,");
1446 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1448 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1449 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1450 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1451 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1453 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1454 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1455 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1456 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1457 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1458 if (SvPCS_IMPORTED(sv))
1459 sv_catpv(d, "PCS_IMPORTED,");
1461 sv_catpv(d, "SCREAM,");
1467 if (CvANON(sv)) sv_catpv(d, "ANON,");
1468 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1469 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1470 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1471 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1472 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1473 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1474 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1475 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1476 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1477 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1480 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1481 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1482 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1483 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1484 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1488 if (isGV_with_GP(sv)) {
1489 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1490 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1491 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1492 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1493 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1495 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1496 sv_catpv(d, "IMPORT");
1497 if (GvIMPORTED(sv) == GVf_IMPORTED)
1498 sv_catpv(d, "ALL,");
1501 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1502 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1503 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1504 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1508 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1509 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1513 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1514 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1517 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1518 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1521 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1526 /* SVphv_SHAREKEYS is also 0x20000000 */
1527 if ((type != SVt_PVHV) && SvUTF8(sv))
1528 sv_catpv(d, "UTF8");
1530 if (*(SvEND(d) - 1) == ',') {
1531 SvCUR_set(d, SvCUR(d) - 1);
1532 SvPVX(d)[SvCUR(d)] = '\0';
1537 #ifdef DEBUG_LEAKING_SCALARS
1538 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1539 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1541 sv->sv_debug_inpad ? "for" : "by",
1542 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1543 sv->sv_debug_cloned ? " (cloned)" : "");
1545 Perl_dump_indent(aTHX_ level, file, "SV = ");
1546 if (type < SVt_LAST) {
1547 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1549 if (type == SVt_NULL) {
1554 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1558 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1559 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM)
1560 || (type == SVt_IV && !SvROK(sv))) {
1562 #ifdef PERL_OLD_COPY_ON_WRITE
1566 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1568 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1569 #ifdef PERL_OLD_COPY_ON_WRITE
1570 if (SvIsCOW_shared_hash(sv))
1571 PerlIO_printf(file, " (HASH)");
1572 else if (SvIsCOW_normal(sv))
1573 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1575 PerlIO_putc(file, '\n');
1577 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1578 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1579 (UV) COP_SEQ_RANGE_LOW(sv));
1580 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1581 (UV) COP_SEQ_RANGE_HIGH(sv));
1582 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1583 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1584 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1585 || type == SVt_NV) {
1586 STORE_NUMERIC_LOCAL_SET_STANDARD();
1587 /* %Vg doesn't work? --jhi */
1588 #ifdef USE_LONG_DOUBLE
1589 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1591 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1593 RESTORE_NUMERIC_LOCAL();
1596 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1598 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1600 if (type < SVt_PV) {
1604 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1605 if (SvPVX_const(sv)) {
1608 SvOOK_offset(sv, delta);
1609 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1614 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1616 PerlIO_printf(file, "( %s . ) ",
1617 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1620 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1621 if (SvUTF8(sv)) /* the 6? \x{....} */
1622 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1623 PerlIO_printf(file, "\n");
1624 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1625 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1628 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1630 if (type == SVt_REGEXP) {
1632 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1633 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1636 if (type >= SVt_PVMG) {
1637 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1638 HV * const ost = SvOURSTASH(sv);
1640 do_hv_dump(level, file, " OURSTASH", ost);
1643 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1646 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1650 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1651 if (AvARRAY(sv) != AvALLOC(sv)) {
1652 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1653 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1656 PerlIO_putc(file, '\n');
1657 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1658 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1659 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1661 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1662 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1663 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1664 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1665 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1667 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1668 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1670 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1672 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1677 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1678 if (HvARRAY(sv) && HvKEYS(sv)) {
1679 /* Show distribution of HEs in the ARRAY */
1681 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1684 U32 pow2 = 2, keys = HvKEYS(sv);
1685 NV theoret, sum = 0;
1687 PerlIO_printf(file, " (");
1688 Zero(freq, FREQ_MAX + 1, int);
1689 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1692 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1694 if (count > FREQ_MAX)
1700 for (i = 0; i <= max; i++) {
1702 PerlIO_printf(file, "%d%s:%d", i,
1703 (i == FREQ_MAX) ? "+" : "",
1706 PerlIO_printf(file, ", ");
1709 PerlIO_putc(file, ')');
1710 /* The "quality" of a hash is defined as the total number of
1711 comparisons needed to access every element once, relative
1712 to the expected number needed for a random hash.
1714 The total number of comparisons is equal to the sum of
1715 the squares of the number of entries in each bucket.
1716 For a random hash of n keys into k buckets, the expected
1721 for (i = max; i > 0; i--) { /* Precision: count down. */
1722 sum += freq[i] * i * i;
1724 while ((keys = keys >> 1))
1726 theoret = HvKEYS(sv);
1727 theoret += theoret * (theoret-1)/pow2;
1728 PerlIO_putc(file, '\n');
1729 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1731 PerlIO_putc(file, '\n');
1732 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1733 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1734 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1735 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1736 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1738 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1739 if (mg && mg->mg_obj) {
1740 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1744 const char * const hvname = HvNAME_get(sv);
1746 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1750 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1752 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1754 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1758 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1760 HV * const hv = MUTABLE_HV(sv);
1761 int count = maxnest - nest;
1764 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1767 const U32 hash = HeHASH(he);
1768 SV * const keysv = hv_iterkeysv(he);
1769 const char * const keypv = SvPV_const(keysv, len);
1770 SV * const elt = hv_iterval(hv, he);
1772 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1774 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1776 PerlIO_printf(file, "[REHASH] ");
1777 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1778 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1780 hv_iterinit(hv); /* Return to status quo */
1786 const char *const proto = SvPV_const(sv, len);
1787 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1792 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1793 if (!CvISXSUB(sv)) {
1795 Perl_dump_indent(aTHX_ level, file,
1796 " START = 0x%"UVxf" ===> %"IVdf"\n",
1797 PTR2UV(CvSTART(sv)),
1798 (IV)sequence_num(CvSTART(sv)));
1800 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1801 PTR2UV(CvROOT(sv)));
1802 if (CvROOT(sv) && dumpops) {
1803 do_op_dump(level+1, file, CvROOT(sv));
1806 SV * const constant = cv_const_sv((const CV *)sv);
1808 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1811 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1813 PTR2UV(CvXSUBANY(sv).any_ptr));
1814 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1817 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1818 (IV)CvXSUBANY(sv).any_i32);
1821 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1822 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1823 if (type == SVt_PVCV)
1824 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1825 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1826 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1827 if (type == SVt_PVFM)
1828 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1829 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1830 if (nest < maxnest) {
1831 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1834 const CV * const outside = CvOUTSIDE(sv);
1835 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1838 : CvANON(outside) ? "ANON"
1839 : (outside == PL_main_cv) ? "MAIN"
1840 : CvUNIQUE(outside) ? "UNIQUE"
1841 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1843 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1844 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1848 if (type == SVt_PVLV) {
1849 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1850 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1851 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1852 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1853 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1854 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1858 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1859 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1860 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1861 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1863 if (!isGV_with_GP(sv))
1865 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1866 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1867 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1868 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1871 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1872 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1873 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1874 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1875 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1876 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1877 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1878 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1879 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1880 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1881 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1882 do_gv_dump (level, file, " EGV", GvEGV(sv));
1885 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1886 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1887 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1888 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1889 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1890 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1891 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1893 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1894 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1895 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1897 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1898 PTR2UV(IoTOP_GV(sv)));
1899 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1900 maxnest, dumpops, pvlim);
1902 /* Source filters hide things that are not GVs in these three, so let's
1903 be careful out there. */
1905 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1906 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1907 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1909 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1910 PTR2UV(IoFMT_GV(sv)));
1911 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1912 maxnest, dumpops, pvlim);
1914 if (IoBOTTOM_NAME(sv))
1915 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1916 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1917 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1919 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1920 PTR2UV(IoBOTTOM_GV(sv)));
1921 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
1922 maxnest, dumpops, pvlim);
1924 if (isPRINT(IoTYPE(sv)))
1925 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1927 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1928 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1935 Perl_sv_dump(pTHX_ SV *sv)
1939 PERL_ARGS_ASSERT_SV_DUMP;
1942 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1944 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1948 Perl_runops_debug(pTHX)
1952 if (ckWARN_d(WARN_DEBUGGING))
1953 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1957 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1961 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1962 PerlIO_printf(Perl_debug_log,
1963 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1964 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1965 PTR2UV(*PL_watchaddr));
1966 if (DEBUG_s_TEST_) {
1967 if (DEBUG_v_TEST_) {
1968 PerlIO_printf(Perl_debug_log, "\n");
1976 if (DEBUG_t_TEST_) debop(PL_op);
1977 if (DEBUG_P_TEST_) debprof(PL_op);
1979 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1980 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1987 Perl_debop(pTHX_ const OP *o)
1991 PERL_ARGS_ASSERT_DEBOP;
1993 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1996 Perl_deb(aTHX_ "%s", OP_NAME(o));
1997 switch (o->op_type) {
2000 /* With ITHREADS, consts are stored in the pad, and the right pad
2001 * may not be active here, so check.
2002 * Looks like only during compiling the pads are illegal.
2005 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2007 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2012 SV * const sv = newSV(0);
2014 /* FIXME - is this making unwarranted assumptions about the
2015 UTF-8 cleanliness of the dump file handle? */
2018 gv_fullname3(sv, cGVOPo_gv, NULL);
2019 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2023 PerlIO_printf(Perl_debug_log, "(NULL)");
2029 /* print the lexical's name */
2030 CV * const cv = deb_curcv(cxstack_ix);
2033 AV * const padlist = CvPADLIST(cv);
2034 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2035 sv = *av_fetch(comppad, o->op_targ, FALSE);
2039 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2041 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2047 PerlIO_printf(Perl_debug_log, "\n");
2052 S_deb_curcv(pTHX_ const I32 ix)
2055 const PERL_CONTEXT * const cx = &cxstack[ix];
2056 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2057 return cx->blk_sub.cv;
2058 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2060 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2065 return deb_curcv(ix - 1);
2069 Perl_watch(pTHX_ char **addr)
2073 PERL_ARGS_ASSERT_WATCH;
2075 PL_watchaddr = addr;
2077 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2078 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2082 S_debprof(pTHX_ const OP *o)
2086 PERL_ARGS_ASSERT_DEBPROF;
2088 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2090 if (!PL_profiledata)
2091 Newxz(PL_profiledata, MAXO, U32);
2092 ++PL_profiledata[o->op_type];
2096 Perl_debprofdump(pTHX)
2100 if (!PL_profiledata)
2102 for (i = 0; i < MAXO; i++) {
2103 if (PL_profiledata[i])
2104 PerlIO_printf(Perl_debug_log,
2105 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2112 * XML variants of most of the above routines
2116 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2120 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2122 PerlIO_printf(file, "\n ");
2123 va_start(args, pat);
2124 xmldump_vindent(level, file, pat, &args);
2130 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2133 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2134 va_start(args, pat);
2135 xmldump_vindent(level, file, pat, &args);
2140 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2142 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2144 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2145 PerlIO_vprintf(file, pat, *args);
2149 Perl_xmldump_all(pTHX)
2151 PerlIO_setlinebuf(PL_xmlfp);
2153 op_xmldump(PL_main_root);
2154 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2155 PerlIO_close(PL_xmlfp);
2160 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2165 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2167 if (!HvARRAY(stash))
2169 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2170 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2171 GV *gv = (GV*)HeVAL(entry);
2173 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2179 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2180 && (hv = GvHV(gv)) && hv != PL_defstash)
2181 xmldump_packsubs(hv); /* nested package */
2187 Perl_xmldump_sub(pTHX_ const GV *gv)
2189 SV * const sv = sv_newmortal();
2191 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2193 gv_fullname3(sv, gv, NULL);
2194 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2195 if (CvXSUB(GvCV(gv)))
2196 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2197 PTR2UV(CvXSUB(GvCV(gv))),
2198 (int)CvXSUBANY(GvCV(gv)).any_i32);
2199 else if (CvROOT(GvCV(gv)))
2200 op_xmldump(CvROOT(GvCV(gv)));
2202 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2206 Perl_xmldump_form(pTHX_ const GV *gv)
2208 SV * const sv = sv_newmortal();
2210 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2212 gv_fullname3(sv, gv, NULL);
2213 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2214 if (CvROOT(GvFORM(gv)))
2215 op_xmldump(CvROOT(GvFORM(gv)));
2217 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2221 Perl_xmldump_eval(pTHX)
2223 op_xmldump(PL_eval_root);
2227 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2229 PERL_ARGS_ASSERT_SV_CATXMLSV;
2230 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2234 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2237 const char * const e = pv + len;
2238 const char * const start = pv;
2242 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2245 dsvcur = SvCUR(dsv); /* in case we have to restart */
2250 c = utf8_to_uvchr((U8*)pv, &cl);
2252 SvCUR(dsv) = dsvcur;
2317 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2320 sv_catpvs(dsv, "<");
2323 sv_catpvs(dsv, ">");
2326 sv_catpvs(dsv, "&");
2329 sv_catpvs(dsv, """);
2333 if (c < 32 || c > 127) {
2334 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2337 const char string = (char) c;
2338 sv_catpvn(dsv, &string, 1);
2342 if ((c >= 0xD800 && c <= 0xDB7F) ||
2343 (c >= 0xDC00 && c <= 0xDFFF) ||
2344 (c >= 0xFFF0 && c <= 0xFFFF) ||
2346 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2348 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2361 Perl_sv_xmlpeek(pTHX_ SV *sv)
2363 SV * const t = sv_newmortal();
2367 PERL_ARGS_ASSERT_SV_XMLPEEK;
2373 sv_catpv(t, "VOID=\"\"");
2376 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2377 sv_catpv(t, "WILD=\"\"");
2380 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2381 if (sv == &PL_sv_undef) {
2382 sv_catpv(t, "SV_UNDEF=\"1\"");
2383 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2384 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2388 else if (sv == &PL_sv_no) {
2389 sv_catpv(t, "SV_NO=\"1\"");
2390 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2391 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2392 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2393 SVp_POK|SVp_NOK)) &&
2398 else if (sv == &PL_sv_yes) {
2399 sv_catpv(t, "SV_YES=\"1\"");
2400 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2401 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2402 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2403 SVp_POK|SVp_NOK)) &&
2405 SvPVX(sv) && *SvPVX(sv) == '1' &&
2410 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2411 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2412 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2416 sv_catpv(t, " XXX=\"\" ");
2418 else if (SvREFCNT(sv) == 0) {
2419 sv_catpv(t, " refcnt=\"0\"");
2422 else if (DEBUG_R_TEST_) {
2425 /* is this SV on the tmps stack? */
2426 for (ix=PL_tmps_ix; ix>=0; ix--) {
2427 if (PL_tmps_stack[ix] == sv) {
2432 if (SvREFCNT(sv) > 1)
2433 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2436 sv_catpv(t, " DRT=\"<T>\"");
2440 sv_catpv(t, " ROK=\"\"");
2442 switch (SvTYPE(sv)) {
2444 sv_catpv(t, " FREED=\"1\"");
2448 sv_catpv(t, " UNDEF=\"1\"");
2451 sv_catpv(t, " IV=\"");
2454 sv_catpv(t, " NV=\"");
2457 sv_catpv(t, " PV=\"");
2460 sv_catpv(t, " PVIV=\"");
2463 sv_catpv(t, " PVNV=\"");
2466 sv_catpv(t, " PVMG=\"");
2469 sv_catpv(t, " PVLV=\"");
2472 sv_catpv(t, " AV=\"");
2475 sv_catpv(t, " HV=\"");
2479 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2481 sv_catpv(t, " CV=\"()\"");
2484 sv_catpv(t, " GV=\"");
2487 sv_catpv(t, " BIND=\"");
2490 sv_catpv(t, " ORANGE=\"");
2493 sv_catpv(t, " FM=\"");
2496 sv_catpv(t, " IO=\"");
2505 else if (SvNOKp(sv)) {
2506 STORE_NUMERIC_LOCAL_SET_STANDARD();
2507 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2508 RESTORE_NUMERIC_LOCAL();
2510 else if (SvIOKp(sv)) {
2512 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2514 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2523 return SvPV(t, n_a);
2527 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2529 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2532 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2535 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2538 REGEXP *const r = PM_GETRE(pm);
2539 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2540 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2541 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2543 SvREFCNT_dec(tmpsv);
2544 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2545 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2548 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2549 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2550 SV * const tmpsv = pm_description(pm);
2551 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2552 SvREFCNT_dec(tmpsv);
2556 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2557 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2558 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2559 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2560 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2561 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2564 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2568 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2570 do_pmop_xmldump(0, PL_xmlfp, pm);
2574 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2579 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2584 seq = sequence_num(o);
2585 Perl_xmldump_indent(aTHX_ level, file,
2586 "<op_%s seq=\"%"UVuf" -> ",
2591 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2592 sequence_num(o->op_next));
2594 PerlIO_printf(file, "DONE\"");
2597 if (o->op_type == OP_NULL)
2599 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2600 if (o->op_targ == OP_NEXTSTATE)
2603 PerlIO_printf(file, " line=\"%"UVuf"\"",
2604 (UV)CopLINE(cCOPo));
2605 if (CopSTASHPV(cCOPo))
2606 PerlIO_printf(file, " package=\"%s\"",
2608 if (CopLABEL(cCOPo))
2609 PerlIO_printf(file, " label=\"%s\"",
2614 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2617 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2620 SV * const tmpsv = newSVpvs("");
2621 switch (o->op_flags & OPf_WANT) {
2623 sv_catpv(tmpsv, ",VOID");
2625 case OPf_WANT_SCALAR:
2626 sv_catpv(tmpsv, ",SCALAR");
2629 sv_catpv(tmpsv, ",LIST");
2632 sv_catpv(tmpsv, ",UNKNOWN");
2635 if (o->op_flags & OPf_KIDS)
2636 sv_catpv(tmpsv, ",KIDS");
2637 if (o->op_flags & OPf_PARENS)
2638 sv_catpv(tmpsv, ",PARENS");
2639 if (o->op_flags & OPf_STACKED)
2640 sv_catpv(tmpsv, ",STACKED");
2641 if (o->op_flags & OPf_REF)
2642 sv_catpv(tmpsv, ",REF");
2643 if (o->op_flags & OPf_MOD)
2644 sv_catpv(tmpsv, ",MOD");
2645 if (o->op_flags & OPf_SPECIAL)
2646 sv_catpv(tmpsv, ",SPECIAL");
2647 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2648 SvREFCNT_dec(tmpsv);
2650 if (o->op_private) {
2651 SV * const tmpsv = newSVpvs("");
2652 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2653 if (o->op_private & OPpTARGET_MY)
2654 sv_catpv(tmpsv, ",TARGET_MY");
2656 else if (o->op_type == OP_LEAVESUB ||
2657 o->op_type == OP_LEAVE ||
2658 o->op_type == OP_LEAVESUBLV ||
2659 o->op_type == OP_LEAVEWRITE) {
2660 if (o->op_private & OPpREFCOUNTED)
2661 sv_catpv(tmpsv, ",REFCOUNTED");
2663 else if (o->op_type == OP_AASSIGN) {
2664 if (o->op_private & OPpASSIGN_COMMON)
2665 sv_catpv(tmpsv, ",COMMON");
2667 else if (o->op_type == OP_SASSIGN) {
2668 if (o->op_private & OPpASSIGN_BACKWARDS)
2669 sv_catpv(tmpsv, ",BACKWARDS");
2671 else if (o->op_type == OP_TRANS) {
2672 if (o->op_private & OPpTRANS_SQUASH)
2673 sv_catpv(tmpsv, ",SQUASH");
2674 if (o->op_private & OPpTRANS_DELETE)
2675 sv_catpv(tmpsv, ",DELETE");
2676 if (o->op_private & OPpTRANS_COMPLEMENT)
2677 sv_catpv(tmpsv, ",COMPLEMENT");
2678 if (o->op_private & OPpTRANS_IDENTICAL)
2679 sv_catpv(tmpsv, ",IDENTICAL");
2680 if (o->op_private & OPpTRANS_GROWS)
2681 sv_catpv(tmpsv, ",GROWS");
2683 else if (o->op_type == OP_REPEAT) {
2684 if (o->op_private & OPpREPEAT_DOLIST)
2685 sv_catpv(tmpsv, ",DOLIST");
2687 else if (o->op_type == OP_ENTERSUB ||
2688 o->op_type == OP_RV2SV ||
2689 o->op_type == OP_GVSV ||
2690 o->op_type == OP_RV2AV ||
2691 o->op_type == OP_RV2HV ||
2692 o->op_type == OP_RV2GV ||
2693 o->op_type == OP_AELEM ||
2694 o->op_type == OP_HELEM )
2696 if (o->op_type == OP_ENTERSUB) {
2697 if (o->op_private & OPpENTERSUB_AMPER)
2698 sv_catpv(tmpsv, ",AMPER");
2699 if (o->op_private & OPpENTERSUB_DB)
2700 sv_catpv(tmpsv, ",DB");
2701 if (o->op_private & OPpENTERSUB_HASTARG)
2702 sv_catpv(tmpsv, ",HASTARG");
2703 if (o->op_private & OPpENTERSUB_NOPAREN)
2704 sv_catpv(tmpsv, ",NOPAREN");
2705 if (o->op_private & OPpENTERSUB_INARGS)
2706 sv_catpv(tmpsv, ",INARGS");
2707 if (o->op_private & OPpENTERSUB_NOMOD)
2708 sv_catpv(tmpsv, ",NOMOD");
2711 switch (o->op_private & OPpDEREF) {
2713 sv_catpv(tmpsv, ",SV");
2716 sv_catpv(tmpsv, ",AV");
2719 sv_catpv(tmpsv, ",HV");
2722 if (o->op_private & OPpMAYBE_LVSUB)
2723 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2725 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2726 if (o->op_private & OPpLVAL_DEFER)
2727 sv_catpv(tmpsv, ",LVAL_DEFER");
2730 if (o->op_private & HINT_STRICT_REFS)
2731 sv_catpv(tmpsv, ",STRICT_REFS");
2732 if (o->op_private & OPpOUR_INTRO)
2733 sv_catpv(tmpsv, ",OUR_INTRO");
2736 else if (o->op_type == OP_CONST) {
2737 if (o->op_private & OPpCONST_BARE)
2738 sv_catpv(tmpsv, ",BARE");
2739 if (o->op_private & OPpCONST_STRICT)
2740 sv_catpv(tmpsv, ",STRICT");
2741 if (o->op_private & OPpCONST_ARYBASE)
2742 sv_catpv(tmpsv, ",ARYBASE");
2743 if (o->op_private & OPpCONST_WARNING)
2744 sv_catpv(tmpsv, ",WARNING");
2745 if (o->op_private & OPpCONST_ENTERED)
2746 sv_catpv(tmpsv, ",ENTERED");
2748 else if (o->op_type == OP_FLIP) {
2749 if (o->op_private & OPpFLIP_LINENUM)
2750 sv_catpv(tmpsv, ",LINENUM");
2752 else if (o->op_type == OP_FLOP) {
2753 if (o->op_private & OPpFLIP_LINENUM)
2754 sv_catpv(tmpsv, ",LINENUM");
2756 else if (o->op_type == OP_RV2CV) {
2757 if (o->op_private & OPpLVAL_INTRO)
2758 sv_catpv(tmpsv, ",INTRO");
2760 else if (o->op_type == OP_GV) {
2761 if (o->op_private & OPpEARLY_CV)
2762 sv_catpv(tmpsv, ",EARLY_CV");
2764 else if (o->op_type == OP_LIST) {
2765 if (o->op_private & OPpLIST_GUESSED)
2766 sv_catpv(tmpsv, ",GUESSED");
2768 else if (o->op_type == OP_DELETE) {
2769 if (o->op_private & OPpSLICE)
2770 sv_catpv(tmpsv, ",SLICE");
2772 else if (o->op_type == OP_EXISTS) {
2773 if (o->op_private & OPpEXISTS_SUB)
2774 sv_catpv(tmpsv, ",EXISTS_SUB");
2776 else if (o->op_type == OP_SORT) {
2777 if (o->op_private & OPpSORT_NUMERIC)
2778 sv_catpv(tmpsv, ",NUMERIC");
2779 if (o->op_private & OPpSORT_INTEGER)
2780 sv_catpv(tmpsv, ",INTEGER");
2781 if (o->op_private & OPpSORT_REVERSE)
2782 sv_catpv(tmpsv, ",REVERSE");
2784 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2785 if (o->op_private & OPpOPEN_IN_RAW)
2786 sv_catpv(tmpsv, ",IN_RAW");
2787 if (o->op_private & OPpOPEN_IN_CRLF)
2788 sv_catpv(tmpsv, ",IN_CRLF");
2789 if (o->op_private & OPpOPEN_OUT_RAW)
2790 sv_catpv(tmpsv, ",OUT_RAW");
2791 if (o->op_private & OPpOPEN_OUT_CRLF)
2792 sv_catpv(tmpsv, ",OUT_CRLF");
2794 else if (o->op_type == OP_EXIT) {
2795 if (o->op_private & OPpEXIT_VMSISH)
2796 sv_catpv(tmpsv, ",EXIT_VMSISH");
2797 if (o->op_private & OPpHUSH_VMSISH)
2798 sv_catpv(tmpsv, ",HUSH_VMSISH");
2800 else if (o->op_type == OP_DIE) {
2801 if (o->op_private & OPpHUSH_VMSISH)
2802 sv_catpv(tmpsv, ",HUSH_VMSISH");
2804 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2805 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2806 sv_catpv(tmpsv, ",FT_ACCESS");
2807 if (o->op_private & OPpFT_STACKED)
2808 sv_catpv(tmpsv, ",FT_STACKED");
2810 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2811 sv_catpv(tmpsv, ",INTRO");
2813 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2814 SvREFCNT_dec(tmpsv);
2817 switch (o->op_type) {
2819 if (o->op_flags & OPf_SPECIAL) {
2825 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2827 if (cSVOPo->op_sv) {
2828 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2829 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2835 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
2836 s = SvPV(tmpsv1,len);
2837 sv_catxmlpvn(tmpsv2, s, len, 1);
2838 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2842 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2847 case OP_METHOD_NAMED:
2848 #ifndef USE_ITHREADS
2849 /* with ITHREADS, consts are stored in the pad, and the right pad
2850 * may not be active here, so skip */
2851 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2857 PerlIO_printf(file, ">\n");
2859 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2864 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2865 (UV)CopLINE(cCOPo));
2866 if (CopSTASHPV(cCOPo))
2867 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2869 if (CopLABEL(cCOPo))
2870 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2874 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2875 if (cLOOPo->op_redoop)
2876 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2878 PerlIO_printf(file, "DONE\"");
2879 S_xmldump_attr(aTHX_ level, file, "next=\"");
2880 if (cLOOPo->op_nextop)
2881 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2883 PerlIO_printf(file, "DONE\"");
2884 S_xmldump_attr(aTHX_ level, file, "last=\"");
2885 if (cLOOPo->op_lastop)
2886 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2888 PerlIO_printf(file, "DONE\"");
2896 S_xmldump_attr(aTHX_ level, file, "other=\"");
2897 if (cLOGOPo->op_other)
2898 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2900 PerlIO_printf(file, "DONE\"");
2908 if (o->op_private & OPpREFCOUNTED)
2909 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2915 if (PL_madskills && o->op_madprop) {
2916 char prevkey = '\0';
2917 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2918 const MADPROP* mp = o->op_madprop;
2922 PerlIO_printf(file, ">\n");
2924 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2927 char tmp = mp->mad_key;
2928 sv_setpvs(tmpsv,"\"");
2930 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2931 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2932 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2935 sv_catpv(tmpsv, "\"");
2936 switch (mp->mad_type) {
2938 sv_catpv(tmpsv, "NULL");
2939 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2942 sv_catpv(tmpsv, " val=\"");
2943 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2944 sv_catpv(tmpsv, "\"");
2945 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2948 sv_catpv(tmpsv, " val=\"");
2949 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
2950 sv_catpv(tmpsv, "\"");
2951 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2954 if ((OP*)mp->mad_val) {
2955 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2956 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2957 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2961 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2967 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2969 SvREFCNT_dec(tmpsv);
2972 switch (o->op_type) {
2979 PerlIO_printf(file, ">\n");
2981 do_pmop_xmldump(level, file, cPMOPo);
2987 if (o->op_flags & OPf_KIDS) {
2991 PerlIO_printf(file, ">\n");
2993 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2994 do_op_xmldump(level, file, kid);
2998 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3000 PerlIO_printf(file, " />\n");
3004 Perl_op_xmldump(pTHX_ const OP *o)
3006 PERL_ARGS_ASSERT_OP_XMLDUMP;
3008 do_op_xmldump(0, PL_xmlfp, o);
3014 * c-indentation-style: bsd
3016 * indent-tabs-mode: t
3019 * ex: set ts=8 sts=4 sw=4 noet: