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");
652 Perl_pmop_dump(pTHX_ PMOP *pm)
654 do_pmop_dump(0, Perl_debug_log, pm);
657 /* An op sequencer. We visit the ops in the order they're to execute. */
660 S_sequence(pTHX_ register const OP *o)
663 const OP *oldop = NULL;
676 for (; o; o = o->op_next) {
678 SV * const op = newSVuv(PTR2UV(o));
679 const char * const key = SvPV_const(op, len);
681 if (hv_exists(Sequence, key, len))
684 switch (o->op_type) {
686 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
687 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
696 if (oldop && o->op_next)
703 if (oldop && o->op_next)
705 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
718 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
719 sequence_tail(cLOGOPo->op_other);
724 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
725 sequence_tail(cLOOPo->op_redoop);
726 sequence_tail(cLOOPo->op_nextop);
727 sequence_tail(cLOOPo->op_lastop);
731 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
732 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
741 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
749 S_sequence_tail(pTHX_ const OP *o)
751 while (o && (o->op_type == OP_NULL))
757 S_sequence_num(pTHX_ const OP *o)
765 op = newSVuv(PTR2UV(o));
766 key = SvPV_const(op, len);
767 seq = hv_fetch(Sequence, key, len, 0);
768 return seq ? SvUV(*seq): 0;
772 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
776 const OPCODE optype = o->op_type;
778 PERL_ARGS_ASSERT_DO_OP_DUMP;
781 Perl_dump_indent(aTHX_ level, file, "{\n");
783 seq = sequence_num(o);
785 PerlIO_printf(file, "%-4"UVuf, seq);
787 PerlIO_printf(file, " ");
789 "%*sTYPE = %s ===> ",
790 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
792 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
793 sequence_num(o->op_next));
795 PerlIO_printf(file, "DONE\n");
797 if (optype == OP_NULL) {
798 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
799 if (o->op_targ == OP_NEXTSTATE) {
801 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
803 if (CopSTASHPV(cCOPo))
804 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
807 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
812 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
815 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
817 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
818 SV * const tmpsv = newSVpvs("");
819 switch (o->op_flags & OPf_WANT) {
821 sv_catpv(tmpsv, ",VOID");
823 case OPf_WANT_SCALAR:
824 sv_catpv(tmpsv, ",SCALAR");
827 sv_catpv(tmpsv, ",LIST");
830 sv_catpv(tmpsv, ",UNKNOWN");
833 if (o->op_flags & OPf_KIDS)
834 sv_catpv(tmpsv, ",KIDS");
835 if (o->op_flags & OPf_PARENS)
836 sv_catpv(tmpsv, ",PARENS");
837 if (o->op_flags & OPf_STACKED)
838 sv_catpv(tmpsv, ",STACKED");
839 if (o->op_flags & OPf_REF)
840 sv_catpv(tmpsv, ",REF");
841 if (o->op_flags & OPf_MOD)
842 sv_catpv(tmpsv, ",MOD");
843 if (o->op_flags & OPf_SPECIAL)
844 sv_catpv(tmpsv, ",SPECIAL");
846 sv_catpv(tmpsv, ",LATEFREE");
848 sv_catpv(tmpsv, ",LATEFREED");
850 sv_catpv(tmpsv, ",ATTACHED");
851 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
855 SV * const tmpsv = newSVpvs("");
856 if (PL_opargs[optype] & OA_TARGLEX) {
857 if (o->op_private & OPpTARGET_MY)
858 sv_catpv(tmpsv, ",TARGET_MY");
860 else if (optype == OP_LEAVESUB ||
861 optype == OP_LEAVE ||
862 optype == OP_LEAVESUBLV ||
863 optype == OP_LEAVEWRITE) {
864 if (o->op_private & OPpREFCOUNTED)
865 sv_catpv(tmpsv, ",REFCOUNTED");
867 else if (optype == OP_AASSIGN) {
868 if (o->op_private & OPpASSIGN_COMMON)
869 sv_catpv(tmpsv, ",COMMON");
871 else if (optype == OP_SASSIGN) {
872 if (o->op_private & OPpASSIGN_BACKWARDS)
873 sv_catpv(tmpsv, ",BACKWARDS");
875 else if (optype == OP_TRANS) {
876 if (o->op_private & OPpTRANS_SQUASH)
877 sv_catpv(tmpsv, ",SQUASH");
878 if (o->op_private & OPpTRANS_DELETE)
879 sv_catpv(tmpsv, ",DELETE");
880 if (o->op_private & OPpTRANS_COMPLEMENT)
881 sv_catpv(tmpsv, ",COMPLEMENT");
882 if (o->op_private & OPpTRANS_IDENTICAL)
883 sv_catpv(tmpsv, ",IDENTICAL");
884 if (o->op_private & OPpTRANS_GROWS)
885 sv_catpv(tmpsv, ",GROWS");
887 else if (optype == OP_REPEAT) {
888 if (o->op_private & OPpREPEAT_DOLIST)
889 sv_catpv(tmpsv, ",DOLIST");
891 else if (optype == OP_ENTERSUB ||
892 optype == OP_RV2SV ||
894 optype == OP_RV2AV ||
895 optype == OP_RV2HV ||
896 optype == OP_RV2GV ||
897 optype == OP_AELEM ||
900 if (optype == OP_ENTERSUB) {
901 if (o->op_private & OPpENTERSUB_AMPER)
902 sv_catpv(tmpsv, ",AMPER");
903 if (o->op_private & OPpENTERSUB_DB)
904 sv_catpv(tmpsv, ",DB");
905 if (o->op_private & OPpENTERSUB_HASTARG)
906 sv_catpv(tmpsv, ",HASTARG");
907 if (o->op_private & OPpENTERSUB_NOPAREN)
908 sv_catpv(tmpsv, ",NOPAREN");
909 if (o->op_private & OPpENTERSUB_INARGS)
910 sv_catpv(tmpsv, ",INARGS");
911 if (o->op_private & OPpENTERSUB_NOMOD)
912 sv_catpv(tmpsv, ",NOMOD");
915 switch (o->op_private & OPpDEREF) {
917 sv_catpv(tmpsv, ",SV");
920 sv_catpv(tmpsv, ",AV");
923 sv_catpv(tmpsv, ",HV");
926 if (o->op_private & OPpMAYBE_LVSUB)
927 sv_catpv(tmpsv, ",MAYBE_LVSUB");
929 if (optype == OP_AELEM || optype == OP_HELEM) {
930 if (o->op_private & OPpLVAL_DEFER)
931 sv_catpv(tmpsv, ",LVAL_DEFER");
934 if (o->op_private & HINT_STRICT_REFS)
935 sv_catpv(tmpsv, ",STRICT_REFS");
936 if (o->op_private & OPpOUR_INTRO)
937 sv_catpv(tmpsv, ",OUR_INTRO");
940 else if (optype == OP_CONST) {
941 if (o->op_private & OPpCONST_BARE)
942 sv_catpv(tmpsv, ",BARE");
943 if (o->op_private & OPpCONST_STRICT)
944 sv_catpv(tmpsv, ",STRICT");
945 if (o->op_private & OPpCONST_ARYBASE)
946 sv_catpv(tmpsv, ",ARYBASE");
947 if (o->op_private & OPpCONST_WARNING)
948 sv_catpv(tmpsv, ",WARNING");
949 if (o->op_private & OPpCONST_ENTERED)
950 sv_catpv(tmpsv, ",ENTERED");
952 else if (optype == OP_FLIP) {
953 if (o->op_private & OPpFLIP_LINENUM)
954 sv_catpv(tmpsv, ",LINENUM");
956 else if (optype == OP_FLOP) {
957 if (o->op_private & OPpFLIP_LINENUM)
958 sv_catpv(tmpsv, ",LINENUM");
960 else if (optype == OP_RV2CV) {
961 if (o->op_private & OPpLVAL_INTRO)
962 sv_catpv(tmpsv, ",INTRO");
964 else if (optype == OP_GV) {
965 if (o->op_private & OPpEARLY_CV)
966 sv_catpv(tmpsv, ",EARLY_CV");
968 else if (optype == OP_LIST) {
969 if (o->op_private & OPpLIST_GUESSED)
970 sv_catpv(tmpsv, ",GUESSED");
972 else if (optype == OP_DELETE) {
973 if (o->op_private & OPpSLICE)
974 sv_catpv(tmpsv, ",SLICE");
976 else if (optype == OP_EXISTS) {
977 if (o->op_private & OPpEXISTS_SUB)
978 sv_catpv(tmpsv, ",EXISTS_SUB");
980 else if (optype == OP_SORT) {
981 if (o->op_private & OPpSORT_NUMERIC)
982 sv_catpv(tmpsv, ",NUMERIC");
983 if (o->op_private & OPpSORT_INTEGER)
984 sv_catpv(tmpsv, ",INTEGER");
985 if (o->op_private & OPpSORT_REVERSE)
986 sv_catpv(tmpsv, ",REVERSE");
988 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
989 if (o->op_private & OPpOPEN_IN_RAW)
990 sv_catpv(tmpsv, ",IN_RAW");
991 if (o->op_private & OPpOPEN_IN_CRLF)
992 sv_catpv(tmpsv, ",IN_CRLF");
993 if (o->op_private & OPpOPEN_OUT_RAW)
994 sv_catpv(tmpsv, ",OUT_RAW");
995 if (o->op_private & OPpOPEN_OUT_CRLF)
996 sv_catpv(tmpsv, ",OUT_CRLF");
998 else if (optype == OP_EXIT) {
999 if (o->op_private & OPpEXIT_VMSISH)
1000 sv_catpv(tmpsv, ",EXIT_VMSISH");
1001 if (o->op_private & OPpHUSH_VMSISH)
1002 sv_catpv(tmpsv, ",HUSH_VMSISH");
1004 else if (optype == OP_DIE) {
1005 if (o->op_private & OPpHUSH_VMSISH)
1006 sv_catpv(tmpsv, ",HUSH_VMSISH");
1008 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
1009 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1010 sv_catpv(tmpsv, ",FT_ACCESS");
1011 if (o->op_private & OPpFT_STACKED)
1012 sv_catpv(tmpsv, ",FT_STACKED");
1014 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1015 sv_catpv(tmpsv, ",INTRO");
1017 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1018 SvREFCNT_dec(tmpsv);
1022 if (PL_madskills && o->op_madprop) {
1023 SV * const tmpsv = newSVpvs("");
1024 MADPROP* mp = o->op_madprop;
1025 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1028 const char tmp = mp->mad_key;
1029 sv_setpvs(tmpsv,"'");
1031 sv_catpvn(tmpsv, &tmp, 1);
1032 sv_catpv(tmpsv, "'=");
1033 switch (mp->mad_type) {
1035 sv_catpv(tmpsv, "NULL");
1036 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1039 sv_catpv(tmpsv, "<");
1040 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1041 sv_catpv(tmpsv, ">");
1042 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1045 if ((OP*)mp->mad_val) {
1046 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1047 do_op_dump(level, file, (OP*)mp->mad_val);
1051 sv_catpv(tmpsv, "(UNK)");
1052 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1058 Perl_dump_indent(aTHX_ level, file, "}\n");
1060 SvREFCNT_dec(tmpsv);
1069 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1071 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1072 if (cSVOPo->op_sv) {
1073 SV * const tmpsv = newSV(0);
1077 /* FIXME - is this making unwarranted assumptions about the
1078 UTF-8 cleanliness of the dump file handle? */
1081 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1082 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1083 SvPV_nolen_const(tmpsv));
1087 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1093 case OP_METHOD_NAMED:
1094 #ifndef USE_ITHREADS
1095 /* with ITHREADS, consts are stored in the pad, and the right pad
1096 * may not be active here, so skip */
1097 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1103 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1104 (UV)CopLINE(cCOPo));
1105 if (CopSTASHPV(cCOPo))
1106 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1108 if (CopLABEL(cCOPo))
1109 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1113 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1114 if (cLOOPo->op_redoop)
1115 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1117 PerlIO_printf(file, "DONE\n");
1118 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1119 if (cLOOPo->op_nextop)
1120 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1122 PerlIO_printf(file, "DONE\n");
1123 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1124 if (cLOOPo->op_lastop)
1125 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1127 PerlIO_printf(file, "DONE\n");
1135 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1136 if (cLOGOPo->op_other)
1137 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1139 PerlIO_printf(file, "DONE\n");
1145 do_pmop_dump(level, file, cPMOPo);
1153 if (o->op_private & OPpREFCOUNTED)
1154 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1159 if (o->op_flags & OPf_KIDS) {
1161 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1162 do_op_dump(level, file, kid);
1164 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1168 Perl_op_dump(pTHX_ const OP *o)
1170 PERL_ARGS_ASSERT_OP_DUMP;
1171 do_op_dump(0, Perl_debug_log, o);
1175 Perl_gv_dump(pTHX_ GV *gv)
1179 PERL_ARGS_ASSERT_GV_DUMP;
1182 PerlIO_printf(Perl_debug_log, "{}\n");
1185 sv = sv_newmortal();
1186 PerlIO_printf(Perl_debug_log, "{\n");
1187 gv_fullname3(sv, gv, NULL);
1188 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1189 if (gv != GvEGV(gv)) {
1190 gv_efullname3(sv, GvEGV(gv), NULL);
1191 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1193 PerlIO_putc(Perl_debug_log, '\n');
1194 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1198 /* map magic types to the symbolic names
1199 * (with the PERL_MAGIC_ prefixed stripped)
1202 static const struct { const char type; const char *name; } magic_names[] = {
1203 { PERL_MAGIC_sv, "sv(\\0)" },
1204 { PERL_MAGIC_arylen, "arylen(#)" },
1205 { PERL_MAGIC_rhash, "rhash(%)" },
1206 { PERL_MAGIC_pos, "pos(.)" },
1207 { PERL_MAGIC_symtab, "symtab(:)" },
1208 { PERL_MAGIC_backref, "backref(<)" },
1209 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1210 { PERL_MAGIC_overload, "overload(A)" },
1211 { PERL_MAGIC_bm, "bm(B)" },
1212 { PERL_MAGIC_regdata, "regdata(D)" },
1213 { PERL_MAGIC_env, "env(E)" },
1214 { PERL_MAGIC_hints, "hints(H)" },
1215 { PERL_MAGIC_isa, "isa(I)" },
1216 { PERL_MAGIC_dbfile, "dbfile(L)" },
1217 { PERL_MAGIC_shared, "shared(N)" },
1218 { PERL_MAGIC_tied, "tied(P)" },
1219 { PERL_MAGIC_sig, "sig(S)" },
1220 { PERL_MAGIC_uvar, "uvar(U)" },
1221 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1222 { PERL_MAGIC_overload_table, "overload_table(c)" },
1223 { PERL_MAGIC_regdatum, "regdatum(d)" },
1224 { PERL_MAGIC_envelem, "envelem(e)" },
1225 { PERL_MAGIC_fm, "fm(f)" },
1226 { PERL_MAGIC_regex_global, "regex_global(g)" },
1227 { PERL_MAGIC_hintselem, "hintselem(h)" },
1228 { PERL_MAGIC_isaelem, "isaelem(i)" },
1229 { PERL_MAGIC_nkeys, "nkeys(k)" },
1230 { PERL_MAGIC_dbline, "dbline(l)" },
1231 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1232 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1233 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1234 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1235 { PERL_MAGIC_qr, "qr(r)" },
1236 { PERL_MAGIC_sigelem, "sigelem(s)" },
1237 { PERL_MAGIC_taint, "taint(t)" },
1238 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1239 { PERL_MAGIC_vec, "vec(v)" },
1240 { PERL_MAGIC_vstring, "vstring(V)" },
1241 { PERL_MAGIC_utf8, "utf8(w)" },
1242 { PERL_MAGIC_substr, "substr(x)" },
1243 { PERL_MAGIC_defelem, "defelem(y)" },
1244 { PERL_MAGIC_ext, "ext(~)" },
1245 /* this null string terminates the list */
1250 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1252 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1254 for (; mg; mg = mg->mg_moremagic) {
1255 Perl_dump_indent(aTHX_ level, file,
1256 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1257 if (mg->mg_virtual) {
1258 const MGVTBL * const v = mg->mg_virtual;
1260 if (v == &PL_vtbl_sv) s = "sv";
1261 else if (v == &PL_vtbl_env) s = "env";
1262 else if (v == &PL_vtbl_envelem) s = "envelem";
1263 else if (v == &PL_vtbl_sig) s = "sig";
1264 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1265 else if (v == &PL_vtbl_pack) s = "pack";
1266 else if (v == &PL_vtbl_packelem) s = "packelem";
1267 else if (v == &PL_vtbl_dbline) s = "dbline";
1268 else if (v == &PL_vtbl_isa) s = "isa";
1269 else if (v == &PL_vtbl_arylen) s = "arylen";
1270 else if (v == &PL_vtbl_mglob) s = "mglob";
1271 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1272 else if (v == &PL_vtbl_taint) s = "taint";
1273 else if (v == &PL_vtbl_substr) s = "substr";
1274 else if (v == &PL_vtbl_vec) s = "vec";
1275 else if (v == &PL_vtbl_pos) s = "pos";
1276 else if (v == &PL_vtbl_bm) s = "bm";
1277 else if (v == &PL_vtbl_fm) s = "fm";
1278 else if (v == &PL_vtbl_uvar) s = "uvar";
1279 else if (v == &PL_vtbl_defelem) s = "defelem";
1280 #ifdef USE_LOCALE_COLLATE
1281 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1283 else if (v == &PL_vtbl_amagic) s = "amagic";
1284 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1285 else if (v == &PL_vtbl_backref) s = "backref";
1286 else if (v == &PL_vtbl_utf8) s = "utf8";
1287 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1288 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1289 else if (v == &PL_vtbl_hints) s = "hints";
1292 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1294 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1297 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1300 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1304 const char *name = NULL;
1305 for (n = 0; magic_names[n].name; n++) {
1306 if (mg->mg_type == magic_names[n].type) {
1307 name = magic_names[n].name;
1312 Perl_dump_indent(aTHX_ level, file,
1313 " MG_TYPE = PERL_MAGIC_%s\n", name);
1315 Perl_dump_indent(aTHX_ level, file,
1316 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1320 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1321 if (mg->mg_type == PERL_MAGIC_envelem &&
1322 mg->mg_flags & MGf_TAINTEDDIR)
1323 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1324 if (mg->mg_flags & MGf_REFCOUNTED)
1325 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1326 if (mg->mg_flags & MGf_GSKIP)
1327 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1328 if (mg->mg_type == PERL_MAGIC_regex_global &&
1329 mg->mg_flags & MGf_MINMATCH)
1330 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1333 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1334 PTR2UV(mg->mg_obj));
1335 if (mg->mg_type == PERL_MAGIC_qr) {
1336 REGEXP* const re = (REGEXP *)mg->mg_obj;
1337 SV * const dsv = sv_newmortal();
1338 const char * const s
1339 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1341 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1342 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1344 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1345 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1348 if (mg->mg_flags & MGf_REFCOUNTED)
1349 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1352 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1354 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1355 if (mg->mg_len >= 0) {
1356 if (mg->mg_type != PERL_MAGIC_utf8) {
1357 SV * const sv = newSVpvs("");
1358 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1362 else if (mg->mg_len == HEf_SVKEY) {
1363 PerlIO_puts(file, " => HEf_SVKEY\n");
1364 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1365 maxnest, dumpops, pvlim); /* MG is already +1 */
1369 PerlIO_puts(file, " ???? - please notify IZ");
1370 PerlIO_putc(file, '\n');
1372 if (mg->mg_type == PERL_MAGIC_utf8) {
1373 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1376 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1377 Perl_dump_indent(aTHX_ level, file,
1378 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1381 (UV)cache[i * 2 + 1]);
1388 Perl_magic_dump(pTHX_ const MAGIC *mg)
1390 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1394 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1398 PERL_ARGS_ASSERT_DO_HV_DUMP;
1400 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1401 if (sv && (hvname = HvNAME_get(sv)))
1402 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1404 PerlIO_putc(file, '\n');
1408 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1410 PERL_ARGS_ASSERT_DO_GV_DUMP;
1412 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1413 if (sv && GvNAME(sv))
1414 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1416 PerlIO_putc(file, '\n');
1420 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1422 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1424 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1425 if (sv && GvNAME(sv)) {
1427 PerlIO_printf(file, "\t\"");
1428 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1429 PerlIO_printf(file, "%s\" :: \"", hvname);
1430 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1433 PerlIO_putc(file, '\n');
1437 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1445 PERL_ARGS_ASSERT_DO_SV_DUMP;
1448 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1452 flags = SvFLAGS(sv);
1455 d = Perl_newSVpvf(aTHX_
1456 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1457 PTR2UV(SvANY(sv)), PTR2UV(sv),
1458 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1459 (int)(PL_dumpindent*level), "");
1461 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1462 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1464 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1465 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1466 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1468 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1469 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1470 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1471 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1472 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1474 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1475 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1476 if (flags & SVf_POK) sv_catpv(d, "POK,");
1477 if (flags & SVf_ROK) {
1478 sv_catpv(d, "ROK,");
1479 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1481 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1482 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1483 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1484 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1486 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1487 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1488 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1489 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1490 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1491 if (SvPCS_IMPORTED(sv))
1492 sv_catpv(d, "PCS_IMPORTED,");
1494 sv_catpv(d, "SCREAM,");
1500 if (CvANON(sv)) sv_catpv(d, "ANON,");
1501 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1502 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1503 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1504 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1505 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1506 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1507 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1508 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1509 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1512 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1513 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1514 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1515 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1516 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1520 if (isGV_with_GP(sv)) {
1521 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1522 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1523 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1524 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1526 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1527 sv_catpv(d, "IMPORT");
1528 if (GvIMPORTED(sv) == GVf_IMPORTED)
1529 sv_catpv(d, "ALL,");
1532 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1533 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1534 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1535 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1539 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1540 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1544 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1545 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1548 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1549 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1552 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1557 /* SVphv_SHAREKEYS is also 0x20000000 */
1558 if ((type != SVt_PVHV) && SvUTF8(sv))
1559 sv_catpv(d, "UTF8");
1561 if (*(SvEND(d) - 1) == ',') {
1562 SvCUR_set(d, SvCUR(d) - 1);
1563 SvPVX(d)[SvCUR(d)] = '\0';
1568 #ifdef DEBUG_LEAKING_SCALARS
1569 Perl_dump_indent(aTHX_ level, file,
1570 "ALLOCATED at %s:%d %s %s%s; serial %"UVuf"\n",
1571 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1573 sv->sv_debug_inpad ? "for" : "by",
1574 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1575 sv->sv_debug_cloned ? " (cloned)" : "",
1579 Perl_dump_indent(aTHX_ level, file, "SV = ");
1580 if (type < SVt_LAST) {
1581 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1583 if (type == SVt_NULL) {
1588 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1592 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1593 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
1594 && type != SVt_PVIO)
1595 || (type == SVt_IV && !SvROK(sv))) {
1597 #ifdef PERL_OLD_COPY_ON_WRITE
1601 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1603 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1604 #ifdef PERL_OLD_COPY_ON_WRITE
1605 if (SvIsCOW_shared_hash(sv))
1606 PerlIO_printf(file, " (HASH)");
1607 else if (SvIsCOW_normal(sv))
1608 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1610 PerlIO_putc(file, '\n');
1612 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1613 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1614 (UV) COP_SEQ_RANGE_LOW(sv));
1615 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1616 (UV) COP_SEQ_RANGE_HIGH(sv));
1617 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1618 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1619 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1620 || type == SVt_NV) {
1621 STORE_NUMERIC_LOCAL_SET_STANDARD();
1622 /* %Vg doesn't work? --jhi */
1623 #ifdef USE_LONG_DOUBLE
1624 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1626 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1628 RESTORE_NUMERIC_LOCAL();
1631 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1633 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1635 if (type < SVt_PV) {
1639 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1640 if (SvPVX_const(sv)) {
1643 SvOOK_offset(sv, delta);
1644 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1649 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1651 PerlIO_printf(file, "( %s . ) ",
1652 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1655 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1656 if (SvUTF8(sv)) /* the 6? \x{....} */
1657 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1658 PerlIO_printf(file, "\n");
1659 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1660 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1663 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1665 if (type == SVt_REGEXP) {
1667 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1668 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1671 if (type >= SVt_PVMG) {
1672 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1673 HV * const ost = SvOURSTASH(sv);
1675 do_hv_dump(level, file, " OURSTASH", ost);
1678 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1681 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1685 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1686 if (AvARRAY(sv) != AvALLOC(sv)) {
1687 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1688 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1691 PerlIO_putc(file, '\n');
1692 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1693 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1694 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1696 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1697 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1698 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1699 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1700 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1702 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1703 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1705 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1707 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1712 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1713 if (HvARRAY(sv) && HvKEYS(sv)) {
1714 /* Show distribution of HEs in the ARRAY */
1716 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1719 U32 pow2 = 2, keys = HvKEYS(sv);
1720 NV theoret, sum = 0;
1722 PerlIO_printf(file, " (");
1723 Zero(freq, FREQ_MAX + 1, int);
1724 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1727 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1729 if (count > FREQ_MAX)
1735 for (i = 0; i <= max; i++) {
1737 PerlIO_printf(file, "%d%s:%d", i,
1738 (i == FREQ_MAX) ? "+" : "",
1741 PerlIO_printf(file, ", ");
1744 PerlIO_putc(file, ')');
1745 /* The "quality" of a hash is defined as the total number of
1746 comparisons needed to access every element once, relative
1747 to the expected number needed for a random hash.
1749 The total number of comparisons is equal to the sum of
1750 the squares of the number of entries in each bucket.
1751 For a random hash of n keys into k buckets, the expected
1756 for (i = max; i > 0; i--) { /* Precision: count down. */
1757 sum += freq[i] * i * i;
1759 while ((keys = keys >> 1))
1761 theoret = HvKEYS(sv);
1762 theoret += theoret * (theoret-1)/pow2;
1763 PerlIO_putc(file, '\n');
1764 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1766 PerlIO_putc(file, '\n');
1767 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1768 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1769 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1770 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1771 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1773 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1774 if (mg && mg->mg_obj) {
1775 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1779 const char * const hvname = HvNAME_get(sv);
1781 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1785 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1786 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1788 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1790 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1794 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1795 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1796 (int)meta->mro_which->length,
1797 meta->mro_which->name,
1798 PTR2UV(meta->mro_which));
1799 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1800 (UV)meta->cache_gen);
1801 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1803 if (meta->mro_linear_all) {
1804 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1805 PTR2UV(meta->mro_linear_all));
1806 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1809 if (meta->mro_linear_current) {
1810 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1811 PTR2UV(meta->mro_linear_current));
1812 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1815 if (meta->mro_nextmethod) {
1816 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1817 PTR2UV(meta->mro_nextmethod));
1818 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1822 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1824 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1829 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1831 HV * const hv = MUTABLE_HV(sv);
1832 int count = maxnest - nest;
1835 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1838 const U32 hash = HeHASH(he);
1839 SV * const keysv = hv_iterkeysv(he);
1840 const char * const keypv = SvPV_const(keysv, len);
1841 SV * const elt = hv_iterval(hv, he);
1843 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1845 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1847 PerlIO_printf(file, "[REHASH] ");
1848 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1849 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1851 hv_iterinit(hv); /* Return to status quo */
1857 const char *const proto = SvPV_const(sv, len);
1858 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1863 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1864 if (!CvISXSUB(sv)) {
1866 Perl_dump_indent(aTHX_ level, file,
1867 " START = 0x%"UVxf" ===> %"IVdf"\n",
1868 PTR2UV(CvSTART(sv)),
1869 (IV)sequence_num(CvSTART(sv)));
1871 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1872 PTR2UV(CvROOT(sv)));
1873 if (CvROOT(sv) && dumpops) {
1874 do_op_dump(level+1, file, CvROOT(sv));
1877 SV * const constant = cv_const_sv((const CV *)sv);
1879 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1882 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1884 PTR2UV(CvXSUBANY(sv).any_ptr));
1885 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1888 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1889 (IV)CvXSUBANY(sv).any_i32);
1892 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1893 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1894 if (type == SVt_PVCV)
1895 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1896 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1897 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1898 if (type == SVt_PVFM)
1899 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1900 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1901 if (nest < maxnest) {
1902 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1905 const CV * const outside = CvOUTSIDE(sv);
1906 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1909 : CvANON(outside) ? "ANON"
1910 : (outside == PL_main_cv) ? "MAIN"
1911 : CvUNIQUE(outside) ? "UNIQUE"
1912 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1914 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1915 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1919 if (type == SVt_PVLV) {
1920 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1921 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1922 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1923 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1924 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1925 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1929 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1930 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1931 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1932 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1934 if (!isGV_with_GP(sv))
1936 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1937 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1938 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1939 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1942 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1943 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1944 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1945 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1946 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1947 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1948 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1949 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1950 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1951 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1952 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1953 do_gv_dump (level, file, " EGV", GvEGV(sv));
1956 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1957 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1958 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1959 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1960 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1961 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1962 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1964 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1965 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1966 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1968 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1969 PTR2UV(IoTOP_GV(sv)));
1970 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1971 maxnest, dumpops, pvlim);
1973 /* Source filters hide things that are not GVs in these three, so let's
1974 be careful out there. */
1976 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1977 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1978 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1980 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1981 PTR2UV(IoFMT_GV(sv)));
1982 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1983 maxnest, dumpops, pvlim);
1985 if (IoBOTTOM_NAME(sv))
1986 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1987 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1988 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1990 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1991 PTR2UV(IoBOTTOM_GV(sv)));
1992 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
1993 maxnest, dumpops, pvlim);
1995 if (isPRINT(IoTYPE(sv)))
1996 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1998 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1999 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2006 Perl_sv_dump(pTHX_ SV *sv)
2010 PERL_ARGS_ASSERT_SV_DUMP;
2013 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2015 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2019 Perl_runops_debug(pTHX)
2023 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2027 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2030 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2031 PerlIO_printf(Perl_debug_log,
2032 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2033 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2034 PTR2UV(*PL_watchaddr));
2035 if (DEBUG_s_TEST_) {
2036 if (DEBUG_v_TEST_) {
2037 PerlIO_printf(Perl_debug_log, "\n");
2045 if (DEBUG_t_TEST_) debop(PL_op);
2046 if (DEBUG_P_TEST_) debprof(PL_op);
2048 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2049 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2056 Perl_debop(pTHX_ const OP *o)
2060 PERL_ARGS_ASSERT_DEBOP;
2062 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2065 Perl_deb(aTHX_ "%s", OP_NAME(o));
2066 switch (o->op_type) {
2069 /* With ITHREADS, consts are stored in the pad, and the right pad
2070 * may not be active here, so check.
2071 * Looks like only during compiling the pads are illegal.
2074 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2076 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2081 SV * const sv = newSV(0);
2083 /* FIXME - is this making unwarranted assumptions about the
2084 UTF-8 cleanliness of the dump file handle? */
2087 gv_fullname3(sv, cGVOPo_gv, NULL);
2088 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2092 PerlIO_printf(Perl_debug_log, "(NULL)");
2098 /* print the lexical's name */
2099 CV * const cv = deb_curcv(cxstack_ix);
2102 AV * const padlist = CvPADLIST(cv);
2103 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2104 sv = *av_fetch(comppad, o->op_targ, FALSE);
2108 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2110 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2116 PerlIO_printf(Perl_debug_log, "\n");
2121 S_deb_curcv(pTHX_ const I32 ix)
2124 const PERL_CONTEXT * const cx = &cxstack[ix];
2125 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2126 return cx->blk_sub.cv;
2127 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2129 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2134 return deb_curcv(ix - 1);
2138 Perl_watch(pTHX_ char **addr)
2142 PERL_ARGS_ASSERT_WATCH;
2144 PL_watchaddr = addr;
2146 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2147 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2151 S_debprof(pTHX_ const OP *o)
2155 PERL_ARGS_ASSERT_DEBPROF;
2157 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2159 if (!PL_profiledata)
2160 Newxz(PL_profiledata, MAXO, U32);
2161 ++PL_profiledata[o->op_type];
2165 Perl_debprofdump(pTHX)
2169 if (!PL_profiledata)
2171 for (i = 0; i < MAXO; i++) {
2172 if (PL_profiledata[i])
2173 PerlIO_printf(Perl_debug_log,
2174 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2181 * XML variants of most of the above routines
2185 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2189 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2191 PerlIO_printf(file, "\n ");
2192 va_start(args, pat);
2193 xmldump_vindent(level, file, pat, &args);
2199 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2202 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2203 va_start(args, pat);
2204 xmldump_vindent(level, file, pat, &args);
2209 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2211 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2213 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2214 PerlIO_vprintf(file, pat, *args);
2218 Perl_xmldump_all(pTHX)
2220 xmldump_all_perl(FALSE);
2224 Perl_xmldump_all_perl(pTHX_ bool justperl)
2226 PerlIO_setlinebuf(PL_xmlfp);
2228 op_xmldump(PL_main_root);
2229 xmldump_packsubs_perl(PL_defstash, justperl);
2230 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2231 PerlIO_close(PL_xmlfp);
2236 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2238 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2239 xmldump_packsubs_perl(stash, FALSE);
2243 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2248 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2250 if (!HvARRAY(stash))
2252 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2253 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2254 GV *gv = MUTABLE_GV(HeVAL(entry));
2256 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2259 xmldump_sub_perl(gv, justperl);
2262 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2263 && (hv = GvHV(gv)) && hv != PL_defstash)
2264 xmldump_packsubs_perl(hv, justperl); /* nested package */
2270 Perl_xmldump_sub(pTHX_ const GV *gv)
2272 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2273 xmldump_sub_perl(gv, FALSE);
2277 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2281 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2283 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2286 sv = sv_newmortal();
2287 gv_fullname3(sv, gv, NULL);
2288 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2289 if (CvXSUB(GvCV(gv)))
2290 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2291 PTR2UV(CvXSUB(GvCV(gv))),
2292 (int)CvXSUBANY(GvCV(gv)).any_i32);
2293 else if (CvROOT(GvCV(gv)))
2294 op_xmldump(CvROOT(GvCV(gv)));
2296 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2300 Perl_xmldump_form(pTHX_ const GV *gv)
2302 SV * const sv = sv_newmortal();
2304 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2306 gv_fullname3(sv, gv, NULL);
2307 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2308 if (CvROOT(GvFORM(gv)))
2309 op_xmldump(CvROOT(GvFORM(gv)));
2311 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2315 Perl_xmldump_eval(pTHX)
2317 op_xmldump(PL_eval_root);
2321 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2323 PERL_ARGS_ASSERT_SV_CATXMLSV;
2324 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2328 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2331 const char * const e = pv + len;
2332 const char * const start = pv;
2336 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2339 dsvcur = SvCUR(dsv); /* in case we have to restart */
2344 c = utf8_to_uvchr((U8*)pv, &cl);
2346 SvCUR(dsv) = dsvcur;
2411 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2414 sv_catpvs(dsv, "<");
2417 sv_catpvs(dsv, ">");
2420 sv_catpvs(dsv, "&");
2423 sv_catpvs(dsv, """);
2427 if (c < 32 || c > 127) {
2428 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2431 const char string = (char) c;
2432 sv_catpvn(dsv, &string, 1);
2436 if ((c >= 0xD800 && c <= 0xDB7F) ||
2437 (c >= 0xDC00 && c <= 0xDFFF) ||
2438 (c >= 0xFFF0 && c <= 0xFFFF) ||
2440 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2442 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2455 Perl_sv_xmlpeek(pTHX_ SV *sv)
2457 SV * const t = sv_newmortal();
2461 PERL_ARGS_ASSERT_SV_XMLPEEK;
2467 sv_catpv(t, "VOID=\"\"");
2470 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2471 sv_catpv(t, "WILD=\"\"");
2474 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2475 if (sv == &PL_sv_undef) {
2476 sv_catpv(t, "SV_UNDEF=\"1\"");
2477 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2478 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2482 else if (sv == &PL_sv_no) {
2483 sv_catpv(t, "SV_NO=\"1\"");
2484 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2485 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2486 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2487 SVp_POK|SVp_NOK)) &&
2492 else if (sv == &PL_sv_yes) {
2493 sv_catpv(t, "SV_YES=\"1\"");
2494 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2495 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2496 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2497 SVp_POK|SVp_NOK)) &&
2499 SvPVX(sv) && *SvPVX(sv) == '1' &&
2504 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2505 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2506 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2510 sv_catpv(t, " XXX=\"\" ");
2512 else if (SvREFCNT(sv) == 0) {
2513 sv_catpv(t, " refcnt=\"0\"");
2516 else if (DEBUG_R_TEST_) {
2519 /* is this SV on the tmps stack? */
2520 for (ix=PL_tmps_ix; ix>=0; ix--) {
2521 if (PL_tmps_stack[ix] == sv) {
2526 if (SvREFCNT(sv) > 1)
2527 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2530 sv_catpv(t, " DRT=\"<T>\"");
2534 sv_catpv(t, " ROK=\"\"");
2536 switch (SvTYPE(sv)) {
2538 sv_catpv(t, " FREED=\"1\"");
2542 sv_catpv(t, " UNDEF=\"1\"");
2545 sv_catpv(t, " IV=\"");
2548 sv_catpv(t, " NV=\"");
2551 sv_catpv(t, " PV=\"");
2554 sv_catpv(t, " PVIV=\"");
2557 sv_catpv(t, " PVNV=\"");
2560 sv_catpv(t, " PVMG=\"");
2563 sv_catpv(t, " PVLV=\"");
2566 sv_catpv(t, " AV=\"");
2569 sv_catpv(t, " HV=\"");
2573 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2575 sv_catpv(t, " CV=\"()\"");
2578 sv_catpv(t, " GV=\"");
2581 sv_catpv(t, " BIND=\"");
2584 sv_catpv(t, " ORANGE=\"");
2587 sv_catpv(t, " FM=\"");
2590 sv_catpv(t, " IO=\"");
2599 else if (SvNOKp(sv)) {
2600 STORE_NUMERIC_LOCAL_SET_STANDARD();
2601 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2602 RESTORE_NUMERIC_LOCAL();
2604 else if (SvIOKp(sv)) {
2606 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2608 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2617 return SvPV(t, n_a);
2621 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2623 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2626 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2629 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2632 REGEXP *const r = PM_GETRE(pm);
2633 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2634 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2635 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2637 SvREFCNT_dec(tmpsv);
2638 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2639 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2642 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2643 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2644 SV * const tmpsv = pm_description(pm);
2645 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2646 SvREFCNT_dec(tmpsv);
2650 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2651 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2652 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2653 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2654 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2655 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2658 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2662 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2664 do_pmop_xmldump(0, PL_xmlfp, pm);
2668 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2673 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2678 seq = sequence_num(o);
2679 Perl_xmldump_indent(aTHX_ level, file,
2680 "<op_%s seq=\"%"UVuf" -> ",
2685 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2686 sequence_num(o->op_next));
2688 PerlIO_printf(file, "DONE\"");
2691 if (o->op_type == OP_NULL)
2693 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2694 if (o->op_targ == OP_NEXTSTATE)
2697 PerlIO_printf(file, " line=\"%"UVuf"\"",
2698 (UV)CopLINE(cCOPo));
2699 if (CopSTASHPV(cCOPo))
2700 PerlIO_printf(file, " package=\"%s\"",
2702 if (CopLABEL(cCOPo))
2703 PerlIO_printf(file, " label=\"%s\"",
2708 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2711 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2714 SV * const tmpsv = newSVpvs("");
2715 switch (o->op_flags & OPf_WANT) {
2717 sv_catpv(tmpsv, ",VOID");
2719 case OPf_WANT_SCALAR:
2720 sv_catpv(tmpsv, ",SCALAR");
2723 sv_catpv(tmpsv, ",LIST");
2726 sv_catpv(tmpsv, ",UNKNOWN");
2729 if (o->op_flags & OPf_KIDS)
2730 sv_catpv(tmpsv, ",KIDS");
2731 if (o->op_flags & OPf_PARENS)
2732 sv_catpv(tmpsv, ",PARENS");
2733 if (o->op_flags & OPf_STACKED)
2734 sv_catpv(tmpsv, ",STACKED");
2735 if (o->op_flags & OPf_REF)
2736 sv_catpv(tmpsv, ",REF");
2737 if (o->op_flags & OPf_MOD)
2738 sv_catpv(tmpsv, ",MOD");
2739 if (o->op_flags & OPf_SPECIAL)
2740 sv_catpv(tmpsv, ",SPECIAL");
2741 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2742 SvREFCNT_dec(tmpsv);
2744 if (o->op_private) {
2745 SV * const tmpsv = newSVpvs("");
2746 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2747 if (o->op_private & OPpTARGET_MY)
2748 sv_catpv(tmpsv, ",TARGET_MY");
2750 else if (o->op_type == OP_LEAVESUB ||
2751 o->op_type == OP_LEAVE ||
2752 o->op_type == OP_LEAVESUBLV ||
2753 o->op_type == OP_LEAVEWRITE) {
2754 if (o->op_private & OPpREFCOUNTED)
2755 sv_catpv(tmpsv, ",REFCOUNTED");
2757 else if (o->op_type == OP_AASSIGN) {
2758 if (o->op_private & OPpASSIGN_COMMON)
2759 sv_catpv(tmpsv, ",COMMON");
2761 else if (o->op_type == OP_SASSIGN) {
2762 if (o->op_private & OPpASSIGN_BACKWARDS)
2763 sv_catpv(tmpsv, ",BACKWARDS");
2765 else if (o->op_type == OP_TRANS) {
2766 if (o->op_private & OPpTRANS_SQUASH)
2767 sv_catpv(tmpsv, ",SQUASH");
2768 if (o->op_private & OPpTRANS_DELETE)
2769 sv_catpv(tmpsv, ",DELETE");
2770 if (o->op_private & OPpTRANS_COMPLEMENT)
2771 sv_catpv(tmpsv, ",COMPLEMENT");
2772 if (o->op_private & OPpTRANS_IDENTICAL)
2773 sv_catpv(tmpsv, ",IDENTICAL");
2774 if (o->op_private & OPpTRANS_GROWS)
2775 sv_catpv(tmpsv, ",GROWS");
2777 else if (o->op_type == OP_REPEAT) {
2778 if (o->op_private & OPpREPEAT_DOLIST)
2779 sv_catpv(tmpsv, ",DOLIST");
2781 else if (o->op_type == OP_ENTERSUB ||
2782 o->op_type == OP_RV2SV ||
2783 o->op_type == OP_GVSV ||
2784 o->op_type == OP_RV2AV ||
2785 o->op_type == OP_RV2HV ||
2786 o->op_type == OP_RV2GV ||
2787 o->op_type == OP_AELEM ||
2788 o->op_type == OP_HELEM )
2790 if (o->op_type == OP_ENTERSUB) {
2791 if (o->op_private & OPpENTERSUB_AMPER)
2792 sv_catpv(tmpsv, ",AMPER");
2793 if (o->op_private & OPpENTERSUB_DB)
2794 sv_catpv(tmpsv, ",DB");
2795 if (o->op_private & OPpENTERSUB_HASTARG)
2796 sv_catpv(tmpsv, ",HASTARG");
2797 if (o->op_private & OPpENTERSUB_NOPAREN)
2798 sv_catpv(tmpsv, ",NOPAREN");
2799 if (o->op_private & OPpENTERSUB_INARGS)
2800 sv_catpv(tmpsv, ",INARGS");
2801 if (o->op_private & OPpENTERSUB_NOMOD)
2802 sv_catpv(tmpsv, ",NOMOD");
2805 switch (o->op_private & OPpDEREF) {
2807 sv_catpv(tmpsv, ",SV");
2810 sv_catpv(tmpsv, ",AV");
2813 sv_catpv(tmpsv, ",HV");
2816 if (o->op_private & OPpMAYBE_LVSUB)
2817 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2819 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2820 if (o->op_private & OPpLVAL_DEFER)
2821 sv_catpv(tmpsv, ",LVAL_DEFER");
2824 if (o->op_private & HINT_STRICT_REFS)
2825 sv_catpv(tmpsv, ",STRICT_REFS");
2826 if (o->op_private & OPpOUR_INTRO)
2827 sv_catpv(tmpsv, ",OUR_INTRO");
2830 else if (o->op_type == OP_CONST) {
2831 if (o->op_private & OPpCONST_BARE)
2832 sv_catpv(tmpsv, ",BARE");
2833 if (o->op_private & OPpCONST_STRICT)
2834 sv_catpv(tmpsv, ",STRICT");
2835 if (o->op_private & OPpCONST_ARYBASE)
2836 sv_catpv(tmpsv, ",ARYBASE");
2837 if (o->op_private & OPpCONST_WARNING)
2838 sv_catpv(tmpsv, ",WARNING");
2839 if (o->op_private & OPpCONST_ENTERED)
2840 sv_catpv(tmpsv, ",ENTERED");
2842 else if (o->op_type == OP_FLIP) {
2843 if (o->op_private & OPpFLIP_LINENUM)
2844 sv_catpv(tmpsv, ",LINENUM");
2846 else if (o->op_type == OP_FLOP) {
2847 if (o->op_private & OPpFLIP_LINENUM)
2848 sv_catpv(tmpsv, ",LINENUM");
2850 else if (o->op_type == OP_RV2CV) {
2851 if (o->op_private & OPpLVAL_INTRO)
2852 sv_catpv(tmpsv, ",INTRO");
2854 else if (o->op_type == OP_GV) {
2855 if (o->op_private & OPpEARLY_CV)
2856 sv_catpv(tmpsv, ",EARLY_CV");
2858 else if (o->op_type == OP_LIST) {
2859 if (o->op_private & OPpLIST_GUESSED)
2860 sv_catpv(tmpsv, ",GUESSED");
2862 else if (o->op_type == OP_DELETE) {
2863 if (o->op_private & OPpSLICE)
2864 sv_catpv(tmpsv, ",SLICE");
2866 else if (o->op_type == OP_EXISTS) {
2867 if (o->op_private & OPpEXISTS_SUB)
2868 sv_catpv(tmpsv, ",EXISTS_SUB");
2870 else if (o->op_type == OP_SORT) {
2871 if (o->op_private & OPpSORT_NUMERIC)
2872 sv_catpv(tmpsv, ",NUMERIC");
2873 if (o->op_private & OPpSORT_INTEGER)
2874 sv_catpv(tmpsv, ",INTEGER");
2875 if (o->op_private & OPpSORT_REVERSE)
2876 sv_catpv(tmpsv, ",REVERSE");
2878 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2879 if (o->op_private & OPpOPEN_IN_RAW)
2880 sv_catpv(tmpsv, ",IN_RAW");
2881 if (o->op_private & OPpOPEN_IN_CRLF)
2882 sv_catpv(tmpsv, ",IN_CRLF");
2883 if (o->op_private & OPpOPEN_OUT_RAW)
2884 sv_catpv(tmpsv, ",OUT_RAW");
2885 if (o->op_private & OPpOPEN_OUT_CRLF)
2886 sv_catpv(tmpsv, ",OUT_CRLF");
2888 else if (o->op_type == OP_EXIT) {
2889 if (o->op_private & OPpEXIT_VMSISH)
2890 sv_catpv(tmpsv, ",EXIT_VMSISH");
2891 if (o->op_private & OPpHUSH_VMSISH)
2892 sv_catpv(tmpsv, ",HUSH_VMSISH");
2894 else if (o->op_type == OP_DIE) {
2895 if (o->op_private & OPpHUSH_VMSISH)
2896 sv_catpv(tmpsv, ",HUSH_VMSISH");
2898 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2899 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2900 sv_catpv(tmpsv, ",FT_ACCESS");
2901 if (o->op_private & OPpFT_STACKED)
2902 sv_catpv(tmpsv, ",FT_STACKED");
2904 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2905 sv_catpv(tmpsv, ",INTRO");
2907 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2908 SvREFCNT_dec(tmpsv);
2911 switch (o->op_type) {
2913 if (o->op_flags & OPf_SPECIAL) {
2919 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2921 if (cSVOPo->op_sv) {
2922 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2923 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2929 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2930 s = SvPV(tmpsv1,len);
2931 sv_catxmlpvn(tmpsv2, s, len, 1);
2932 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2936 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2941 case OP_METHOD_NAMED:
2942 #ifndef USE_ITHREADS
2943 /* with ITHREADS, consts are stored in the pad, and the right pad
2944 * may not be active here, so skip */
2945 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2951 PerlIO_printf(file, ">\n");
2953 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2958 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2959 (UV)CopLINE(cCOPo));
2960 if (CopSTASHPV(cCOPo))
2961 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2963 if (CopLABEL(cCOPo))
2964 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2968 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2969 if (cLOOPo->op_redoop)
2970 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2972 PerlIO_printf(file, "DONE\"");
2973 S_xmldump_attr(aTHX_ level, file, "next=\"");
2974 if (cLOOPo->op_nextop)
2975 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2977 PerlIO_printf(file, "DONE\"");
2978 S_xmldump_attr(aTHX_ level, file, "last=\"");
2979 if (cLOOPo->op_lastop)
2980 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2982 PerlIO_printf(file, "DONE\"");
2990 S_xmldump_attr(aTHX_ level, file, "other=\"");
2991 if (cLOGOPo->op_other)
2992 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2994 PerlIO_printf(file, "DONE\"");
3002 if (o->op_private & OPpREFCOUNTED)
3003 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3009 if (PL_madskills && o->op_madprop) {
3010 char prevkey = '\0';
3011 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3012 const MADPROP* mp = o->op_madprop;
3016 PerlIO_printf(file, ">\n");
3018 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3021 char tmp = mp->mad_key;
3022 sv_setpvs(tmpsv,"\"");
3024 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3025 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3026 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3029 sv_catpv(tmpsv, "\"");
3030 switch (mp->mad_type) {
3032 sv_catpv(tmpsv, "NULL");
3033 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3036 sv_catpv(tmpsv, " val=\"");
3037 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3038 sv_catpv(tmpsv, "\"");
3039 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3042 sv_catpv(tmpsv, " val=\"");
3043 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3044 sv_catpv(tmpsv, "\"");
3045 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3048 if ((OP*)mp->mad_val) {
3049 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3050 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3051 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3055 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3061 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3063 SvREFCNT_dec(tmpsv);
3066 switch (o->op_type) {
3073 PerlIO_printf(file, ">\n");
3075 do_pmop_xmldump(level, file, cPMOPo);
3081 if (o->op_flags & OPf_KIDS) {
3085 PerlIO_printf(file, ">\n");
3087 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3088 do_op_xmldump(level, file, kid);
3092 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3094 PerlIO_printf(file, " />\n");
3098 Perl_op_xmldump(pTHX_ const OP *o)
3100 PERL_ARGS_ASSERT_OP_XMLDUMP;
3102 do_op_xmldump(0, PL_xmlfp, o);
3108 * c-indentation-style: bsd
3110 * indent-tabs-mode: t
3113 * ex: set ts=8 sts=4 sw=4 noet: