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);
96 PerlIO_setlinebuf(Perl_debug_log);
98 op_dump(PL_main_root);
99 dump_packsubs(PL_defstash);
103 Perl_dump_packsubs(pTHX_ const HV *stash)
108 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
112 for (i = 0; i <= (I32) HvMAX(stash); i++) {
114 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
115 const GV * const gv = (const GV *)HeVAL(entry);
116 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
122 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
123 const HV * const hv = GvHV(gv);
124 if (hv && (hv != PL_defstash))
125 dump_packsubs(hv); /* nested package */
132 Perl_dump_sub(pTHX_ const GV *gv)
134 SV * const sv = sv_newmortal();
136 PERL_ARGS_ASSERT_DUMP_SUB;
138 gv_fullname3(sv, gv, NULL);
139 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
140 if (CvISXSUB(GvCV(gv)))
141 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
142 PTR2UV(CvXSUB(GvCV(gv))),
143 (int)CvXSUBANY(GvCV(gv)).any_i32);
144 else if (CvROOT(GvCV(gv)))
145 op_dump(CvROOT(GvCV(gv)));
147 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
151 Perl_dump_form(pTHX_ const GV *gv)
153 SV * const sv = sv_newmortal();
155 PERL_ARGS_ASSERT_DUMP_FORM;
157 gv_fullname3(sv, gv, NULL);
158 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
159 if (CvROOT(GvFORM(gv)))
160 op_dump(CvROOT(GvFORM(gv)));
162 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
169 op_dump(PL_eval_root);
174 =for apidoc pv_escape
176 Escapes at most the first "count" chars of pv and puts the results into
177 dsv such that the size of the escaped string will not exceed "max" chars
178 and will not contain any incomplete escape sequences.
180 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
181 will also be escaped.
183 Normally the SV will be cleared before the escaped string is prepared,
184 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
186 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
187 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
188 using C<is_utf8_string()> to determine if it is Unicode.
190 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
191 using C<\x01F1> style escapes, otherwise only chars above 255 will be
192 escaped using this style, other non printable chars will use octal or
193 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
194 then all chars below 255 will be treated as printable and
195 will be output as literals.
197 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
198 string will be escaped, regardles of max. If the string is utf8 and
199 the chars value is >255 then it will be returned as a plain hex
200 sequence. Thus the output will either be a single char,
201 an octal escape sequence, a special escape like C<\n> or a 3 or
202 more digit hex value.
204 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
205 not a '\\'. This is because regexes very often contain backslashed
206 sequences, whereas '%' is not a particularly common character in patterns.
208 Returns a pointer to the escaped text as held by dsv.
212 #define PV_ESCAPE_OCTBUFSIZE 32
215 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
216 const STRLEN count, const STRLEN max,
217 STRLEN * const escaped, const U32 flags )
219 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
220 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
221 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
222 STRLEN wrote = 0; /* chars written so far */
223 STRLEN chsize = 0; /* size of data to be written */
224 STRLEN readsize = 1; /* size of data just read */
225 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
226 const char *pv = str;
227 const char * const end = pv + count; /* end of string */
230 PERL_ARGS_ASSERT_PV_ESCAPE;
232 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
233 /* This won't alter the UTF-8 flag */
237 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
240 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
241 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
242 const U8 c = (U8)u & 0xFF;
244 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
245 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
246 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
249 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
250 "%cx{%"UVxf"}", esc, u);
251 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
254 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
258 case '\\' : /* fallthrough */
259 case '%' : if ( c == esc ) {
265 case '\v' : octbuf[1] = 'v'; break;
266 case '\t' : octbuf[1] = 't'; break;
267 case '\r' : octbuf[1] = 'r'; break;
268 case '\n' : octbuf[1] = 'n'; break;
269 case '\f' : octbuf[1] = 'f'; break;
277 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
278 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
281 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
288 if ( max && (wrote + chsize > max) ) {
290 } else if (chsize > 1) {
291 sv_catpvn(dsv, octbuf, chsize);
294 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
295 128-255 can be appended raw to the dsv. If dsv happens to be
296 UTF-8 then we need catpvf to upgrade them for us.
297 Or add a new API call sv_catpvc(). Think about that name, and
298 how to keep it clear that it's unlike the s of catpvs, which is
299 really an array octets, not a string. */
300 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
303 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
311 =for apidoc pv_pretty
313 Converts a string into something presentable, handling escaping via
314 pv_escape() and supporting quoting and ellipses.
316 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
317 double quoted with any double quotes in the string escaped. Otherwise
318 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
321 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
322 string were output then an ellipsis C<...> will be appended to the
323 string. Note that this happens AFTER it has been quoted.
325 If start_color is non-null then it will be inserted after the opening
326 quote (if there is one) but before the escaped text. If end_color
327 is non-null then it will be inserted after the escaped text but before
328 any quotes or ellipses.
330 Returns a pointer to the prettified text as held by dsv.
336 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
337 const STRLEN max, char const * const start_color, char const * const end_color,
340 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
343 PERL_ARGS_ASSERT_PV_PRETTY;
345 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
346 /* This won't alter the UTF-8 flag */
351 sv_catpvs(dsv, "\"");
352 else if ( flags & PERL_PV_PRETTY_LTGT )
355 if ( start_color != NULL )
356 sv_catpv(dsv, start_color);
358 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
360 if ( end_color != NULL )
361 sv_catpv(dsv, end_color);
364 sv_catpvs( dsv, "\"");
365 else if ( flags & PERL_PV_PRETTY_LTGT )
368 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
369 sv_catpvs(dsv, "...");
375 =for apidoc pv_display
379 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
381 except that an additional "\0" will be appended to the string when
382 len > cur and pv[cur] is "\0".
384 Note that the final string may be up to 7 chars longer than pvlim.
390 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
392 PERL_ARGS_ASSERT_PV_DISPLAY;
394 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
395 if (len > cur && pv[cur] == '\0')
396 sv_catpvs( dsv, "\\0");
401 Perl_sv_peek(pTHX_ SV *sv)
404 SV * const t = sv_newmortal();
414 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
418 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
419 if (sv == &PL_sv_undef) {
420 sv_catpv(t, "SV_UNDEF");
421 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
422 SVs_GMG|SVs_SMG|SVs_RMG)) &&
426 else if (sv == &PL_sv_no) {
427 sv_catpv(t, "SV_NO");
428 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
429 SVs_GMG|SVs_SMG|SVs_RMG)) &&
430 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
436 else if (sv == &PL_sv_yes) {
437 sv_catpv(t, "SV_YES");
438 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
439 SVs_GMG|SVs_SMG|SVs_RMG)) &&
440 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
443 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
448 sv_catpv(t, "SV_PLACEHOLDER");
449 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
450 SVs_GMG|SVs_SMG|SVs_RMG)) &&
456 else if (SvREFCNT(sv) == 0) {
460 else if (DEBUG_R_TEST_) {
463 /* is this SV on the tmps stack? */
464 for (ix=PL_tmps_ix; ix>=0; ix--) {
465 if (PL_tmps_stack[ix] == sv) {
470 if (SvREFCNT(sv) > 1)
471 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
479 if (SvCUR(t) + unref > 10) {
480 SvCUR_set(t, unref + 3);
489 if (type == SVt_PVCV) {
490 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
492 } else if (type < SVt_LAST) {
493 sv_catpv(t, svshorttypenames[type]);
495 if (type == SVt_NULL)
498 sv_catpv(t, "FREED");
503 if (!SvPVX_const(sv))
504 sv_catpv(t, "(null)");
506 SV * const tmp = newSVpvs("");
509 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
510 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
512 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
513 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
518 else if (SvNOKp(sv)) {
519 STORE_NUMERIC_LOCAL_SET_STANDARD();
520 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
521 RESTORE_NUMERIC_LOCAL();
523 else if (SvIOKp(sv)) {
525 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
527 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
535 return SvPV_nolen(t);
539 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
543 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
546 Perl_dump_indent(aTHX_ level, file, "{}\n");
549 Perl_dump_indent(aTHX_ level, file, "{\n");
551 if (pm->op_pmflags & PMf_ONCE)
556 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
557 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
558 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
560 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
561 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
562 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
563 op_dump(pm->op_pmreplrootu.op_pmreplroot);
565 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
566 SV * const tmpsv = pm_description(pm);
567 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
571 Perl_dump_indent(aTHX_ level-1, file, "}\n");
575 S_pm_description(pTHX_ const PMOP *pm)
577 SV * const desc = newSVpvs("");
578 const REGEXP * const regex = PM_GETRE(pm);
579 const U32 pmflags = pm->op_pmflags;
581 PERL_ARGS_ASSERT_PM_DESCRIPTION;
583 if (pmflags & PMf_ONCE)
584 sv_catpv(desc, ",ONCE");
586 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
587 sv_catpv(desc, ":USED");
589 if (pmflags & PMf_USED)
590 sv_catpv(desc, ":USED");
594 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
595 sv_catpv(desc, ",TAINTED");
596 if (RX_CHECK_SUBSTR(regex)) {
597 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
598 sv_catpv(desc, ",SCANFIRST");
599 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
600 sv_catpv(desc, ",ALL");
602 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
603 sv_catpv(desc, ",SKIPWHITE");
606 if (pmflags & PMf_CONST)
607 sv_catpv(desc, ",CONST");
608 if (pmflags & PMf_KEEP)
609 sv_catpv(desc, ",KEEP");
610 if (pmflags & PMf_GLOBAL)
611 sv_catpv(desc, ",GLOBAL");
612 if (pmflags & PMf_CONTINUE)
613 sv_catpv(desc, ",CONTINUE");
614 if (pmflags & PMf_RETAINT)
615 sv_catpv(desc, ",RETAINT");
616 if (pmflags & PMf_EVAL)
617 sv_catpv(desc, ",EVAL");
622 Perl_pmop_dump(pTHX_ PMOP *pm)
624 do_pmop_dump(0, Perl_debug_log, pm);
627 /* An op sequencer. We visit the ops in the order they're to execute. */
630 S_sequence(pTHX_ register const OP *o)
633 const OP *oldop = NULL;
646 for (; o; o = o->op_next) {
648 SV * const op = newSVuv(PTR2UV(o));
649 const char * const key = SvPV_const(op, len);
651 if (hv_exists(Sequence, key, len))
654 switch (o->op_type) {
656 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
657 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
666 if (oldop && o->op_next)
673 if (oldop && o->op_next)
675 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
688 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
689 sequence_tail(cLOGOPo->op_other);
694 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
695 sequence_tail(cLOOPo->op_redoop);
696 sequence_tail(cLOOPo->op_nextop);
697 sequence_tail(cLOOPo->op_lastop);
701 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
702 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
711 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
719 S_sequence_tail(pTHX_ const OP *o)
721 while (o && (o->op_type == OP_NULL))
727 S_sequence_num(pTHX_ const OP *o)
735 op = newSVuv(PTR2UV(o));
736 key = SvPV_const(op, len);
737 seq = hv_fetch(Sequence, key, len, 0);
738 return seq ? SvUV(*seq): 0;
742 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
746 const OPCODE optype = o->op_type;
748 PERL_ARGS_ASSERT_DO_OP_DUMP;
751 Perl_dump_indent(aTHX_ level, file, "{\n");
753 seq = sequence_num(o);
755 PerlIO_printf(file, "%-4"UVuf, seq);
757 PerlIO_printf(file, " ");
759 "%*sTYPE = %s ===> ",
760 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
762 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
763 sequence_num(o->op_next));
765 PerlIO_printf(file, "DONE\n");
767 if (optype == OP_NULL) {
768 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
769 if (o->op_targ == OP_NEXTSTATE) {
771 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
773 if (CopSTASHPV(cCOPo))
774 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
777 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
782 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
785 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
787 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
788 SV * const tmpsv = newSVpvs("");
789 switch (o->op_flags & OPf_WANT) {
791 sv_catpv(tmpsv, ",VOID");
793 case OPf_WANT_SCALAR:
794 sv_catpv(tmpsv, ",SCALAR");
797 sv_catpv(tmpsv, ",LIST");
800 sv_catpv(tmpsv, ",UNKNOWN");
803 if (o->op_flags & OPf_KIDS)
804 sv_catpv(tmpsv, ",KIDS");
805 if (o->op_flags & OPf_PARENS)
806 sv_catpv(tmpsv, ",PARENS");
807 if (o->op_flags & OPf_STACKED)
808 sv_catpv(tmpsv, ",STACKED");
809 if (o->op_flags & OPf_REF)
810 sv_catpv(tmpsv, ",REF");
811 if (o->op_flags & OPf_MOD)
812 sv_catpv(tmpsv, ",MOD");
813 if (o->op_flags & OPf_SPECIAL)
814 sv_catpv(tmpsv, ",SPECIAL");
816 sv_catpv(tmpsv, ",LATEFREE");
818 sv_catpv(tmpsv, ",LATEFREED");
820 sv_catpv(tmpsv, ",ATTACHED");
821 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
825 SV * const tmpsv = newSVpvs("");
826 if (PL_opargs[optype] & OA_TARGLEX) {
827 if (o->op_private & OPpTARGET_MY)
828 sv_catpv(tmpsv, ",TARGET_MY");
830 else if (optype == OP_LEAVESUB ||
831 optype == OP_LEAVE ||
832 optype == OP_LEAVESUBLV ||
833 optype == OP_LEAVEWRITE) {
834 if (o->op_private & OPpREFCOUNTED)
835 sv_catpv(tmpsv, ",REFCOUNTED");
837 else if (optype == OP_AASSIGN) {
838 if (o->op_private & OPpASSIGN_COMMON)
839 sv_catpv(tmpsv, ",COMMON");
841 else if (optype == OP_SASSIGN) {
842 if (o->op_private & OPpASSIGN_BACKWARDS)
843 sv_catpv(tmpsv, ",BACKWARDS");
845 else if (optype == OP_TRANS) {
846 if (o->op_private & OPpTRANS_SQUASH)
847 sv_catpv(tmpsv, ",SQUASH");
848 if (o->op_private & OPpTRANS_DELETE)
849 sv_catpv(tmpsv, ",DELETE");
850 if (o->op_private & OPpTRANS_COMPLEMENT)
851 sv_catpv(tmpsv, ",COMPLEMENT");
852 if (o->op_private & OPpTRANS_IDENTICAL)
853 sv_catpv(tmpsv, ",IDENTICAL");
854 if (o->op_private & OPpTRANS_GROWS)
855 sv_catpv(tmpsv, ",GROWS");
857 else if (optype == OP_REPEAT) {
858 if (o->op_private & OPpREPEAT_DOLIST)
859 sv_catpv(tmpsv, ",DOLIST");
861 else if (optype == OP_ENTERSUB ||
862 optype == OP_RV2SV ||
864 optype == OP_RV2AV ||
865 optype == OP_RV2HV ||
866 optype == OP_RV2GV ||
867 optype == OP_AELEM ||
870 if (optype == OP_ENTERSUB) {
871 if (o->op_private & OPpENTERSUB_AMPER)
872 sv_catpv(tmpsv, ",AMPER");
873 if (o->op_private & OPpENTERSUB_DB)
874 sv_catpv(tmpsv, ",DB");
875 if (o->op_private & OPpENTERSUB_HASTARG)
876 sv_catpv(tmpsv, ",HASTARG");
877 if (o->op_private & OPpENTERSUB_NOPAREN)
878 sv_catpv(tmpsv, ",NOPAREN");
879 if (o->op_private & OPpENTERSUB_INARGS)
880 sv_catpv(tmpsv, ",INARGS");
881 if (o->op_private & OPpENTERSUB_NOMOD)
882 sv_catpv(tmpsv, ",NOMOD");
885 switch (o->op_private & OPpDEREF) {
887 sv_catpv(tmpsv, ",SV");
890 sv_catpv(tmpsv, ",AV");
893 sv_catpv(tmpsv, ",HV");
896 if (o->op_private & OPpMAYBE_LVSUB)
897 sv_catpv(tmpsv, ",MAYBE_LVSUB");
899 if (optype == OP_AELEM || optype == OP_HELEM) {
900 if (o->op_private & OPpLVAL_DEFER)
901 sv_catpv(tmpsv, ",LVAL_DEFER");
904 if (o->op_private & HINT_STRICT_REFS)
905 sv_catpv(tmpsv, ",STRICT_REFS");
906 if (o->op_private & OPpOUR_INTRO)
907 sv_catpv(tmpsv, ",OUR_INTRO");
910 else if (optype == OP_CONST) {
911 if (o->op_private & OPpCONST_BARE)
912 sv_catpv(tmpsv, ",BARE");
913 if (o->op_private & OPpCONST_STRICT)
914 sv_catpv(tmpsv, ",STRICT");
915 if (o->op_private & OPpCONST_ARYBASE)
916 sv_catpv(tmpsv, ",ARYBASE");
917 if (o->op_private & OPpCONST_WARNING)
918 sv_catpv(tmpsv, ",WARNING");
919 if (o->op_private & OPpCONST_ENTERED)
920 sv_catpv(tmpsv, ",ENTERED");
922 else if (optype == OP_FLIP) {
923 if (o->op_private & OPpFLIP_LINENUM)
924 sv_catpv(tmpsv, ",LINENUM");
926 else if (optype == OP_FLOP) {
927 if (o->op_private & OPpFLIP_LINENUM)
928 sv_catpv(tmpsv, ",LINENUM");
930 else if (optype == OP_RV2CV) {
931 if (o->op_private & OPpLVAL_INTRO)
932 sv_catpv(tmpsv, ",INTRO");
934 else if (optype == OP_GV) {
935 if (o->op_private & OPpEARLY_CV)
936 sv_catpv(tmpsv, ",EARLY_CV");
938 else if (optype == OP_LIST) {
939 if (o->op_private & OPpLIST_GUESSED)
940 sv_catpv(tmpsv, ",GUESSED");
942 else if (optype == OP_DELETE) {
943 if (o->op_private & OPpSLICE)
944 sv_catpv(tmpsv, ",SLICE");
946 else if (optype == OP_EXISTS) {
947 if (o->op_private & OPpEXISTS_SUB)
948 sv_catpv(tmpsv, ",EXISTS_SUB");
950 else if (optype == OP_SORT) {
951 if (o->op_private & OPpSORT_NUMERIC)
952 sv_catpv(tmpsv, ",NUMERIC");
953 if (o->op_private & OPpSORT_INTEGER)
954 sv_catpv(tmpsv, ",INTEGER");
955 if (o->op_private & OPpSORT_REVERSE)
956 sv_catpv(tmpsv, ",REVERSE");
958 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
959 if (o->op_private & OPpOPEN_IN_RAW)
960 sv_catpv(tmpsv, ",IN_RAW");
961 if (o->op_private & OPpOPEN_IN_CRLF)
962 sv_catpv(tmpsv, ",IN_CRLF");
963 if (o->op_private & OPpOPEN_OUT_RAW)
964 sv_catpv(tmpsv, ",OUT_RAW");
965 if (o->op_private & OPpOPEN_OUT_CRLF)
966 sv_catpv(tmpsv, ",OUT_CRLF");
968 else if (optype == OP_EXIT) {
969 if (o->op_private & OPpEXIT_VMSISH)
970 sv_catpv(tmpsv, ",EXIT_VMSISH");
971 if (o->op_private & OPpHUSH_VMSISH)
972 sv_catpv(tmpsv, ",HUSH_VMSISH");
974 else if (optype == OP_DIE) {
975 if (o->op_private & OPpHUSH_VMSISH)
976 sv_catpv(tmpsv, ",HUSH_VMSISH");
978 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
979 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
980 sv_catpv(tmpsv, ",FT_ACCESS");
981 if (o->op_private & OPpFT_STACKED)
982 sv_catpv(tmpsv, ",FT_STACKED");
984 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
985 sv_catpv(tmpsv, ",INTRO");
987 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
992 if (PL_madskills && o->op_madprop) {
993 SV * const tmpsv = newSVpvs("");
994 MADPROP* mp = o->op_madprop;
995 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
998 const char tmp = mp->mad_key;
999 sv_setpvs(tmpsv,"'");
1001 sv_catpvn(tmpsv, &tmp, 1);
1002 sv_catpv(tmpsv, "'=");
1003 switch (mp->mad_type) {
1005 sv_catpv(tmpsv, "NULL");
1006 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1009 sv_catpv(tmpsv, "<");
1010 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1011 sv_catpv(tmpsv, ">");
1012 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1015 if ((OP*)mp->mad_val) {
1016 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1017 do_op_dump(level, file, (OP*)mp->mad_val);
1021 sv_catpv(tmpsv, "(UNK)");
1022 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1028 Perl_dump_indent(aTHX_ level, file, "}\n");
1030 SvREFCNT_dec(tmpsv);
1039 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1041 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1042 if (cSVOPo->op_sv) {
1043 SV * const tmpsv = newSV(0);
1047 /* FIXME - is this making unwarranted assumptions about the
1048 UTF-8 cleanliness of the dump file handle? */
1051 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1052 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1053 SvPV_nolen_const(tmpsv));
1057 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1063 case OP_METHOD_NAMED:
1064 #ifndef USE_ITHREADS
1065 /* with ITHREADS, consts are stored in the pad, and the right pad
1066 * may not be active here, so skip */
1067 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1073 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1074 (UV)CopLINE(cCOPo));
1075 if (CopSTASHPV(cCOPo))
1076 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1078 if (CopLABEL(cCOPo))
1079 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1083 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1084 if (cLOOPo->op_redoop)
1085 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1087 PerlIO_printf(file, "DONE\n");
1088 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1089 if (cLOOPo->op_nextop)
1090 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1092 PerlIO_printf(file, "DONE\n");
1093 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1094 if (cLOOPo->op_lastop)
1095 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1097 PerlIO_printf(file, "DONE\n");
1105 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1106 if (cLOGOPo->op_other)
1107 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1109 PerlIO_printf(file, "DONE\n");
1115 do_pmop_dump(level, file, cPMOPo);
1123 if (o->op_private & OPpREFCOUNTED)
1124 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1129 if (o->op_flags & OPf_KIDS) {
1131 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1132 do_op_dump(level, file, kid);
1134 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1138 Perl_op_dump(pTHX_ const OP *o)
1140 PERL_ARGS_ASSERT_OP_DUMP;
1141 do_op_dump(0, Perl_debug_log, o);
1145 Perl_gv_dump(pTHX_ GV *gv)
1149 PERL_ARGS_ASSERT_GV_DUMP;
1152 PerlIO_printf(Perl_debug_log, "{}\n");
1155 sv = sv_newmortal();
1156 PerlIO_printf(Perl_debug_log, "{\n");
1157 gv_fullname3(sv, gv, NULL);
1158 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1159 if (gv != GvEGV(gv)) {
1160 gv_efullname3(sv, GvEGV(gv), NULL);
1161 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1163 PerlIO_putc(Perl_debug_log, '\n');
1164 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1168 /* map magic types to the symbolic names
1169 * (with the PERL_MAGIC_ prefixed stripped)
1172 static const struct { const char type; const char *name; } magic_names[] = {
1173 { PERL_MAGIC_sv, "sv(\\0)" },
1174 { PERL_MAGIC_arylen, "arylen(#)" },
1175 { PERL_MAGIC_rhash, "rhash(%)" },
1176 { PERL_MAGIC_pos, "pos(.)" },
1177 { PERL_MAGIC_symtab, "symtab(:)" },
1178 { PERL_MAGIC_backref, "backref(<)" },
1179 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1180 { PERL_MAGIC_overload, "overload(A)" },
1181 { PERL_MAGIC_bm, "bm(B)" },
1182 { PERL_MAGIC_regdata, "regdata(D)" },
1183 { PERL_MAGIC_env, "env(E)" },
1184 { PERL_MAGIC_hints, "hints(H)" },
1185 { PERL_MAGIC_isa, "isa(I)" },
1186 { PERL_MAGIC_dbfile, "dbfile(L)" },
1187 { PERL_MAGIC_shared, "shared(N)" },
1188 { PERL_MAGIC_tied, "tied(P)" },
1189 { PERL_MAGIC_sig, "sig(S)" },
1190 { PERL_MAGIC_uvar, "uvar(U)" },
1191 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1192 { PERL_MAGIC_overload_table, "overload_table(c)" },
1193 { PERL_MAGIC_regdatum, "regdatum(d)" },
1194 { PERL_MAGIC_envelem, "envelem(e)" },
1195 { PERL_MAGIC_fm, "fm(f)" },
1196 { PERL_MAGIC_regex_global, "regex_global(g)" },
1197 { PERL_MAGIC_hintselem, "hintselem(h)" },
1198 { PERL_MAGIC_isaelem, "isaelem(i)" },
1199 { PERL_MAGIC_nkeys, "nkeys(k)" },
1200 { PERL_MAGIC_dbline, "dbline(l)" },
1201 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1202 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1203 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1204 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1205 { PERL_MAGIC_qr, "qr(r)" },
1206 { PERL_MAGIC_sigelem, "sigelem(s)" },
1207 { PERL_MAGIC_taint, "taint(t)" },
1208 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1209 { PERL_MAGIC_vec, "vec(v)" },
1210 { PERL_MAGIC_vstring, "vstring(V)" },
1211 { PERL_MAGIC_utf8, "utf8(w)" },
1212 { PERL_MAGIC_substr, "substr(x)" },
1213 { PERL_MAGIC_defelem, "defelem(y)" },
1214 { PERL_MAGIC_ext, "ext(~)" },
1215 /* this null string terminates the list */
1220 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1222 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1224 for (; mg; mg = mg->mg_moremagic) {
1225 Perl_dump_indent(aTHX_ level, file,
1226 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1227 if (mg->mg_virtual) {
1228 const MGVTBL * const v = mg->mg_virtual;
1230 if (v == &PL_vtbl_sv) s = "sv";
1231 else if (v == &PL_vtbl_env) s = "env";
1232 else if (v == &PL_vtbl_envelem) s = "envelem";
1233 else if (v == &PL_vtbl_sig) s = "sig";
1234 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1235 else if (v == &PL_vtbl_pack) s = "pack";
1236 else if (v == &PL_vtbl_packelem) s = "packelem";
1237 else if (v == &PL_vtbl_dbline) s = "dbline";
1238 else if (v == &PL_vtbl_isa) s = "isa";
1239 else if (v == &PL_vtbl_arylen) s = "arylen";
1240 else if (v == &PL_vtbl_mglob) s = "mglob";
1241 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1242 else if (v == &PL_vtbl_taint) s = "taint";
1243 else if (v == &PL_vtbl_substr) s = "substr";
1244 else if (v == &PL_vtbl_vec) s = "vec";
1245 else if (v == &PL_vtbl_pos) s = "pos";
1246 else if (v == &PL_vtbl_bm) s = "bm";
1247 else if (v == &PL_vtbl_fm) s = "fm";
1248 else if (v == &PL_vtbl_uvar) s = "uvar";
1249 else if (v == &PL_vtbl_defelem) s = "defelem";
1250 #ifdef USE_LOCALE_COLLATE
1251 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1253 else if (v == &PL_vtbl_amagic) s = "amagic";
1254 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1255 else if (v == &PL_vtbl_backref) s = "backref";
1256 else if (v == &PL_vtbl_utf8) s = "utf8";
1257 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1258 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1261 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1263 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1266 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1269 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1273 const char *name = NULL;
1274 for (n = 0; magic_names[n].name; n++) {
1275 if (mg->mg_type == magic_names[n].type) {
1276 name = magic_names[n].name;
1281 Perl_dump_indent(aTHX_ level, file,
1282 " MG_TYPE = PERL_MAGIC_%s\n", name);
1284 Perl_dump_indent(aTHX_ level, file,
1285 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1289 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1290 if (mg->mg_type == PERL_MAGIC_envelem &&
1291 mg->mg_flags & MGf_TAINTEDDIR)
1292 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1293 if (mg->mg_flags & MGf_REFCOUNTED)
1294 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1295 if (mg->mg_flags & MGf_GSKIP)
1296 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1297 if (mg->mg_type == PERL_MAGIC_regex_global &&
1298 mg->mg_flags & MGf_MINMATCH)
1299 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1302 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1303 PTR2UV(mg->mg_obj));
1304 if (mg->mg_type == PERL_MAGIC_qr) {
1305 REGEXP* const re = (REGEXP *)mg->mg_obj;
1306 SV * const dsv = sv_newmortal();
1307 const char * const s
1308 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1310 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1311 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1313 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1314 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1317 if (mg->mg_flags & MGf_REFCOUNTED)
1318 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1321 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1323 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1324 if (mg->mg_len >= 0) {
1325 if (mg->mg_type != PERL_MAGIC_utf8) {
1326 SV * const sv = newSVpvs("");
1327 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1331 else if (mg->mg_len == HEf_SVKEY) {
1332 PerlIO_puts(file, " => HEf_SVKEY\n");
1333 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1334 maxnest, dumpops, pvlim); /* MG is already +1 */
1338 PerlIO_puts(file, " ???? - please notify IZ");
1339 PerlIO_putc(file, '\n');
1341 if (mg->mg_type == PERL_MAGIC_utf8) {
1342 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1345 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1346 Perl_dump_indent(aTHX_ level, file,
1347 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1350 (UV)cache[i * 2 + 1]);
1357 Perl_magic_dump(pTHX_ const MAGIC *mg)
1359 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1363 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1367 PERL_ARGS_ASSERT_DO_HV_DUMP;
1369 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1370 if (sv && (hvname = HvNAME_get(sv)))
1371 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1373 PerlIO_putc(file, '\n');
1377 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1379 PERL_ARGS_ASSERT_DO_GV_DUMP;
1381 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1382 if (sv && GvNAME(sv))
1383 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1385 PerlIO_putc(file, '\n');
1389 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1391 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1393 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1394 if (sv && GvNAME(sv)) {
1396 PerlIO_printf(file, "\t\"");
1397 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1398 PerlIO_printf(file, "%s\" :: \"", hvname);
1399 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1402 PerlIO_putc(file, '\n');
1406 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1414 PERL_ARGS_ASSERT_DO_SV_DUMP;
1417 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1421 flags = SvFLAGS(sv);
1424 d = Perl_newSVpvf(aTHX_
1425 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1426 PTR2UV(SvANY(sv)), PTR2UV(sv),
1427 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1428 (int)(PL_dumpindent*level), "");
1430 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1431 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1433 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1434 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1435 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1437 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1438 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1439 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1440 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1441 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1443 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1444 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1445 if (flags & SVf_POK) sv_catpv(d, "POK,");
1446 if (flags & SVf_ROK) {
1447 sv_catpv(d, "ROK,");
1448 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1450 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1451 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1452 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1453 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1455 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1456 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1457 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1458 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1459 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1460 if (SvPCS_IMPORTED(sv))
1461 sv_catpv(d, "PCS_IMPORTED,");
1463 sv_catpv(d, "SCREAM,");
1469 if (CvANON(sv)) sv_catpv(d, "ANON,");
1470 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1471 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1472 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1473 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1474 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1475 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1476 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1477 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1478 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1479 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1482 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1483 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1484 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1485 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1486 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1490 if (isGV_with_GP(sv)) {
1491 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1492 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1493 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1494 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1495 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1497 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1498 sv_catpv(d, "IMPORT");
1499 if (GvIMPORTED(sv) == GVf_IMPORTED)
1500 sv_catpv(d, "ALL,");
1503 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1504 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1505 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1506 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1510 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1511 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1515 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1516 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1519 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1520 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1523 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1528 /* SVphv_SHAREKEYS is also 0x20000000 */
1529 if ((type != SVt_PVHV) && SvUTF8(sv))
1530 sv_catpv(d, "UTF8");
1532 if (*(SvEND(d) - 1) == ',') {
1533 SvCUR_set(d, SvCUR(d) - 1);
1534 SvPVX(d)[SvCUR(d)] = '\0';
1539 #ifdef DEBUG_LEAKING_SCALARS
1540 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1541 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1543 sv->sv_debug_inpad ? "for" : "by",
1544 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1545 sv->sv_debug_cloned ? " (cloned)" : "");
1547 Perl_dump_indent(aTHX_ level, file, "SV = ");
1548 if (type < SVt_LAST) {
1549 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1551 if (type == SVt_NULL) {
1556 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1560 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1561 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM)
1562 || (type == SVt_IV && !SvROK(sv))) {
1564 #ifdef PERL_OLD_COPY_ON_WRITE
1568 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1570 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1571 #ifdef PERL_OLD_COPY_ON_WRITE
1572 if (SvIsCOW_shared_hash(sv))
1573 PerlIO_printf(file, " (HASH)");
1574 else if (SvIsCOW_normal(sv))
1575 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1577 PerlIO_putc(file, '\n');
1579 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1580 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1581 (UV) COP_SEQ_RANGE_LOW(sv));
1582 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1583 (UV) COP_SEQ_RANGE_HIGH(sv));
1584 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1585 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1586 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1587 || type == SVt_NV) {
1588 STORE_NUMERIC_LOCAL_SET_STANDARD();
1589 /* %Vg doesn't work? --jhi */
1590 #ifdef USE_LONG_DOUBLE
1591 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1593 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1595 RESTORE_NUMERIC_LOCAL();
1598 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1600 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1602 if (type < SVt_PV) {
1606 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1607 if (SvPVX_const(sv)) {
1610 SvOOK_offset(sv, delta);
1611 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1616 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1618 PerlIO_printf(file, "( %s . ) ",
1619 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1622 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1623 if (SvUTF8(sv)) /* the 6? \x{....} */
1624 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1625 PerlIO_printf(file, "\n");
1626 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1627 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1630 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1632 if (type == SVt_REGEXP) {
1634 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1635 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1638 if (type >= SVt_PVMG) {
1639 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1640 HV * const ost = SvOURSTASH(sv);
1642 do_hv_dump(level, file, " OURSTASH", ost);
1645 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1648 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1652 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1653 if (AvARRAY(sv) != AvALLOC(sv)) {
1654 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1655 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1658 PerlIO_putc(file, '\n');
1659 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1660 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1661 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1663 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1664 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1665 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1666 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1667 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1669 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1670 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1672 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1674 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1679 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1680 if (HvARRAY(sv) && HvKEYS(sv)) {
1681 /* Show distribution of HEs in the ARRAY */
1683 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1686 U32 pow2 = 2, keys = HvKEYS(sv);
1687 NV theoret, sum = 0;
1689 PerlIO_printf(file, " (");
1690 Zero(freq, FREQ_MAX + 1, int);
1691 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1694 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1696 if (count > FREQ_MAX)
1702 for (i = 0; i <= max; i++) {
1704 PerlIO_printf(file, "%d%s:%d", i,
1705 (i == FREQ_MAX) ? "+" : "",
1708 PerlIO_printf(file, ", ");
1711 PerlIO_putc(file, ')');
1712 /* The "quality" of a hash is defined as the total number of
1713 comparisons needed to access every element once, relative
1714 to the expected number needed for a random hash.
1716 The total number of comparisons is equal to the sum of
1717 the squares of the number of entries in each bucket.
1718 For a random hash of n keys into k buckets, the expected
1723 for (i = max; i > 0; i--) { /* Precision: count down. */
1724 sum += freq[i] * i * i;
1726 while ((keys = keys >> 1))
1728 theoret = HvKEYS(sv);
1729 theoret += theoret * (theoret-1)/pow2;
1730 PerlIO_putc(file, '\n');
1731 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1733 PerlIO_putc(file, '\n');
1734 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1735 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1736 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1737 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1738 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1740 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1741 if (mg && mg->mg_obj) {
1742 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1746 const char * const hvname = HvNAME_get(sv);
1748 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1752 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1754 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1756 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1760 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1762 HV * const hv = MUTABLE_HV(sv);
1763 int count = maxnest - nest;
1766 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1769 const U32 hash = HeHASH(he);
1770 SV * const keysv = hv_iterkeysv(he);
1771 const char * const keypv = SvPV_const(keysv, len);
1772 SV * const elt = hv_iterval(hv, he);
1774 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1776 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1778 PerlIO_printf(file, "[REHASH] ");
1779 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1780 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1782 hv_iterinit(hv); /* Return to status quo */
1788 const char *const proto = SvPV_const(sv, len);
1789 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1794 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1795 if (!CvISXSUB(sv)) {
1797 Perl_dump_indent(aTHX_ level, file,
1798 " START = 0x%"UVxf" ===> %"IVdf"\n",
1799 PTR2UV(CvSTART(sv)),
1800 (IV)sequence_num(CvSTART(sv)));
1802 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1803 PTR2UV(CvROOT(sv)));
1804 if (CvROOT(sv) && dumpops) {
1805 do_op_dump(level+1, file, CvROOT(sv));
1808 SV * const constant = cv_const_sv((const CV *)sv);
1810 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1813 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1815 PTR2UV(CvXSUBANY(sv).any_ptr));
1816 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1819 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1820 (IV)CvXSUBANY(sv).any_i32);
1823 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1824 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1825 if (type == SVt_PVCV)
1826 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1827 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1828 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1829 if (type == SVt_PVFM)
1830 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1831 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1832 if (nest < maxnest) {
1833 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1836 const CV * const outside = CvOUTSIDE(sv);
1837 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1840 : CvANON(outside) ? "ANON"
1841 : (outside == PL_main_cv) ? "MAIN"
1842 : CvUNIQUE(outside) ? "UNIQUE"
1843 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1845 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1846 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1850 if (type == SVt_PVLV) {
1851 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1852 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1853 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1854 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1855 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1856 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1860 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1861 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1862 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1863 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1865 if (!isGV_with_GP(sv))
1867 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1868 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1869 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1870 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1873 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1874 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1875 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1876 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1877 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1878 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1879 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1880 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1881 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1882 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1883 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1884 do_gv_dump (level, file, " EGV", GvEGV(sv));
1887 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1888 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1889 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1890 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1891 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1892 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1893 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1895 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1896 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1897 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1899 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1900 PTR2UV(IoTOP_GV(sv)));
1901 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1902 maxnest, dumpops, pvlim);
1904 /* Source filters hide things that are not GVs in these three, so let's
1905 be careful out there. */
1907 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1908 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1909 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1911 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1912 PTR2UV(IoFMT_GV(sv)));
1913 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1914 maxnest, dumpops, pvlim);
1916 if (IoBOTTOM_NAME(sv))
1917 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1918 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1919 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1921 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1922 PTR2UV(IoBOTTOM_GV(sv)));
1923 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
1924 maxnest, dumpops, pvlim);
1926 if (isPRINT(IoTYPE(sv)))
1927 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1929 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1930 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1937 Perl_sv_dump(pTHX_ SV *sv)
1941 PERL_ARGS_ASSERT_SV_DUMP;
1944 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1946 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1950 Perl_runops_debug(pTHX)
1954 if (ckWARN_d(WARN_DEBUGGING))
1955 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1959 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1963 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1964 PerlIO_printf(Perl_debug_log,
1965 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1966 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1967 PTR2UV(*PL_watchaddr));
1968 if (DEBUG_s_TEST_) {
1969 if (DEBUG_v_TEST_) {
1970 PerlIO_printf(Perl_debug_log, "\n");
1978 if (DEBUG_t_TEST_) debop(PL_op);
1979 if (DEBUG_P_TEST_) debprof(PL_op);
1981 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1982 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1989 Perl_debop(pTHX_ const OP *o)
1993 PERL_ARGS_ASSERT_DEBOP;
1995 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1998 Perl_deb(aTHX_ "%s", OP_NAME(o));
1999 switch (o->op_type) {
2002 /* With ITHREADS, consts are stored in the pad, and the right pad
2003 * may not be active here, so check.
2004 * Looks like only during compiling the pads are illegal.
2007 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2009 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2014 SV * const sv = newSV(0);
2016 /* FIXME - is this making unwarranted assumptions about the
2017 UTF-8 cleanliness of the dump file handle? */
2020 gv_fullname3(sv, cGVOPo_gv, NULL);
2021 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2025 PerlIO_printf(Perl_debug_log, "(NULL)");
2031 /* print the lexical's name */
2032 CV * const cv = deb_curcv(cxstack_ix);
2035 AV * const padlist = CvPADLIST(cv);
2036 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2037 sv = *av_fetch(comppad, o->op_targ, FALSE);
2041 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2043 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2049 PerlIO_printf(Perl_debug_log, "\n");
2054 S_deb_curcv(pTHX_ const I32 ix)
2057 const PERL_CONTEXT * const cx = &cxstack[ix];
2058 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2059 return cx->blk_sub.cv;
2060 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2062 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2067 return deb_curcv(ix - 1);
2071 Perl_watch(pTHX_ char **addr)
2075 PERL_ARGS_ASSERT_WATCH;
2077 PL_watchaddr = addr;
2079 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2080 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2084 S_debprof(pTHX_ const OP *o)
2088 PERL_ARGS_ASSERT_DEBPROF;
2090 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2092 if (!PL_profiledata)
2093 Newxz(PL_profiledata, MAXO, U32);
2094 ++PL_profiledata[o->op_type];
2098 Perl_debprofdump(pTHX)
2102 if (!PL_profiledata)
2104 for (i = 0; i < MAXO; i++) {
2105 if (PL_profiledata[i])
2106 PerlIO_printf(Perl_debug_log,
2107 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2114 * XML variants of most of the above routines
2118 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2122 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2124 PerlIO_printf(file, "\n ");
2125 va_start(args, pat);
2126 xmldump_vindent(level, file, pat, &args);
2132 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2135 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2136 va_start(args, pat);
2137 xmldump_vindent(level, file, pat, &args);
2142 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2144 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2146 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2147 PerlIO_vprintf(file, pat, *args);
2151 Perl_xmldump_all(pTHX)
2153 PerlIO_setlinebuf(PL_xmlfp);
2155 op_xmldump(PL_main_root);
2156 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2157 PerlIO_close(PL_xmlfp);
2162 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2167 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2169 if (!HvARRAY(stash))
2171 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2172 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2173 GV *gv = MUTABLE_GV(HeVAL(entry));
2175 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2181 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2182 && (hv = GvHV(gv)) && hv != PL_defstash)
2183 xmldump_packsubs(hv); /* nested package */
2189 Perl_xmldump_sub(pTHX_ const GV *gv)
2191 SV * const sv = sv_newmortal();
2193 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2195 gv_fullname3(sv, gv, NULL);
2196 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2197 if (CvXSUB(GvCV(gv)))
2198 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2199 PTR2UV(CvXSUB(GvCV(gv))),
2200 (int)CvXSUBANY(GvCV(gv)).any_i32);
2201 else if (CvROOT(GvCV(gv)))
2202 op_xmldump(CvROOT(GvCV(gv)));
2204 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2208 Perl_xmldump_form(pTHX_ const GV *gv)
2210 SV * const sv = sv_newmortal();
2212 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2214 gv_fullname3(sv, gv, NULL);
2215 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2216 if (CvROOT(GvFORM(gv)))
2217 op_xmldump(CvROOT(GvFORM(gv)));
2219 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2223 Perl_xmldump_eval(pTHX)
2225 op_xmldump(PL_eval_root);
2229 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2231 PERL_ARGS_ASSERT_SV_CATXMLSV;
2232 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2236 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2239 const char * const e = pv + len;
2240 const char * const start = pv;
2244 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2247 dsvcur = SvCUR(dsv); /* in case we have to restart */
2252 c = utf8_to_uvchr((U8*)pv, &cl);
2254 SvCUR(dsv) = dsvcur;
2319 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2322 sv_catpvs(dsv, "<");
2325 sv_catpvs(dsv, ">");
2328 sv_catpvs(dsv, "&");
2331 sv_catpvs(dsv, """);
2335 if (c < 32 || c > 127) {
2336 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2339 const char string = (char) c;
2340 sv_catpvn(dsv, &string, 1);
2344 if ((c >= 0xD800 && c <= 0xDB7F) ||
2345 (c >= 0xDC00 && c <= 0xDFFF) ||
2346 (c >= 0xFFF0 && c <= 0xFFFF) ||
2348 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2350 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2363 Perl_sv_xmlpeek(pTHX_ SV *sv)
2365 SV * const t = sv_newmortal();
2369 PERL_ARGS_ASSERT_SV_XMLPEEK;
2375 sv_catpv(t, "VOID=\"\"");
2378 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2379 sv_catpv(t, "WILD=\"\"");
2382 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2383 if (sv == &PL_sv_undef) {
2384 sv_catpv(t, "SV_UNDEF=\"1\"");
2385 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2386 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2390 else if (sv == &PL_sv_no) {
2391 sv_catpv(t, "SV_NO=\"1\"");
2392 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2393 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2394 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2395 SVp_POK|SVp_NOK)) &&
2400 else if (sv == &PL_sv_yes) {
2401 sv_catpv(t, "SV_YES=\"1\"");
2402 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2403 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2404 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2405 SVp_POK|SVp_NOK)) &&
2407 SvPVX(sv) && *SvPVX(sv) == '1' &&
2412 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2413 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2414 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2418 sv_catpv(t, " XXX=\"\" ");
2420 else if (SvREFCNT(sv) == 0) {
2421 sv_catpv(t, " refcnt=\"0\"");
2424 else if (DEBUG_R_TEST_) {
2427 /* is this SV on the tmps stack? */
2428 for (ix=PL_tmps_ix; ix>=0; ix--) {
2429 if (PL_tmps_stack[ix] == sv) {
2434 if (SvREFCNT(sv) > 1)
2435 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2438 sv_catpv(t, " DRT=\"<T>\"");
2442 sv_catpv(t, " ROK=\"\"");
2444 switch (SvTYPE(sv)) {
2446 sv_catpv(t, " FREED=\"1\"");
2450 sv_catpv(t, " UNDEF=\"1\"");
2453 sv_catpv(t, " IV=\"");
2456 sv_catpv(t, " NV=\"");
2459 sv_catpv(t, " PV=\"");
2462 sv_catpv(t, " PVIV=\"");
2465 sv_catpv(t, " PVNV=\"");
2468 sv_catpv(t, " PVMG=\"");
2471 sv_catpv(t, " PVLV=\"");
2474 sv_catpv(t, " AV=\"");
2477 sv_catpv(t, " HV=\"");
2481 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2483 sv_catpv(t, " CV=\"()\"");
2486 sv_catpv(t, " GV=\"");
2489 sv_catpv(t, " BIND=\"");
2492 sv_catpv(t, " ORANGE=\"");
2495 sv_catpv(t, " FM=\"");
2498 sv_catpv(t, " IO=\"");
2507 else if (SvNOKp(sv)) {
2508 STORE_NUMERIC_LOCAL_SET_STANDARD();
2509 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2510 RESTORE_NUMERIC_LOCAL();
2512 else if (SvIOKp(sv)) {
2514 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2516 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2525 return SvPV(t, n_a);
2529 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2531 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2534 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2537 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2540 REGEXP *const r = PM_GETRE(pm);
2541 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2542 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2543 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2545 SvREFCNT_dec(tmpsv);
2546 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2547 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2550 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2551 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2552 SV * const tmpsv = pm_description(pm);
2553 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2554 SvREFCNT_dec(tmpsv);
2558 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2559 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2560 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2561 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2562 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2563 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2566 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2570 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2572 do_pmop_xmldump(0, PL_xmlfp, pm);
2576 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2581 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2586 seq = sequence_num(o);
2587 Perl_xmldump_indent(aTHX_ level, file,
2588 "<op_%s seq=\"%"UVuf" -> ",
2593 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2594 sequence_num(o->op_next));
2596 PerlIO_printf(file, "DONE\"");
2599 if (o->op_type == OP_NULL)
2601 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2602 if (o->op_targ == OP_NEXTSTATE)
2605 PerlIO_printf(file, " line=\"%"UVuf"\"",
2606 (UV)CopLINE(cCOPo));
2607 if (CopSTASHPV(cCOPo))
2608 PerlIO_printf(file, " package=\"%s\"",
2610 if (CopLABEL(cCOPo))
2611 PerlIO_printf(file, " label=\"%s\"",
2616 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2619 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2622 SV * const tmpsv = newSVpvs("");
2623 switch (o->op_flags & OPf_WANT) {
2625 sv_catpv(tmpsv, ",VOID");
2627 case OPf_WANT_SCALAR:
2628 sv_catpv(tmpsv, ",SCALAR");
2631 sv_catpv(tmpsv, ",LIST");
2634 sv_catpv(tmpsv, ",UNKNOWN");
2637 if (o->op_flags & OPf_KIDS)
2638 sv_catpv(tmpsv, ",KIDS");
2639 if (o->op_flags & OPf_PARENS)
2640 sv_catpv(tmpsv, ",PARENS");
2641 if (o->op_flags & OPf_STACKED)
2642 sv_catpv(tmpsv, ",STACKED");
2643 if (o->op_flags & OPf_REF)
2644 sv_catpv(tmpsv, ",REF");
2645 if (o->op_flags & OPf_MOD)
2646 sv_catpv(tmpsv, ",MOD");
2647 if (o->op_flags & OPf_SPECIAL)
2648 sv_catpv(tmpsv, ",SPECIAL");
2649 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2650 SvREFCNT_dec(tmpsv);
2652 if (o->op_private) {
2653 SV * const tmpsv = newSVpvs("");
2654 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2655 if (o->op_private & OPpTARGET_MY)
2656 sv_catpv(tmpsv, ",TARGET_MY");
2658 else if (o->op_type == OP_LEAVESUB ||
2659 o->op_type == OP_LEAVE ||
2660 o->op_type == OP_LEAVESUBLV ||
2661 o->op_type == OP_LEAVEWRITE) {
2662 if (o->op_private & OPpREFCOUNTED)
2663 sv_catpv(tmpsv, ",REFCOUNTED");
2665 else if (o->op_type == OP_AASSIGN) {
2666 if (o->op_private & OPpASSIGN_COMMON)
2667 sv_catpv(tmpsv, ",COMMON");
2669 else if (o->op_type == OP_SASSIGN) {
2670 if (o->op_private & OPpASSIGN_BACKWARDS)
2671 sv_catpv(tmpsv, ",BACKWARDS");
2673 else if (o->op_type == OP_TRANS) {
2674 if (o->op_private & OPpTRANS_SQUASH)
2675 sv_catpv(tmpsv, ",SQUASH");
2676 if (o->op_private & OPpTRANS_DELETE)
2677 sv_catpv(tmpsv, ",DELETE");
2678 if (o->op_private & OPpTRANS_COMPLEMENT)
2679 sv_catpv(tmpsv, ",COMPLEMENT");
2680 if (o->op_private & OPpTRANS_IDENTICAL)
2681 sv_catpv(tmpsv, ",IDENTICAL");
2682 if (o->op_private & OPpTRANS_GROWS)
2683 sv_catpv(tmpsv, ",GROWS");
2685 else if (o->op_type == OP_REPEAT) {
2686 if (o->op_private & OPpREPEAT_DOLIST)
2687 sv_catpv(tmpsv, ",DOLIST");
2689 else if (o->op_type == OP_ENTERSUB ||
2690 o->op_type == OP_RV2SV ||
2691 o->op_type == OP_GVSV ||
2692 o->op_type == OP_RV2AV ||
2693 o->op_type == OP_RV2HV ||
2694 o->op_type == OP_RV2GV ||
2695 o->op_type == OP_AELEM ||
2696 o->op_type == OP_HELEM )
2698 if (o->op_type == OP_ENTERSUB) {
2699 if (o->op_private & OPpENTERSUB_AMPER)
2700 sv_catpv(tmpsv, ",AMPER");
2701 if (o->op_private & OPpENTERSUB_DB)
2702 sv_catpv(tmpsv, ",DB");
2703 if (o->op_private & OPpENTERSUB_HASTARG)
2704 sv_catpv(tmpsv, ",HASTARG");
2705 if (o->op_private & OPpENTERSUB_NOPAREN)
2706 sv_catpv(tmpsv, ",NOPAREN");
2707 if (o->op_private & OPpENTERSUB_INARGS)
2708 sv_catpv(tmpsv, ",INARGS");
2709 if (o->op_private & OPpENTERSUB_NOMOD)
2710 sv_catpv(tmpsv, ",NOMOD");
2713 switch (o->op_private & OPpDEREF) {
2715 sv_catpv(tmpsv, ",SV");
2718 sv_catpv(tmpsv, ",AV");
2721 sv_catpv(tmpsv, ",HV");
2724 if (o->op_private & OPpMAYBE_LVSUB)
2725 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2727 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2728 if (o->op_private & OPpLVAL_DEFER)
2729 sv_catpv(tmpsv, ",LVAL_DEFER");
2732 if (o->op_private & HINT_STRICT_REFS)
2733 sv_catpv(tmpsv, ",STRICT_REFS");
2734 if (o->op_private & OPpOUR_INTRO)
2735 sv_catpv(tmpsv, ",OUR_INTRO");
2738 else if (o->op_type == OP_CONST) {
2739 if (o->op_private & OPpCONST_BARE)
2740 sv_catpv(tmpsv, ",BARE");
2741 if (o->op_private & OPpCONST_STRICT)
2742 sv_catpv(tmpsv, ",STRICT");
2743 if (o->op_private & OPpCONST_ARYBASE)
2744 sv_catpv(tmpsv, ",ARYBASE");
2745 if (o->op_private & OPpCONST_WARNING)
2746 sv_catpv(tmpsv, ",WARNING");
2747 if (o->op_private & OPpCONST_ENTERED)
2748 sv_catpv(tmpsv, ",ENTERED");
2750 else if (o->op_type == OP_FLIP) {
2751 if (o->op_private & OPpFLIP_LINENUM)
2752 sv_catpv(tmpsv, ",LINENUM");
2754 else if (o->op_type == OP_FLOP) {
2755 if (o->op_private & OPpFLIP_LINENUM)
2756 sv_catpv(tmpsv, ",LINENUM");
2758 else if (o->op_type == OP_RV2CV) {
2759 if (o->op_private & OPpLVAL_INTRO)
2760 sv_catpv(tmpsv, ",INTRO");
2762 else if (o->op_type == OP_GV) {
2763 if (o->op_private & OPpEARLY_CV)
2764 sv_catpv(tmpsv, ",EARLY_CV");
2766 else if (o->op_type == OP_LIST) {
2767 if (o->op_private & OPpLIST_GUESSED)
2768 sv_catpv(tmpsv, ",GUESSED");
2770 else if (o->op_type == OP_DELETE) {
2771 if (o->op_private & OPpSLICE)
2772 sv_catpv(tmpsv, ",SLICE");
2774 else if (o->op_type == OP_EXISTS) {
2775 if (o->op_private & OPpEXISTS_SUB)
2776 sv_catpv(tmpsv, ",EXISTS_SUB");
2778 else if (o->op_type == OP_SORT) {
2779 if (o->op_private & OPpSORT_NUMERIC)
2780 sv_catpv(tmpsv, ",NUMERIC");
2781 if (o->op_private & OPpSORT_INTEGER)
2782 sv_catpv(tmpsv, ",INTEGER");
2783 if (o->op_private & OPpSORT_REVERSE)
2784 sv_catpv(tmpsv, ",REVERSE");
2786 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2787 if (o->op_private & OPpOPEN_IN_RAW)
2788 sv_catpv(tmpsv, ",IN_RAW");
2789 if (o->op_private & OPpOPEN_IN_CRLF)
2790 sv_catpv(tmpsv, ",IN_CRLF");
2791 if (o->op_private & OPpOPEN_OUT_RAW)
2792 sv_catpv(tmpsv, ",OUT_RAW");
2793 if (o->op_private & OPpOPEN_OUT_CRLF)
2794 sv_catpv(tmpsv, ",OUT_CRLF");
2796 else if (o->op_type == OP_EXIT) {
2797 if (o->op_private & OPpEXIT_VMSISH)
2798 sv_catpv(tmpsv, ",EXIT_VMSISH");
2799 if (o->op_private & OPpHUSH_VMSISH)
2800 sv_catpv(tmpsv, ",HUSH_VMSISH");
2802 else if (o->op_type == OP_DIE) {
2803 if (o->op_private & OPpHUSH_VMSISH)
2804 sv_catpv(tmpsv, ",HUSH_VMSISH");
2806 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2807 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2808 sv_catpv(tmpsv, ",FT_ACCESS");
2809 if (o->op_private & OPpFT_STACKED)
2810 sv_catpv(tmpsv, ",FT_STACKED");
2812 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2813 sv_catpv(tmpsv, ",INTRO");
2815 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2816 SvREFCNT_dec(tmpsv);
2819 switch (o->op_type) {
2821 if (o->op_flags & OPf_SPECIAL) {
2827 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2829 if (cSVOPo->op_sv) {
2830 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2831 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2837 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2838 s = SvPV(tmpsv1,len);
2839 sv_catxmlpvn(tmpsv2, s, len, 1);
2840 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2844 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2849 case OP_METHOD_NAMED:
2850 #ifndef USE_ITHREADS
2851 /* with ITHREADS, consts are stored in the pad, and the right pad
2852 * may not be active here, so skip */
2853 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2859 PerlIO_printf(file, ">\n");
2861 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2866 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2867 (UV)CopLINE(cCOPo));
2868 if (CopSTASHPV(cCOPo))
2869 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2871 if (CopLABEL(cCOPo))
2872 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2876 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2877 if (cLOOPo->op_redoop)
2878 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2880 PerlIO_printf(file, "DONE\"");
2881 S_xmldump_attr(aTHX_ level, file, "next=\"");
2882 if (cLOOPo->op_nextop)
2883 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2885 PerlIO_printf(file, "DONE\"");
2886 S_xmldump_attr(aTHX_ level, file, "last=\"");
2887 if (cLOOPo->op_lastop)
2888 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2890 PerlIO_printf(file, "DONE\"");
2898 S_xmldump_attr(aTHX_ level, file, "other=\"");
2899 if (cLOGOPo->op_other)
2900 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2902 PerlIO_printf(file, "DONE\"");
2910 if (o->op_private & OPpREFCOUNTED)
2911 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2917 if (PL_madskills && o->op_madprop) {
2918 char prevkey = '\0';
2919 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2920 const MADPROP* mp = o->op_madprop;
2924 PerlIO_printf(file, ">\n");
2926 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2929 char tmp = mp->mad_key;
2930 sv_setpvs(tmpsv,"\"");
2932 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2933 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2934 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2937 sv_catpv(tmpsv, "\"");
2938 switch (mp->mad_type) {
2940 sv_catpv(tmpsv, "NULL");
2941 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2944 sv_catpv(tmpsv, " val=\"");
2945 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2946 sv_catpv(tmpsv, "\"");
2947 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2950 sv_catpv(tmpsv, " val=\"");
2951 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
2952 sv_catpv(tmpsv, "\"");
2953 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2956 if ((OP*)mp->mad_val) {
2957 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2958 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2959 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2963 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2969 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2971 SvREFCNT_dec(tmpsv);
2974 switch (o->op_type) {
2981 PerlIO_printf(file, ">\n");
2983 do_pmop_xmldump(level, file, cPMOPo);
2989 if (o->op_flags & OPf_KIDS) {
2993 PerlIO_printf(file, ">\n");
2995 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2996 do_op_xmldump(level, file, kid);
3000 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3002 PerlIO_printf(file, " />\n");
3006 Perl_op_xmldump(pTHX_ const OP *o)
3008 PERL_ARGS_ASSERT_OP_XMLDUMP;
3010 do_op_xmldump(0, PL_xmlfp, o);
3016 * c-indentation-style: bsd
3018 * indent-tabs-mode: t
3021 * ex: set ts=8 sts=4 sw=4 noet: