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");
931 if (optype == OP_AELEM || optype == OP_HELEM) {
932 if (o->op_private & OPpLVAL_DEFER)
933 sv_catpv(tmpsv, ",LVAL_DEFER");
936 if (o->op_private & HINT_STRICT_REFS)
937 sv_catpv(tmpsv, ",STRICT_REFS");
938 if (o->op_private & OPpOUR_INTRO)
939 sv_catpv(tmpsv, ",OUR_INTRO");
942 else if (optype == OP_CONST) {
943 if (o->op_private & OPpCONST_BARE)
944 sv_catpv(tmpsv, ",BARE");
945 if (o->op_private & OPpCONST_STRICT)
946 sv_catpv(tmpsv, ",STRICT");
947 if (o->op_private & OPpCONST_ARYBASE)
948 sv_catpv(tmpsv, ",ARYBASE");
949 if (o->op_private & OPpCONST_WARNING)
950 sv_catpv(tmpsv, ",WARNING");
951 if (o->op_private & OPpCONST_ENTERED)
952 sv_catpv(tmpsv, ",ENTERED");
954 else if (optype == OP_FLIP) {
955 if (o->op_private & OPpFLIP_LINENUM)
956 sv_catpv(tmpsv, ",LINENUM");
958 else if (optype == OP_FLOP) {
959 if (o->op_private & OPpFLIP_LINENUM)
960 sv_catpv(tmpsv, ",LINENUM");
962 else if (optype == OP_RV2CV) {
963 if (o->op_private & OPpLVAL_INTRO)
964 sv_catpv(tmpsv, ",INTRO");
966 else if (optype == OP_GV) {
967 if (o->op_private & OPpEARLY_CV)
968 sv_catpv(tmpsv, ",EARLY_CV");
970 else if (optype == OP_LIST) {
971 if (o->op_private & OPpLIST_GUESSED)
972 sv_catpv(tmpsv, ",GUESSED");
974 else if (optype == OP_DELETE) {
975 if (o->op_private & OPpSLICE)
976 sv_catpv(tmpsv, ",SLICE");
978 else if (optype == OP_EXISTS) {
979 if (o->op_private & OPpEXISTS_SUB)
980 sv_catpv(tmpsv, ",EXISTS_SUB");
982 else if (optype == OP_SORT) {
983 if (o->op_private & OPpSORT_NUMERIC)
984 sv_catpv(tmpsv, ",NUMERIC");
985 if (o->op_private & OPpSORT_INTEGER)
986 sv_catpv(tmpsv, ",INTEGER");
987 if (o->op_private & OPpSORT_REVERSE)
988 sv_catpv(tmpsv, ",REVERSE");
990 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
991 if (o->op_private & OPpOPEN_IN_RAW)
992 sv_catpv(tmpsv, ",IN_RAW");
993 if (o->op_private & OPpOPEN_IN_CRLF)
994 sv_catpv(tmpsv, ",IN_CRLF");
995 if (o->op_private & OPpOPEN_OUT_RAW)
996 sv_catpv(tmpsv, ",OUT_RAW");
997 if (o->op_private & OPpOPEN_OUT_CRLF)
998 sv_catpv(tmpsv, ",OUT_CRLF");
1000 else if (optype == OP_EXIT) {
1001 if (o->op_private & OPpEXIT_VMSISH)
1002 sv_catpv(tmpsv, ",EXIT_VMSISH");
1003 if (o->op_private & OPpHUSH_VMSISH)
1004 sv_catpv(tmpsv, ",HUSH_VMSISH");
1006 else if (optype == OP_DIE) {
1007 if (o->op_private & OPpHUSH_VMSISH)
1008 sv_catpv(tmpsv, ",HUSH_VMSISH");
1010 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
1011 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1012 sv_catpv(tmpsv, ",FT_ACCESS");
1013 if (o->op_private & OPpFT_STACKED)
1014 sv_catpv(tmpsv, ",FT_STACKED");
1016 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1017 sv_catpv(tmpsv, ",INTRO");
1019 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1020 SvREFCNT_dec(tmpsv);
1024 if (PL_madskills && o->op_madprop) {
1025 SV * const tmpsv = newSVpvs("");
1026 MADPROP* mp = o->op_madprop;
1027 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1030 const char tmp = mp->mad_key;
1031 sv_setpvs(tmpsv,"'");
1033 sv_catpvn(tmpsv, &tmp, 1);
1034 sv_catpv(tmpsv, "'=");
1035 switch (mp->mad_type) {
1037 sv_catpv(tmpsv, "NULL");
1038 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1041 sv_catpv(tmpsv, "<");
1042 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1043 sv_catpv(tmpsv, ">");
1044 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1047 if ((OP*)mp->mad_val) {
1048 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1049 do_op_dump(level, file, (OP*)mp->mad_val);
1053 sv_catpv(tmpsv, "(UNK)");
1054 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1060 Perl_dump_indent(aTHX_ level, file, "}\n");
1062 SvREFCNT_dec(tmpsv);
1071 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1073 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1074 if (cSVOPo->op_sv) {
1075 SV * const tmpsv = newSV(0);
1079 /* FIXME - is this making unwarranted assumptions about the
1080 UTF-8 cleanliness of the dump file handle? */
1083 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1084 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1085 SvPV_nolen_const(tmpsv));
1089 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1095 case OP_METHOD_NAMED:
1096 #ifndef USE_ITHREADS
1097 /* with ITHREADS, consts are stored in the pad, and the right pad
1098 * may not be active here, so skip */
1099 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1105 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1106 (UV)CopLINE(cCOPo));
1107 if (CopSTASHPV(cCOPo))
1108 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1110 if (CopLABEL(cCOPo))
1111 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1115 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1116 if (cLOOPo->op_redoop)
1117 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1119 PerlIO_printf(file, "DONE\n");
1120 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1121 if (cLOOPo->op_nextop)
1122 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1124 PerlIO_printf(file, "DONE\n");
1125 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1126 if (cLOOPo->op_lastop)
1127 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1129 PerlIO_printf(file, "DONE\n");
1137 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1138 if (cLOGOPo->op_other)
1139 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1141 PerlIO_printf(file, "DONE\n");
1147 do_pmop_dump(level, file, cPMOPo);
1155 if (o->op_private & OPpREFCOUNTED)
1156 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1161 if (o->op_flags & OPf_KIDS) {
1163 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1164 do_op_dump(level, file, kid);
1166 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1170 Perl_op_dump(pTHX_ const OP *o)
1172 PERL_ARGS_ASSERT_OP_DUMP;
1173 do_op_dump(0, Perl_debug_log, o);
1177 Perl_gv_dump(pTHX_ GV *gv)
1181 PERL_ARGS_ASSERT_GV_DUMP;
1184 PerlIO_printf(Perl_debug_log, "{}\n");
1187 sv = sv_newmortal();
1188 PerlIO_printf(Perl_debug_log, "{\n");
1189 gv_fullname3(sv, gv, NULL);
1190 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1191 if (gv != GvEGV(gv)) {
1192 gv_efullname3(sv, GvEGV(gv), NULL);
1193 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1195 PerlIO_putc(Perl_debug_log, '\n');
1196 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1200 /* map magic types to the symbolic names
1201 * (with the PERL_MAGIC_ prefixed stripped)
1204 static const struct { const char type; const char *name; } magic_names[] = {
1205 { PERL_MAGIC_sv, "sv(\\0)" },
1206 { PERL_MAGIC_arylen, "arylen(#)" },
1207 { PERL_MAGIC_rhash, "rhash(%)" },
1208 { PERL_MAGIC_pos, "pos(.)" },
1209 { PERL_MAGIC_symtab, "symtab(:)" },
1210 { PERL_MAGIC_backref, "backref(<)" },
1211 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1212 { PERL_MAGIC_overload, "overload(A)" },
1213 { PERL_MAGIC_bm, "bm(B)" },
1214 { PERL_MAGIC_regdata, "regdata(D)" },
1215 { PERL_MAGIC_env, "env(E)" },
1216 { PERL_MAGIC_hints, "hints(H)" },
1217 { PERL_MAGIC_isa, "isa(I)" },
1218 { PERL_MAGIC_dbfile, "dbfile(L)" },
1219 { PERL_MAGIC_shared, "shared(N)" },
1220 { PERL_MAGIC_tied, "tied(P)" },
1221 { PERL_MAGIC_sig, "sig(S)" },
1222 { PERL_MAGIC_uvar, "uvar(U)" },
1223 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1224 { PERL_MAGIC_overload_table, "overload_table(c)" },
1225 { PERL_MAGIC_regdatum, "regdatum(d)" },
1226 { PERL_MAGIC_envelem, "envelem(e)" },
1227 { PERL_MAGIC_fm, "fm(f)" },
1228 { PERL_MAGIC_regex_global, "regex_global(g)" },
1229 { PERL_MAGIC_hintselem, "hintselem(h)" },
1230 { PERL_MAGIC_isaelem, "isaelem(i)" },
1231 { PERL_MAGIC_nkeys, "nkeys(k)" },
1232 { PERL_MAGIC_dbline, "dbline(l)" },
1233 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1234 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1235 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1236 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1237 { PERL_MAGIC_qr, "qr(r)" },
1238 { PERL_MAGIC_sigelem, "sigelem(s)" },
1239 { PERL_MAGIC_taint, "taint(t)" },
1240 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1241 { PERL_MAGIC_vec, "vec(v)" },
1242 { PERL_MAGIC_vstring, "vstring(V)" },
1243 { PERL_MAGIC_utf8, "utf8(w)" },
1244 { PERL_MAGIC_substr, "substr(x)" },
1245 { PERL_MAGIC_defelem, "defelem(y)" },
1246 { PERL_MAGIC_ext, "ext(~)" },
1247 /* this null string terminates the list */
1252 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1254 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1256 for (; mg; mg = mg->mg_moremagic) {
1257 Perl_dump_indent(aTHX_ level, file,
1258 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1259 if (mg->mg_virtual) {
1260 const MGVTBL * const v = mg->mg_virtual;
1262 if (v == &PL_vtbl_sv) s = "sv";
1263 else if (v == &PL_vtbl_env) s = "env";
1264 else if (v == &PL_vtbl_envelem) s = "envelem";
1265 else if (v == &PL_vtbl_sig) s = "sig";
1266 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1267 else if (v == &PL_vtbl_pack) s = "pack";
1268 else if (v == &PL_vtbl_packelem) s = "packelem";
1269 else if (v == &PL_vtbl_dbline) s = "dbline";
1270 else if (v == &PL_vtbl_isa) s = "isa";
1271 else if (v == &PL_vtbl_arylen) s = "arylen";
1272 else if (v == &PL_vtbl_mglob) s = "mglob";
1273 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1274 else if (v == &PL_vtbl_taint) s = "taint";
1275 else if (v == &PL_vtbl_substr) s = "substr";
1276 else if (v == &PL_vtbl_vec) s = "vec";
1277 else if (v == &PL_vtbl_pos) s = "pos";
1278 else if (v == &PL_vtbl_bm) s = "bm";
1279 else if (v == &PL_vtbl_fm) s = "fm";
1280 else if (v == &PL_vtbl_uvar) s = "uvar";
1281 else if (v == &PL_vtbl_defelem) s = "defelem";
1282 #ifdef USE_LOCALE_COLLATE
1283 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1285 else if (v == &PL_vtbl_amagic) s = "amagic";
1286 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1287 else if (v == &PL_vtbl_backref) s = "backref";
1288 else if (v == &PL_vtbl_utf8) s = "utf8";
1289 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1290 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1291 else if (v == &PL_vtbl_hints) s = "hints";
1294 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1296 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1299 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1302 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1306 const char *name = NULL;
1307 for (n = 0; magic_names[n].name; n++) {
1308 if (mg->mg_type == magic_names[n].type) {
1309 name = magic_names[n].name;
1314 Perl_dump_indent(aTHX_ level, file,
1315 " MG_TYPE = PERL_MAGIC_%s\n", name);
1317 Perl_dump_indent(aTHX_ level, file,
1318 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1322 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1323 if (mg->mg_type == PERL_MAGIC_envelem &&
1324 mg->mg_flags & MGf_TAINTEDDIR)
1325 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1326 if (mg->mg_flags & MGf_REFCOUNTED)
1327 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1328 if (mg->mg_flags & MGf_GSKIP)
1329 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1330 if (mg->mg_type == PERL_MAGIC_regex_global &&
1331 mg->mg_flags & MGf_MINMATCH)
1332 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1335 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1336 PTR2UV(mg->mg_obj));
1337 if (mg->mg_type == PERL_MAGIC_qr) {
1338 REGEXP* const re = (REGEXP *)mg->mg_obj;
1339 SV * const dsv = sv_newmortal();
1340 const char * const s
1341 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1343 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1344 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1346 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1347 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1350 if (mg->mg_flags & MGf_REFCOUNTED)
1351 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1354 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1356 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1357 if (mg->mg_len >= 0) {
1358 if (mg->mg_type != PERL_MAGIC_utf8) {
1359 SV * const sv = newSVpvs("");
1360 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1364 else if (mg->mg_len == HEf_SVKEY) {
1365 PerlIO_puts(file, " => HEf_SVKEY\n");
1366 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1367 maxnest, dumpops, pvlim); /* MG is already +1 */
1370 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1375 " does not know how to handle this MG_LEN"
1377 PerlIO_putc(file, '\n');
1379 if (mg->mg_type == PERL_MAGIC_utf8) {
1380 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1383 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1384 Perl_dump_indent(aTHX_ level, file,
1385 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1388 (UV)cache[i * 2 + 1]);
1395 Perl_magic_dump(pTHX_ const MAGIC *mg)
1397 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1401 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1405 PERL_ARGS_ASSERT_DO_HV_DUMP;
1407 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1408 if (sv && (hvname = HvNAME_get(sv)))
1409 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1411 PerlIO_putc(file, '\n');
1415 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1417 PERL_ARGS_ASSERT_DO_GV_DUMP;
1419 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1420 if (sv && GvNAME(sv))
1421 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1423 PerlIO_putc(file, '\n');
1427 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1429 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1431 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1432 if (sv && GvNAME(sv)) {
1434 PerlIO_printf(file, "\t\"");
1435 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1436 PerlIO_printf(file, "%s\" :: \"", hvname);
1437 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1440 PerlIO_putc(file, '\n');
1444 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1452 PERL_ARGS_ASSERT_DO_SV_DUMP;
1455 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1459 flags = SvFLAGS(sv);
1462 d = Perl_newSVpvf(aTHX_
1463 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1464 PTR2UV(SvANY(sv)), PTR2UV(sv),
1465 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1466 (int)(PL_dumpindent*level), "");
1468 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1469 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1471 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1472 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1473 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1475 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1476 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1477 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1478 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1479 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1481 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1482 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1483 if (flags & SVf_POK) sv_catpv(d, "POK,");
1484 if (flags & SVf_ROK) {
1485 sv_catpv(d, "ROK,");
1486 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1488 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1489 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1490 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1491 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1493 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1494 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1495 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1496 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1497 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1498 if (SvPCS_IMPORTED(sv))
1499 sv_catpv(d, "PCS_IMPORTED,");
1501 sv_catpv(d, "SCREAM,");
1507 if (CvANON(sv)) sv_catpv(d, "ANON,");
1508 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1509 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1510 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1511 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1512 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1513 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1514 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1515 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1516 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1519 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1520 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1521 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1522 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1523 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1527 if (isGV_with_GP(sv)) {
1528 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1529 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1530 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1531 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1533 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1534 sv_catpv(d, "IMPORT");
1535 if (GvIMPORTED(sv) == GVf_IMPORTED)
1536 sv_catpv(d, "ALL,");
1539 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1540 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1541 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1542 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1546 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1547 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1551 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1552 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1555 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1556 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1559 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1564 /* SVphv_SHAREKEYS is also 0x20000000 */
1565 if ((type != SVt_PVHV) && SvUTF8(sv))
1566 sv_catpv(d, "UTF8");
1568 if (*(SvEND(d) - 1) == ',') {
1569 SvCUR_set(d, SvCUR(d) - 1);
1570 SvPVX(d)[SvCUR(d)] = '\0';
1575 #ifdef DEBUG_LEAKING_SCALARS
1576 Perl_dump_indent(aTHX_ level, file,
1577 "ALLOCATED at %s:%d %s %s%s; serial %"UVuf"\n",
1578 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1580 sv->sv_debug_inpad ? "for" : "by",
1581 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1582 sv->sv_debug_cloned ? " (cloned)" : "",
1586 Perl_dump_indent(aTHX_ level, file, "SV = ");
1587 if (type < SVt_LAST) {
1588 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1590 if (type == SVt_NULL) {
1595 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1599 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1600 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
1601 && type != SVt_PVIO && type != SVt_REGEXP)
1602 || (type == SVt_IV && !SvROK(sv))) {
1604 #ifdef PERL_OLD_COPY_ON_WRITE
1608 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1610 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1611 #ifdef PERL_OLD_COPY_ON_WRITE
1612 if (SvIsCOW_shared_hash(sv))
1613 PerlIO_printf(file, " (HASH)");
1614 else if (SvIsCOW_normal(sv))
1615 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1617 PerlIO_putc(file, '\n');
1619 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1620 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1621 (UV) COP_SEQ_RANGE_LOW(sv));
1622 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1623 (UV) COP_SEQ_RANGE_HIGH(sv));
1624 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1625 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1626 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1627 || type == SVt_NV) {
1628 STORE_NUMERIC_LOCAL_SET_STANDARD();
1629 /* %Vg doesn't work? --jhi */
1630 #ifdef USE_LONG_DOUBLE
1631 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1633 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1635 RESTORE_NUMERIC_LOCAL();
1638 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1640 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1642 if (type < SVt_PV) {
1646 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1647 if (SvPVX_const(sv)) {
1650 SvOOK_offset(sv, delta);
1651 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1656 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1658 PerlIO_printf(file, "( %s . ) ",
1659 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1662 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1663 if (SvUTF8(sv)) /* the 6? \x{....} */
1664 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1665 PerlIO_printf(file, "\n");
1666 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1667 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1670 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1672 if (type == SVt_REGEXP) {
1674 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1675 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1678 if (type >= SVt_PVMG) {
1679 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1680 HV * const ost = SvOURSTASH(sv);
1682 do_hv_dump(level, file, " OURSTASH", ost);
1685 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1688 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1692 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1693 if (AvARRAY(sv) != AvALLOC(sv)) {
1694 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1695 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1698 PerlIO_putc(file, '\n');
1699 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1700 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1701 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1703 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1704 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1705 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1706 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1707 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1709 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1710 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1712 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1714 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1719 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1720 if (HvARRAY(sv) && HvKEYS(sv)) {
1721 /* Show distribution of HEs in the ARRAY */
1723 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1726 U32 pow2 = 2, keys = HvKEYS(sv);
1727 NV theoret, sum = 0;
1729 PerlIO_printf(file, " (");
1730 Zero(freq, FREQ_MAX + 1, int);
1731 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1734 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1736 if (count > FREQ_MAX)
1742 for (i = 0; i <= max; i++) {
1744 PerlIO_printf(file, "%d%s:%d", i,
1745 (i == FREQ_MAX) ? "+" : "",
1748 PerlIO_printf(file, ", ");
1751 PerlIO_putc(file, ')');
1752 /* The "quality" of a hash is defined as the total number of
1753 comparisons needed to access every element once, relative
1754 to the expected number needed for a random hash.
1756 The total number of comparisons is equal to the sum of
1757 the squares of the number of entries in each bucket.
1758 For a random hash of n keys into k buckets, the expected
1763 for (i = max; i > 0; i--) { /* Precision: count down. */
1764 sum += freq[i] * i * i;
1766 while ((keys = keys >> 1))
1768 theoret = HvKEYS(sv);
1769 theoret += theoret * (theoret-1)/pow2;
1770 PerlIO_putc(file, '\n');
1771 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1773 PerlIO_putc(file, '\n');
1774 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1775 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1776 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1777 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1778 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1780 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1781 if (mg && mg->mg_obj) {
1782 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1786 const char * const hvname = HvNAME_get(sv);
1788 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1792 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1793 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1795 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1797 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1801 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1802 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1803 (int)meta->mro_which->length,
1804 meta->mro_which->name,
1805 PTR2UV(meta->mro_which));
1806 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1807 (UV)meta->cache_gen);
1808 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1810 if (meta->mro_linear_all) {
1811 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1812 PTR2UV(meta->mro_linear_all));
1813 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1816 if (meta->mro_linear_current) {
1817 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1818 PTR2UV(meta->mro_linear_current));
1819 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1822 if (meta->mro_nextmethod) {
1823 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1824 PTR2UV(meta->mro_nextmethod));
1825 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1829 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1831 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1836 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1838 HV * const hv = MUTABLE_HV(sv);
1839 int count = maxnest - nest;
1842 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1845 const U32 hash = HeHASH(he);
1846 SV * const keysv = hv_iterkeysv(he);
1847 const char * const keypv = SvPV_const(keysv, len);
1848 SV * const elt = hv_iterval(hv, he);
1850 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1852 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1854 PerlIO_printf(file, "[REHASH] ");
1855 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1856 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1858 hv_iterinit(hv); /* Return to status quo */
1864 const char *const proto = SvPV_const(sv, len);
1865 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1870 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1871 if (!CvISXSUB(sv)) {
1873 Perl_dump_indent(aTHX_ level, file,
1874 " START = 0x%"UVxf" ===> %"IVdf"\n",
1875 PTR2UV(CvSTART(sv)),
1876 (IV)sequence_num(CvSTART(sv)));
1878 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1879 PTR2UV(CvROOT(sv)));
1880 if (CvROOT(sv) && dumpops) {
1881 do_op_dump(level+1, file, CvROOT(sv));
1884 SV * const constant = cv_const_sv((const CV *)sv);
1886 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1889 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1891 PTR2UV(CvXSUBANY(sv).any_ptr));
1892 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1895 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1896 (IV)CvXSUBANY(sv).any_i32);
1899 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1900 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1901 if (type == SVt_PVCV)
1902 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1903 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1904 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1905 if (type == SVt_PVFM)
1906 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1907 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1908 if (nest < maxnest) {
1909 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1912 const CV * const outside = CvOUTSIDE(sv);
1913 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1916 : CvANON(outside) ? "ANON"
1917 : (outside == PL_main_cv) ? "MAIN"
1918 : CvUNIQUE(outside) ? "UNIQUE"
1919 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1921 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1922 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1926 if (type == SVt_PVLV) {
1927 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1928 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1929 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1930 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1931 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1932 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1936 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1937 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1938 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1939 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1941 if (!isGV_with_GP(sv))
1943 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1944 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1945 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1946 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1949 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1950 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1951 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1952 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1953 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1954 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1955 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1956 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1957 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1958 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1959 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1960 do_gv_dump (level, file, " EGV", GvEGV(sv));
1963 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1964 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1965 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1966 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1967 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1968 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1969 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1971 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1972 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1973 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1975 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1976 PTR2UV(IoTOP_GV(sv)));
1977 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1978 maxnest, dumpops, pvlim);
1980 /* Source filters hide things that are not GVs in these three, so let's
1981 be careful out there. */
1983 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1984 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1985 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1987 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1988 PTR2UV(IoFMT_GV(sv)));
1989 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1990 maxnest, dumpops, pvlim);
1992 if (IoBOTTOM_NAME(sv))
1993 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1994 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1995 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1997 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1998 PTR2UV(IoBOTTOM_GV(sv)));
1999 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2000 maxnest, dumpops, pvlim);
2002 if (isPRINT(IoTYPE(sv)))
2003 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2005 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2006 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2013 Perl_sv_dump(pTHX_ SV *sv)
2017 PERL_ARGS_ASSERT_SV_DUMP;
2020 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2022 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2026 Perl_runops_debug(pTHX)
2030 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2034 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2037 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2038 PerlIO_printf(Perl_debug_log,
2039 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2040 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2041 PTR2UV(*PL_watchaddr));
2042 if (DEBUG_s_TEST_) {
2043 if (DEBUG_v_TEST_) {
2044 PerlIO_printf(Perl_debug_log, "\n");
2052 if (DEBUG_t_TEST_) debop(PL_op);
2053 if (DEBUG_P_TEST_) debprof(PL_op);
2055 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2056 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2063 Perl_debop(pTHX_ const OP *o)
2067 PERL_ARGS_ASSERT_DEBOP;
2069 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2072 Perl_deb(aTHX_ "%s", OP_NAME(o));
2073 switch (o->op_type) {
2076 /* With ITHREADS, consts are stored in the pad, and the right pad
2077 * may not be active here, so check.
2078 * Looks like only during compiling the pads are illegal.
2081 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2083 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2088 SV * const sv = newSV(0);
2090 /* FIXME - is this making unwarranted assumptions about the
2091 UTF-8 cleanliness of the dump file handle? */
2094 gv_fullname3(sv, cGVOPo_gv, NULL);
2095 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2099 PerlIO_printf(Perl_debug_log, "(NULL)");
2105 /* print the lexical's name */
2106 CV * const cv = deb_curcv(cxstack_ix);
2109 AV * const padlist = CvPADLIST(cv);
2110 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2111 sv = *av_fetch(comppad, o->op_targ, FALSE);
2115 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2117 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2123 PerlIO_printf(Perl_debug_log, "\n");
2128 S_deb_curcv(pTHX_ const I32 ix)
2131 const PERL_CONTEXT * const cx = &cxstack[ix];
2132 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2133 return cx->blk_sub.cv;
2134 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2136 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2141 return deb_curcv(ix - 1);
2145 Perl_watch(pTHX_ char **addr)
2149 PERL_ARGS_ASSERT_WATCH;
2151 PL_watchaddr = addr;
2153 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2154 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2158 S_debprof(pTHX_ const OP *o)
2162 PERL_ARGS_ASSERT_DEBPROF;
2164 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2166 if (!PL_profiledata)
2167 Newxz(PL_profiledata, MAXO, U32);
2168 ++PL_profiledata[o->op_type];
2172 Perl_debprofdump(pTHX)
2176 if (!PL_profiledata)
2178 for (i = 0; i < MAXO; i++) {
2179 if (PL_profiledata[i])
2180 PerlIO_printf(Perl_debug_log,
2181 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2188 * XML variants of most of the above routines
2192 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2196 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2198 PerlIO_printf(file, "\n ");
2199 va_start(args, pat);
2200 xmldump_vindent(level, file, pat, &args);
2206 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2209 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2210 va_start(args, pat);
2211 xmldump_vindent(level, file, pat, &args);
2216 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2218 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2220 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2221 PerlIO_vprintf(file, pat, *args);
2225 Perl_xmldump_all(pTHX)
2227 xmldump_all_perl(FALSE);
2231 Perl_xmldump_all_perl(pTHX_ bool justperl)
2233 PerlIO_setlinebuf(PL_xmlfp);
2235 op_xmldump(PL_main_root);
2236 xmldump_packsubs_perl(PL_defstash, justperl);
2237 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2238 PerlIO_close(PL_xmlfp);
2243 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2245 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2246 xmldump_packsubs_perl(stash, FALSE);
2250 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2255 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2257 if (!HvARRAY(stash))
2259 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2260 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2261 GV *gv = MUTABLE_GV(HeVAL(entry));
2263 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2266 xmldump_sub_perl(gv, justperl);
2269 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2270 && (hv = GvHV(gv)) && hv != PL_defstash)
2271 xmldump_packsubs_perl(hv, justperl); /* nested package */
2277 Perl_xmldump_sub(pTHX_ const GV *gv)
2279 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2280 xmldump_sub_perl(gv, FALSE);
2284 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2288 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2290 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2293 sv = sv_newmortal();
2294 gv_fullname3(sv, gv, NULL);
2295 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2296 if (CvXSUB(GvCV(gv)))
2297 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2298 PTR2UV(CvXSUB(GvCV(gv))),
2299 (int)CvXSUBANY(GvCV(gv)).any_i32);
2300 else if (CvROOT(GvCV(gv)))
2301 op_xmldump(CvROOT(GvCV(gv)));
2303 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2307 Perl_xmldump_form(pTHX_ const GV *gv)
2309 SV * const sv = sv_newmortal();
2311 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2313 gv_fullname3(sv, gv, NULL);
2314 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2315 if (CvROOT(GvFORM(gv)))
2316 op_xmldump(CvROOT(GvFORM(gv)));
2318 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2322 Perl_xmldump_eval(pTHX)
2324 op_xmldump(PL_eval_root);
2328 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2330 PERL_ARGS_ASSERT_SV_CATXMLSV;
2331 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2335 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2338 const char * const e = pv + len;
2339 const char * const start = pv;
2343 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2346 dsvcur = SvCUR(dsv); /* in case we have to restart */
2351 c = utf8_to_uvchr((U8*)pv, &cl);
2353 SvCUR(dsv) = dsvcur;
2418 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2421 sv_catpvs(dsv, "<");
2424 sv_catpvs(dsv, ">");
2427 sv_catpvs(dsv, "&");
2430 sv_catpvs(dsv, """);
2434 if (c < 32 || c > 127) {
2435 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2438 const char string = (char) c;
2439 sv_catpvn(dsv, &string, 1);
2443 if ((c >= 0xD800 && c <= 0xDB7F) ||
2444 (c >= 0xDC00 && c <= 0xDFFF) ||
2445 (c >= 0xFFF0 && c <= 0xFFFF) ||
2447 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2449 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2462 Perl_sv_xmlpeek(pTHX_ SV *sv)
2464 SV * const t = sv_newmortal();
2468 PERL_ARGS_ASSERT_SV_XMLPEEK;
2474 sv_catpv(t, "VOID=\"\"");
2477 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2478 sv_catpv(t, "WILD=\"\"");
2481 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2482 if (sv == &PL_sv_undef) {
2483 sv_catpv(t, "SV_UNDEF=\"1\"");
2484 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2485 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2489 else if (sv == &PL_sv_no) {
2490 sv_catpv(t, "SV_NO=\"1\"");
2491 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2492 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2493 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2494 SVp_POK|SVp_NOK)) &&
2499 else if (sv == &PL_sv_yes) {
2500 sv_catpv(t, "SV_YES=\"1\"");
2501 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2502 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2503 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2504 SVp_POK|SVp_NOK)) &&
2506 SvPVX(sv) && *SvPVX(sv) == '1' &&
2511 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2512 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2513 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2517 sv_catpv(t, " XXX=\"\" ");
2519 else if (SvREFCNT(sv) == 0) {
2520 sv_catpv(t, " refcnt=\"0\"");
2523 else if (DEBUG_R_TEST_) {
2526 /* is this SV on the tmps stack? */
2527 for (ix=PL_tmps_ix; ix>=0; ix--) {
2528 if (PL_tmps_stack[ix] == sv) {
2533 if (SvREFCNT(sv) > 1)
2534 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2537 sv_catpv(t, " DRT=\"<T>\"");
2541 sv_catpv(t, " ROK=\"\"");
2543 switch (SvTYPE(sv)) {
2545 sv_catpv(t, " FREED=\"1\"");
2549 sv_catpv(t, " UNDEF=\"1\"");
2552 sv_catpv(t, " IV=\"");
2555 sv_catpv(t, " NV=\"");
2558 sv_catpv(t, " PV=\"");
2561 sv_catpv(t, " PVIV=\"");
2564 sv_catpv(t, " PVNV=\"");
2567 sv_catpv(t, " PVMG=\"");
2570 sv_catpv(t, " PVLV=\"");
2573 sv_catpv(t, " AV=\"");
2576 sv_catpv(t, " HV=\"");
2580 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2582 sv_catpv(t, " CV=\"()\"");
2585 sv_catpv(t, " GV=\"");
2588 sv_catpv(t, " BIND=\"");
2591 sv_catpv(t, " ORANGE=\"");
2594 sv_catpv(t, " FM=\"");
2597 sv_catpv(t, " IO=\"");
2606 else if (SvNOKp(sv)) {
2607 STORE_NUMERIC_LOCAL_SET_STANDARD();
2608 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2609 RESTORE_NUMERIC_LOCAL();
2611 else if (SvIOKp(sv)) {
2613 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2615 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2624 return SvPV(t, n_a);
2628 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2630 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2633 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2636 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2639 REGEXP *const r = PM_GETRE(pm);
2640 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2641 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2642 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2644 SvREFCNT_dec(tmpsv);
2645 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2646 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2649 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2650 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2651 SV * const tmpsv = pm_description(pm);
2652 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2653 SvREFCNT_dec(tmpsv);
2657 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2658 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2659 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2660 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2661 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2662 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2665 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2669 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2671 do_pmop_xmldump(0, PL_xmlfp, pm);
2675 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2680 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2685 seq = sequence_num(o);
2686 Perl_xmldump_indent(aTHX_ level, file,
2687 "<op_%s seq=\"%"UVuf" -> ",
2692 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2693 sequence_num(o->op_next));
2695 PerlIO_printf(file, "DONE\"");
2698 if (o->op_type == OP_NULL)
2700 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2701 if (o->op_targ == OP_NEXTSTATE)
2704 PerlIO_printf(file, " line=\"%"UVuf"\"",
2705 (UV)CopLINE(cCOPo));
2706 if (CopSTASHPV(cCOPo))
2707 PerlIO_printf(file, " package=\"%s\"",
2709 if (CopLABEL(cCOPo))
2710 PerlIO_printf(file, " label=\"%s\"",
2715 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2718 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2721 SV * const tmpsv = newSVpvs("");
2722 switch (o->op_flags & OPf_WANT) {
2724 sv_catpv(tmpsv, ",VOID");
2726 case OPf_WANT_SCALAR:
2727 sv_catpv(tmpsv, ",SCALAR");
2730 sv_catpv(tmpsv, ",LIST");
2733 sv_catpv(tmpsv, ",UNKNOWN");
2736 if (o->op_flags & OPf_KIDS)
2737 sv_catpv(tmpsv, ",KIDS");
2738 if (o->op_flags & OPf_PARENS)
2739 sv_catpv(tmpsv, ",PARENS");
2740 if (o->op_flags & OPf_STACKED)
2741 sv_catpv(tmpsv, ",STACKED");
2742 if (o->op_flags & OPf_REF)
2743 sv_catpv(tmpsv, ",REF");
2744 if (o->op_flags & OPf_MOD)
2745 sv_catpv(tmpsv, ",MOD");
2746 if (o->op_flags & OPf_SPECIAL)
2747 sv_catpv(tmpsv, ",SPECIAL");
2748 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2749 SvREFCNT_dec(tmpsv);
2751 if (o->op_private) {
2752 SV * const tmpsv = newSVpvs("");
2753 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2754 if (o->op_private & OPpTARGET_MY)
2755 sv_catpv(tmpsv, ",TARGET_MY");
2757 else if (o->op_type == OP_LEAVESUB ||
2758 o->op_type == OP_LEAVE ||
2759 o->op_type == OP_LEAVESUBLV ||
2760 o->op_type == OP_LEAVEWRITE) {
2761 if (o->op_private & OPpREFCOUNTED)
2762 sv_catpv(tmpsv, ",REFCOUNTED");
2764 else if (o->op_type == OP_AASSIGN) {
2765 if (o->op_private & OPpASSIGN_COMMON)
2766 sv_catpv(tmpsv, ",COMMON");
2768 else if (o->op_type == OP_SASSIGN) {
2769 if (o->op_private & OPpASSIGN_BACKWARDS)
2770 sv_catpv(tmpsv, ",BACKWARDS");
2772 else if (o->op_type == OP_TRANS) {
2773 if (o->op_private & OPpTRANS_SQUASH)
2774 sv_catpv(tmpsv, ",SQUASH");
2775 if (o->op_private & OPpTRANS_DELETE)
2776 sv_catpv(tmpsv, ",DELETE");
2777 if (o->op_private & OPpTRANS_COMPLEMENT)
2778 sv_catpv(tmpsv, ",COMPLEMENT");
2779 if (o->op_private & OPpTRANS_IDENTICAL)
2780 sv_catpv(tmpsv, ",IDENTICAL");
2781 if (o->op_private & OPpTRANS_GROWS)
2782 sv_catpv(tmpsv, ",GROWS");
2784 else if (o->op_type == OP_REPEAT) {
2785 if (o->op_private & OPpREPEAT_DOLIST)
2786 sv_catpv(tmpsv, ",DOLIST");
2788 else if (o->op_type == OP_ENTERSUB ||
2789 o->op_type == OP_RV2SV ||
2790 o->op_type == OP_GVSV ||
2791 o->op_type == OP_RV2AV ||
2792 o->op_type == OP_RV2HV ||
2793 o->op_type == OP_RV2GV ||
2794 o->op_type == OP_AELEM ||
2795 o->op_type == OP_HELEM )
2797 if (o->op_type == OP_ENTERSUB) {
2798 if (o->op_private & OPpENTERSUB_AMPER)
2799 sv_catpv(tmpsv, ",AMPER");
2800 if (o->op_private & OPpENTERSUB_DB)
2801 sv_catpv(tmpsv, ",DB");
2802 if (o->op_private & OPpENTERSUB_HASTARG)
2803 sv_catpv(tmpsv, ",HASTARG");
2804 if (o->op_private & OPpENTERSUB_NOPAREN)
2805 sv_catpv(tmpsv, ",NOPAREN");
2806 if (o->op_private & OPpENTERSUB_INARGS)
2807 sv_catpv(tmpsv, ",INARGS");
2808 if (o->op_private & OPpENTERSUB_NOMOD)
2809 sv_catpv(tmpsv, ",NOMOD");
2812 switch (o->op_private & OPpDEREF) {
2814 sv_catpv(tmpsv, ",SV");
2817 sv_catpv(tmpsv, ",AV");
2820 sv_catpv(tmpsv, ",HV");
2823 if (o->op_private & OPpMAYBE_LVSUB)
2824 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2826 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2827 if (o->op_private & OPpLVAL_DEFER)
2828 sv_catpv(tmpsv, ",LVAL_DEFER");
2831 if (o->op_private & HINT_STRICT_REFS)
2832 sv_catpv(tmpsv, ",STRICT_REFS");
2833 if (o->op_private & OPpOUR_INTRO)
2834 sv_catpv(tmpsv, ",OUR_INTRO");
2837 else if (o->op_type == OP_CONST) {
2838 if (o->op_private & OPpCONST_BARE)
2839 sv_catpv(tmpsv, ",BARE");
2840 if (o->op_private & OPpCONST_STRICT)
2841 sv_catpv(tmpsv, ",STRICT");
2842 if (o->op_private & OPpCONST_ARYBASE)
2843 sv_catpv(tmpsv, ",ARYBASE");
2844 if (o->op_private & OPpCONST_WARNING)
2845 sv_catpv(tmpsv, ",WARNING");
2846 if (o->op_private & OPpCONST_ENTERED)
2847 sv_catpv(tmpsv, ",ENTERED");
2849 else if (o->op_type == OP_FLIP) {
2850 if (o->op_private & OPpFLIP_LINENUM)
2851 sv_catpv(tmpsv, ",LINENUM");
2853 else if (o->op_type == OP_FLOP) {
2854 if (o->op_private & OPpFLIP_LINENUM)
2855 sv_catpv(tmpsv, ",LINENUM");
2857 else if (o->op_type == OP_RV2CV) {
2858 if (o->op_private & OPpLVAL_INTRO)
2859 sv_catpv(tmpsv, ",INTRO");
2861 else if (o->op_type == OP_GV) {
2862 if (o->op_private & OPpEARLY_CV)
2863 sv_catpv(tmpsv, ",EARLY_CV");
2865 else if (o->op_type == OP_LIST) {
2866 if (o->op_private & OPpLIST_GUESSED)
2867 sv_catpv(tmpsv, ",GUESSED");
2869 else if (o->op_type == OP_DELETE) {
2870 if (o->op_private & OPpSLICE)
2871 sv_catpv(tmpsv, ",SLICE");
2873 else if (o->op_type == OP_EXISTS) {
2874 if (o->op_private & OPpEXISTS_SUB)
2875 sv_catpv(tmpsv, ",EXISTS_SUB");
2877 else if (o->op_type == OP_SORT) {
2878 if (o->op_private & OPpSORT_NUMERIC)
2879 sv_catpv(tmpsv, ",NUMERIC");
2880 if (o->op_private & OPpSORT_INTEGER)
2881 sv_catpv(tmpsv, ",INTEGER");
2882 if (o->op_private & OPpSORT_REVERSE)
2883 sv_catpv(tmpsv, ",REVERSE");
2885 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2886 if (o->op_private & OPpOPEN_IN_RAW)
2887 sv_catpv(tmpsv, ",IN_RAW");
2888 if (o->op_private & OPpOPEN_IN_CRLF)
2889 sv_catpv(tmpsv, ",IN_CRLF");
2890 if (o->op_private & OPpOPEN_OUT_RAW)
2891 sv_catpv(tmpsv, ",OUT_RAW");
2892 if (o->op_private & OPpOPEN_OUT_CRLF)
2893 sv_catpv(tmpsv, ",OUT_CRLF");
2895 else if (o->op_type == OP_EXIT) {
2896 if (o->op_private & OPpEXIT_VMSISH)
2897 sv_catpv(tmpsv, ",EXIT_VMSISH");
2898 if (o->op_private & OPpHUSH_VMSISH)
2899 sv_catpv(tmpsv, ",HUSH_VMSISH");
2901 else if (o->op_type == OP_DIE) {
2902 if (o->op_private & OPpHUSH_VMSISH)
2903 sv_catpv(tmpsv, ",HUSH_VMSISH");
2905 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2906 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2907 sv_catpv(tmpsv, ",FT_ACCESS");
2908 if (o->op_private & OPpFT_STACKED)
2909 sv_catpv(tmpsv, ",FT_STACKED");
2911 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2912 sv_catpv(tmpsv, ",INTRO");
2914 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2915 SvREFCNT_dec(tmpsv);
2918 switch (o->op_type) {
2920 if (o->op_flags & OPf_SPECIAL) {
2926 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2928 if (cSVOPo->op_sv) {
2929 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2930 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2936 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2937 s = SvPV(tmpsv1,len);
2938 sv_catxmlpvn(tmpsv2, s, len, 1);
2939 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2943 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2948 case OP_METHOD_NAMED:
2949 #ifndef USE_ITHREADS
2950 /* with ITHREADS, consts are stored in the pad, and the right pad
2951 * may not be active here, so skip */
2952 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2958 PerlIO_printf(file, ">\n");
2960 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2965 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2966 (UV)CopLINE(cCOPo));
2967 if (CopSTASHPV(cCOPo))
2968 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2970 if (CopLABEL(cCOPo))
2971 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2975 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2976 if (cLOOPo->op_redoop)
2977 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2979 PerlIO_printf(file, "DONE\"");
2980 S_xmldump_attr(aTHX_ level, file, "next=\"");
2981 if (cLOOPo->op_nextop)
2982 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2984 PerlIO_printf(file, "DONE\"");
2985 S_xmldump_attr(aTHX_ level, file, "last=\"");
2986 if (cLOOPo->op_lastop)
2987 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2989 PerlIO_printf(file, "DONE\"");
2997 S_xmldump_attr(aTHX_ level, file, "other=\"");
2998 if (cLOGOPo->op_other)
2999 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3001 PerlIO_printf(file, "DONE\"");
3009 if (o->op_private & OPpREFCOUNTED)
3010 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3016 if (PL_madskills && o->op_madprop) {
3017 char prevkey = '\0';
3018 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3019 const MADPROP* mp = o->op_madprop;
3023 PerlIO_printf(file, ">\n");
3025 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3028 char tmp = mp->mad_key;
3029 sv_setpvs(tmpsv,"\"");
3031 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3032 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3033 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3036 sv_catpv(tmpsv, "\"");
3037 switch (mp->mad_type) {
3039 sv_catpv(tmpsv, "NULL");
3040 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3043 sv_catpv(tmpsv, " val=\"");
3044 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3045 sv_catpv(tmpsv, "\"");
3046 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3049 sv_catpv(tmpsv, " val=\"");
3050 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3051 sv_catpv(tmpsv, "\"");
3052 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3055 if ((OP*)mp->mad_val) {
3056 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3057 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3058 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3062 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3068 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3070 SvREFCNT_dec(tmpsv);
3073 switch (o->op_type) {
3080 PerlIO_printf(file, ">\n");
3082 do_pmop_xmldump(level, file, cPMOPo);
3088 if (o->op_flags & OPf_KIDS) {
3092 PerlIO_printf(file, ">\n");
3094 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3095 do_op_xmldump(level, file, kid);
3099 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3101 PerlIO_printf(file, " />\n");
3105 Perl_op_xmldump(pTHX_ const OP *o)
3107 PERL_ARGS_ASSERT_OP_XMLDUMP;
3109 do_op_xmldump(0, PL_xmlfp, o);
3115 * c-indentation-style: bsd
3117 * indent-tabs-mode: t
3120 * ex: set ts=8 sts=4 sw=4 noet: