3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'
15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
18 /* This file contains utility routines to dump the contents of SV and OP
19 * structures, as used by command-line options like -Dt and -Dx, and
22 * It also holds the debugging version of the runops function.
26 #define PERL_IN_DUMP_C
32 static const char* const svtypenames[SVt_LAST] = {
52 static const char* const svshorttypenames[SVt_LAST] = {
71 #define Sequence PL_op_sequence
74 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
77 PERL_ARGS_ASSERT_DUMP_INDENT;
79 dump_vindent(level, file, pat, &args);
84 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
87 PERL_ARGS_ASSERT_DUMP_VINDENT;
88 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
89 PerlIO_vprintf(file, pat, *args);
99 Perl_dump_all_perl(pTHX_ bool justperl)
103 PerlIO_setlinebuf(Perl_debug_log);
105 op_dump(PL_main_root);
106 dump_packsubs_perl(PL_defstash, justperl);
110 Perl_dump_packsubs(pTHX_ const HV *stash)
112 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
113 dump_packsubs_perl(stash, FALSE);
117 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
122 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
126 for (i = 0; i <= (I32) HvMAX(stash); i++) {
128 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
129 const GV * const gv = (const GV *)HeVAL(entry);
130 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
133 dump_sub_perl(gv, justperl);
136 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
137 const HV * const hv = GvHV(gv);
138 if (hv && (hv != PL_defstash))
139 dump_packsubs_perl(hv, justperl); /* nested package */
146 Perl_dump_sub(pTHX_ const GV *gv)
148 PERL_ARGS_ASSERT_DUMP_SUB;
149 dump_sub_perl(gv, FALSE);
153 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
157 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
159 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
163 gv_fullname3(sv, gv, NULL);
164 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
165 if (CvISXSUB(GvCV(gv)))
166 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
167 PTR2UV(CvXSUB(GvCV(gv))),
168 (int)CvXSUBANY(GvCV(gv)).any_i32);
169 else if (CvROOT(GvCV(gv)))
170 op_dump(CvROOT(GvCV(gv)));
172 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
176 Perl_dump_form(pTHX_ const GV *gv)
178 SV * const sv = sv_newmortal();
180 PERL_ARGS_ASSERT_DUMP_FORM;
182 gv_fullname3(sv, gv, NULL);
183 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
184 if (CvROOT(GvFORM(gv)))
185 op_dump(CvROOT(GvFORM(gv)));
187 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
194 op_dump(PL_eval_root);
199 =for apidoc pv_escape
201 Escapes at most the first "count" chars of pv and puts the results into
202 dsv such that the size of the escaped string will not exceed "max" chars
203 and will not contain any incomplete escape sequences.
205 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
206 will also be escaped.
208 Normally the SV will be cleared before the escaped string is prepared,
209 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
211 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
212 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
213 using C<is_utf8_string()> to determine if it is Unicode.
215 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
216 using C<\x01F1> style escapes, otherwise only chars above 255 will be
217 escaped using this style, other non printable chars will use octal or
218 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
219 then all chars below 255 will be treated as printable and
220 will be output as literals.
222 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
223 string will be escaped, regardles of max. If the string is utf8 and
224 the chars value is >255 then it will be returned as a plain hex
225 sequence. Thus the output will either be a single char,
226 an octal escape sequence, a special escape like C<\n> or a 3 or
227 more digit hex value.
229 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
230 not a '\\'. This is because regexes very often contain backslashed
231 sequences, whereas '%' is not a particularly common character in patterns.
233 Returns a pointer to the escaped text as held by dsv.
237 #define PV_ESCAPE_OCTBUFSIZE 32
240 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
241 const STRLEN count, const STRLEN max,
242 STRLEN * const escaped, const U32 flags )
244 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
245 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
246 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
247 STRLEN wrote = 0; /* chars written so far */
248 STRLEN chsize = 0; /* size of data to be written */
249 STRLEN readsize = 1; /* size of data just read */
250 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
251 const char *pv = str;
252 const char * const end = pv + count; /* end of string */
255 PERL_ARGS_ASSERT_PV_ESCAPE;
257 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
258 /* This won't alter the UTF-8 flag */
262 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
265 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
266 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
267 const U8 c = (U8)u & 0xFF;
269 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
270 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
271 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
274 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
275 "%cx{%"UVxf"}", esc, u);
276 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
279 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
283 case '\\' : /* fallthrough */
284 case '%' : if ( c == esc ) {
290 case '\v' : octbuf[1] = 'v'; break;
291 case '\t' : octbuf[1] = 't'; break;
292 case '\r' : octbuf[1] = 'r'; break;
293 case '\n' : octbuf[1] = 'n'; break;
294 case '\f' : octbuf[1] = 'f'; break;
302 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
303 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
306 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
313 if ( max && (wrote + chsize > max) ) {
315 } else if (chsize > 1) {
316 sv_catpvn(dsv, octbuf, chsize);
319 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
320 128-255 can be appended raw to the dsv. If dsv happens to be
321 UTF-8 then we need catpvf to upgrade them for us.
322 Or add a new API call sv_catpvc(). Think about that name, and
323 how to keep it clear that it's unlike the s of catpvs, which is
324 really an array octets, not a string. */
325 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
328 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
336 =for apidoc pv_pretty
338 Converts a string into something presentable, handling escaping via
339 pv_escape() and supporting quoting and ellipses.
341 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
342 double quoted with any double quotes in the string escaped. Otherwise
343 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
346 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
347 string were output then an ellipsis C<...> will be appended to the
348 string. Note that this happens AFTER it has been quoted.
350 If start_color is non-null then it will be inserted after the opening
351 quote (if there is one) but before the escaped text. If end_color
352 is non-null then it will be inserted after the escaped text but before
353 any quotes or ellipses.
355 Returns a pointer to the prettified text as held by dsv.
361 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
362 const STRLEN max, char const * const start_color, char const * const end_color,
365 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
368 PERL_ARGS_ASSERT_PV_PRETTY;
370 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
371 /* This won't alter the UTF-8 flag */
376 sv_catpvs(dsv, "\"");
377 else if ( flags & PERL_PV_PRETTY_LTGT )
380 if ( start_color != NULL )
381 sv_catpv(dsv, start_color);
383 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
385 if ( end_color != NULL )
386 sv_catpv(dsv, end_color);
389 sv_catpvs( dsv, "\"");
390 else if ( flags & PERL_PV_PRETTY_LTGT )
393 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
394 sv_catpvs(dsv, "...");
400 =for apidoc pv_display
404 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
406 except that an additional "\0" will be appended to the string when
407 len > cur and pv[cur] is "\0".
409 Note that the final string may be up to 7 chars longer than pvlim.
415 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
417 PERL_ARGS_ASSERT_PV_DISPLAY;
419 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
420 if (len > cur && pv[cur] == '\0')
421 sv_catpvs( dsv, "\\0");
426 Perl_sv_peek(pTHX_ SV *sv)
429 SV * const t = sv_newmortal();
439 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
443 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
444 if (sv == &PL_sv_undef) {
445 sv_catpv(t, "SV_UNDEF");
446 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
447 SVs_GMG|SVs_SMG|SVs_RMG)) &&
451 else if (sv == &PL_sv_no) {
452 sv_catpv(t, "SV_NO");
453 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
454 SVs_GMG|SVs_SMG|SVs_RMG)) &&
455 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
461 else if (sv == &PL_sv_yes) {
462 sv_catpv(t, "SV_YES");
463 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
464 SVs_GMG|SVs_SMG|SVs_RMG)) &&
465 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
468 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
473 sv_catpv(t, "SV_PLACEHOLDER");
474 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
475 SVs_GMG|SVs_SMG|SVs_RMG)) &&
481 else if (SvREFCNT(sv) == 0) {
485 else if (DEBUG_R_TEST_) {
488 /* is this SV on the tmps stack? */
489 for (ix=PL_tmps_ix; ix>=0; ix--) {
490 if (PL_tmps_stack[ix] == sv) {
495 if (SvREFCNT(sv) > 1)
496 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
504 if (SvCUR(t) + unref > 10) {
505 SvCUR_set(t, unref + 3);
514 if (type == SVt_PVCV) {
515 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
517 } else if (type < SVt_LAST) {
518 sv_catpv(t, svshorttypenames[type]);
520 if (type == SVt_NULL)
523 sv_catpv(t, "FREED");
528 if (!SvPVX_const(sv))
529 sv_catpv(t, "(null)");
531 SV * const tmp = newSVpvs("");
535 SvOOK_offset(sv, delta);
536 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
538 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
540 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
541 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
546 else if (SvNOKp(sv)) {
547 STORE_NUMERIC_LOCAL_SET_STANDARD();
548 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
549 RESTORE_NUMERIC_LOCAL();
551 else if (SvIOKp(sv)) {
553 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
555 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
563 if (PL_tainting && SvTAINTED(sv))
564 sv_catpv(t, " [tainted]");
565 return SvPV_nolen(t);
569 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
573 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
576 Perl_dump_indent(aTHX_ level, file, "{}\n");
579 Perl_dump_indent(aTHX_ level, file, "{\n");
581 if (pm->op_pmflags & PMf_ONCE)
586 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
587 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
588 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
590 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
591 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
592 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
593 op_dump(pm->op_pmreplrootu.op_pmreplroot);
595 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
596 SV * const tmpsv = pm_description(pm);
597 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
601 Perl_dump_indent(aTHX_ level-1, file, "}\n");
605 S_pm_description(pTHX_ const PMOP *pm)
607 SV * const desc = newSVpvs("");
608 const REGEXP * const regex = PM_GETRE(pm);
609 const U32 pmflags = pm->op_pmflags;
611 PERL_ARGS_ASSERT_PM_DESCRIPTION;
613 if (pmflags & PMf_ONCE)
614 sv_catpv(desc, ",ONCE");
616 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
617 sv_catpv(desc, ":USED");
619 if (pmflags & PMf_USED)
620 sv_catpv(desc, ":USED");
624 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
625 sv_catpv(desc, ",TAINTED");
626 if (RX_CHECK_SUBSTR(regex)) {
627 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
628 sv_catpv(desc, ",SCANFIRST");
629 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
630 sv_catpv(desc, ",ALL");
632 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
633 sv_catpv(desc, ",SKIPWHITE");
636 if (pmflags & PMf_CONST)
637 sv_catpv(desc, ",CONST");
638 if (pmflags & PMf_KEEP)
639 sv_catpv(desc, ",KEEP");
640 if (pmflags & PMf_GLOBAL)
641 sv_catpv(desc, ",GLOBAL");
642 if (pmflags & PMf_CONTINUE)
643 sv_catpv(desc, ",CONTINUE");
644 if (pmflags & PMf_RETAINT)
645 sv_catpv(desc, ",RETAINT");
646 if (pmflags & PMf_EVAL)
647 sv_catpv(desc, ",EVAL");
652 Perl_pmop_dump(pTHX_ PMOP *pm)
654 do_pmop_dump(0, Perl_debug_log, pm);
657 /* An op sequencer. We visit the ops in the order they're to execute. */
660 S_sequence(pTHX_ register const OP *o)
663 const OP *oldop = NULL;
676 for (; o; o = o->op_next) {
678 SV * const op = newSVuv(PTR2UV(o));
679 const char * const key = SvPV_const(op, len);
681 if (hv_exists(Sequence, key, len))
684 switch (o->op_type) {
686 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
687 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
696 if (oldop && o->op_next)
703 if (oldop && o->op_next)
705 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
718 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
719 sequence_tail(cLOGOPo->op_other);
724 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
725 sequence_tail(cLOOPo->op_redoop);
726 sequence_tail(cLOOPo->op_nextop);
727 sequence_tail(cLOOPo->op_lastop);
731 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
732 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
741 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
749 S_sequence_tail(pTHX_ const OP *o)
751 while (o && (o->op_type == OP_NULL))
757 S_sequence_num(pTHX_ const OP *o)
765 op = newSVuv(PTR2UV(o));
766 key = SvPV_const(op, len);
767 seq = hv_fetch(Sequence, key, len, 0);
768 return seq ? SvUV(*seq): 0;
772 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
776 const OPCODE optype = o->op_type;
778 PERL_ARGS_ASSERT_DO_OP_DUMP;
781 Perl_dump_indent(aTHX_ level, file, "{\n");
783 seq = sequence_num(o);
785 PerlIO_printf(file, "%-4"UVuf, seq);
787 PerlIO_printf(file, " ");
789 "%*sTYPE = %s ===> ",
790 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
792 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
793 sequence_num(o->op_next));
795 PerlIO_printf(file, "DONE\n");
797 if (optype == OP_NULL) {
798 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
799 if (o->op_targ == OP_NEXTSTATE) {
801 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
803 if (CopSTASHPV(cCOPo))
804 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
807 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
812 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
815 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
817 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
818 SV * const tmpsv = newSVpvs("");
819 switch (o->op_flags & OPf_WANT) {
821 sv_catpv(tmpsv, ",VOID");
823 case OPf_WANT_SCALAR:
824 sv_catpv(tmpsv, ",SCALAR");
827 sv_catpv(tmpsv, ",LIST");
830 sv_catpv(tmpsv, ",UNKNOWN");
833 if (o->op_flags & OPf_KIDS)
834 sv_catpv(tmpsv, ",KIDS");
835 if (o->op_flags & OPf_PARENS)
836 sv_catpv(tmpsv, ",PARENS");
837 if (o->op_flags & OPf_STACKED)
838 sv_catpv(tmpsv, ",STACKED");
839 if (o->op_flags & OPf_REF)
840 sv_catpv(tmpsv, ",REF");
841 if (o->op_flags & OPf_MOD)
842 sv_catpv(tmpsv, ",MOD");
843 if (o->op_flags & OPf_SPECIAL)
844 sv_catpv(tmpsv, ",SPECIAL");
846 sv_catpv(tmpsv, ",LATEFREE");
848 sv_catpv(tmpsv, ",LATEFREED");
850 sv_catpv(tmpsv, ",ATTACHED");
851 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
855 SV * const tmpsv = newSVpvs("");
856 if (PL_opargs[optype] & OA_TARGLEX) {
857 if (o->op_private & OPpTARGET_MY)
858 sv_catpv(tmpsv, ",TARGET_MY");
860 else if (optype == OP_LEAVESUB ||
861 optype == OP_LEAVE ||
862 optype == OP_LEAVESUBLV ||
863 optype == OP_LEAVEWRITE) {
864 if (o->op_private & OPpREFCOUNTED)
865 sv_catpv(tmpsv, ",REFCOUNTED");
867 else if (optype == OP_AASSIGN) {
868 if (o->op_private & OPpASSIGN_COMMON)
869 sv_catpv(tmpsv, ",COMMON");
871 else if (optype == OP_SASSIGN) {
872 if (o->op_private & OPpASSIGN_BACKWARDS)
873 sv_catpv(tmpsv, ",BACKWARDS");
875 else if (optype == OP_TRANS) {
876 if (o->op_private & OPpTRANS_SQUASH)
877 sv_catpv(tmpsv, ",SQUASH");
878 if (o->op_private & OPpTRANS_DELETE)
879 sv_catpv(tmpsv, ",DELETE");
880 if (o->op_private & OPpTRANS_COMPLEMENT)
881 sv_catpv(tmpsv, ",COMPLEMENT");
882 if (o->op_private & OPpTRANS_IDENTICAL)
883 sv_catpv(tmpsv, ",IDENTICAL");
884 if (o->op_private & OPpTRANS_GROWS)
885 sv_catpv(tmpsv, ",GROWS");
887 else if (optype == OP_REPEAT) {
888 if (o->op_private & OPpREPEAT_DOLIST)
889 sv_catpv(tmpsv, ",DOLIST");
891 else if (optype == OP_ENTERSUB ||
892 optype == OP_RV2SV ||
894 optype == OP_RV2AV ||
895 optype == OP_RV2HV ||
896 optype == OP_RV2GV ||
897 optype == OP_AELEM ||
900 if (optype == OP_ENTERSUB) {
901 if (o->op_private & OPpENTERSUB_AMPER)
902 sv_catpv(tmpsv, ",AMPER");
903 if (o->op_private & OPpENTERSUB_DB)
904 sv_catpv(tmpsv, ",DB");
905 if (o->op_private & OPpENTERSUB_HASTARG)
906 sv_catpv(tmpsv, ",HASTARG");
907 if (o->op_private & OPpENTERSUB_NOPAREN)
908 sv_catpv(tmpsv, ",NOPAREN");
909 if (o->op_private & OPpENTERSUB_INARGS)
910 sv_catpv(tmpsv, ",INARGS");
911 if (o->op_private & OPpENTERSUB_NOMOD)
912 sv_catpv(tmpsv, ",NOMOD");
915 switch (o->op_private & OPpDEREF) {
917 sv_catpv(tmpsv, ",SV");
920 sv_catpv(tmpsv, ",AV");
923 sv_catpv(tmpsv, ",HV");
926 if (o->op_private & OPpMAYBE_LVSUB)
927 sv_catpv(tmpsv, ",MAYBE_LVSUB");
929 if (optype == OP_AELEM || optype == OP_HELEM) {
930 if (o->op_private & OPpLVAL_DEFER)
931 sv_catpv(tmpsv, ",LVAL_DEFER");
934 if (o->op_private & HINT_STRICT_REFS)
935 sv_catpv(tmpsv, ",STRICT_REFS");
936 if (o->op_private & OPpOUR_INTRO)
937 sv_catpv(tmpsv, ",OUR_INTRO");
940 else if (optype == OP_CONST) {
941 if (o->op_private & OPpCONST_BARE)
942 sv_catpv(tmpsv, ",BARE");
943 if (o->op_private & OPpCONST_STRICT)
944 sv_catpv(tmpsv, ",STRICT");
945 if (o->op_private & OPpCONST_ARYBASE)
946 sv_catpv(tmpsv, ",ARYBASE");
947 if (o->op_private & OPpCONST_WARNING)
948 sv_catpv(tmpsv, ",WARNING");
949 if (o->op_private & OPpCONST_ENTERED)
950 sv_catpv(tmpsv, ",ENTERED");
952 else if (optype == OP_FLIP) {
953 if (o->op_private & OPpFLIP_LINENUM)
954 sv_catpv(tmpsv, ",LINENUM");
956 else if (optype == OP_FLOP) {
957 if (o->op_private & OPpFLIP_LINENUM)
958 sv_catpv(tmpsv, ",LINENUM");
960 else if (optype == OP_RV2CV) {
961 if (o->op_private & OPpLVAL_INTRO)
962 sv_catpv(tmpsv, ",INTRO");
964 else if (optype == OP_GV) {
965 if (o->op_private & OPpEARLY_CV)
966 sv_catpv(tmpsv, ",EARLY_CV");
968 else if (optype == OP_LIST) {
969 if (o->op_private & OPpLIST_GUESSED)
970 sv_catpv(tmpsv, ",GUESSED");
972 else if (optype == OP_DELETE) {
973 if (o->op_private & OPpSLICE)
974 sv_catpv(tmpsv, ",SLICE");
976 else if (optype == OP_EXISTS) {
977 if (o->op_private & OPpEXISTS_SUB)
978 sv_catpv(tmpsv, ",EXISTS_SUB");
980 else if (optype == OP_SORT) {
981 if (o->op_private & OPpSORT_NUMERIC)
982 sv_catpv(tmpsv, ",NUMERIC");
983 if (o->op_private & OPpSORT_INTEGER)
984 sv_catpv(tmpsv, ",INTEGER");
985 if (o->op_private & OPpSORT_REVERSE)
986 sv_catpv(tmpsv, ",REVERSE");
988 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
989 if (o->op_private & OPpOPEN_IN_RAW)
990 sv_catpv(tmpsv, ",IN_RAW");
991 if (o->op_private & OPpOPEN_IN_CRLF)
992 sv_catpv(tmpsv, ",IN_CRLF");
993 if (o->op_private & OPpOPEN_OUT_RAW)
994 sv_catpv(tmpsv, ",OUT_RAW");
995 if (o->op_private & OPpOPEN_OUT_CRLF)
996 sv_catpv(tmpsv, ",OUT_CRLF");
998 else if (optype == OP_EXIT) {
999 if (o->op_private & OPpEXIT_VMSISH)
1000 sv_catpv(tmpsv, ",EXIT_VMSISH");
1001 if (o->op_private & OPpHUSH_VMSISH)
1002 sv_catpv(tmpsv, ",HUSH_VMSISH");
1004 else if (optype == OP_DIE) {
1005 if (o->op_private & OPpHUSH_VMSISH)
1006 sv_catpv(tmpsv, ",HUSH_VMSISH");
1008 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
1009 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1010 sv_catpv(tmpsv, ",FT_ACCESS");
1011 if (o->op_private & OPpFT_STACKED)
1012 sv_catpv(tmpsv, ",FT_STACKED");
1014 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1015 sv_catpv(tmpsv, ",INTRO");
1017 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1018 SvREFCNT_dec(tmpsv);
1022 if (PL_madskills && o->op_madprop) {
1023 SV * const tmpsv = newSVpvs("");
1024 MADPROP* mp = o->op_madprop;
1025 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1028 const char tmp = mp->mad_key;
1029 sv_setpvs(tmpsv,"'");
1031 sv_catpvn(tmpsv, &tmp, 1);
1032 sv_catpv(tmpsv, "'=");
1033 switch (mp->mad_type) {
1035 sv_catpv(tmpsv, "NULL");
1036 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1039 sv_catpv(tmpsv, "<");
1040 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1041 sv_catpv(tmpsv, ">");
1042 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1045 if ((OP*)mp->mad_val) {
1046 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1047 do_op_dump(level, file, (OP*)mp->mad_val);
1051 sv_catpv(tmpsv, "(UNK)");
1052 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1058 Perl_dump_indent(aTHX_ level, file, "}\n");
1060 SvREFCNT_dec(tmpsv);
1069 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1071 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1072 if (cSVOPo->op_sv) {
1073 SV * const tmpsv = newSV(0);
1077 /* FIXME - is this making unwarranted assumptions about the
1078 UTF-8 cleanliness of the dump file handle? */
1081 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1082 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1083 SvPV_nolen_const(tmpsv));
1087 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1093 case OP_METHOD_NAMED:
1094 #ifndef USE_ITHREADS
1095 /* with ITHREADS, consts are stored in the pad, and the right pad
1096 * may not be active here, so skip */
1097 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1103 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1104 (UV)CopLINE(cCOPo));
1105 if (CopSTASHPV(cCOPo))
1106 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1108 if (CopLABEL(cCOPo))
1109 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1113 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1114 if (cLOOPo->op_redoop)
1115 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1117 PerlIO_printf(file, "DONE\n");
1118 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1119 if (cLOOPo->op_nextop)
1120 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1122 PerlIO_printf(file, "DONE\n");
1123 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1124 if (cLOOPo->op_lastop)
1125 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1127 PerlIO_printf(file, "DONE\n");
1135 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1136 if (cLOGOPo->op_other)
1137 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1139 PerlIO_printf(file, "DONE\n");
1145 do_pmop_dump(level, file, cPMOPo);
1153 if (o->op_private & OPpREFCOUNTED)
1154 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1159 if (o->op_flags & OPf_KIDS) {
1161 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1162 do_op_dump(level, file, kid);
1164 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1168 Perl_op_dump(pTHX_ const OP *o)
1170 PERL_ARGS_ASSERT_OP_DUMP;
1171 do_op_dump(0, Perl_debug_log, o);
1175 Perl_gv_dump(pTHX_ GV *gv)
1179 PERL_ARGS_ASSERT_GV_DUMP;
1182 PerlIO_printf(Perl_debug_log, "{}\n");
1185 sv = sv_newmortal();
1186 PerlIO_printf(Perl_debug_log, "{\n");
1187 gv_fullname3(sv, gv, NULL);
1188 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1189 if (gv != GvEGV(gv)) {
1190 gv_efullname3(sv, GvEGV(gv), NULL);
1191 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1193 PerlIO_putc(Perl_debug_log, '\n');
1194 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1198 /* map magic types to the symbolic names
1199 * (with the PERL_MAGIC_ prefixed stripped)
1202 static const struct { const char type; const char *name; } magic_names[] = {
1203 { PERL_MAGIC_sv, "sv(\\0)" },
1204 { PERL_MAGIC_arylen, "arylen(#)" },
1205 { PERL_MAGIC_rhash, "rhash(%)" },
1206 { PERL_MAGIC_pos, "pos(.)" },
1207 { PERL_MAGIC_symtab, "symtab(:)" },
1208 { PERL_MAGIC_backref, "backref(<)" },
1209 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1210 { PERL_MAGIC_overload, "overload(A)" },
1211 { PERL_MAGIC_bm, "bm(B)" },
1212 { PERL_MAGIC_regdata, "regdata(D)" },
1213 { PERL_MAGIC_env, "env(E)" },
1214 { PERL_MAGIC_hints, "hints(H)" },
1215 { PERL_MAGIC_isa, "isa(I)" },
1216 { PERL_MAGIC_dbfile, "dbfile(L)" },
1217 { PERL_MAGIC_shared, "shared(N)" },
1218 { PERL_MAGIC_tied, "tied(P)" },
1219 { PERL_MAGIC_sig, "sig(S)" },
1220 { PERL_MAGIC_uvar, "uvar(U)" },
1221 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1222 { PERL_MAGIC_overload_table, "overload_table(c)" },
1223 { PERL_MAGIC_regdatum, "regdatum(d)" },
1224 { PERL_MAGIC_envelem, "envelem(e)" },
1225 { PERL_MAGIC_fm, "fm(f)" },
1226 { PERL_MAGIC_regex_global, "regex_global(g)" },
1227 { PERL_MAGIC_hintselem, "hintselem(h)" },
1228 { PERL_MAGIC_isaelem, "isaelem(i)" },
1229 { PERL_MAGIC_nkeys, "nkeys(k)" },
1230 { PERL_MAGIC_dbline, "dbline(l)" },
1231 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1232 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1233 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1234 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1235 { PERL_MAGIC_qr, "qr(r)" },
1236 { PERL_MAGIC_sigelem, "sigelem(s)" },
1237 { PERL_MAGIC_taint, "taint(t)" },
1238 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1239 { PERL_MAGIC_vec, "vec(v)" },
1240 { PERL_MAGIC_vstring, "vstring(V)" },
1241 { PERL_MAGIC_utf8, "utf8(w)" },
1242 { PERL_MAGIC_substr, "substr(x)" },
1243 { PERL_MAGIC_defelem, "defelem(y)" },
1244 { PERL_MAGIC_ext, "ext(~)" },
1245 /* this null string terminates the list */
1250 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1252 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1254 for (; mg; mg = mg->mg_moremagic) {
1255 Perl_dump_indent(aTHX_ level, file,
1256 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1257 if (mg->mg_virtual) {
1258 const MGVTBL * const v = mg->mg_virtual;
1260 if (v == &PL_vtbl_sv) s = "sv";
1261 else if (v == &PL_vtbl_env) s = "env";
1262 else if (v == &PL_vtbl_envelem) s = "envelem";
1263 else if (v == &PL_vtbl_sig) s = "sig";
1264 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1265 else if (v == &PL_vtbl_pack) s = "pack";
1266 else if (v == &PL_vtbl_packelem) s = "packelem";
1267 else if (v == &PL_vtbl_dbline) s = "dbline";
1268 else if (v == &PL_vtbl_isa) s = "isa";
1269 else if (v == &PL_vtbl_arylen) s = "arylen";
1270 else if (v == &PL_vtbl_mglob) s = "mglob";
1271 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1272 else if (v == &PL_vtbl_taint) s = "taint";
1273 else if (v == &PL_vtbl_substr) s = "substr";
1274 else if (v == &PL_vtbl_vec) s = "vec";
1275 else if (v == &PL_vtbl_pos) s = "pos";
1276 else if (v == &PL_vtbl_bm) s = "bm";
1277 else if (v == &PL_vtbl_fm) s = "fm";
1278 else if (v == &PL_vtbl_uvar) s = "uvar";
1279 else if (v == &PL_vtbl_defelem) s = "defelem";
1280 #ifdef USE_LOCALE_COLLATE
1281 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1283 else if (v == &PL_vtbl_amagic) s = "amagic";
1284 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1285 else if (v == &PL_vtbl_backref) s = "backref";
1286 else if (v == &PL_vtbl_utf8) s = "utf8";
1287 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1288 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1289 else if (v == &PL_vtbl_hints) s = "hints";
1292 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1294 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1297 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1300 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1304 const char *name = NULL;
1305 for (n = 0; magic_names[n].name; n++) {
1306 if (mg->mg_type == magic_names[n].type) {
1307 name = magic_names[n].name;
1312 Perl_dump_indent(aTHX_ level, file,
1313 " MG_TYPE = PERL_MAGIC_%s\n", name);
1315 Perl_dump_indent(aTHX_ level, file,
1316 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1320 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1321 if (mg->mg_type == PERL_MAGIC_envelem &&
1322 mg->mg_flags & MGf_TAINTEDDIR)
1323 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1324 if (mg->mg_flags & MGf_REFCOUNTED)
1325 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1326 if (mg->mg_flags & MGf_GSKIP)
1327 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1328 if (mg->mg_type == PERL_MAGIC_regex_global &&
1329 mg->mg_flags & MGf_MINMATCH)
1330 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1333 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1334 PTR2UV(mg->mg_obj));
1335 if (mg->mg_type == PERL_MAGIC_qr) {
1336 REGEXP* const re = (REGEXP *)mg->mg_obj;
1337 SV * const dsv = sv_newmortal();
1338 const char * const s
1339 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1341 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1342 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1344 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1345 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1348 if (mg->mg_flags & MGf_REFCOUNTED)
1349 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1352 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1354 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1355 if (mg->mg_len >= 0) {
1356 if (mg->mg_type != PERL_MAGIC_utf8) {
1357 SV * const sv = newSVpvs("");
1358 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1362 else if (mg->mg_len == HEf_SVKEY) {
1363 PerlIO_puts(file, " => HEf_SVKEY\n");
1364 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1365 maxnest, dumpops, pvlim); /* MG is already +1 */
1368 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1373 " does not know how to handle this MG_LEN"
1375 PerlIO_putc(file, '\n');
1377 if (mg->mg_type == PERL_MAGIC_utf8) {
1378 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1381 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1382 Perl_dump_indent(aTHX_ level, file,
1383 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1386 (UV)cache[i * 2 + 1]);
1393 Perl_magic_dump(pTHX_ const MAGIC *mg)
1395 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1399 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1403 PERL_ARGS_ASSERT_DO_HV_DUMP;
1405 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1406 if (sv && (hvname = HvNAME_get(sv)))
1407 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1409 PerlIO_putc(file, '\n');
1413 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1415 PERL_ARGS_ASSERT_DO_GV_DUMP;
1417 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1418 if (sv && GvNAME(sv))
1419 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1421 PerlIO_putc(file, '\n');
1425 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1427 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1429 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1430 if (sv && GvNAME(sv)) {
1432 PerlIO_printf(file, "\t\"");
1433 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1434 PerlIO_printf(file, "%s\" :: \"", hvname);
1435 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1438 PerlIO_putc(file, '\n');
1442 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1450 PERL_ARGS_ASSERT_DO_SV_DUMP;
1453 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1457 flags = SvFLAGS(sv);
1460 d = Perl_newSVpvf(aTHX_
1461 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1462 PTR2UV(SvANY(sv)), PTR2UV(sv),
1463 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1464 (int)(PL_dumpindent*level), "");
1466 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1467 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1469 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1470 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1471 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1473 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1474 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1475 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1476 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1477 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1479 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1480 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1481 if (flags & SVf_POK) sv_catpv(d, "POK,");
1482 if (flags & SVf_ROK) {
1483 sv_catpv(d, "ROK,");
1484 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1486 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1487 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1488 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1489 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1491 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1492 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1493 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1494 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1495 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1496 if (SvPCS_IMPORTED(sv))
1497 sv_catpv(d, "PCS_IMPORTED,");
1499 sv_catpv(d, "SCREAM,");
1505 if (CvANON(sv)) sv_catpv(d, "ANON,");
1506 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1507 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1508 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1509 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1510 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1511 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1512 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1513 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1514 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1517 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1518 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1519 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1520 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1521 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1525 if (isGV_with_GP(sv)) {
1526 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1527 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1528 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1529 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1531 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1532 sv_catpv(d, "IMPORT");
1533 if (GvIMPORTED(sv) == GVf_IMPORTED)
1534 sv_catpv(d, "ALL,");
1537 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1538 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1539 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1540 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1544 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1545 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1549 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1550 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1553 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1554 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1557 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1562 /* SVphv_SHAREKEYS is also 0x20000000 */
1563 if ((type != SVt_PVHV) && SvUTF8(sv))
1564 sv_catpv(d, "UTF8");
1566 if (*(SvEND(d) - 1) == ',') {
1567 SvCUR_set(d, SvCUR(d) - 1);
1568 SvPVX(d)[SvCUR(d)] = '\0';
1573 #ifdef DEBUG_LEAKING_SCALARS
1574 Perl_dump_indent(aTHX_ level, file,
1575 "ALLOCATED at %s:%d %s %s%s; serial %"UVuf"\n",
1576 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1578 sv->sv_debug_inpad ? "for" : "by",
1579 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1580 sv->sv_debug_cloned ? " (cloned)" : "",
1584 Perl_dump_indent(aTHX_ level, file, "SV = ");
1585 if (type < SVt_LAST) {
1586 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1588 if (type == SVt_NULL) {
1593 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1597 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1598 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
1599 && type != SVt_PVIO)
1600 || (type == SVt_IV && !SvROK(sv))) {
1602 #ifdef PERL_OLD_COPY_ON_WRITE
1606 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1608 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1609 #ifdef PERL_OLD_COPY_ON_WRITE
1610 if (SvIsCOW_shared_hash(sv))
1611 PerlIO_printf(file, " (HASH)");
1612 else if (SvIsCOW_normal(sv))
1613 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1615 PerlIO_putc(file, '\n');
1617 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1618 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1619 (UV) COP_SEQ_RANGE_LOW(sv));
1620 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1621 (UV) COP_SEQ_RANGE_HIGH(sv));
1622 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1623 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1624 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1625 || type == SVt_NV) {
1626 STORE_NUMERIC_LOCAL_SET_STANDARD();
1627 /* %Vg doesn't work? --jhi */
1628 #ifdef USE_LONG_DOUBLE
1629 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1631 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1633 RESTORE_NUMERIC_LOCAL();
1636 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1638 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1640 if (type < SVt_PV) {
1644 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1645 if (SvPVX_const(sv)) {
1648 SvOOK_offset(sv, delta);
1649 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1654 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1656 PerlIO_printf(file, "( %s . ) ",
1657 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1660 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1661 if (SvUTF8(sv)) /* the 6? \x{....} */
1662 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1663 PerlIO_printf(file, "\n");
1664 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1665 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1668 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1670 if (type == SVt_REGEXP) {
1672 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1673 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1676 if (type >= SVt_PVMG) {
1677 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1678 HV * const ost = SvOURSTASH(sv);
1680 do_hv_dump(level, file, " OURSTASH", ost);
1683 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1686 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1690 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1691 if (AvARRAY(sv) != AvALLOC(sv)) {
1692 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1693 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1696 PerlIO_putc(file, '\n');
1697 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1698 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1699 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1701 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1702 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1703 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1704 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1705 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1707 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1708 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1710 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1712 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1717 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1718 if (HvARRAY(sv) && HvKEYS(sv)) {
1719 /* Show distribution of HEs in the ARRAY */
1721 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1724 U32 pow2 = 2, keys = HvKEYS(sv);
1725 NV theoret, sum = 0;
1727 PerlIO_printf(file, " (");
1728 Zero(freq, FREQ_MAX + 1, int);
1729 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1732 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1734 if (count > FREQ_MAX)
1740 for (i = 0; i <= max; i++) {
1742 PerlIO_printf(file, "%d%s:%d", i,
1743 (i == FREQ_MAX) ? "+" : "",
1746 PerlIO_printf(file, ", ");
1749 PerlIO_putc(file, ')');
1750 /* The "quality" of a hash is defined as the total number of
1751 comparisons needed to access every element once, relative
1752 to the expected number needed for a random hash.
1754 The total number of comparisons is equal to the sum of
1755 the squares of the number of entries in each bucket.
1756 For a random hash of n keys into k buckets, the expected
1761 for (i = max; i > 0; i--) { /* Precision: count down. */
1762 sum += freq[i] * i * i;
1764 while ((keys = keys >> 1))
1766 theoret = HvKEYS(sv);
1767 theoret += theoret * (theoret-1)/pow2;
1768 PerlIO_putc(file, '\n');
1769 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1771 PerlIO_putc(file, '\n');
1772 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1773 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1774 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1775 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1776 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1778 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1779 if (mg && mg->mg_obj) {
1780 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1784 const char * const hvname = HvNAME_get(sv);
1786 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1790 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1791 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1793 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1795 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1799 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1800 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1801 (int)meta->mro_which->length,
1802 meta->mro_which->name,
1803 PTR2UV(meta->mro_which));
1804 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1805 (UV)meta->cache_gen);
1806 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1808 if (meta->mro_linear_all) {
1809 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1810 PTR2UV(meta->mro_linear_all));
1811 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1814 if (meta->mro_linear_current) {
1815 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1816 PTR2UV(meta->mro_linear_current));
1817 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1820 if (meta->mro_nextmethod) {
1821 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1822 PTR2UV(meta->mro_nextmethod));
1823 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1827 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1829 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1834 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1836 HV * const hv = MUTABLE_HV(sv);
1837 int count = maxnest - nest;
1840 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1843 const U32 hash = HeHASH(he);
1844 SV * const keysv = hv_iterkeysv(he);
1845 const char * const keypv = SvPV_const(keysv, len);
1846 SV * const elt = hv_iterval(hv, he);
1848 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1850 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1852 PerlIO_printf(file, "[REHASH] ");
1853 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1854 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1856 hv_iterinit(hv); /* Return to status quo */
1862 const char *const proto = SvPV_const(sv, len);
1863 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1868 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1869 if (!CvISXSUB(sv)) {
1871 Perl_dump_indent(aTHX_ level, file,
1872 " START = 0x%"UVxf" ===> %"IVdf"\n",
1873 PTR2UV(CvSTART(sv)),
1874 (IV)sequence_num(CvSTART(sv)));
1876 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1877 PTR2UV(CvROOT(sv)));
1878 if (CvROOT(sv) && dumpops) {
1879 do_op_dump(level+1, file, CvROOT(sv));
1882 SV * const constant = cv_const_sv((const CV *)sv);
1884 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1887 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1889 PTR2UV(CvXSUBANY(sv).any_ptr));
1890 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1893 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1894 (IV)CvXSUBANY(sv).any_i32);
1897 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1898 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1899 if (type == SVt_PVCV)
1900 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1901 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1902 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1903 if (type == SVt_PVFM)
1904 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1905 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1906 if (nest < maxnest) {
1907 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1910 const CV * const outside = CvOUTSIDE(sv);
1911 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1914 : CvANON(outside) ? "ANON"
1915 : (outside == PL_main_cv) ? "MAIN"
1916 : CvUNIQUE(outside) ? "UNIQUE"
1917 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1919 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1920 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1924 if (type == SVt_PVLV) {
1925 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1926 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1927 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1928 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1929 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1930 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1934 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1935 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1936 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1937 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1939 if (!isGV_with_GP(sv))
1941 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1942 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1943 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1944 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1947 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1948 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1949 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1950 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1951 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1952 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1953 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1954 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1955 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1956 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1957 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1958 do_gv_dump (level, file, " EGV", GvEGV(sv));
1961 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1962 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1963 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1964 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1965 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1966 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1967 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1969 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1970 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1971 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1973 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1974 PTR2UV(IoTOP_GV(sv)));
1975 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1976 maxnest, dumpops, pvlim);
1978 /* Source filters hide things that are not GVs in these three, so let's
1979 be careful out there. */
1981 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1982 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1983 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1985 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1986 PTR2UV(IoFMT_GV(sv)));
1987 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1988 maxnest, dumpops, pvlim);
1990 if (IoBOTTOM_NAME(sv))
1991 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1992 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1993 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1995 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1996 PTR2UV(IoBOTTOM_GV(sv)));
1997 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
1998 maxnest, dumpops, pvlim);
2000 if (isPRINT(IoTYPE(sv)))
2001 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2003 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2004 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2011 Perl_sv_dump(pTHX_ SV *sv)
2015 PERL_ARGS_ASSERT_SV_DUMP;
2018 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2020 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2024 Perl_runops_debug(pTHX)
2028 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2032 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2035 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2036 PerlIO_printf(Perl_debug_log,
2037 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2038 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2039 PTR2UV(*PL_watchaddr));
2040 if (DEBUG_s_TEST_) {
2041 if (DEBUG_v_TEST_) {
2042 PerlIO_printf(Perl_debug_log, "\n");
2050 if (DEBUG_t_TEST_) debop(PL_op);
2051 if (DEBUG_P_TEST_) debprof(PL_op);
2053 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2054 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2061 Perl_debop(pTHX_ const OP *o)
2065 PERL_ARGS_ASSERT_DEBOP;
2067 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2070 Perl_deb(aTHX_ "%s", OP_NAME(o));
2071 switch (o->op_type) {
2074 /* With ITHREADS, consts are stored in the pad, and the right pad
2075 * may not be active here, so check.
2076 * Looks like only during compiling the pads are illegal.
2079 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2081 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2086 SV * const sv = newSV(0);
2088 /* FIXME - is this making unwarranted assumptions about the
2089 UTF-8 cleanliness of the dump file handle? */
2092 gv_fullname3(sv, cGVOPo_gv, NULL);
2093 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2097 PerlIO_printf(Perl_debug_log, "(NULL)");
2103 /* print the lexical's name */
2104 CV * const cv = deb_curcv(cxstack_ix);
2107 AV * const padlist = CvPADLIST(cv);
2108 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2109 sv = *av_fetch(comppad, o->op_targ, FALSE);
2113 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2115 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2121 PerlIO_printf(Perl_debug_log, "\n");
2126 S_deb_curcv(pTHX_ const I32 ix)
2129 const PERL_CONTEXT * const cx = &cxstack[ix];
2130 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2131 return cx->blk_sub.cv;
2132 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2134 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2139 return deb_curcv(ix - 1);
2143 Perl_watch(pTHX_ char **addr)
2147 PERL_ARGS_ASSERT_WATCH;
2149 PL_watchaddr = addr;
2151 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2152 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2156 S_debprof(pTHX_ const OP *o)
2160 PERL_ARGS_ASSERT_DEBPROF;
2162 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2164 if (!PL_profiledata)
2165 Newxz(PL_profiledata, MAXO, U32);
2166 ++PL_profiledata[o->op_type];
2170 Perl_debprofdump(pTHX)
2174 if (!PL_profiledata)
2176 for (i = 0; i < MAXO; i++) {
2177 if (PL_profiledata[i])
2178 PerlIO_printf(Perl_debug_log,
2179 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2186 * XML variants of most of the above routines
2190 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2194 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2196 PerlIO_printf(file, "\n ");
2197 va_start(args, pat);
2198 xmldump_vindent(level, file, pat, &args);
2204 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2207 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2208 va_start(args, pat);
2209 xmldump_vindent(level, file, pat, &args);
2214 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2216 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2218 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2219 PerlIO_vprintf(file, pat, *args);
2223 Perl_xmldump_all(pTHX)
2225 xmldump_all_perl(FALSE);
2229 Perl_xmldump_all_perl(pTHX_ bool justperl)
2231 PerlIO_setlinebuf(PL_xmlfp);
2233 op_xmldump(PL_main_root);
2234 xmldump_packsubs_perl(PL_defstash, justperl);
2235 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2236 PerlIO_close(PL_xmlfp);
2241 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2243 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2244 xmldump_packsubs_perl(stash, FALSE);
2248 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2253 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2255 if (!HvARRAY(stash))
2257 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2258 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2259 GV *gv = MUTABLE_GV(HeVAL(entry));
2261 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2264 xmldump_sub_perl(gv, justperl);
2267 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2268 && (hv = GvHV(gv)) && hv != PL_defstash)
2269 xmldump_packsubs_perl(hv, justperl); /* nested package */
2275 Perl_xmldump_sub(pTHX_ const GV *gv)
2277 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2278 xmldump_sub_perl(gv, FALSE);
2282 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2286 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2288 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2291 sv = sv_newmortal();
2292 gv_fullname3(sv, gv, NULL);
2293 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2294 if (CvXSUB(GvCV(gv)))
2295 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2296 PTR2UV(CvXSUB(GvCV(gv))),
2297 (int)CvXSUBANY(GvCV(gv)).any_i32);
2298 else if (CvROOT(GvCV(gv)))
2299 op_xmldump(CvROOT(GvCV(gv)));
2301 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2305 Perl_xmldump_form(pTHX_ const GV *gv)
2307 SV * const sv = sv_newmortal();
2309 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2311 gv_fullname3(sv, gv, NULL);
2312 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2313 if (CvROOT(GvFORM(gv)))
2314 op_xmldump(CvROOT(GvFORM(gv)));
2316 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2320 Perl_xmldump_eval(pTHX)
2322 op_xmldump(PL_eval_root);
2326 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2328 PERL_ARGS_ASSERT_SV_CATXMLSV;
2329 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2333 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2336 const char * const e = pv + len;
2337 const char * const start = pv;
2341 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2344 dsvcur = SvCUR(dsv); /* in case we have to restart */
2349 c = utf8_to_uvchr((U8*)pv, &cl);
2351 SvCUR(dsv) = dsvcur;
2416 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2419 sv_catpvs(dsv, "<");
2422 sv_catpvs(dsv, ">");
2425 sv_catpvs(dsv, "&");
2428 sv_catpvs(dsv, """);
2432 if (c < 32 || c > 127) {
2433 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2436 const char string = (char) c;
2437 sv_catpvn(dsv, &string, 1);
2441 if ((c >= 0xD800 && c <= 0xDB7F) ||
2442 (c >= 0xDC00 && c <= 0xDFFF) ||
2443 (c >= 0xFFF0 && c <= 0xFFFF) ||
2445 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2447 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2460 Perl_sv_xmlpeek(pTHX_ SV *sv)
2462 SV * const t = sv_newmortal();
2466 PERL_ARGS_ASSERT_SV_XMLPEEK;
2472 sv_catpv(t, "VOID=\"\"");
2475 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2476 sv_catpv(t, "WILD=\"\"");
2479 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2480 if (sv == &PL_sv_undef) {
2481 sv_catpv(t, "SV_UNDEF=\"1\"");
2482 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2483 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2487 else if (sv == &PL_sv_no) {
2488 sv_catpv(t, "SV_NO=\"1\"");
2489 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2490 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2491 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2492 SVp_POK|SVp_NOK)) &&
2497 else if (sv == &PL_sv_yes) {
2498 sv_catpv(t, "SV_YES=\"1\"");
2499 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2500 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2501 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2502 SVp_POK|SVp_NOK)) &&
2504 SvPVX(sv) && *SvPVX(sv) == '1' &&
2509 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2510 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2511 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2515 sv_catpv(t, " XXX=\"\" ");
2517 else if (SvREFCNT(sv) == 0) {
2518 sv_catpv(t, " refcnt=\"0\"");
2521 else if (DEBUG_R_TEST_) {
2524 /* is this SV on the tmps stack? */
2525 for (ix=PL_tmps_ix; ix>=0; ix--) {
2526 if (PL_tmps_stack[ix] == sv) {
2531 if (SvREFCNT(sv) > 1)
2532 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2535 sv_catpv(t, " DRT=\"<T>\"");
2539 sv_catpv(t, " ROK=\"\"");
2541 switch (SvTYPE(sv)) {
2543 sv_catpv(t, " FREED=\"1\"");
2547 sv_catpv(t, " UNDEF=\"1\"");
2550 sv_catpv(t, " IV=\"");
2553 sv_catpv(t, " NV=\"");
2556 sv_catpv(t, " PV=\"");
2559 sv_catpv(t, " PVIV=\"");
2562 sv_catpv(t, " PVNV=\"");
2565 sv_catpv(t, " PVMG=\"");
2568 sv_catpv(t, " PVLV=\"");
2571 sv_catpv(t, " AV=\"");
2574 sv_catpv(t, " HV=\"");
2578 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2580 sv_catpv(t, " CV=\"()\"");
2583 sv_catpv(t, " GV=\"");
2586 sv_catpv(t, " BIND=\"");
2589 sv_catpv(t, " ORANGE=\"");
2592 sv_catpv(t, " FM=\"");
2595 sv_catpv(t, " IO=\"");
2604 else if (SvNOKp(sv)) {
2605 STORE_NUMERIC_LOCAL_SET_STANDARD();
2606 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2607 RESTORE_NUMERIC_LOCAL();
2609 else if (SvIOKp(sv)) {
2611 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2613 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2622 return SvPV(t, n_a);
2626 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2628 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2631 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2634 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2637 REGEXP *const r = PM_GETRE(pm);
2638 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2639 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2640 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2642 SvREFCNT_dec(tmpsv);
2643 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2644 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2647 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2648 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2649 SV * const tmpsv = pm_description(pm);
2650 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2651 SvREFCNT_dec(tmpsv);
2655 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2656 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2657 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2658 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2659 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2660 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2663 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2667 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2669 do_pmop_xmldump(0, PL_xmlfp, pm);
2673 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2678 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2683 seq = sequence_num(o);
2684 Perl_xmldump_indent(aTHX_ level, file,
2685 "<op_%s seq=\"%"UVuf" -> ",
2690 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2691 sequence_num(o->op_next));
2693 PerlIO_printf(file, "DONE\"");
2696 if (o->op_type == OP_NULL)
2698 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2699 if (o->op_targ == OP_NEXTSTATE)
2702 PerlIO_printf(file, " line=\"%"UVuf"\"",
2703 (UV)CopLINE(cCOPo));
2704 if (CopSTASHPV(cCOPo))
2705 PerlIO_printf(file, " package=\"%s\"",
2707 if (CopLABEL(cCOPo))
2708 PerlIO_printf(file, " label=\"%s\"",
2713 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2716 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2719 SV * const tmpsv = newSVpvs("");
2720 switch (o->op_flags & OPf_WANT) {
2722 sv_catpv(tmpsv, ",VOID");
2724 case OPf_WANT_SCALAR:
2725 sv_catpv(tmpsv, ",SCALAR");
2728 sv_catpv(tmpsv, ",LIST");
2731 sv_catpv(tmpsv, ",UNKNOWN");
2734 if (o->op_flags & OPf_KIDS)
2735 sv_catpv(tmpsv, ",KIDS");
2736 if (o->op_flags & OPf_PARENS)
2737 sv_catpv(tmpsv, ",PARENS");
2738 if (o->op_flags & OPf_STACKED)
2739 sv_catpv(tmpsv, ",STACKED");
2740 if (o->op_flags & OPf_REF)
2741 sv_catpv(tmpsv, ",REF");
2742 if (o->op_flags & OPf_MOD)
2743 sv_catpv(tmpsv, ",MOD");
2744 if (o->op_flags & OPf_SPECIAL)
2745 sv_catpv(tmpsv, ",SPECIAL");
2746 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2747 SvREFCNT_dec(tmpsv);
2749 if (o->op_private) {
2750 SV * const tmpsv = newSVpvs("");
2751 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2752 if (o->op_private & OPpTARGET_MY)
2753 sv_catpv(tmpsv, ",TARGET_MY");
2755 else if (o->op_type == OP_LEAVESUB ||
2756 o->op_type == OP_LEAVE ||
2757 o->op_type == OP_LEAVESUBLV ||
2758 o->op_type == OP_LEAVEWRITE) {
2759 if (o->op_private & OPpREFCOUNTED)
2760 sv_catpv(tmpsv, ",REFCOUNTED");
2762 else if (o->op_type == OP_AASSIGN) {
2763 if (o->op_private & OPpASSIGN_COMMON)
2764 sv_catpv(tmpsv, ",COMMON");
2766 else if (o->op_type == OP_SASSIGN) {
2767 if (o->op_private & OPpASSIGN_BACKWARDS)
2768 sv_catpv(tmpsv, ",BACKWARDS");
2770 else if (o->op_type == OP_TRANS) {
2771 if (o->op_private & OPpTRANS_SQUASH)
2772 sv_catpv(tmpsv, ",SQUASH");
2773 if (o->op_private & OPpTRANS_DELETE)
2774 sv_catpv(tmpsv, ",DELETE");
2775 if (o->op_private & OPpTRANS_COMPLEMENT)
2776 sv_catpv(tmpsv, ",COMPLEMENT");
2777 if (o->op_private & OPpTRANS_IDENTICAL)
2778 sv_catpv(tmpsv, ",IDENTICAL");
2779 if (o->op_private & OPpTRANS_GROWS)
2780 sv_catpv(tmpsv, ",GROWS");
2782 else if (o->op_type == OP_REPEAT) {
2783 if (o->op_private & OPpREPEAT_DOLIST)
2784 sv_catpv(tmpsv, ",DOLIST");
2786 else if (o->op_type == OP_ENTERSUB ||
2787 o->op_type == OP_RV2SV ||
2788 o->op_type == OP_GVSV ||
2789 o->op_type == OP_RV2AV ||
2790 o->op_type == OP_RV2HV ||
2791 o->op_type == OP_RV2GV ||
2792 o->op_type == OP_AELEM ||
2793 o->op_type == OP_HELEM )
2795 if (o->op_type == OP_ENTERSUB) {
2796 if (o->op_private & OPpENTERSUB_AMPER)
2797 sv_catpv(tmpsv, ",AMPER");
2798 if (o->op_private & OPpENTERSUB_DB)
2799 sv_catpv(tmpsv, ",DB");
2800 if (o->op_private & OPpENTERSUB_HASTARG)
2801 sv_catpv(tmpsv, ",HASTARG");
2802 if (o->op_private & OPpENTERSUB_NOPAREN)
2803 sv_catpv(tmpsv, ",NOPAREN");
2804 if (o->op_private & OPpENTERSUB_INARGS)
2805 sv_catpv(tmpsv, ",INARGS");
2806 if (o->op_private & OPpENTERSUB_NOMOD)
2807 sv_catpv(tmpsv, ",NOMOD");
2810 switch (o->op_private & OPpDEREF) {
2812 sv_catpv(tmpsv, ",SV");
2815 sv_catpv(tmpsv, ",AV");
2818 sv_catpv(tmpsv, ",HV");
2821 if (o->op_private & OPpMAYBE_LVSUB)
2822 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2824 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2825 if (o->op_private & OPpLVAL_DEFER)
2826 sv_catpv(tmpsv, ",LVAL_DEFER");
2829 if (o->op_private & HINT_STRICT_REFS)
2830 sv_catpv(tmpsv, ",STRICT_REFS");
2831 if (o->op_private & OPpOUR_INTRO)
2832 sv_catpv(tmpsv, ",OUR_INTRO");
2835 else if (o->op_type == OP_CONST) {
2836 if (o->op_private & OPpCONST_BARE)
2837 sv_catpv(tmpsv, ",BARE");
2838 if (o->op_private & OPpCONST_STRICT)
2839 sv_catpv(tmpsv, ",STRICT");
2840 if (o->op_private & OPpCONST_ARYBASE)
2841 sv_catpv(tmpsv, ",ARYBASE");
2842 if (o->op_private & OPpCONST_WARNING)
2843 sv_catpv(tmpsv, ",WARNING");
2844 if (o->op_private & OPpCONST_ENTERED)
2845 sv_catpv(tmpsv, ",ENTERED");
2847 else if (o->op_type == OP_FLIP) {
2848 if (o->op_private & OPpFLIP_LINENUM)
2849 sv_catpv(tmpsv, ",LINENUM");
2851 else if (o->op_type == OP_FLOP) {
2852 if (o->op_private & OPpFLIP_LINENUM)
2853 sv_catpv(tmpsv, ",LINENUM");
2855 else if (o->op_type == OP_RV2CV) {
2856 if (o->op_private & OPpLVAL_INTRO)
2857 sv_catpv(tmpsv, ",INTRO");
2859 else if (o->op_type == OP_GV) {
2860 if (o->op_private & OPpEARLY_CV)
2861 sv_catpv(tmpsv, ",EARLY_CV");
2863 else if (o->op_type == OP_LIST) {
2864 if (o->op_private & OPpLIST_GUESSED)
2865 sv_catpv(tmpsv, ",GUESSED");
2867 else if (o->op_type == OP_DELETE) {
2868 if (o->op_private & OPpSLICE)
2869 sv_catpv(tmpsv, ",SLICE");
2871 else if (o->op_type == OP_EXISTS) {
2872 if (o->op_private & OPpEXISTS_SUB)
2873 sv_catpv(tmpsv, ",EXISTS_SUB");
2875 else if (o->op_type == OP_SORT) {
2876 if (o->op_private & OPpSORT_NUMERIC)
2877 sv_catpv(tmpsv, ",NUMERIC");
2878 if (o->op_private & OPpSORT_INTEGER)
2879 sv_catpv(tmpsv, ",INTEGER");
2880 if (o->op_private & OPpSORT_REVERSE)
2881 sv_catpv(tmpsv, ",REVERSE");
2883 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2884 if (o->op_private & OPpOPEN_IN_RAW)
2885 sv_catpv(tmpsv, ",IN_RAW");
2886 if (o->op_private & OPpOPEN_IN_CRLF)
2887 sv_catpv(tmpsv, ",IN_CRLF");
2888 if (o->op_private & OPpOPEN_OUT_RAW)
2889 sv_catpv(tmpsv, ",OUT_RAW");
2890 if (o->op_private & OPpOPEN_OUT_CRLF)
2891 sv_catpv(tmpsv, ",OUT_CRLF");
2893 else if (o->op_type == OP_EXIT) {
2894 if (o->op_private & OPpEXIT_VMSISH)
2895 sv_catpv(tmpsv, ",EXIT_VMSISH");
2896 if (o->op_private & OPpHUSH_VMSISH)
2897 sv_catpv(tmpsv, ",HUSH_VMSISH");
2899 else if (o->op_type == OP_DIE) {
2900 if (o->op_private & OPpHUSH_VMSISH)
2901 sv_catpv(tmpsv, ",HUSH_VMSISH");
2903 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2904 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2905 sv_catpv(tmpsv, ",FT_ACCESS");
2906 if (o->op_private & OPpFT_STACKED)
2907 sv_catpv(tmpsv, ",FT_STACKED");
2909 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2910 sv_catpv(tmpsv, ",INTRO");
2912 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2913 SvREFCNT_dec(tmpsv);
2916 switch (o->op_type) {
2918 if (o->op_flags & OPf_SPECIAL) {
2924 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2926 if (cSVOPo->op_sv) {
2927 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2928 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2934 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2935 s = SvPV(tmpsv1,len);
2936 sv_catxmlpvn(tmpsv2, s, len, 1);
2937 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2941 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2946 case OP_METHOD_NAMED:
2947 #ifndef USE_ITHREADS
2948 /* with ITHREADS, consts are stored in the pad, and the right pad
2949 * may not be active here, so skip */
2950 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2956 PerlIO_printf(file, ">\n");
2958 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2963 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2964 (UV)CopLINE(cCOPo));
2965 if (CopSTASHPV(cCOPo))
2966 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2968 if (CopLABEL(cCOPo))
2969 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2973 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2974 if (cLOOPo->op_redoop)
2975 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2977 PerlIO_printf(file, "DONE\"");
2978 S_xmldump_attr(aTHX_ level, file, "next=\"");
2979 if (cLOOPo->op_nextop)
2980 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2982 PerlIO_printf(file, "DONE\"");
2983 S_xmldump_attr(aTHX_ level, file, "last=\"");
2984 if (cLOOPo->op_lastop)
2985 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2987 PerlIO_printf(file, "DONE\"");
2995 S_xmldump_attr(aTHX_ level, file, "other=\"");
2996 if (cLOGOPo->op_other)
2997 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2999 PerlIO_printf(file, "DONE\"");
3007 if (o->op_private & OPpREFCOUNTED)
3008 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3014 if (PL_madskills && o->op_madprop) {
3015 char prevkey = '\0';
3016 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3017 const MADPROP* mp = o->op_madprop;
3021 PerlIO_printf(file, ">\n");
3023 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3026 char tmp = mp->mad_key;
3027 sv_setpvs(tmpsv,"\"");
3029 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3030 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3031 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3034 sv_catpv(tmpsv, "\"");
3035 switch (mp->mad_type) {
3037 sv_catpv(tmpsv, "NULL");
3038 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3041 sv_catpv(tmpsv, " val=\"");
3042 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3043 sv_catpv(tmpsv, "\"");
3044 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3047 sv_catpv(tmpsv, " val=\"");
3048 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3049 sv_catpv(tmpsv, "\"");
3050 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3053 if ((OP*)mp->mad_val) {
3054 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3055 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3056 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3060 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3066 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3068 SvREFCNT_dec(tmpsv);
3071 switch (o->op_type) {
3078 PerlIO_printf(file, ">\n");
3080 do_pmop_xmldump(level, file, cPMOPo);
3086 if (o->op_flags & OPf_KIDS) {
3090 PerlIO_printf(file, ">\n");
3092 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3093 do_op_xmldump(level, file, kid);
3097 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3099 PerlIO_printf(file, " />\n");
3103 Perl_op_xmldump(pTHX_ const OP *o)
3105 PERL_ARGS_ASSERT_OP_XMLDUMP;
3107 do_op_xmldump(0, PL_xmlfp, o);
3113 * c-indentation-style: bsd
3115 * indent-tabs-mode: t
3118 * ex: set ts=8 sts=4 sw=4 noet: