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.'
15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
18 /* This file contains utility routines to dump the contents of SV and OP
19 * structures, as used by command-line options like -Dt and -Dx, and
22 * It also holds the debugging version of the runops function.
26 #define PERL_IN_DUMP_C
32 static const char* const svtypenames[SVt_LAST] = {
52 static const char* const svshorttypenames[SVt_LAST] = {
71 #define Sequence PL_op_sequence
74 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
77 PERL_ARGS_ASSERT_DUMP_INDENT;
79 dump_vindent(level, file, pat, &args);
84 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
87 PERL_ARGS_ASSERT_DUMP_VINDENT;
88 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
89 PerlIO_vprintf(file, pat, *args);
99 Perl_dump_all_perl(pTHX_ bool justperl)
103 PerlIO_setlinebuf(Perl_debug_log);
105 op_dump(PL_main_root);
106 dump_packsubs_perl(PL_defstash, justperl);
110 Perl_dump_packsubs(pTHX_ const HV *stash)
112 dump_packsubs_perl(stash, FALSE);
116 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
121 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
125 for (i = 0; i <= (I32) HvMAX(stash); i++) {
127 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
128 const GV * const gv = (const GV *)HeVAL(entry);
129 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
132 dump_sub_perl(gv, justperl);
135 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
136 const HV * const hv = GvHV(gv);
137 if (hv && (hv != PL_defstash))
138 dump_packsubs_perl(hv, justperl); /* nested package */
145 Perl_dump_sub(pTHX_ const GV *gv)
147 dump_sub_perl(gv, FALSE);
151 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
155 PERL_ARGS_ASSERT_DUMP_SUB;
157 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
161 gv_fullname3(sv, gv, NULL);
162 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
163 if (CvISXSUB(GvCV(gv)))
164 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
165 PTR2UV(CvXSUB(GvCV(gv))),
166 (int)CvXSUBANY(GvCV(gv)).any_i32);
167 else if (CvROOT(GvCV(gv)))
168 op_dump(CvROOT(GvCV(gv)));
170 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
174 Perl_dump_form(pTHX_ const GV *gv)
176 SV * const sv = sv_newmortal();
178 PERL_ARGS_ASSERT_DUMP_FORM;
180 gv_fullname3(sv, gv, NULL);
181 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
182 if (CvROOT(GvFORM(gv)))
183 op_dump(CvROOT(GvFORM(gv)));
185 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
192 op_dump(PL_eval_root);
197 =for apidoc pv_escape
199 Escapes at most the first "count" chars of pv and puts the results into
200 dsv such that the size of the escaped string will not exceed "max" chars
201 and will not contain any incomplete escape sequences.
203 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
204 will also be escaped.
206 Normally the SV will be cleared before the escaped string is prepared,
207 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
209 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
210 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
211 using C<is_utf8_string()> to determine if it is Unicode.
213 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
214 using C<\x01F1> style escapes, otherwise only chars above 255 will be
215 escaped using this style, other non printable chars will use octal or
216 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
217 then all chars below 255 will be treated as printable and
218 will be output as literals.
220 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
221 string will be escaped, regardles of max. If the string is utf8 and
222 the chars value is >255 then it will be returned as a plain hex
223 sequence. Thus the output will either be a single char,
224 an octal escape sequence, a special escape like C<\n> or a 3 or
225 more digit hex value.
227 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
228 not a '\\'. This is because regexes very often contain backslashed
229 sequences, whereas '%' is not a particularly common character in patterns.
231 Returns a pointer to the escaped text as held by dsv.
235 #define PV_ESCAPE_OCTBUFSIZE 32
238 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
239 const STRLEN count, const STRLEN max,
240 STRLEN * const escaped, const U32 flags )
242 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
243 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
244 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
245 STRLEN wrote = 0; /* chars written so far */
246 STRLEN chsize = 0; /* size of data to be written */
247 STRLEN readsize = 1; /* size of data just read */
248 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
249 const char *pv = str;
250 const char * const end = pv + count; /* end of string */
253 PERL_ARGS_ASSERT_PV_ESCAPE;
255 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
256 /* This won't alter the UTF-8 flag */
260 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
263 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
264 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
265 const U8 c = (U8)u & 0xFF;
267 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
268 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
269 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
272 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
273 "%cx{%"UVxf"}", esc, u);
274 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
277 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
281 case '\\' : /* fallthrough */
282 case '%' : if ( c == esc ) {
288 case '\v' : octbuf[1] = 'v'; break;
289 case '\t' : octbuf[1] = 't'; break;
290 case '\r' : octbuf[1] = 'r'; break;
291 case '\n' : octbuf[1] = 'n'; break;
292 case '\f' : octbuf[1] = 'f'; break;
300 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
301 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
304 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
311 if ( max && (wrote + chsize > max) ) {
313 } else if (chsize > 1) {
314 sv_catpvn(dsv, octbuf, chsize);
317 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
318 128-255 can be appended raw to the dsv. If dsv happens to be
319 UTF-8 then we need catpvf to upgrade them for us.
320 Or add a new API call sv_catpvc(). Think about that name, and
321 how to keep it clear that it's unlike the s of catpvs, which is
322 really an array octets, not a string. */
323 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
326 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
334 =for apidoc pv_pretty
336 Converts a string into something presentable, handling escaping via
337 pv_escape() and supporting quoting and ellipses.
339 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
340 double quoted with any double quotes in the string escaped. Otherwise
341 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
344 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
345 string were output then an ellipsis C<...> will be appended to the
346 string. Note that this happens AFTER it has been quoted.
348 If start_color is non-null then it will be inserted after the opening
349 quote (if there is one) but before the escaped text. If end_color
350 is non-null then it will be inserted after the escaped text but before
351 any quotes or ellipses.
353 Returns a pointer to the prettified text as held by dsv.
359 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
360 const STRLEN max, char const * const start_color, char const * const end_color,
363 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
366 PERL_ARGS_ASSERT_PV_PRETTY;
368 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
369 /* This won't alter the UTF-8 flag */
374 sv_catpvs(dsv, "\"");
375 else if ( flags & PERL_PV_PRETTY_LTGT )
378 if ( start_color != NULL )
379 sv_catpv(dsv, start_color);
381 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
383 if ( end_color != NULL )
384 sv_catpv(dsv, end_color);
387 sv_catpvs( dsv, "\"");
388 else if ( flags & PERL_PV_PRETTY_LTGT )
391 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
392 sv_catpvs(dsv, "...");
398 =for apidoc pv_display
402 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
404 except that an additional "\0" will be appended to the string when
405 len > cur and pv[cur] is "\0".
407 Note that the final string may be up to 7 chars longer than pvlim.
413 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
415 PERL_ARGS_ASSERT_PV_DISPLAY;
417 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
418 if (len > cur && pv[cur] == '\0')
419 sv_catpvs( dsv, "\\0");
424 Perl_sv_peek(pTHX_ SV *sv)
427 SV * const t = sv_newmortal();
437 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
441 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
442 if (sv == &PL_sv_undef) {
443 sv_catpv(t, "SV_UNDEF");
444 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
445 SVs_GMG|SVs_SMG|SVs_RMG)) &&
449 else if (sv == &PL_sv_no) {
450 sv_catpv(t, "SV_NO");
451 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
452 SVs_GMG|SVs_SMG|SVs_RMG)) &&
453 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
459 else if (sv == &PL_sv_yes) {
460 sv_catpv(t, "SV_YES");
461 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
462 SVs_GMG|SVs_SMG|SVs_RMG)) &&
463 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
466 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
471 sv_catpv(t, "SV_PLACEHOLDER");
472 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
473 SVs_GMG|SVs_SMG|SVs_RMG)) &&
479 else if (SvREFCNT(sv) == 0) {
483 else if (DEBUG_R_TEST_) {
486 /* is this SV on the tmps stack? */
487 for (ix=PL_tmps_ix; ix>=0; ix--) {
488 if (PL_tmps_stack[ix] == sv) {
493 if (SvREFCNT(sv) > 1)
494 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
502 if (SvCUR(t) + unref > 10) {
503 SvCUR_set(t, unref + 3);
512 if (type == SVt_PVCV) {
513 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
515 } else if (type < SVt_LAST) {
516 sv_catpv(t, svshorttypenames[type]);
518 if (type == SVt_NULL)
521 sv_catpv(t, "FREED");
526 if (!SvPVX_const(sv))
527 sv_catpv(t, "(null)");
529 SV * const tmp = newSVpvs("");
533 SvOOK_offset(sv, delta);
534 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
536 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
538 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
539 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
544 else if (SvNOKp(sv)) {
545 STORE_NUMERIC_LOCAL_SET_STANDARD();
546 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
547 RESTORE_NUMERIC_LOCAL();
549 else if (SvIOKp(sv)) {
551 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
553 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
561 if (PL_tainting && SvTAINTED(sv))
562 sv_catpv(t, " [tainted]");
563 return SvPV_nolen(t);
567 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
571 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
574 Perl_dump_indent(aTHX_ level, file, "{}\n");
577 Perl_dump_indent(aTHX_ level, file, "{\n");
579 if (pm->op_pmflags & PMf_ONCE)
584 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
585 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
586 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
588 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
589 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
590 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
591 op_dump(pm->op_pmreplrootu.op_pmreplroot);
593 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
594 SV * const tmpsv = pm_description(pm);
595 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
599 Perl_dump_indent(aTHX_ level-1, file, "}\n");
603 S_pm_description(pTHX_ const PMOP *pm)
605 SV * const desc = newSVpvs("");
606 const REGEXP * const regex = PM_GETRE(pm);
607 const U32 pmflags = pm->op_pmflags;
609 PERL_ARGS_ASSERT_PM_DESCRIPTION;
611 if (pmflags & PMf_ONCE)
612 sv_catpv(desc, ",ONCE");
614 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
615 sv_catpv(desc, ":USED");
617 if (pmflags & PMf_USED)
618 sv_catpv(desc, ":USED");
622 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
623 sv_catpv(desc, ",TAINTED");
624 if (RX_CHECK_SUBSTR(regex)) {
625 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
626 sv_catpv(desc, ",SCANFIRST");
627 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
628 sv_catpv(desc, ",ALL");
630 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
631 sv_catpv(desc, ",SKIPWHITE");
634 if (pmflags & PMf_CONST)
635 sv_catpv(desc, ",CONST");
636 if (pmflags & PMf_KEEP)
637 sv_catpv(desc, ",KEEP");
638 if (pmflags & PMf_GLOBAL)
639 sv_catpv(desc, ",GLOBAL");
640 if (pmflags & PMf_CONTINUE)
641 sv_catpv(desc, ",CONTINUE");
642 if (pmflags & PMf_RETAINT)
643 sv_catpv(desc, ",RETAINT");
644 if (pmflags & PMf_EVAL)
645 sv_catpv(desc, ",EVAL");
650 Perl_pmop_dump(pTHX_ PMOP *pm)
652 do_pmop_dump(0, Perl_debug_log, pm);
655 /* An op sequencer. We visit the ops in the order they're to execute. */
658 S_sequence(pTHX_ register const OP *o)
661 const OP *oldop = NULL;
674 for (; o; o = o->op_next) {
676 SV * const op = newSVuv(PTR2UV(o));
677 const char * const key = SvPV_const(op, len);
679 if (hv_exists(Sequence, key, len))
682 switch (o->op_type) {
684 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
685 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
694 if (oldop && o->op_next)
701 if (oldop && o->op_next)
703 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
716 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
717 sequence_tail(cLOGOPo->op_other);
722 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
723 sequence_tail(cLOOPo->op_redoop);
724 sequence_tail(cLOOPo->op_nextop);
725 sequence_tail(cLOOPo->op_lastop);
729 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
730 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
739 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
747 S_sequence_tail(pTHX_ const OP *o)
749 while (o && (o->op_type == OP_NULL))
755 S_sequence_num(pTHX_ const OP *o)
763 op = newSVuv(PTR2UV(o));
764 key = SvPV_const(op, len);
765 seq = hv_fetch(Sequence, key, len, 0);
766 return seq ? SvUV(*seq): 0;
770 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
774 const OPCODE optype = o->op_type;
776 PERL_ARGS_ASSERT_DO_OP_DUMP;
779 Perl_dump_indent(aTHX_ level, file, "{\n");
781 seq = sequence_num(o);
783 PerlIO_printf(file, "%-4"UVuf, seq);
785 PerlIO_printf(file, " ");
787 "%*sTYPE = %s ===> ",
788 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
790 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
791 sequence_num(o->op_next));
793 PerlIO_printf(file, "DONE\n");
795 if (optype == OP_NULL) {
796 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
797 if (o->op_targ == OP_NEXTSTATE) {
799 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
801 if (CopSTASHPV(cCOPo))
802 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
805 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
810 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
813 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
815 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
816 SV * const tmpsv = newSVpvs("");
817 switch (o->op_flags & OPf_WANT) {
819 sv_catpv(tmpsv, ",VOID");
821 case OPf_WANT_SCALAR:
822 sv_catpv(tmpsv, ",SCALAR");
825 sv_catpv(tmpsv, ",LIST");
828 sv_catpv(tmpsv, ",UNKNOWN");
831 if (o->op_flags & OPf_KIDS)
832 sv_catpv(tmpsv, ",KIDS");
833 if (o->op_flags & OPf_PARENS)
834 sv_catpv(tmpsv, ",PARENS");
835 if (o->op_flags & OPf_STACKED)
836 sv_catpv(tmpsv, ",STACKED");
837 if (o->op_flags & OPf_REF)
838 sv_catpv(tmpsv, ",REF");
839 if (o->op_flags & OPf_MOD)
840 sv_catpv(tmpsv, ",MOD");
841 if (o->op_flags & OPf_SPECIAL)
842 sv_catpv(tmpsv, ",SPECIAL");
844 sv_catpv(tmpsv, ",LATEFREE");
846 sv_catpv(tmpsv, ",LATEFREED");
848 sv_catpv(tmpsv, ",ATTACHED");
849 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
853 SV * const tmpsv = newSVpvs("");
854 if (PL_opargs[optype] & OA_TARGLEX) {
855 if (o->op_private & OPpTARGET_MY)
856 sv_catpv(tmpsv, ",TARGET_MY");
858 else if (optype == OP_LEAVESUB ||
859 optype == OP_LEAVE ||
860 optype == OP_LEAVESUBLV ||
861 optype == OP_LEAVEWRITE) {
862 if (o->op_private & OPpREFCOUNTED)
863 sv_catpv(tmpsv, ",REFCOUNTED");
865 else if (optype == OP_AASSIGN) {
866 if (o->op_private & OPpASSIGN_COMMON)
867 sv_catpv(tmpsv, ",COMMON");
869 else if (optype == OP_SASSIGN) {
870 if (o->op_private & OPpASSIGN_BACKWARDS)
871 sv_catpv(tmpsv, ",BACKWARDS");
873 else if (optype == OP_TRANS) {
874 if (o->op_private & OPpTRANS_SQUASH)
875 sv_catpv(tmpsv, ",SQUASH");
876 if (o->op_private & OPpTRANS_DELETE)
877 sv_catpv(tmpsv, ",DELETE");
878 if (o->op_private & OPpTRANS_COMPLEMENT)
879 sv_catpv(tmpsv, ",COMPLEMENT");
880 if (o->op_private & OPpTRANS_IDENTICAL)
881 sv_catpv(tmpsv, ",IDENTICAL");
882 if (o->op_private & OPpTRANS_GROWS)
883 sv_catpv(tmpsv, ",GROWS");
885 else if (optype == OP_REPEAT) {
886 if (o->op_private & OPpREPEAT_DOLIST)
887 sv_catpv(tmpsv, ",DOLIST");
889 else if (optype == OP_ENTERSUB ||
890 optype == OP_RV2SV ||
892 optype == OP_RV2AV ||
893 optype == OP_RV2HV ||
894 optype == OP_RV2GV ||
895 optype == OP_AELEM ||
898 if (optype == OP_ENTERSUB) {
899 if (o->op_private & OPpENTERSUB_AMPER)
900 sv_catpv(tmpsv, ",AMPER");
901 if (o->op_private & OPpENTERSUB_DB)
902 sv_catpv(tmpsv, ",DB");
903 if (o->op_private & OPpENTERSUB_HASTARG)
904 sv_catpv(tmpsv, ",HASTARG");
905 if (o->op_private & OPpENTERSUB_NOPAREN)
906 sv_catpv(tmpsv, ",NOPAREN");
907 if (o->op_private & OPpENTERSUB_INARGS)
908 sv_catpv(tmpsv, ",INARGS");
909 if (o->op_private & OPpENTERSUB_NOMOD)
910 sv_catpv(tmpsv, ",NOMOD");
913 switch (o->op_private & OPpDEREF) {
915 sv_catpv(tmpsv, ",SV");
918 sv_catpv(tmpsv, ",AV");
921 sv_catpv(tmpsv, ",HV");
924 if (o->op_private & OPpMAYBE_LVSUB)
925 sv_catpv(tmpsv, ",MAYBE_LVSUB");
927 if (optype == OP_AELEM || optype == OP_HELEM) {
928 if (o->op_private & OPpLVAL_DEFER)
929 sv_catpv(tmpsv, ",LVAL_DEFER");
932 if (o->op_private & HINT_STRICT_REFS)
933 sv_catpv(tmpsv, ",STRICT_REFS");
934 if (o->op_private & OPpOUR_INTRO)
935 sv_catpv(tmpsv, ",OUR_INTRO");
938 else if (optype == OP_CONST) {
939 if (o->op_private & OPpCONST_BARE)
940 sv_catpv(tmpsv, ",BARE");
941 if (o->op_private & OPpCONST_STRICT)
942 sv_catpv(tmpsv, ",STRICT");
943 if (o->op_private & OPpCONST_ARYBASE)
944 sv_catpv(tmpsv, ",ARYBASE");
945 if (o->op_private & OPpCONST_WARNING)
946 sv_catpv(tmpsv, ",WARNING");
947 if (o->op_private & OPpCONST_ENTERED)
948 sv_catpv(tmpsv, ",ENTERED");
950 else if (optype == OP_FLIP) {
951 if (o->op_private & OPpFLIP_LINENUM)
952 sv_catpv(tmpsv, ",LINENUM");
954 else if (optype == OP_FLOP) {
955 if (o->op_private & OPpFLIP_LINENUM)
956 sv_catpv(tmpsv, ",LINENUM");
958 else if (optype == OP_RV2CV) {
959 if (o->op_private & OPpLVAL_INTRO)
960 sv_catpv(tmpsv, ",INTRO");
962 else if (optype == OP_GV) {
963 if (o->op_private & OPpEARLY_CV)
964 sv_catpv(tmpsv, ",EARLY_CV");
966 else if (optype == OP_LIST) {
967 if (o->op_private & OPpLIST_GUESSED)
968 sv_catpv(tmpsv, ",GUESSED");
970 else if (optype == OP_DELETE) {
971 if (o->op_private & OPpSLICE)
972 sv_catpv(tmpsv, ",SLICE");
974 else if (optype == OP_EXISTS) {
975 if (o->op_private & OPpEXISTS_SUB)
976 sv_catpv(tmpsv, ",EXISTS_SUB");
978 else if (optype == OP_SORT) {
979 if (o->op_private & OPpSORT_NUMERIC)
980 sv_catpv(tmpsv, ",NUMERIC");
981 if (o->op_private & OPpSORT_INTEGER)
982 sv_catpv(tmpsv, ",INTEGER");
983 if (o->op_private & OPpSORT_REVERSE)
984 sv_catpv(tmpsv, ",REVERSE");
986 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
987 if (o->op_private & OPpOPEN_IN_RAW)
988 sv_catpv(tmpsv, ",IN_RAW");
989 if (o->op_private & OPpOPEN_IN_CRLF)
990 sv_catpv(tmpsv, ",IN_CRLF");
991 if (o->op_private & OPpOPEN_OUT_RAW)
992 sv_catpv(tmpsv, ",OUT_RAW");
993 if (o->op_private & OPpOPEN_OUT_CRLF)
994 sv_catpv(tmpsv, ",OUT_CRLF");
996 else if (optype == OP_EXIT) {
997 if (o->op_private & OPpEXIT_VMSISH)
998 sv_catpv(tmpsv, ",EXIT_VMSISH");
999 if (o->op_private & OPpHUSH_VMSISH)
1000 sv_catpv(tmpsv, ",HUSH_VMSISH");
1002 else if (optype == OP_DIE) {
1003 if (o->op_private & OPpHUSH_VMSISH)
1004 sv_catpv(tmpsv, ",HUSH_VMSISH");
1006 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
1007 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1008 sv_catpv(tmpsv, ",FT_ACCESS");
1009 if (o->op_private & OPpFT_STACKED)
1010 sv_catpv(tmpsv, ",FT_STACKED");
1012 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1013 sv_catpv(tmpsv, ",INTRO");
1015 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1016 SvREFCNT_dec(tmpsv);
1020 if (PL_madskills && o->op_madprop) {
1021 SV * const tmpsv = newSVpvs("");
1022 MADPROP* mp = o->op_madprop;
1023 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1026 const char tmp = mp->mad_key;
1027 sv_setpvs(tmpsv,"'");
1029 sv_catpvn(tmpsv, &tmp, 1);
1030 sv_catpv(tmpsv, "'=");
1031 switch (mp->mad_type) {
1033 sv_catpv(tmpsv, "NULL");
1034 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1037 sv_catpv(tmpsv, "<");
1038 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1039 sv_catpv(tmpsv, ">");
1040 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1043 if ((OP*)mp->mad_val) {
1044 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1045 do_op_dump(level, file, (OP*)mp->mad_val);
1049 sv_catpv(tmpsv, "(UNK)");
1050 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1056 Perl_dump_indent(aTHX_ level, file, "}\n");
1058 SvREFCNT_dec(tmpsv);
1067 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1069 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1070 if (cSVOPo->op_sv) {
1071 SV * const tmpsv = newSV(0);
1075 /* FIXME - is this making unwarranted assumptions about the
1076 UTF-8 cleanliness of the dump file handle? */
1079 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1080 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1081 SvPV_nolen_const(tmpsv));
1085 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1091 case OP_METHOD_NAMED:
1092 #ifndef USE_ITHREADS
1093 /* with ITHREADS, consts are stored in the pad, and the right pad
1094 * may not be active here, so skip */
1095 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1101 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1102 (UV)CopLINE(cCOPo));
1103 if (CopSTASHPV(cCOPo))
1104 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1106 if (CopLABEL(cCOPo))
1107 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1111 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1112 if (cLOOPo->op_redoop)
1113 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1115 PerlIO_printf(file, "DONE\n");
1116 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1117 if (cLOOPo->op_nextop)
1118 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1120 PerlIO_printf(file, "DONE\n");
1121 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1122 if (cLOOPo->op_lastop)
1123 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1125 PerlIO_printf(file, "DONE\n");
1133 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1134 if (cLOGOPo->op_other)
1135 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1137 PerlIO_printf(file, "DONE\n");
1143 do_pmop_dump(level, file, cPMOPo);
1151 if (o->op_private & OPpREFCOUNTED)
1152 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1157 if (o->op_flags & OPf_KIDS) {
1159 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1160 do_op_dump(level, file, kid);
1162 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1166 Perl_op_dump(pTHX_ const OP *o)
1168 PERL_ARGS_ASSERT_OP_DUMP;
1169 do_op_dump(0, Perl_debug_log, o);
1173 Perl_gv_dump(pTHX_ GV *gv)
1177 PERL_ARGS_ASSERT_GV_DUMP;
1180 PerlIO_printf(Perl_debug_log, "{}\n");
1183 sv = sv_newmortal();
1184 PerlIO_printf(Perl_debug_log, "{\n");
1185 gv_fullname3(sv, gv, NULL);
1186 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1187 if (gv != GvEGV(gv)) {
1188 gv_efullname3(sv, GvEGV(gv), NULL);
1189 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1191 PerlIO_putc(Perl_debug_log, '\n');
1192 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1196 /* map magic types to the symbolic names
1197 * (with the PERL_MAGIC_ prefixed stripped)
1200 static const struct { const char type; const char *name; } magic_names[] = {
1201 { PERL_MAGIC_sv, "sv(\\0)" },
1202 { PERL_MAGIC_arylen, "arylen(#)" },
1203 { PERL_MAGIC_rhash, "rhash(%)" },
1204 { PERL_MAGIC_pos, "pos(.)" },
1205 { PERL_MAGIC_symtab, "symtab(:)" },
1206 { PERL_MAGIC_backref, "backref(<)" },
1207 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1208 { PERL_MAGIC_overload, "overload(A)" },
1209 { PERL_MAGIC_bm, "bm(B)" },
1210 { PERL_MAGIC_regdata, "regdata(D)" },
1211 { PERL_MAGIC_env, "env(E)" },
1212 { PERL_MAGIC_hints, "hints(H)" },
1213 { PERL_MAGIC_isa, "isa(I)" },
1214 { PERL_MAGIC_dbfile, "dbfile(L)" },
1215 { PERL_MAGIC_shared, "shared(N)" },
1216 { PERL_MAGIC_tied, "tied(P)" },
1217 { PERL_MAGIC_sig, "sig(S)" },
1218 { PERL_MAGIC_uvar, "uvar(U)" },
1219 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1220 { PERL_MAGIC_overload_table, "overload_table(c)" },
1221 { PERL_MAGIC_regdatum, "regdatum(d)" },
1222 { PERL_MAGIC_envelem, "envelem(e)" },
1223 { PERL_MAGIC_fm, "fm(f)" },
1224 { PERL_MAGIC_regex_global, "regex_global(g)" },
1225 { PERL_MAGIC_hintselem, "hintselem(h)" },
1226 { PERL_MAGIC_isaelem, "isaelem(i)" },
1227 { PERL_MAGIC_nkeys, "nkeys(k)" },
1228 { PERL_MAGIC_dbline, "dbline(l)" },
1229 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1230 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1231 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1232 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1233 { PERL_MAGIC_qr, "qr(r)" },
1234 { PERL_MAGIC_sigelem, "sigelem(s)" },
1235 { PERL_MAGIC_taint, "taint(t)" },
1236 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1237 { PERL_MAGIC_vec, "vec(v)" },
1238 { PERL_MAGIC_vstring, "vstring(V)" },
1239 { PERL_MAGIC_utf8, "utf8(w)" },
1240 { PERL_MAGIC_substr, "substr(x)" },
1241 { PERL_MAGIC_defelem, "defelem(y)" },
1242 { PERL_MAGIC_ext, "ext(~)" },
1243 /* this null string terminates the list */
1248 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1250 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1252 for (; mg; mg = mg->mg_moremagic) {
1253 Perl_dump_indent(aTHX_ level, file,
1254 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1255 if (mg->mg_virtual) {
1256 const MGVTBL * const v = mg->mg_virtual;
1258 if (v == &PL_vtbl_sv) s = "sv";
1259 else if (v == &PL_vtbl_env) s = "env";
1260 else if (v == &PL_vtbl_envelem) s = "envelem";
1261 else if (v == &PL_vtbl_sig) s = "sig";
1262 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1263 else if (v == &PL_vtbl_pack) s = "pack";
1264 else if (v == &PL_vtbl_packelem) s = "packelem";
1265 else if (v == &PL_vtbl_dbline) s = "dbline";
1266 else if (v == &PL_vtbl_isa) s = "isa";
1267 else if (v == &PL_vtbl_arylen) s = "arylen";
1268 else if (v == &PL_vtbl_mglob) s = "mglob";
1269 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1270 else if (v == &PL_vtbl_taint) s = "taint";
1271 else if (v == &PL_vtbl_substr) s = "substr";
1272 else if (v == &PL_vtbl_vec) s = "vec";
1273 else if (v == &PL_vtbl_pos) s = "pos";
1274 else if (v == &PL_vtbl_bm) s = "bm";
1275 else if (v == &PL_vtbl_fm) s = "fm";
1276 else if (v == &PL_vtbl_uvar) s = "uvar";
1277 else if (v == &PL_vtbl_defelem) s = "defelem";
1278 #ifdef USE_LOCALE_COLLATE
1279 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1281 else if (v == &PL_vtbl_amagic) s = "amagic";
1282 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1283 else if (v == &PL_vtbl_backref) s = "backref";
1284 else if (v == &PL_vtbl_utf8) s = "utf8";
1285 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1286 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1287 else if (v == &PL_vtbl_hints) s = "hints";
1290 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1292 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1295 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1298 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1302 const char *name = NULL;
1303 for (n = 0; magic_names[n].name; n++) {
1304 if (mg->mg_type == magic_names[n].type) {
1305 name = magic_names[n].name;
1310 Perl_dump_indent(aTHX_ level, file,
1311 " MG_TYPE = PERL_MAGIC_%s\n", name);
1313 Perl_dump_indent(aTHX_ level, file,
1314 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1318 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1319 if (mg->mg_type == PERL_MAGIC_envelem &&
1320 mg->mg_flags & MGf_TAINTEDDIR)
1321 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1322 if (mg->mg_flags & MGf_REFCOUNTED)
1323 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1324 if (mg->mg_flags & MGf_GSKIP)
1325 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1326 if (mg->mg_type == PERL_MAGIC_regex_global &&
1327 mg->mg_flags & MGf_MINMATCH)
1328 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1331 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1332 PTR2UV(mg->mg_obj));
1333 if (mg->mg_type == PERL_MAGIC_qr) {
1334 REGEXP* const re = (REGEXP *)mg->mg_obj;
1335 SV * const dsv = sv_newmortal();
1336 const char * const s
1337 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1339 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1340 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1342 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1343 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1346 if (mg->mg_flags & MGf_REFCOUNTED)
1347 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1350 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1352 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1353 if (mg->mg_len >= 0) {
1354 if (mg->mg_type != PERL_MAGIC_utf8) {
1355 SV * const sv = newSVpvs("");
1356 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1360 else if (mg->mg_len == HEf_SVKEY) {
1361 PerlIO_puts(file, " => HEf_SVKEY\n");
1362 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1363 maxnest, dumpops, pvlim); /* MG is already +1 */
1367 PerlIO_puts(file, " ???? - please notify IZ");
1368 PerlIO_putc(file, '\n');
1370 if (mg->mg_type == PERL_MAGIC_utf8) {
1371 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1374 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1375 Perl_dump_indent(aTHX_ level, file,
1376 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1379 (UV)cache[i * 2 + 1]);
1386 Perl_magic_dump(pTHX_ const MAGIC *mg)
1388 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1392 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1396 PERL_ARGS_ASSERT_DO_HV_DUMP;
1398 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1399 if (sv && (hvname = HvNAME_get(sv)))
1400 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1402 PerlIO_putc(file, '\n');
1406 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1408 PERL_ARGS_ASSERT_DO_GV_DUMP;
1410 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1411 if (sv && GvNAME(sv))
1412 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1414 PerlIO_putc(file, '\n');
1418 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1420 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1422 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1423 if (sv && GvNAME(sv)) {
1425 PerlIO_printf(file, "\t\"");
1426 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1427 PerlIO_printf(file, "%s\" :: \"", hvname);
1428 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1431 PerlIO_putc(file, '\n');
1435 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1443 PERL_ARGS_ASSERT_DO_SV_DUMP;
1446 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1450 flags = SvFLAGS(sv);
1453 d = Perl_newSVpvf(aTHX_
1454 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1455 PTR2UV(SvANY(sv)), PTR2UV(sv),
1456 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1457 (int)(PL_dumpindent*level), "");
1459 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1460 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1462 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1463 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1464 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1466 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1467 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1468 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1469 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1470 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1472 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1473 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1474 if (flags & SVf_POK) sv_catpv(d, "POK,");
1475 if (flags & SVf_ROK) {
1476 sv_catpv(d, "ROK,");
1477 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1479 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1480 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1481 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1482 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1484 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1485 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1486 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1487 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1488 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1489 if (SvPCS_IMPORTED(sv))
1490 sv_catpv(d, "PCS_IMPORTED,");
1492 sv_catpv(d, "SCREAM,");
1498 if (CvANON(sv)) sv_catpv(d, "ANON,");
1499 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1500 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1501 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1502 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1503 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1504 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1505 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1506 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1507 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1510 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1511 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1512 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1513 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1514 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1518 if (isGV_with_GP(sv)) {
1519 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1520 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1521 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1522 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1524 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1525 sv_catpv(d, "IMPORT");
1526 if (GvIMPORTED(sv) == GVf_IMPORTED)
1527 sv_catpv(d, "ALL,");
1530 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1531 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1532 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1533 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1537 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1538 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1542 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1543 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1546 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1547 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1550 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1555 /* SVphv_SHAREKEYS is also 0x20000000 */
1556 if ((type != SVt_PVHV) && SvUTF8(sv))
1557 sv_catpv(d, "UTF8");
1559 if (*(SvEND(d) - 1) == ',') {
1560 SvCUR_set(d, SvCUR(d) - 1);
1561 SvPVX(d)[SvCUR(d)] = '\0';
1566 #ifdef DEBUG_LEAKING_SCALARS
1567 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1568 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1570 sv->sv_debug_inpad ? "for" : "by",
1571 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1572 sv->sv_debug_cloned ? " (cloned)" : "");
1574 Perl_dump_indent(aTHX_ level, file, "SV = ");
1575 if (type < SVt_LAST) {
1576 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1578 if (type == SVt_NULL) {
1583 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1587 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1588 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM)
1589 || (type == SVt_IV && !SvROK(sv))) {
1591 #ifdef PERL_OLD_COPY_ON_WRITE
1595 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1597 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1598 #ifdef PERL_OLD_COPY_ON_WRITE
1599 if (SvIsCOW_shared_hash(sv))
1600 PerlIO_printf(file, " (HASH)");
1601 else if (SvIsCOW_normal(sv))
1602 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1604 PerlIO_putc(file, '\n');
1606 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1607 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1608 (UV) COP_SEQ_RANGE_LOW(sv));
1609 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1610 (UV) COP_SEQ_RANGE_HIGH(sv));
1611 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1612 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1613 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1614 || type == SVt_NV) {
1615 STORE_NUMERIC_LOCAL_SET_STANDARD();
1616 /* %Vg doesn't work? --jhi */
1617 #ifdef USE_LONG_DOUBLE
1618 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1620 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1622 RESTORE_NUMERIC_LOCAL();
1625 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1627 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1629 if (type < SVt_PV) {
1633 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1634 if (SvPVX_const(sv)) {
1637 SvOOK_offset(sv, delta);
1638 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1643 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1645 PerlIO_printf(file, "( %s . ) ",
1646 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1649 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1650 if (SvUTF8(sv)) /* the 6? \x{....} */
1651 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1652 PerlIO_printf(file, "\n");
1653 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1654 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1657 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1659 if (type == SVt_REGEXP) {
1661 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1662 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1665 if (type >= SVt_PVMG) {
1666 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1667 HV * const ost = SvOURSTASH(sv);
1669 do_hv_dump(level, file, " OURSTASH", ost);
1672 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1675 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1679 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1680 if (AvARRAY(sv) != AvALLOC(sv)) {
1681 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1682 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1685 PerlIO_putc(file, '\n');
1686 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1687 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1688 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1690 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1691 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1692 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1693 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1694 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1696 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1697 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1699 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1701 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1706 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1707 if (HvARRAY(sv) && HvKEYS(sv)) {
1708 /* Show distribution of HEs in the ARRAY */
1710 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1713 U32 pow2 = 2, keys = HvKEYS(sv);
1714 NV theoret, sum = 0;
1716 PerlIO_printf(file, " (");
1717 Zero(freq, FREQ_MAX + 1, int);
1718 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1721 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1723 if (count > FREQ_MAX)
1729 for (i = 0; i <= max; i++) {
1731 PerlIO_printf(file, "%d%s:%d", i,
1732 (i == FREQ_MAX) ? "+" : "",
1735 PerlIO_printf(file, ", ");
1738 PerlIO_putc(file, ')');
1739 /* The "quality" of a hash is defined as the total number of
1740 comparisons needed to access every element once, relative
1741 to the expected number needed for a random hash.
1743 The total number of comparisons is equal to the sum of
1744 the squares of the number of entries in each bucket.
1745 For a random hash of n keys into k buckets, the expected
1750 for (i = max; i > 0; i--) { /* Precision: count down. */
1751 sum += freq[i] * i * i;
1753 while ((keys = keys >> 1))
1755 theoret = HvKEYS(sv);
1756 theoret += theoret * (theoret-1)/pow2;
1757 PerlIO_putc(file, '\n');
1758 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1760 PerlIO_putc(file, '\n');
1761 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1762 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1763 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1764 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1765 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1767 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1768 if (mg && mg->mg_obj) {
1769 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1773 const char * const hvname = HvNAME_get(sv);
1775 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1779 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1780 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1782 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1784 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1788 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1789 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1790 (int)meta->mro_which->length,
1791 meta->mro_which->name,
1792 PTR2UV(meta->mro_which));
1793 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1794 (UV)meta->cache_gen);
1795 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1797 if (meta->mro_linear_all) {
1798 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1799 PTR2UV(meta->mro_linear_all));
1800 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1803 if (meta->mro_linear_current) {
1804 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1805 PTR2UV(meta->mro_linear_current));
1806 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1809 if (meta->mro_nextmethod) {
1810 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1811 PTR2UV(meta->mro_nextmethod));
1812 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1816 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1818 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1823 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1825 HV * const hv = MUTABLE_HV(sv);
1826 int count = maxnest - nest;
1829 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1832 const U32 hash = HeHASH(he);
1833 SV * const keysv = hv_iterkeysv(he);
1834 const char * const keypv = SvPV_const(keysv, len);
1835 SV * const elt = hv_iterval(hv, he);
1837 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1839 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1841 PerlIO_printf(file, "[REHASH] ");
1842 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1843 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1845 hv_iterinit(hv); /* Return to status quo */
1851 const char *const proto = SvPV_const(sv, len);
1852 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1857 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1858 if (!CvISXSUB(sv)) {
1860 Perl_dump_indent(aTHX_ level, file,
1861 " START = 0x%"UVxf" ===> %"IVdf"\n",
1862 PTR2UV(CvSTART(sv)),
1863 (IV)sequence_num(CvSTART(sv)));
1865 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1866 PTR2UV(CvROOT(sv)));
1867 if (CvROOT(sv) && dumpops) {
1868 do_op_dump(level+1, file, CvROOT(sv));
1871 SV * const constant = cv_const_sv((const CV *)sv);
1873 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1876 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1878 PTR2UV(CvXSUBANY(sv).any_ptr));
1879 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1882 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1883 (IV)CvXSUBANY(sv).any_i32);
1886 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1887 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1888 if (type == SVt_PVCV)
1889 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1890 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1891 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1892 if (type == SVt_PVFM)
1893 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1894 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1895 if (nest < maxnest) {
1896 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1899 const CV * const outside = CvOUTSIDE(sv);
1900 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1903 : CvANON(outside) ? "ANON"
1904 : (outside == PL_main_cv) ? "MAIN"
1905 : CvUNIQUE(outside) ? "UNIQUE"
1906 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1908 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1909 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1913 if (type == SVt_PVLV) {
1914 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1915 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1916 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1917 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1918 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1919 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1923 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1924 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1925 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1926 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1928 if (!isGV_with_GP(sv))
1930 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1931 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1932 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1933 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1936 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1937 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1938 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1939 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1940 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1941 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1942 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1943 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1944 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1945 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1946 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1947 do_gv_dump (level, file, " EGV", GvEGV(sv));
1950 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1951 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1952 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1953 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1954 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1955 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1956 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1958 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1959 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1960 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1962 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1963 PTR2UV(IoTOP_GV(sv)));
1964 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1965 maxnest, dumpops, pvlim);
1967 /* Source filters hide things that are not GVs in these three, so let's
1968 be careful out there. */
1970 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1971 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1972 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1974 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1975 PTR2UV(IoFMT_GV(sv)));
1976 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1977 maxnest, dumpops, pvlim);
1979 if (IoBOTTOM_NAME(sv))
1980 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1981 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1982 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1984 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1985 PTR2UV(IoBOTTOM_GV(sv)));
1986 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
1987 maxnest, dumpops, pvlim);
1989 if (isPRINT(IoTYPE(sv)))
1990 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1992 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1993 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2000 Perl_sv_dump(pTHX_ SV *sv)
2004 PERL_ARGS_ASSERT_SV_DUMP;
2007 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2009 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2013 Perl_runops_debug(pTHX)
2017 if (ckWARN_d(WARN_DEBUGGING))
2018 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2022 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2026 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2027 PerlIO_printf(Perl_debug_log,
2028 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2029 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2030 PTR2UV(*PL_watchaddr));
2031 if (DEBUG_s_TEST_) {
2032 if (DEBUG_v_TEST_) {
2033 PerlIO_printf(Perl_debug_log, "\n");
2041 if (DEBUG_t_TEST_) debop(PL_op);
2042 if (DEBUG_P_TEST_) debprof(PL_op);
2044 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2045 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2052 Perl_debop(pTHX_ const OP *o)
2056 PERL_ARGS_ASSERT_DEBOP;
2058 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2061 Perl_deb(aTHX_ "%s", OP_NAME(o));
2062 switch (o->op_type) {
2065 /* With ITHREADS, consts are stored in the pad, and the right pad
2066 * may not be active here, so check.
2067 * Looks like only during compiling the pads are illegal.
2070 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2072 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2077 SV * const sv = newSV(0);
2079 /* FIXME - is this making unwarranted assumptions about the
2080 UTF-8 cleanliness of the dump file handle? */
2083 gv_fullname3(sv, cGVOPo_gv, NULL);
2084 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2088 PerlIO_printf(Perl_debug_log, "(NULL)");
2094 /* print the lexical's name */
2095 CV * const cv = deb_curcv(cxstack_ix);
2098 AV * const padlist = CvPADLIST(cv);
2099 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2100 sv = *av_fetch(comppad, o->op_targ, FALSE);
2104 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2106 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2112 PerlIO_printf(Perl_debug_log, "\n");
2117 S_deb_curcv(pTHX_ const I32 ix)
2120 const PERL_CONTEXT * const cx = &cxstack[ix];
2121 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2122 return cx->blk_sub.cv;
2123 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2125 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2130 return deb_curcv(ix - 1);
2134 Perl_watch(pTHX_ char **addr)
2138 PERL_ARGS_ASSERT_WATCH;
2140 PL_watchaddr = addr;
2142 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2143 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2147 S_debprof(pTHX_ const OP *o)
2151 PERL_ARGS_ASSERT_DEBPROF;
2153 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2155 if (!PL_profiledata)
2156 Newxz(PL_profiledata, MAXO, U32);
2157 ++PL_profiledata[o->op_type];
2161 Perl_debprofdump(pTHX)
2165 if (!PL_profiledata)
2167 for (i = 0; i < MAXO; i++) {
2168 if (PL_profiledata[i])
2169 PerlIO_printf(Perl_debug_log,
2170 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2177 * XML variants of most of the above routines
2181 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2185 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2187 PerlIO_printf(file, "\n ");
2188 va_start(args, pat);
2189 xmldump_vindent(level, file, pat, &args);
2195 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2198 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2199 va_start(args, pat);
2200 xmldump_vindent(level, file, pat, &args);
2205 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2207 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2209 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2210 PerlIO_vprintf(file, pat, *args);
2214 Perl_xmldump_all(pTHX)
2216 xmldump_all_perl(FALSE);
2220 Perl_xmldump_all_perl(pTHX_ bool justperl)
2222 PerlIO_setlinebuf(PL_xmlfp);
2224 op_xmldump(PL_main_root);
2225 xmldump_packsubs_perl(PL_defstash, justperl)
2226 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2227 PerlIO_close(PL_xmlfp);
2232 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2237 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2239 if (!HvARRAY(stash))
2241 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2242 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2243 GV *gv = MUTABLE_GV(HeVAL(entry));
2245 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2251 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2252 && (hv = GvHV(gv)) && hv != PL_defstash)
2253 xmldump_packsubs(hv); /* nested package */
2259 Perl_xmldump_sub(pTHX_ const GV *gv)
2261 xmldump_sub_perl(gv, FALSE);
2265 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2269 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2271 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2274 sv = sv_newmortal();
2275 gv_fullname3(sv, gv, NULL);
2276 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2277 if (CvXSUB(GvCV(gv)))
2278 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2279 PTR2UV(CvXSUB(GvCV(gv))),
2280 (int)CvXSUBANY(GvCV(gv)).any_i32);
2281 else if (CvROOT(GvCV(gv)))
2282 op_xmldump(CvROOT(GvCV(gv)));
2284 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2288 Perl_xmldump_form(pTHX_ const GV *gv)
2290 SV * const sv = sv_newmortal();
2292 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2294 gv_fullname3(sv, gv, NULL);
2295 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2296 if (CvROOT(GvFORM(gv)))
2297 op_xmldump(CvROOT(GvFORM(gv)));
2299 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2303 Perl_xmldump_eval(pTHX)
2305 op_xmldump(PL_eval_root);
2309 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2311 PERL_ARGS_ASSERT_SV_CATXMLSV;
2312 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2316 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2319 const char * const e = pv + len;
2320 const char * const start = pv;
2324 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2327 dsvcur = SvCUR(dsv); /* in case we have to restart */
2332 c = utf8_to_uvchr((U8*)pv, &cl);
2334 SvCUR(dsv) = dsvcur;
2399 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2402 sv_catpvs(dsv, "<");
2405 sv_catpvs(dsv, ">");
2408 sv_catpvs(dsv, "&");
2411 sv_catpvs(dsv, """);
2415 if (c < 32 || c > 127) {
2416 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2419 const char string = (char) c;
2420 sv_catpvn(dsv, &string, 1);
2424 if ((c >= 0xD800 && c <= 0xDB7F) ||
2425 (c >= 0xDC00 && c <= 0xDFFF) ||
2426 (c >= 0xFFF0 && c <= 0xFFFF) ||
2428 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2430 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2443 Perl_sv_xmlpeek(pTHX_ SV *sv)
2445 SV * const t = sv_newmortal();
2449 PERL_ARGS_ASSERT_SV_XMLPEEK;
2455 sv_catpv(t, "VOID=\"\"");
2458 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2459 sv_catpv(t, "WILD=\"\"");
2462 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2463 if (sv == &PL_sv_undef) {
2464 sv_catpv(t, "SV_UNDEF=\"1\"");
2465 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2466 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2470 else if (sv == &PL_sv_no) {
2471 sv_catpv(t, "SV_NO=\"1\"");
2472 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2473 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2474 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2475 SVp_POK|SVp_NOK)) &&
2480 else if (sv == &PL_sv_yes) {
2481 sv_catpv(t, "SV_YES=\"1\"");
2482 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2483 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2484 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2485 SVp_POK|SVp_NOK)) &&
2487 SvPVX(sv) && *SvPVX(sv) == '1' &&
2492 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2493 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2494 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2498 sv_catpv(t, " XXX=\"\" ");
2500 else if (SvREFCNT(sv) == 0) {
2501 sv_catpv(t, " refcnt=\"0\"");
2504 else if (DEBUG_R_TEST_) {
2507 /* is this SV on the tmps stack? */
2508 for (ix=PL_tmps_ix; ix>=0; ix--) {
2509 if (PL_tmps_stack[ix] == sv) {
2514 if (SvREFCNT(sv) > 1)
2515 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2518 sv_catpv(t, " DRT=\"<T>\"");
2522 sv_catpv(t, " ROK=\"\"");
2524 switch (SvTYPE(sv)) {
2526 sv_catpv(t, " FREED=\"1\"");
2530 sv_catpv(t, " UNDEF=\"1\"");
2533 sv_catpv(t, " IV=\"");
2536 sv_catpv(t, " NV=\"");
2539 sv_catpv(t, " PV=\"");
2542 sv_catpv(t, " PVIV=\"");
2545 sv_catpv(t, " PVNV=\"");
2548 sv_catpv(t, " PVMG=\"");
2551 sv_catpv(t, " PVLV=\"");
2554 sv_catpv(t, " AV=\"");
2557 sv_catpv(t, " HV=\"");
2561 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2563 sv_catpv(t, " CV=\"()\"");
2566 sv_catpv(t, " GV=\"");
2569 sv_catpv(t, " BIND=\"");
2572 sv_catpv(t, " ORANGE=\"");
2575 sv_catpv(t, " FM=\"");
2578 sv_catpv(t, " IO=\"");
2587 else if (SvNOKp(sv)) {
2588 STORE_NUMERIC_LOCAL_SET_STANDARD();
2589 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2590 RESTORE_NUMERIC_LOCAL();
2592 else if (SvIOKp(sv)) {
2594 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2596 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2605 return SvPV(t, n_a);
2609 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2611 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2614 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2617 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2620 REGEXP *const r = PM_GETRE(pm);
2621 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2622 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2623 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2625 SvREFCNT_dec(tmpsv);
2626 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2627 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2630 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2631 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2632 SV * const tmpsv = pm_description(pm);
2633 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2634 SvREFCNT_dec(tmpsv);
2638 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2639 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2640 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2641 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2642 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2643 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2646 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2650 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2652 do_pmop_xmldump(0, PL_xmlfp, pm);
2656 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2661 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2666 seq = sequence_num(o);
2667 Perl_xmldump_indent(aTHX_ level, file,
2668 "<op_%s seq=\"%"UVuf" -> ",
2673 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2674 sequence_num(o->op_next));
2676 PerlIO_printf(file, "DONE\"");
2679 if (o->op_type == OP_NULL)
2681 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2682 if (o->op_targ == OP_NEXTSTATE)
2685 PerlIO_printf(file, " line=\"%"UVuf"\"",
2686 (UV)CopLINE(cCOPo));
2687 if (CopSTASHPV(cCOPo))
2688 PerlIO_printf(file, " package=\"%s\"",
2690 if (CopLABEL(cCOPo))
2691 PerlIO_printf(file, " label=\"%s\"",
2696 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2699 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2702 SV * const tmpsv = newSVpvs("");
2703 switch (o->op_flags & OPf_WANT) {
2705 sv_catpv(tmpsv, ",VOID");
2707 case OPf_WANT_SCALAR:
2708 sv_catpv(tmpsv, ",SCALAR");
2711 sv_catpv(tmpsv, ",LIST");
2714 sv_catpv(tmpsv, ",UNKNOWN");
2717 if (o->op_flags & OPf_KIDS)
2718 sv_catpv(tmpsv, ",KIDS");
2719 if (o->op_flags & OPf_PARENS)
2720 sv_catpv(tmpsv, ",PARENS");
2721 if (o->op_flags & OPf_STACKED)
2722 sv_catpv(tmpsv, ",STACKED");
2723 if (o->op_flags & OPf_REF)
2724 sv_catpv(tmpsv, ",REF");
2725 if (o->op_flags & OPf_MOD)
2726 sv_catpv(tmpsv, ",MOD");
2727 if (o->op_flags & OPf_SPECIAL)
2728 sv_catpv(tmpsv, ",SPECIAL");
2729 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2730 SvREFCNT_dec(tmpsv);
2732 if (o->op_private) {
2733 SV * const tmpsv = newSVpvs("");
2734 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2735 if (o->op_private & OPpTARGET_MY)
2736 sv_catpv(tmpsv, ",TARGET_MY");
2738 else if (o->op_type == OP_LEAVESUB ||
2739 o->op_type == OP_LEAVE ||
2740 o->op_type == OP_LEAVESUBLV ||
2741 o->op_type == OP_LEAVEWRITE) {
2742 if (o->op_private & OPpREFCOUNTED)
2743 sv_catpv(tmpsv, ",REFCOUNTED");
2745 else if (o->op_type == OP_AASSIGN) {
2746 if (o->op_private & OPpASSIGN_COMMON)
2747 sv_catpv(tmpsv, ",COMMON");
2749 else if (o->op_type == OP_SASSIGN) {
2750 if (o->op_private & OPpASSIGN_BACKWARDS)
2751 sv_catpv(tmpsv, ",BACKWARDS");
2753 else if (o->op_type == OP_TRANS) {
2754 if (o->op_private & OPpTRANS_SQUASH)
2755 sv_catpv(tmpsv, ",SQUASH");
2756 if (o->op_private & OPpTRANS_DELETE)
2757 sv_catpv(tmpsv, ",DELETE");
2758 if (o->op_private & OPpTRANS_COMPLEMENT)
2759 sv_catpv(tmpsv, ",COMPLEMENT");
2760 if (o->op_private & OPpTRANS_IDENTICAL)
2761 sv_catpv(tmpsv, ",IDENTICAL");
2762 if (o->op_private & OPpTRANS_GROWS)
2763 sv_catpv(tmpsv, ",GROWS");
2765 else if (o->op_type == OP_REPEAT) {
2766 if (o->op_private & OPpREPEAT_DOLIST)
2767 sv_catpv(tmpsv, ",DOLIST");
2769 else if (o->op_type == OP_ENTERSUB ||
2770 o->op_type == OP_RV2SV ||
2771 o->op_type == OP_GVSV ||
2772 o->op_type == OP_RV2AV ||
2773 o->op_type == OP_RV2HV ||
2774 o->op_type == OP_RV2GV ||
2775 o->op_type == OP_AELEM ||
2776 o->op_type == OP_HELEM )
2778 if (o->op_type == OP_ENTERSUB) {
2779 if (o->op_private & OPpENTERSUB_AMPER)
2780 sv_catpv(tmpsv, ",AMPER");
2781 if (o->op_private & OPpENTERSUB_DB)
2782 sv_catpv(tmpsv, ",DB");
2783 if (o->op_private & OPpENTERSUB_HASTARG)
2784 sv_catpv(tmpsv, ",HASTARG");
2785 if (o->op_private & OPpENTERSUB_NOPAREN)
2786 sv_catpv(tmpsv, ",NOPAREN");
2787 if (o->op_private & OPpENTERSUB_INARGS)
2788 sv_catpv(tmpsv, ",INARGS");
2789 if (o->op_private & OPpENTERSUB_NOMOD)
2790 sv_catpv(tmpsv, ",NOMOD");
2793 switch (o->op_private & OPpDEREF) {
2795 sv_catpv(tmpsv, ",SV");
2798 sv_catpv(tmpsv, ",AV");
2801 sv_catpv(tmpsv, ",HV");
2804 if (o->op_private & OPpMAYBE_LVSUB)
2805 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2807 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2808 if (o->op_private & OPpLVAL_DEFER)
2809 sv_catpv(tmpsv, ",LVAL_DEFER");
2812 if (o->op_private & HINT_STRICT_REFS)
2813 sv_catpv(tmpsv, ",STRICT_REFS");
2814 if (o->op_private & OPpOUR_INTRO)
2815 sv_catpv(tmpsv, ",OUR_INTRO");
2818 else if (o->op_type == OP_CONST) {
2819 if (o->op_private & OPpCONST_BARE)
2820 sv_catpv(tmpsv, ",BARE");
2821 if (o->op_private & OPpCONST_STRICT)
2822 sv_catpv(tmpsv, ",STRICT");
2823 if (o->op_private & OPpCONST_ARYBASE)
2824 sv_catpv(tmpsv, ",ARYBASE");
2825 if (o->op_private & OPpCONST_WARNING)
2826 sv_catpv(tmpsv, ",WARNING");
2827 if (o->op_private & OPpCONST_ENTERED)
2828 sv_catpv(tmpsv, ",ENTERED");
2830 else if (o->op_type == OP_FLIP) {
2831 if (o->op_private & OPpFLIP_LINENUM)
2832 sv_catpv(tmpsv, ",LINENUM");
2834 else if (o->op_type == OP_FLOP) {
2835 if (o->op_private & OPpFLIP_LINENUM)
2836 sv_catpv(tmpsv, ",LINENUM");
2838 else if (o->op_type == OP_RV2CV) {
2839 if (o->op_private & OPpLVAL_INTRO)
2840 sv_catpv(tmpsv, ",INTRO");
2842 else if (o->op_type == OP_GV) {
2843 if (o->op_private & OPpEARLY_CV)
2844 sv_catpv(tmpsv, ",EARLY_CV");
2846 else if (o->op_type == OP_LIST) {
2847 if (o->op_private & OPpLIST_GUESSED)
2848 sv_catpv(tmpsv, ",GUESSED");
2850 else if (o->op_type == OP_DELETE) {
2851 if (o->op_private & OPpSLICE)
2852 sv_catpv(tmpsv, ",SLICE");
2854 else if (o->op_type == OP_EXISTS) {
2855 if (o->op_private & OPpEXISTS_SUB)
2856 sv_catpv(tmpsv, ",EXISTS_SUB");
2858 else if (o->op_type == OP_SORT) {
2859 if (o->op_private & OPpSORT_NUMERIC)
2860 sv_catpv(tmpsv, ",NUMERIC");
2861 if (o->op_private & OPpSORT_INTEGER)
2862 sv_catpv(tmpsv, ",INTEGER");
2863 if (o->op_private & OPpSORT_REVERSE)
2864 sv_catpv(tmpsv, ",REVERSE");
2866 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2867 if (o->op_private & OPpOPEN_IN_RAW)
2868 sv_catpv(tmpsv, ",IN_RAW");
2869 if (o->op_private & OPpOPEN_IN_CRLF)
2870 sv_catpv(tmpsv, ",IN_CRLF");
2871 if (o->op_private & OPpOPEN_OUT_RAW)
2872 sv_catpv(tmpsv, ",OUT_RAW");
2873 if (o->op_private & OPpOPEN_OUT_CRLF)
2874 sv_catpv(tmpsv, ",OUT_CRLF");
2876 else if (o->op_type == OP_EXIT) {
2877 if (o->op_private & OPpEXIT_VMSISH)
2878 sv_catpv(tmpsv, ",EXIT_VMSISH");
2879 if (o->op_private & OPpHUSH_VMSISH)
2880 sv_catpv(tmpsv, ",HUSH_VMSISH");
2882 else if (o->op_type == OP_DIE) {
2883 if (o->op_private & OPpHUSH_VMSISH)
2884 sv_catpv(tmpsv, ",HUSH_VMSISH");
2886 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2887 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2888 sv_catpv(tmpsv, ",FT_ACCESS");
2889 if (o->op_private & OPpFT_STACKED)
2890 sv_catpv(tmpsv, ",FT_STACKED");
2892 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2893 sv_catpv(tmpsv, ",INTRO");
2895 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2896 SvREFCNT_dec(tmpsv);
2899 switch (o->op_type) {
2901 if (o->op_flags & OPf_SPECIAL) {
2907 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2909 if (cSVOPo->op_sv) {
2910 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2911 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2917 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2918 s = SvPV(tmpsv1,len);
2919 sv_catxmlpvn(tmpsv2, s, len, 1);
2920 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2924 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2929 case OP_METHOD_NAMED:
2930 #ifndef USE_ITHREADS
2931 /* with ITHREADS, consts are stored in the pad, and the right pad
2932 * may not be active here, so skip */
2933 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2939 PerlIO_printf(file, ">\n");
2941 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2946 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2947 (UV)CopLINE(cCOPo));
2948 if (CopSTASHPV(cCOPo))
2949 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2951 if (CopLABEL(cCOPo))
2952 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2956 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2957 if (cLOOPo->op_redoop)
2958 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2960 PerlIO_printf(file, "DONE\"");
2961 S_xmldump_attr(aTHX_ level, file, "next=\"");
2962 if (cLOOPo->op_nextop)
2963 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2965 PerlIO_printf(file, "DONE\"");
2966 S_xmldump_attr(aTHX_ level, file, "last=\"");
2967 if (cLOOPo->op_lastop)
2968 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2970 PerlIO_printf(file, "DONE\"");
2978 S_xmldump_attr(aTHX_ level, file, "other=\"");
2979 if (cLOGOPo->op_other)
2980 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2982 PerlIO_printf(file, "DONE\"");
2990 if (o->op_private & OPpREFCOUNTED)
2991 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2997 if (PL_madskills && o->op_madprop) {
2998 char prevkey = '\0';
2999 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3000 const MADPROP* mp = o->op_madprop;
3004 PerlIO_printf(file, ">\n");
3006 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3009 char tmp = mp->mad_key;
3010 sv_setpvs(tmpsv,"\"");
3012 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3013 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3014 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3017 sv_catpv(tmpsv, "\"");
3018 switch (mp->mad_type) {
3020 sv_catpv(tmpsv, "NULL");
3021 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3024 sv_catpv(tmpsv, " val=\"");
3025 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3026 sv_catpv(tmpsv, "\"");
3027 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3030 sv_catpv(tmpsv, " val=\"");
3031 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3032 sv_catpv(tmpsv, "\"");
3033 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3036 if ((OP*)mp->mad_val) {
3037 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3038 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3039 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3043 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3049 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3051 SvREFCNT_dec(tmpsv);
3054 switch (o->op_type) {
3061 PerlIO_printf(file, ">\n");
3063 do_pmop_xmldump(level, file, cPMOPo);
3069 if (o->op_flags & OPf_KIDS) {
3073 PerlIO_printf(file, ">\n");
3075 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3076 do_op_xmldump(level, file, kid);
3080 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3082 PerlIO_printf(file, " />\n");
3086 Perl_op_xmldump(pTHX_ const OP *o)
3088 PERL_ARGS_ASSERT_OP_XMLDUMP;
3090 do_op_xmldump(0, PL_xmlfp, o);
3096 * c-indentation-style: bsd
3098 * indent-tabs-mode: t
3101 * ex: set ts=8 sts=4 sw=4 noet: