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 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
113 dump_packsubs_perl(stash, FALSE);
117 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
122 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
126 for (i = 0; i <= (I32) HvMAX(stash); i++) {
128 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
129 const GV * const gv = (const GV *)HeVAL(entry);
130 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
133 dump_sub_perl(gv, justperl);
136 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
137 const HV * const hv = GvHV(gv);
138 if (hv && (hv != PL_defstash))
139 dump_packsubs_perl(hv, justperl); /* nested package */
146 Perl_dump_sub(pTHX_ const GV *gv)
148 PERL_ARGS_ASSERT_DUMP_SUB;
149 dump_sub_perl(gv, FALSE);
153 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
157 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
159 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
163 gv_fullname3(sv, gv, NULL);
164 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
165 if (CvISXSUB(GvCV(gv)))
166 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
167 PTR2UV(CvXSUB(GvCV(gv))),
168 (int)CvXSUBANY(GvCV(gv)).any_i32);
169 else if (CvROOT(GvCV(gv)))
170 op_dump(CvROOT(GvCV(gv)));
172 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
176 Perl_dump_form(pTHX_ const GV *gv)
178 SV * const sv = sv_newmortal();
180 PERL_ARGS_ASSERT_DUMP_FORM;
182 gv_fullname3(sv, gv, NULL);
183 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
184 if (CvROOT(GvFORM(gv)))
185 op_dump(CvROOT(GvFORM(gv)));
187 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
194 op_dump(PL_eval_root);
199 =for apidoc pv_escape
201 Escapes at most the first "count" chars of pv and puts the results into
202 dsv such that the size of the escaped string will not exceed "max" chars
203 and will not contain any incomplete escape sequences.
205 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
206 will also be escaped.
208 Normally the SV will be cleared before the escaped string is prepared,
209 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
211 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
212 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
213 using C<is_utf8_string()> to determine if it is Unicode.
215 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
216 using C<\x01F1> style escapes, otherwise only chars above 255 will be
217 escaped using this style, other non printable chars will use octal or
218 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
219 then all chars below 255 will be treated as printable and
220 will be output as literals.
222 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
223 string will be escaped, regardles of max. If the string is utf8 and
224 the chars value is >255 then it will be returned as a plain hex
225 sequence. Thus the output will either be a single char,
226 an octal escape sequence, a special escape like C<\n> or a 3 or
227 more digit hex value.
229 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
230 not a '\\'. This is because regexes very often contain backslashed
231 sequences, whereas '%' is not a particularly common character in patterns.
233 Returns a pointer to the escaped text as held by dsv.
237 #define PV_ESCAPE_OCTBUFSIZE 32
240 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
241 const STRLEN count, const STRLEN max,
242 STRLEN * const escaped, const U32 flags )
244 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
245 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
246 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
247 STRLEN wrote = 0; /* chars written so far */
248 STRLEN chsize = 0; /* size of data to be written */
249 STRLEN readsize = 1; /* size of data just read */
250 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
251 const char *pv = str;
252 const char * const end = pv + count; /* end of string */
255 PERL_ARGS_ASSERT_PV_ESCAPE;
257 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
258 /* This won't alter the UTF-8 flag */
262 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
265 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
266 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
267 const U8 c = (U8)u & 0xFF;
269 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
270 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
271 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
274 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
275 "%cx{%"UVxf"}", esc, u);
276 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
279 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
283 case '\\' : /* fallthrough */
284 case '%' : if ( c == esc ) {
290 case '\v' : octbuf[1] = 'v'; break;
291 case '\t' : octbuf[1] = 't'; break;
292 case '\r' : octbuf[1] = 'r'; break;
293 case '\n' : octbuf[1] = 'n'; break;
294 case '\f' : octbuf[1] = 'f'; break;
302 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
303 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
306 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
313 if ( max && (wrote + chsize > max) ) {
315 } else if (chsize > 1) {
316 sv_catpvn(dsv, octbuf, chsize);
319 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
320 128-255 can be appended raw to the dsv. If dsv happens to be
321 UTF-8 then we need catpvf to upgrade them for us.
322 Or add a new API call sv_catpvc(). Think about that name, and
323 how to keep it clear that it's unlike the s of catpvs, which is
324 really an array octets, not a string. */
325 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
328 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
336 =for apidoc pv_pretty
338 Converts a string into something presentable, handling escaping via
339 pv_escape() and supporting quoting and ellipses.
341 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
342 double quoted with any double quotes in the string escaped. Otherwise
343 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
346 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
347 string were output then an ellipsis C<...> will be appended to the
348 string. Note that this happens AFTER it has been quoted.
350 If start_color is non-null then it will be inserted after the opening
351 quote (if there is one) but before the escaped text. If end_color
352 is non-null then it will be inserted after the escaped text but before
353 any quotes or ellipses.
355 Returns a pointer to the prettified text as held by dsv.
361 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
362 const STRLEN max, char const * const start_color, char const * const end_color,
365 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
368 PERL_ARGS_ASSERT_PV_PRETTY;
370 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
371 /* This won't alter the UTF-8 flag */
376 sv_catpvs(dsv, "\"");
377 else if ( flags & PERL_PV_PRETTY_LTGT )
380 if ( start_color != NULL )
381 sv_catpv(dsv, start_color);
383 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
385 if ( end_color != NULL )
386 sv_catpv(dsv, end_color);
389 sv_catpvs( dsv, "\"");
390 else if ( flags & PERL_PV_PRETTY_LTGT )
393 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
394 sv_catpvs(dsv, "...");
400 =for apidoc pv_display
404 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
406 except that an additional "\0" will be appended to the string when
407 len > cur and pv[cur] is "\0".
409 Note that the final string may be up to 7 chars longer than pvlim.
415 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
417 PERL_ARGS_ASSERT_PV_DISPLAY;
419 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
420 if (len > cur && pv[cur] == '\0')
421 sv_catpvs( dsv, "\\0");
426 Perl_sv_peek(pTHX_ SV *sv)
429 SV * const t = sv_newmortal();
439 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
443 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
444 if (sv == &PL_sv_undef) {
445 sv_catpv(t, "SV_UNDEF");
446 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
447 SVs_GMG|SVs_SMG|SVs_RMG)) &&
451 else if (sv == &PL_sv_no) {
452 sv_catpv(t, "SV_NO");
453 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
454 SVs_GMG|SVs_SMG|SVs_RMG)) &&
455 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
461 else if (sv == &PL_sv_yes) {
462 sv_catpv(t, "SV_YES");
463 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
464 SVs_GMG|SVs_SMG|SVs_RMG)) &&
465 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
468 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
473 sv_catpv(t, "SV_PLACEHOLDER");
474 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
475 SVs_GMG|SVs_SMG|SVs_RMG)) &&
481 else if (SvREFCNT(sv) == 0) {
485 else if (DEBUG_R_TEST_) {
488 /* is this SV on the tmps stack? */
489 for (ix=PL_tmps_ix; ix>=0; ix--) {
490 if (PL_tmps_stack[ix] == sv) {
495 if (SvREFCNT(sv) > 1)
496 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
504 if (SvCUR(t) + unref > 10) {
505 SvCUR_set(t, unref + 3);
514 if (type == SVt_PVCV) {
515 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
517 } else if (type < SVt_LAST) {
518 sv_catpv(t, svshorttypenames[type]);
520 if (type == SVt_NULL)
523 sv_catpv(t, "FREED");
528 if (!SvPVX_const(sv))
529 sv_catpv(t, "(null)");
531 SV * const tmp = newSVpvs("");
535 SvOOK_offset(sv, delta);
536 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
538 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
540 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
541 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
546 else if (SvNOKp(sv)) {
547 STORE_NUMERIC_LOCAL_SET_STANDARD();
548 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
549 RESTORE_NUMERIC_LOCAL();
551 else if (SvIOKp(sv)) {
553 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
555 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
563 if (PL_tainting && SvTAINTED(sv))
564 sv_catpv(t, " [tainted]");
565 return SvPV_nolen(t);
569 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
573 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
576 Perl_dump_indent(aTHX_ level, file, "{}\n");
579 Perl_dump_indent(aTHX_ level, file, "{\n");
581 if (pm->op_pmflags & PMf_ONCE)
586 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
587 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
588 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
590 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
591 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
592 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
593 op_dump(pm->op_pmreplrootu.op_pmreplroot);
595 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
596 SV * const tmpsv = pm_description(pm);
597 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
601 Perl_dump_indent(aTHX_ level-1, file, "}\n");
605 S_pm_description(pTHX_ const PMOP *pm)
607 SV * const desc = newSVpvs("");
608 const REGEXP * const regex = PM_GETRE(pm);
609 const U32 pmflags = pm->op_pmflags;
611 PERL_ARGS_ASSERT_PM_DESCRIPTION;
613 if (pmflags & PMf_ONCE)
614 sv_catpv(desc, ",ONCE");
616 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
617 sv_catpv(desc, ":USED");
619 if (pmflags & PMf_USED)
620 sv_catpv(desc, ":USED");
624 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
625 sv_catpv(desc, ",TAINTED");
626 if (RX_CHECK_SUBSTR(regex)) {
627 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
628 sv_catpv(desc, ",SCANFIRST");
629 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
630 sv_catpv(desc, ",ALL");
632 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
633 sv_catpv(desc, ",SKIPWHITE");
636 if (pmflags & PMf_CONST)
637 sv_catpv(desc, ",CONST");
638 if (pmflags & PMf_KEEP)
639 sv_catpv(desc, ",KEEP");
640 if (pmflags & PMf_GLOBAL)
641 sv_catpv(desc, ",GLOBAL");
642 if (pmflags & PMf_CONTINUE)
643 sv_catpv(desc, ",CONTINUE");
644 if (pmflags & PMf_RETAINT)
645 sv_catpv(desc, ",RETAINT");
646 if (pmflags & PMf_EVAL)
647 sv_catpv(desc, ",EVAL");
648 if (pmflags & PMf_NONDESTRUCT)
649 sv_catpv(desc, ",NONDESTRUCT");
654 Perl_pmop_dump(pTHX_ PMOP *pm)
656 do_pmop_dump(0, Perl_debug_log, pm);
659 /* An op sequencer. We visit the ops in the order they're to execute. */
662 S_sequence(pTHX_ register const OP *o)
665 const OP *oldop = NULL;
678 for (; o; o = o->op_next) {
680 SV * const op = newSVuv(PTR2UV(o));
681 const char * const key = SvPV_const(op, len);
683 if (hv_exists(Sequence, key, len))
686 switch (o->op_type) {
688 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
689 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
698 if (oldop && o->op_next)
705 if (oldop && o->op_next)
707 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
720 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
721 sequence_tail(cLOGOPo->op_other);
726 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
727 sequence_tail(cLOOPo->op_redoop);
728 sequence_tail(cLOOPo->op_nextop);
729 sequence_tail(cLOOPo->op_lastop);
733 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
734 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
743 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
751 S_sequence_tail(pTHX_ const OP *o)
753 while (o && (o->op_type == OP_NULL))
759 S_sequence_num(pTHX_ const OP *o)
767 op = newSVuv(PTR2UV(o));
768 key = SvPV_const(op, len);
769 seq = hv_fetch(Sequence, key, len, 0);
770 return seq ? SvUV(*seq): 0;
774 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
778 const OPCODE optype = o->op_type;
780 PERL_ARGS_ASSERT_DO_OP_DUMP;
783 Perl_dump_indent(aTHX_ level, file, "{\n");
785 seq = sequence_num(o);
787 PerlIO_printf(file, "%-4"UVuf, seq);
789 PerlIO_printf(file, " ");
791 "%*sTYPE = %s ===> ",
792 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
794 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
795 sequence_num(o->op_next));
797 PerlIO_printf(file, "DONE\n");
799 if (optype == OP_NULL) {
800 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
801 if (o->op_targ == OP_NEXTSTATE) {
803 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
805 if (CopSTASHPV(cCOPo))
806 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
809 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
814 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
817 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
819 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
820 SV * const tmpsv = newSVpvs("");
821 switch (o->op_flags & OPf_WANT) {
823 sv_catpv(tmpsv, ",VOID");
825 case OPf_WANT_SCALAR:
826 sv_catpv(tmpsv, ",SCALAR");
829 sv_catpv(tmpsv, ",LIST");
832 sv_catpv(tmpsv, ",UNKNOWN");
835 if (o->op_flags & OPf_KIDS)
836 sv_catpv(tmpsv, ",KIDS");
837 if (o->op_flags & OPf_PARENS)
838 sv_catpv(tmpsv, ",PARENS");
839 if (o->op_flags & OPf_STACKED)
840 sv_catpv(tmpsv, ",STACKED");
841 if (o->op_flags & OPf_REF)
842 sv_catpv(tmpsv, ",REF");
843 if (o->op_flags & OPf_MOD)
844 sv_catpv(tmpsv, ",MOD");
845 if (o->op_flags & OPf_SPECIAL)
846 sv_catpv(tmpsv, ",SPECIAL");
848 sv_catpv(tmpsv, ",LATEFREE");
850 sv_catpv(tmpsv, ",LATEFREED");
852 sv_catpv(tmpsv, ",ATTACHED");
853 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
857 SV * const tmpsv = newSVpvs("");
858 if (PL_opargs[optype] & OA_TARGLEX) {
859 if (o->op_private & OPpTARGET_MY)
860 sv_catpv(tmpsv, ",TARGET_MY");
862 else if (optype == OP_LEAVESUB ||
863 optype == OP_LEAVE ||
864 optype == OP_LEAVESUBLV ||
865 optype == OP_LEAVEWRITE) {
866 if (o->op_private & OPpREFCOUNTED)
867 sv_catpv(tmpsv, ",REFCOUNTED");
869 else if (optype == OP_AASSIGN) {
870 if (o->op_private & OPpASSIGN_COMMON)
871 sv_catpv(tmpsv, ",COMMON");
873 else if (optype == OP_SASSIGN) {
874 if (o->op_private & OPpASSIGN_BACKWARDS)
875 sv_catpv(tmpsv, ",BACKWARDS");
877 else if (optype == OP_TRANS) {
878 if (o->op_private & OPpTRANS_SQUASH)
879 sv_catpv(tmpsv, ",SQUASH");
880 if (o->op_private & OPpTRANS_DELETE)
881 sv_catpv(tmpsv, ",DELETE");
882 if (o->op_private & OPpTRANS_COMPLEMENT)
883 sv_catpv(tmpsv, ",COMPLEMENT");
884 if (o->op_private & OPpTRANS_IDENTICAL)
885 sv_catpv(tmpsv, ",IDENTICAL");
886 if (o->op_private & OPpTRANS_GROWS)
887 sv_catpv(tmpsv, ",GROWS");
889 else if (optype == OP_REPEAT) {
890 if (o->op_private & OPpREPEAT_DOLIST)
891 sv_catpv(tmpsv, ",DOLIST");
893 else if (optype == OP_ENTERSUB ||
894 optype == OP_RV2SV ||
896 optype == OP_RV2AV ||
897 optype == OP_RV2HV ||
898 optype == OP_RV2GV ||
899 optype == OP_AELEM ||
902 if (optype == OP_ENTERSUB) {
903 if (o->op_private & OPpENTERSUB_AMPER)
904 sv_catpv(tmpsv, ",AMPER");
905 if (o->op_private & OPpENTERSUB_DB)
906 sv_catpv(tmpsv, ",DB");
907 if (o->op_private & OPpENTERSUB_HASTARG)
908 sv_catpv(tmpsv, ",HASTARG");
909 if (o->op_private & OPpENTERSUB_NOPAREN)
910 sv_catpv(tmpsv, ",NOPAREN");
911 if (o->op_private & OPpENTERSUB_INARGS)
912 sv_catpv(tmpsv, ",INARGS");
913 if (o->op_private & OPpENTERSUB_NOMOD)
914 sv_catpv(tmpsv, ",NOMOD");
917 switch (o->op_private & OPpDEREF) {
919 sv_catpv(tmpsv, ",SV");
922 sv_catpv(tmpsv, ",AV");
925 sv_catpv(tmpsv, ",HV");
928 if (o->op_private & OPpMAYBE_LVSUB)
929 sv_catpv(tmpsv, ",MAYBE_LVSUB");
932 if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
933 && (o->op_private & OPpDEREFed))
934 sv_catpv(tmpsv, ",DEREFed");
936 if (optype == OP_AELEM || optype == OP_HELEM) {
937 if (o->op_private & OPpLVAL_DEFER)
938 sv_catpv(tmpsv, ",LVAL_DEFER");
941 if (o->op_private & HINT_STRICT_REFS)
942 sv_catpv(tmpsv, ",STRICT_REFS");
943 if (o->op_private & OPpOUR_INTRO)
944 sv_catpv(tmpsv, ",OUR_INTRO");
947 else if (optype == OP_CONST) {
948 if (o->op_private & OPpCONST_BARE)
949 sv_catpv(tmpsv, ",BARE");
950 if (o->op_private & OPpCONST_STRICT)
951 sv_catpv(tmpsv, ",STRICT");
952 if (o->op_private & OPpCONST_ARYBASE)
953 sv_catpv(tmpsv, ",ARYBASE");
954 if (o->op_private & OPpCONST_WARNING)
955 sv_catpv(tmpsv, ",WARNING");
956 if (o->op_private & OPpCONST_ENTERED)
957 sv_catpv(tmpsv, ",ENTERED");
959 else if (optype == OP_FLIP) {
960 if (o->op_private & OPpFLIP_LINENUM)
961 sv_catpv(tmpsv, ",LINENUM");
963 else if (optype == OP_FLOP) {
964 if (o->op_private & OPpFLIP_LINENUM)
965 sv_catpv(tmpsv, ",LINENUM");
967 else if (optype == OP_RV2CV) {
968 if (o->op_private & OPpLVAL_INTRO)
969 sv_catpv(tmpsv, ",INTRO");
971 else if (optype == OP_GV) {
972 if (o->op_private & OPpEARLY_CV)
973 sv_catpv(tmpsv, ",EARLY_CV");
975 else if (optype == OP_LIST) {
976 if (o->op_private & OPpLIST_GUESSED)
977 sv_catpv(tmpsv, ",GUESSED");
979 else if (optype == OP_DELETE) {
980 if (o->op_private & OPpSLICE)
981 sv_catpv(tmpsv, ",SLICE");
983 else if (optype == OP_EXISTS) {
984 if (o->op_private & OPpEXISTS_SUB)
985 sv_catpv(tmpsv, ",EXISTS_SUB");
987 else if (optype == OP_SORT) {
988 if (o->op_private & OPpSORT_NUMERIC)
989 sv_catpv(tmpsv, ",NUMERIC");
990 if (o->op_private & OPpSORT_INTEGER)
991 sv_catpv(tmpsv, ",INTEGER");
992 if (o->op_private & OPpSORT_REVERSE)
993 sv_catpv(tmpsv, ",REVERSE");
995 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
996 if (o->op_private & OPpOPEN_IN_RAW)
997 sv_catpv(tmpsv, ",IN_RAW");
998 if (o->op_private & OPpOPEN_IN_CRLF)
999 sv_catpv(tmpsv, ",IN_CRLF");
1000 if (o->op_private & OPpOPEN_OUT_RAW)
1001 sv_catpv(tmpsv, ",OUT_RAW");
1002 if (o->op_private & OPpOPEN_OUT_CRLF)
1003 sv_catpv(tmpsv, ",OUT_CRLF");
1005 else if (optype == OP_EXIT) {
1006 if (o->op_private & OPpEXIT_VMSISH)
1007 sv_catpv(tmpsv, ",EXIT_VMSISH");
1008 if (o->op_private & OPpHUSH_VMSISH)
1009 sv_catpv(tmpsv, ",HUSH_VMSISH");
1011 else if (optype == OP_DIE) {
1012 if (o->op_private & OPpHUSH_VMSISH)
1013 sv_catpv(tmpsv, ",HUSH_VMSISH");
1015 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
1016 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1017 sv_catpv(tmpsv, ",FT_ACCESS");
1018 if (o->op_private & OPpFT_STACKED)
1019 sv_catpv(tmpsv, ",FT_STACKED");
1021 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1022 sv_catpv(tmpsv, ",INTRO");
1024 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1025 SvREFCNT_dec(tmpsv);
1029 if (PL_madskills && o->op_madprop) {
1030 SV * const tmpsv = newSVpvs("");
1031 MADPROP* mp = o->op_madprop;
1032 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1035 const char tmp = mp->mad_key;
1036 sv_setpvs(tmpsv,"'");
1038 sv_catpvn(tmpsv, &tmp, 1);
1039 sv_catpv(tmpsv, "'=");
1040 switch (mp->mad_type) {
1042 sv_catpv(tmpsv, "NULL");
1043 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1046 sv_catpv(tmpsv, "<");
1047 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1048 sv_catpv(tmpsv, ">");
1049 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1052 if ((OP*)mp->mad_val) {
1053 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1054 do_op_dump(level, file, (OP*)mp->mad_val);
1058 sv_catpv(tmpsv, "(UNK)");
1059 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1065 Perl_dump_indent(aTHX_ level, file, "}\n");
1067 SvREFCNT_dec(tmpsv);
1076 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1078 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1079 if (cSVOPo->op_sv) {
1080 SV * const tmpsv = newSV(0);
1084 /* FIXME - is this making unwarranted assumptions about the
1085 UTF-8 cleanliness of the dump file handle? */
1088 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1089 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1090 SvPV_nolen_const(tmpsv));
1094 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1100 case OP_METHOD_NAMED:
1101 #ifndef USE_ITHREADS
1102 /* with ITHREADS, consts are stored in the pad, and the right pad
1103 * may not be active here, so skip */
1104 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1110 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1111 (UV)CopLINE(cCOPo));
1112 if (CopSTASHPV(cCOPo))
1113 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1115 if (CopLABEL(cCOPo))
1116 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1120 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1121 if (cLOOPo->op_redoop)
1122 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1124 PerlIO_printf(file, "DONE\n");
1125 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1126 if (cLOOPo->op_nextop)
1127 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1129 PerlIO_printf(file, "DONE\n");
1130 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1131 if (cLOOPo->op_lastop)
1132 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1134 PerlIO_printf(file, "DONE\n");
1142 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1143 if (cLOGOPo->op_other)
1144 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1146 PerlIO_printf(file, "DONE\n");
1152 do_pmop_dump(level, file, cPMOPo);
1160 if (o->op_private & OPpREFCOUNTED)
1161 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1166 if (o->op_flags & OPf_KIDS) {
1168 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1169 do_op_dump(level, file, kid);
1171 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1175 Perl_op_dump(pTHX_ const OP *o)
1177 PERL_ARGS_ASSERT_OP_DUMP;
1178 do_op_dump(0, Perl_debug_log, o);
1182 Perl_gv_dump(pTHX_ GV *gv)
1186 PERL_ARGS_ASSERT_GV_DUMP;
1189 PerlIO_printf(Perl_debug_log, "{}\n");
1192 sv = sv_newmortal();
1193 PerlIO_printf(Perl_debug_log, "{\n");
1194 gv_fullname3(sv, gv, NULL);
1195 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1196 if (gv != GvEGV(gv)) {
1197 gv_efullname3(sv, GvEGV(gv), NULL);
1198 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1200 PerlIO_putc(Perl_debug_log, '\n');
1201 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1205 /* map magic types to the symbolic names
1206 * (with the PERL_MAGIC_ prefixed stripped)
1209 static const struct { const char type; const char *name; } magic_names[] = {
1210 { PERL_MAGIC_sv, "sv(\\0)" },
1211 { PERL_MAGIC_arylen, "arylen(#)" },
1212 { PERL_MAGIC_rhash, "rhash(%)" },
1213 { PERL_MAGIC_pos, "pos(.)" },
1214 { PERL_MAGIC_symtab, "symtab(:)" },
1215 { PERL_MAGIC_backref, "backref(<)" },
1216 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1217 { PERL_MAGIC_overload, "overload(A)" },
1218 { PERL_MAGIC_bm, "bm(B)" },
1219 { PERL_MAGIC_regdata, "regdata(D)" },
1220 { PERL_MAGIC_env, "env(E)" },
1221 { PERL_MAGIC_hints, "hints(H)" },
1222 { PERL_MAGIC_isa, "isa(I)" },
1223 { PERL_MAGIC_dbfile, "dbfile(L)" },
1224 { PERL_MAGIC_shared, "shared(N)" },
1225 { PERL_MAGIC_tied, "tied(P)" },
1226 { PERL_MAGIC_sig, "sig(S)" },
1227 { PERL_MAGIC_uvar, "uvar(U)" },
1228 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1229 { PERL_MAGIC_overload_table, "overload_table(c)" },
1230 { PERL_MAGIC_regdatum, "regdatum(d)" },
1231 { PERL_MAGIC_envelem, "envelem(e)" },
1232 { PERL_MAGIC_fm, "fm(f)" },
1233 { PERL_MAGIC_regex_global, "regex_global(g)" },
1234 { PERL_MAGIC_hintselem, "hintselem(h)" },
1235 { PERL_MAGIC_isaelem, "isaelem(i)" },
1236 { PERL_MAGIC_nkeys, "nkeys(k)" },
1237 { PERL_MAGIC_dbline, "dbline(l)" },
1238 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1239 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1240 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1241 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1242 { PERL_MAGIC_qr, "qr(r)" },
1243 { PERL_MAGIC_sigelem, "sigelem(s)" },
1244 { PERL_MAGIC_taint, "taint(t)" },
1245 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1246 { PERL_MAGIC_vec, "vec(v)" },
1247 { PERL_MAGIC_vstring, "vstring(V)" },
1248 { PERL_MAGIC_utf8, "utf8(w)" },
1249 { PERL_MAGIC_substr, "substr(x)" },
1250 { PERL_MAGIC_defelem, "defelem(y)" },
1251 { PERL_MAGIC_ext, "ext(~)" },
1252 /* this null string terminates the list */
1257 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1259 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1261 for (; mg; mg = mg->mg_moremagic) {
1262 Perl_dump_indent(aTHX_ level, file,
1263 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1264 if (mg->mg_virtual) {
1265 const MGVTBL * const v = mg->mg_virtual;
1267 if (v == &PL_vtbl_sv) s = "sv";
1268 else if (v == &PL_vtbl_env) s = "env";
1269 else if (v == &PL_vtbl_envelem) s = "envelem";
1270 else if (v == &PL_vtbl_sig) s = "sig";
1271 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1272 else if (v == &PL_vtbl_pack) s = "pack";
1273 else if (v == &PL_vtbl_packelem) s = "packelem";
1274 else if (v == &PL_vtbl_dbline) s = "dbline";
1275 else if (v == &PL_vtbl_isa) s = "isa";
1276 else if (v == &PL_vtbl_arylen) s = "arylen";
1277 else if (v == &PL_vtbl_mglob) s = "mglob";
1278 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1279 else if (v == &PL_vtbl_taint) s = "taint";
1280 else if (v == &PL_vtbl_substr) s = "substr";
1281 else if (v == &PL_vtbl_vec) s = "vec";
1282 else if (v == &PL_vtbl_pos) s = "pos";
1283 else if (v == &PL_vtbl_bm) s = "bm";
1284 else if (v == &PL_vtbl_fm) s = "fm";
1285 else if (v == &PL_vtbl_uvar) s = "uvar";
1286 else if (v == &PL_vtbl_defelem) s = "defelem";
1287 #ifdef USE_LOCALE_COLLATE
1288 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1290 else if (v == &PL_vtbl_amagic) s = "amagic";
1291 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1292 else if (v == &PL_vtbl_backref) s = "backref";
1293 else if (v == &PL_vtbl_utf8) s = "utf8";
1294 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1295 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1296 else if (v == &PL_vtbl_hints) s = "hints";
1299 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1301 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1304 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1307 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1311 const char *name = NULL;
1312 for (n = 0; magic_names[n].name; n++) {
1313 if (mg->mg_type == magic_names[n].type) {
1314 name = magic_names[n].name;
1319 Perl_dump_indent(aTHX_ level, file,
1320 " MG_TYPE = PERL_MAGIC_%s\n", name);
1322 Perl_dump_indent(aTHX_ level, file,
1323 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1327 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1328 if (mg->mg_type == PERL_MAGIC_envelem &&
1329 mg->mg_flags & MGf_TAINTEDDIR)
1330 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1331 if (mg->mg_flags & MGf_REFCOUNTED)
1332 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1333 if (mg->mg_flags & MGf_GSKIP)
1334 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1335 if (mg->mg_type == PERL_MAGIC_regex_global &&
1336 mg->mg_flags & MGf_MINMATCH)
1337 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1340 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1341 PTR2UV(mg->mg_obj));
1342 if (mg->mg_type == PERL_MAGIC_qr) {
1343 REGEXP* const re = (REGEXP *)mg->mg_obj;
1344 SV * const dsv = sv_newmortal();
1345 const char * const s
1346 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1348 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1349 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1351 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1352 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1355 if (mg->mg_flags & MGf_REFCOUNTED)
1356 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1359 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1361 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1362 if (mg->mg_len >= 0) {
1363 if (mg->mg_type != PERL_MAGIC_utf8) {
1364 SV * const sv = newSVpvs("");
1365 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1369 else if (mg->mg_len == HEf_SVKEY) {
1370 PerlIO_puts(file, " => HEf_SVKEY\n");
1371 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1372 maxnest, dumpops, pvlim); /* MG is already +1 */
1375 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1380 " does not know how to handle this MG_LEN"
1382 PerlIO_putc(file, '\n');
1384 if (mg->mg_type == PERL_MAGIC_utf8) {
1385 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1388 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1389 Perl_dump_indent(aTHX_ level, file,
1390 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1393 (UV)cache[i * 2 + 1]);
1400 Perl_magic_dump(pTHX_ const MAGIC *mg)
1402 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1406 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1410 PERL_ARGS_ASSERT_DO_HV_DUMP;
1412 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1413 if (sv && (hvname = HvNAME_get(sv)))
1414 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1416 PerlIO_putc(file, '\n');
1420 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1422 PERL_ARGS_ASSERT_DO_GV_DUMP;
1424 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1425 if (sv && GvNAME(sv))
1426 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1428 PerlIO_putc(file, '\n');
1432 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1434 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1436 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1437 if (sv && GvNAME(sv)) {
1439 PerlIO_printf(file, "\t\"");
1440 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1441 PerlIO_printf(file, "%s\" :: \"", hvname);
1442 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1445 PerlIO_putc(file, '\n');
1449 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1457 PERL_ARGS_ASSERT_DO_SV_DUMP;
1460 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1464 flags = SvFLAGS(sv);
1467 d = Perl_newSVpvf(aTHX_
1468 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1469 PTR2UV(SvANY(sv)), PTR2UV(sv),
1470 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1471 (int)(PL_dumpindent*level), "");
1473 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1474 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1476 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1477 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1478 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1480 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1481 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1482 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1483 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1484 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1486 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1487 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1488 if (flags & SVf_POK) sv_catpv(d, "POK,");
1489 if (flags & SVf_ROK) {
1490 sv_catpv(d, "ROK,");
1491 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1493 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1494 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1495 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1496 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1498 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1499 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1500 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1501 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1502 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1503 if (SvPCS_IMPORTED(sv))
1504 sv_catpv(d, "PCS_IMPORTED,");
1506 sv_catpv(d, "SCREAM,");
1512 if (CvANON(sv)) sv_catpv(d, "ANON,");
1513 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1514 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1515 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1516 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1517 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1518 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1519 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1520 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1521 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1524 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1525 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1526 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1527 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1528 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1532 if (isGV_with_GP(sv)) {
1533 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1534 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1535 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1536 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1538 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1539 sv_catpv(d, "IMPORT");
1540 if (GvIMPORTED(sv) == GVf_IMPORTED)
1541 sv_catpv(d, "ALL,");
1544 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1545 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1546 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1547 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1551 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1552 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1556 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1557 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1560 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1561 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1564 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1569 /* SVphv_SHAREKEYS is also 0x20000000 */
1570 if ((type != SVt_PVHV) && SvUTF8(sv))
1571 sv_catpv(d, "UTF8");
1573 if (*(SvEND(d) - 1) == ',') {
1574 SvCUR_set(d, SvCUR(d) - 1);
1575 SvPVX(d)[SvCUR(d)] = '\0';
1580 #ifdef DEBUG_LEAKING_SCALARS
1581 Perl_dump_indent(aTHX_ level, file,
1582 "ALLOCATED at %s:%d %s %s%s; serial %"UVuf"\n",
1583 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1585 sv->sv_debug_inpad ? "for" : "by",
1586 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1587 sv->sv_debug_cloned ? " (cloned)" : "",
1591 Perl_dump_indent(aTHX_ level, file, "SV = ");
1592 if (type < SVt_LAST) {
1593 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1595 if (type == SVt_NULL) {
1600 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1604 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1605 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
1606 && type != SVt_PVIO && type != SVt_REGEXP)
1607 || (type == SVt_IV && !SvROK(sv))) {
1609 #ifdef PERL_OLD_COPY_ON_WRITE
1613 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1615 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1616 #ifdef PERL_OLD_COPY_ON_WRITE
1617 if (SvIsCOW_shared_hash(sv))
1618 PerlIO_printf(file, " (HASH)");
1619 else if (SvIsCOW_normal(sv))
1620 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1622 PerlIO_putc(file, '\n');
1624 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1625 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1626 (UV) COP_SEQ_RANGE_LOW(sv));
1627 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1628 (UV) COP_SEQ_RANGE_HIGH(sv));
1629 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1630 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1631 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1632 || type == SVt_NV) {
1633 STORE_NUMERIC_LOCAL_SET_STANDARD();
1634 /* %Vg doesn't work? --jhi */
1635 #ifdef USE_LONG_DOUBLE
1636 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1638 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1640 RESTORE_NUMERIC_LOCAL();
1643 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1645 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1647 if (type < SVt_PV) {
1651 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1652 if (SvPVX_const(sv)) {
1655 SvOOK_offset(sv, delta);
1656 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1661 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1663 PerlIO_printf(file, "( %s . ) ",
1664 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1667 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1668 if (SvUTF8(sv)) /* the 6? \x{....} */
1669 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1670 PerlIO_printf(file, "\n");
1671 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1672 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1675 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1677 if (type == SVt_REGEXP) {
1679 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1680 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1683 if (type >= SVt_PVMG) {
1684 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1685 HV * const ost = SvOURSTASH(sv);
1687 do_hv_dump(level, file, " OURSTASH", ost);
1690 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1693 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1697 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1698 if (AvARRAY(sv) != AvALLOC(sv)) {
1699 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1700 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1703 PerlIO_putc(file, '\n');
1704 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1705 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1706 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1708 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1709 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1710 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1711 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1712 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1714 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1715 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1717 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1719 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1724 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1725 if (HvARRAY(sv) && HvKEYS(sv)) {
1726 /* Show distribution of HEs in the ARRAY */
1728 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1731 U32 pow2 = 2, keys = HvKEYS(sv);
1732 NV theoret, sum = 0;
1734 PerlIO_printf(file, " (");
1735 Zero(freq, FREQ_MAX + 1, int);
1736 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1739 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1741 if (count > FREQ_MAX)
1747 for (i = 0; i <= max; i++) {
1749 PerlIO_printf(file, "%d%s:%d", i,
1750 (i == FREQ_MAX) ? "+" : "",
1753 PerlIO_printf(file, ", ");
1756 PerlIO_putc(file, ')');
1757 /* The "quality" of a hash is defined as the total number of
1758 comparisons needed to access every element once, relative
1759 to the expected number needed for a random hash.
1761 The total number of comparisons is equal to the sum of
1762 the squares of the number of entries in each bucket.
1763 For a random hash of n keys into k buckets, the expected
1768 for (i = max; i > 0; i--) { /* Precision: count down. */
1769 sum += freq[i] * i * i;
1771 while ((keys = keys >> 1))
1773 theoret = HvKEYS(sv);
1774 theoret += theoret * (theoret-1)/pow2;
1775 PerlIO_putc(file, '\n');
1776 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1778 PerlIO_putc(file, '\n');
1779 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1780 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1781 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1782 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1783 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1785 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1786 if (mg && mg->mg_obj) {
1787 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1791 const char * const hvname = HvNAME_get(sv);
1793 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1797 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1798 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1800 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1802 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1806 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1807 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1808 (int)meta->mro_which->length,
1809 meta->mro_which->name,
1810 PTR2UV(meta->mro_which));
1811 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1812 (UV)meta->cache_gen);
1813 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1815 if (meta->mro_linear_all) {
1816 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1817 PTR2UV(meta->mro_linear_all));
1818 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1821 if (meta->mro_linear_current) {
1822 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1823 PTR2UV(meta->mro_linear_current));
1824 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1827 if (meta->mro_nextmethod) {
1828 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1829 PTR2UV(meta->mro_nextmethod));
1830 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1834 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1836 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1841 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1843 HV * const hv = MUTABLE_HV(sv);
1844 int count = maxnest - nest;
1847 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1850 const U32 hash = HeHASH(he);
1851 SV * const keysv = hv_iterkeysv(he);
1852 const char * const keypv = SvPV_const(keysv, len);
1853 SV * const elt = hv_iterval(hv, he);
1855 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1857 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1859 PerlIO_printf(file, "[REHASH] ");
1860 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1861 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1863 hv_iterinit(hv); /* Return to status quo */
1869 const char *const proto = SvPV_const(sv, len);
1870 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1875 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1876 if (!CvISXSUB(sv)) {
1878 Perl_dump_indent(aTHX_ level, file,
1879 " START = 0x%"UVxf" ===> %"IVdf"\n",
1880 PTR2UV(CvSTART(sv)),
1881 (IV)sequence_num(CvSTART(sv)));
1883 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1884 PTR2UV(CvROOT(sv)));
1885 if (CvROOT(sv) && dumpops) {
1886 do_op_dump(level+1, file, CvROOT(sv));
1889 SV * const constant = cv_const_sv((const CV *)sv);
1891 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1894 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1896 PTR2UV(CvXSUBANY(sv).any_ptr));
1897 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1900 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1901 (IV)CvXSUBANY(sv).any_i32);
1904 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1905 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1906 if (type == SVt_PVCV)
1907 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1908 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1909 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1910 if (type == SVt_PVFM)
1911 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1912 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1913 if (nest < maxnest) {
1914 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1917 const CV * const outside = CvOUTSIDE(sv);
1918 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1921 : CvANON(outside) ? "ANON"
1922 : (outside == PL_main_cv) ? "MAIN"
1923 : CvUNIQUE(outside) ? "UNIQUE"
1924 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1926 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1927 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1931 if (type == SVt_PVLV) {
1932 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1933 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1934 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1935 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1936 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1937 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1941 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1942 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1943 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1944 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1946 if (!isGV_with_GP(sv))
1948 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1949 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1950 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1951 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1954 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1955 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1956 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1957 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1958 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1959 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1960 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1961 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1962 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1963 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1964 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1965 do_gv_dump (level, file, " EGV", GvEGV(sv));
1968 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1969 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1970 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1971 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1972 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1973 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1974 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1976 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1977 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1978 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1980 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1981 PTR2UV(IoTOP_GV(sv)));
1982 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1983 maxnest, dumpops, pvlim);
1985 /* Source filters hide things that are not GVs in these three, so let's
1986 be careful out there. */
1988 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1989 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1990 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1992 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1993 PTR2UV(IoFMT_GV(sv)));
1994 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1995 maxnest, dumpops, pvlim);
1997 if (IoBOTTOM_NAME(sv))
1998 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1999 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2000 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2002 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2003 PTR2UV(IoBOTTOM_GV(sv)));
2004 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2005 maxnest, dumpops, pvlim);
2007 if (isPRINT(IoTYPE(sv)))
2008 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2010 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2011 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2018 Perl_sv_dump(pTHX_ SV *sv)
2022 PERL_ARGS_ASSERT_SV_DUMP;
2025 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2027 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2031 Perl_runops_debug(pTHX)
2035 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2039 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2042 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2043 PerlIO_printf(Perl_debug_log,
2044 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2045 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2046 PTR2UV(*PL_watchaddr));
2047 if (DEBUG_s_TEST_) {
2048 if (DEBUG_v_TEST_) {
2049 PerlIO_printf(Perl_debug_log, "\n");
2057 if (DEBUG_t_TEST_) debop(PL_op);
2058 if (DEBUG_P_TEST_) debprof(PL_op);
2060 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2061 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2068 Perl_debop(pTHX_ const OP *o)
2072 PERL_ARGS_ASSERT_DEBOP;
2074 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2077 Perl_deb(aTHX_ "%s", OP_NAME(o));
2078 switch (o->op_type) {
2081 /* With ITHREADS, consts are stored in the pad, and the right pad
2082 * may not be active here, so check.
2083 * Looks like only during compiling the pads are illegal.
2086 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2088 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2093 SV * const sv = newSV(0);
2095 /* FIXME - is this making unwarranted assumptions about the
2096 UTF-8 cleanliness of the dump file handle? */
2099 gv_fullname3(sv, cGVOPo_gv, NULL);
2100 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2104 PerlIO_printf(Perl_debug_log, "(NULL)");
2110 /* print the lexical's name */
2111 CV * const cv = deb_curcv(cxstack_ix);
2114 AV * const padlist = CvPADLIST(cv);
2115 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2116 sv = *av_fetch(comppad, o->op_targ, FALSE);
2120 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2122 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2128 PerlIO_printf(Perl_debug_log, "\n");
2133 S_deb_curcv(pTHX_ const I32 ix)
2136 const PERL_CONTEXT * const cx = &cxstack[ix];
2137 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2138 return cx->blk_sub.cv;
2139 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2141 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2146 return deb_curcv(ix - 1);
2150 Perl_watch(pTHX_ char **addr)
2154 PERL_ARGS_ASSERT_WATCH;
2156 PL_watchaddr = addr;
2158 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2159 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2163 S_debprof(pTHX_ const OP *o)
2167 PERL_ARGS_ASSERT_DEBPROF;
2169 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2171 if (!PL_profiledata)
2172 Newxz(PL_profiledata, MAXO, U32);
2173 ++PL_profiledata[o->op_type];
2177 Perl_debprofdump(pTHX)
2181 if (!PL_profiledata)
2183 for (i = 0; i < MAXO; i++) {
2184 if (PL_profiledata[i])
2185 PerlIO_printf(Perl_debug_log,
2186 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2193 * XML variants of most of the above routines
2197 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2201 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2203 PerlIO_printf(file, "\n ");
2204 va_start(args, pat);
2205 xmldump_vindent(level, file, pat, &args);
2211 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2214 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2215 va_start(args, pat);
2216 xmldump_vindent(level, file, pat, &args);
2221 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2223 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2225 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2226 PerlIO_vprintf(file, pat, *args);
2230 Perl_xmldump_all(pTHX)
2232 xmldump_all_perl(FALSE);
2236 Perl_xmldump_all_perl(pTHX_ bool justperl)
2238 PerlIO_setlinebuf(PL_xmlfp);
2240 op_xmldump(PL_main_root);
2241 xmldump_packsubs_perl(PL_defstash, justperl);
2242 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2243 PerlIO_close(PL_xmlfp);
2248 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2250 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2251 xmldump_packsubs_perl(stash, FALSE);
2255 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2260 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2262 if (!HvARRAY(stash))
2264 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2265 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2266 GV *gv = MUTABLE_GV(HeVAL(entry));
2268 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2271 xmldump_sub_perl(gv, justperl);
2274 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2275 && (hv = GvHV(gv)) && hv != PL_defstash)
2276 xmldump_packsubs_perl(hv, justperl); /* nested package */
2282 Perl_xmldump_sub(pTHX_ const GV *gv)
2284 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2285 xmldump_sub_perl(gv, FALSE);
2289 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2293 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2295 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2298 sv = sv_newmortal();
2299 gv_fullname3(sv, gv, NULL);
2300 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2301 if (CvXSUB(GvCV(gv)))
2302 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2303 PTR2UV(CvXSUB(GvCV(gv))),
2304 (int)CvXSUBANY(GvCV(gv)).any_i32);
2305 else if (CvROOT(GvCV(gv)))
2306 op_xmldump(CvROOT(GvCV(gv)));
2308 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2312 Perl_xmldump_form(pTHX_ const GV *gv)
2314 SV * const sv = sv_newmortal();
2316 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2318 gv_fullname3(sv, gv, NULL);
2319 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2320 if (CvROOT(GvFORM(gv)))
2321 op_xmldump(CvROOT(GvFORM(gv)));
2323 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2327 Perl_xmldump_eval(pTHX)
2329 op_xmldump(PL_eval_root);
2333 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2335 PERL_ARGS_ASSERT_SV_CATXMLSV;
2336 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2340 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2343 const char * const e = pv + len;
2344 const char * const start = pv;
2348 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2351 dsvcur = SvCUR(dsv); /* in case we have to restart */
2356 c = utf8_to_uvchr((U8*)pv, &cl);
2358 SvCUR(dsv) = dsvcur;
2423 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2426 sv_catpvs(dsv, "<");
2429 sv_catpvs(dsv, ">");
2432 sv_catpvs(dsv, "&");
2435 sv_catpvs(dsv, """);
2439 if (c < 32 || c > 127) {
2440 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2443 const char string = (char) c;
2444 sv_catpvn(dsv, &string, 1);
2448 if ((c >= 0xD800 && c <= 0xDB7F) ||
2449 (c >= 0xDC00 && c <= 0xDFFF) ||
2450 (c >= 0xFFF0 && c <= 0xFFFF) ||
2452 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2454 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2467 Perl_sv_xmlpeek(pTHX_ SV *sv)
2469 SV * const t = sv_newmortal();
2473 PERL_ARGS_ASSERT_SV_XMLPEEK;
2479 sv_catpv(t, "VOID=\"\"");
2482 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2483 sv_catpv(t, "WILD=\"\"");
2486 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2487 if (sv == &PL_sv_undef) {
2488 sv_catpv(t, "SV_UNDEF=\"1\"");
2489 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2490 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2494 else if (sv == &PL_sv_no) {
2495 sv_catpv(t, "SV_NO=\"1\"");
2496 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2497 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2498 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2499 SVp_POK|SVp_NOK)) &&
2504 else if (sv == &PL_sv_yes) {
2505 sv_catpv(t, "SV_YES=\"1\"");
2506 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2507 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2508 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2509 SVp_POK|SVp_NOK)) &&
2511 SvPVX(sv) && *SvPVX(sv) == '1' &&
2516 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2517 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2518 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2522 sv_catpv(t, " XXX=\"\" ");
2524 else if (SvREFCNT(sv) == 0) {
2525 sv_catpv(t, " refcnt=\"0\"");
2528 else if (DEBUG_R_TEST_) {
2531 /* is this SV on the tmps stack? */
2532 for (ix=PL_tmps_ix; ix>=0; ix--) {
2533 if (PL_tmps_stack[ix] == sv) {
2538 if (SvREFCNT(sv) > 1)
2539 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2542 sv_catpv(t, " DRT=\"<T>\"");
2546 sv_catpv(t, " ROK=\"\"");
2548 switch (SvTYPE(sv)) {
2550 sv_catpv(t, " FREED=\"1\"");
2554 sv_catpv(t, " UNDEF=\"1\"");
2557 sv_catpv(t, " IV=\"");
2560 sv_catpv(t, " NV=\"");
2563 sv_catpv(t, " PV=\"");
2566 sv_catpv(t, " PVIV=\"");
2569 sv_catpv(t, " PVNV=\"");
2572 sv_catpv(t, " PVMG=\"");
2575 sv_catpv(t, " PVLV=\"");
2578 sv_catpv(t, " AV=\"");
2581 sv_catpv(t, " HV=\"");
2585 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2587 sv_catpv(t, " CV=\"()\"");
2590 sv_catpv(t, " GV=\"");
2593 sv_catpv(t, " BIND=\"");
2596 sv_catpv(t, " ORANGE=\"");
2599 sv_catpv(t, " FM=\"");
2602 sv_catpv(t, " IO=\"");
2611 else if (SvNOKp(sv)) {
2612 STORE_NUMERIC_LOCAL_SET_STANDARD();
2613 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2614 RESTORE_NUMERIC_LOCAL();
2616 else if (SvIOKp(sv)) {
2618 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2620 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2629 return SvPV(t, n_a);
2633 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2635 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2638 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2641 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2644 REGEXP *const r = PM_GETRE(pm);
2645 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2646 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2647 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2649 SvREFCNT_dec(tmpsv);
2650 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2651 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2654 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2655 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2656 SV * const tmpsv = pm_description(pm);
2657 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2658 SvREFCNT_dec(tmpsv);
2662 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2663 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2664 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2665 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2666 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2667 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2670 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2674 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2676 do_pmop_xmldump(0, PL_xmlfp, pm);
2680 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2685 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2690 seq = sequence_num(o);
2691 Perl_xmldump_indent(aTHX_ level, file,
2692 "<op_%s seq=\"%"UVuf" -> ",
2697 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2698 sequence_num(o->op_next));
2700 PerlIO_printf(file, "DONE\"");
2703 if (o->op_type == OP_NULL)
2705 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2706 if (o->op_targ == OP_NEXTSTATE)
2709 PerlIO_printf(file, " line=\"%"UVuf"\"",
2710 (UV)CopLINE(cCOPo));
2711 if (CopSTASHPV(cCOPo))
2712 PerlIO_printf(file, " package=\"%s\"",
2714 if (CopLABEL(cCOPo))
2715 PerlIO_printf(file, " label=\"%s\"",
2720 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2723 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2726 SV * const tmpsv = newSVpvs("");
2727 switch (o->op_flags & OPf_WANT) {
2729 sv_catpv(tmpsv, ",VOID");
2731 case OPf_WANT_SCALAR:
2732 sv_catpv(tmpsv, ",SCALAR");
2735 sv_catpv(tmpsv, ",LIST");
2738 sv_catpv(tmpsv, ",UNKNOWN");
2741 if (o->op_flags & OPf_KIDS)
2742 sv_catpv(tmpsv, ",KIDS");
2743 if (o->op_flags & OPf_PARENS)
2744 sv_catpv(tmpsv, ",PARENS");
2745 if (o->op_flags & OPf_STACKED)
2746 sv_catpv(tmpsv, ",STACKED");
2747 if (o->op_flags & OPf_REF)
2748 sv_catpv(tmpsv, ",REF");
2749 if (o->op_flags & OPf_MOD)
2750 sv_catpv(tmpsv, ",MOD");
2751 if (o->op_flags & OPf_SPECIAL)
2752 sv_catpv(tmpsv, ",SPECIAL");
2753 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2754 SvREFCNT_dec(tmpsv);
2756 if (o->op_private) {
2757 SV * const tmpsv = newSVpvs("");
2758 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2759 if (o->op_private & OPpTARGET_MY)
2760 sv_catpv(tmpsv, ",TARGET_MY");
2762 else if (o->op_type == OP_LEAVESUB ||
2763 o->op_type == OP_LEAVE ||
2764 o->op_type == OP_LEAVESUBLV ||
2765 o->op_type == OP_LEAVEWRITE) {
2766 if (o->op_private & OPpREFCOUNTED)
2767 sv_catpv(tmpsv, ",REFCOUNTED");
2769 else if (o->op_type == OP_AASSIGN) {
2770 if (o->op_private & OPpASSIGN_COMMON)
2771 sv_catpv(tmpsv, ",COMMON");
2773 else if (o->op_type == OP_SASSIGN) {
2774 if (o->op_private & OPpASSIGN_BACKWARDS)
2775 sv_catpv(tmpsv, ",BACKWARDS");
2777 else if (o->op_type == OP_TRANS) {
2778 if (o->op_private & OPpTRANS_SQUASH)
2779 sv_catpv(tmpsv, ",SQUASH");
2780 if (o->op_private & OPpTRANS_DELETE)
2781 sv_catpv(tmpsv, ",DELETE");
2782 if (o->op_private & OPpTRANS_COMPLEMENT)
2783 sv_catpv(tmpsv, ",COMPLEMENT");
2784 if (o->op_private & OPpTRANS_IDENTICAL)
2785 sv_catpv(tmpsv, ",IDENTICAL");
2786 if (o->op_private & OPpTRANS_GROWS)
2787 sv_catpv(tmpsv, ",GROWS");
2789 else if (o->op_type == OP_REPEAT) {
2790 if (o->op_private & OPpREPEAT_DOLIST)
2791 sv_catpv(tmpsv, ",DOLIST");
2793 else if (o->op_type == OP_ENTERSUB ||
2794 o->op_type == OP_RV2SV ||
2795 o->op_type == OP_GVSV ||
2796 o->op_type == OP_RV2AV ||
2797 o->op_type == OP_RV2HV ||
2798 o->op_type == OP_RV2GV ||
2799 o->op_type == OP_AELEM ||
2800 o->op_type == OP_HELEM )
2802 if (o->op_type == OP_ENTERSUB) {
2803 if (o->op_private & OPpENTERSUB_AMPER)
2804 sv_catpv(tmpsv, ",AMPER");
2805 if (o->op_private & OPpENTERSUB_DB)
2806 sv_catpv(tmpsv, ",DB");
2807 if (o->op_private & OPpENTERSUB_HASTARG)
2808 sv_catpv(tmpsv, ",HASTARG");
2809 if (o->op_private & OPpENTERSUB_NOPAREN)
2810 sv_catpv(tmpsv, ",NOPAREN");
2811 if (o->op_private & OPpENTERSUB_INARGS)
2812 sv_catpv(tmpsv, ",INARGS");
2813 if (o->op_private & OPpENTERSUB_NOMOD)
2814 sv_catpv(tmpsv, ",NOMOD");
2817 switch (o->op_private & OPpDEREF) {
2819 sv_catpv(tmpsv, ",SV");
2822 sv_catpv(tmpsv, ",AV");
2825 sv_catpv(tmpsv, ",HV");
2828 if (o->op_private & OPpMAYBE_LVSUB)
2829 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2831 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2832 if (o->op_private & OPpLVAL_DEFER)
2833 sv_catpv(tmpsv, ",LVAL_DEFER");
2836 if (o->op_private & HINT_STRICT_REFS)
2837 sv_catpv(tmpsv, ",STRICT_REFS");
2838 if (o->op_private & OPpOUR_INTRO)
2839 sv_catpv(tmpsv, ",OUR_INTRO");
2842 else if (o->op_type == OP_CONST) {
2843 if (o->op_private & OPpCONST_BARE)
2844 sv_catpv(tmpsv, ",BARE");
2845 if (o->op_private & OPpCONST_STRICT)
2846 sv_catpv(tmpsv, ",STRICT");
2847 if (o->op_private & OPpCONST_ARYBASE)
2848 sv_catpv(tmpsv, ",ARYBASE");
2849 if (o->op_private & OPpCONST_WARNING)
2850 sv_catpv(tmpsv, ",WARNING");
2851 if (o->op_private & OPpCONST_ENTERED)
2852 sv_catpv(tmpsv, ",ENTERED");
2854 else if (o->op_type == OP_FLIP) {
2855 if (o->op_private & OPpFLIP_LINENUM)
2856 sv_catpv(tmpsv, ",LINENUM");
2858 else if (o->op_type == OP_FLOP) {
2859 if (o->op_private & OPpFLIP_LINENUM)
2860 sv_catpv(tmpsv, ",LINENUM");
2862 else if (o->op_type == OP_RV2CV) {
2863 if (o->op_private & OPpLVAL_INTRO)
2864 sv_catpv(tmpsv, ",INTRO");
2866 else if (o->op_type == OP_GV) {
2867 if (o->op_private & OPpEARLY_CV)
2868 sv_catpv(tmpsv, ",EARLY_CV");
2870 else if (o->op_type == OP_LIST) {
2871 if (o->op_private & OPpLIST_GUESSED)
2872 sv_catpv(tmpsv, ",GUESSED");
2874 else if (o->op_type == OP_DELETE) {
2875 if (o->op_private & OPpSLICE)
2876 sv_catpv(tmpsv, ",SLICE");
2878 else if (o->op_type == OP_EXISTS) {
2879 if (o->op_private & OPpEXISTS_SUB)
2880 sv_catpv(tmpsv, ",EXISTS_SUB");
2882 else if (o->op_type == OP_SORT) {
2883 if (o->op_private & OPpSORT_NUMERIC)
2884 sv_catpv(tmpsv, ",NUMERIC");
2885 if (o->op_private & OPpSORT_INTEGER)
2886 sv_catpv(tmpsv, ",INTEGER");
2887 if (o->op_private & OPpSORT_REVERSE)
2888 sv_catpv(tmpsv, ",REVERSE");
2890 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2891 if (o->op_private & OPpOPEN_IN_RAW)
2892 sv_catpv(tmpsv, ",IN_RAW");
2893 if (o->op_private & OPpOPEN_IN_CRLF)
2894 sv_catpv(tmpsv, ",IN_CRLF");
2895 if (o->op_private & OPpOPEN_OUT_RAW)
2896 sv_catpv(tmpsv, ",OUT_RAW");
2897 if (o->op_private & OPpOPEN_OUT_CRLF)
2898 sv_catpv(tmpsv, ",OUT_CRLF");
2900 else if (o->op_type == OP_EXIT) {
2901 if (o->op_private & OPpEXIT_VMSISH)
2902 sv_catpv(tmpsv, ",EXIT_VMSISH");
2903 if (o->op_private & OPpHUSH_VMSISH)
2904 sv_catpv(tmpsv, ",HUSH_VMSISH");
2906 else if (o->op_type == OP_DIE) {
2907 if (o->op_private & OPpHUSH_VMSISH)
2908 sv_catpv(tmpsv, ",HUSH_VMSISH");
2910 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2911 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2912 sv_catpv(tmpsv, ",FT_ACCESS");
2913 if (o->op_private & OPpFT_STACKED)
2914 sv_catpv(tmpsv, ",FT_STACKED");
2916 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2917 sv_catpv(tmpsv, ",INTRO");
2919 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2920 SvREFCNT_dec(tmpsv);
2923 switch (o->op_type) {
2925 if (o->op_flags & OPf_SPECIAL) {
2931 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2933 if (cSVOPo->op_sv) {
2934 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2935 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2941 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2942 s = SvPV(tmpsv1,len);
2943 sv_catxmlpvn(tmpsv2, s, len, 1);
2944 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2948 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2953 case OP_METHOD_NAMED:
2954 #ifndef USE_ITHREADS
2955 /* with ITHREADS, consts are stored in the pad, and the right pad
2956 * may not be active here, so skip */
2957 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2963 PerlIO_printf(file, ">\n");
2965 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2970 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2971 (UV)CopLINE(cCOPo));
2972 if (CopSTASHPV(cCOPo))
2973 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2975 if (CopLABEL(cCOPo))
2976 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2980 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2981 if (cLOOPo->op_redoop)
2982 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2984 PerlIO_printf(file, "DONE\"");
2985 S_xmldump_attr(aTHX_ level, file, "next=\"");
2986 if (cLOOPo->op_nextop)
2987 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2989 PerlIO_printf(file, "DONE\"");
2990 S_xmldump_attr(aTHX_ level, file, "last=\"");
2991 if (cLOOPo->op_lastop)
2992 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2994 PerlIO_printf(file, "DONE\"");
3002 S_xmldump_attr(aTHX_ level, file, "other=\"");
3003 if (cLOGOPo->op_other)
3004 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3006 PerlIO_printf(file, "DONE\"");
3014 if (o->op_private & OPpREFCOUNTED)
3015 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3021 if (PL_madskills && o->op_madprop) {
3022 char prevkey = '\0';
3023 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3024 const MADPROP* mp = o->op_madprop;
3028 PerlIO_printf(file, ">\n");
3030 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3033 char tmp = mp->mad_key;
3034 sv_setpvs(tmpsv,"\"");
3036 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3037 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3038 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3041 sv_catpv(tmpsv, "\"");
3042 switch (mp->mad_type) {
3044 sv_catpv(tmpsv, "NULL");
3045 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3048 sv_catpv(tmpsv, " val=\"");
3049 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3050 sv_catpv(tmpsv, "\"");
3051 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3054 sv_catpv(tmpsv, " val=\"");
3055 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3056 sv_catpv(tmpsv, "\"");
3057 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3060 if ((OP*)mp->mad_val) {
3061 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3062 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3063 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3067 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3073 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3075 SvREFCNT_dec(tmpsv);
3078 switch (o->op_type) {
3085 PerlIO_printf(file, ">\n");
3087 do_pmop_xmldump(level, file, cPMOPo);
3093 if (o->op_flags & OPf_KIDS) {
3097 PerlIO_printf(file, ">\n");
3099 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3100 do_op_xmldump(level, file, kid);
3104 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3106 PerlIO_printf(file, " />\n");
3110 Perl_op_xmldump(pTHX_ const OP *o)
3112 PERL_ARGS_ASSERT_OP_XMLDUMP;
3114 do_op_xmldump(0, PL_xmlfp, o);
3120 * c-indentation-style: bsd
3122 * indent-tabs-mode: t
3125 * ex: set ts=8 sts=4 sw=4 noet: