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] = {
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78 const struct flag_to_name *const end)
81 if (flags & start->flag)
82 sv_catpv(sv, start->name);
83 } while (++start < end);
86 #define append_flags(sv, f, flags) \
87 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
90 #define Sequence PL_op_sequence
93 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
96 PERL_ARGS_ASSERT_DUMP_INDENT;
98 dump_vindent(level, file, pat, &args);
103 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
106 PERL_ARGS_ASSERT_DUMP_VINDENT;
107 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
108 PerlIO_vprintf(file, pat, *args);
114 dump_all_perl(FALSE);
118 Perl_dump_all_perl(pTHX_ bool justperl)
122 PerlIO_setlinebuf(Perl_debug_log);
124 op_dump(PL_main_root);
125 dump_packsubs_perl(PL_defstash, justperl);
129 Perl_dump_packsubs(pTHX_ const HV *stash)
131 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
132 dump_packsubs_perl(stash, FALSE);
136 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
141 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
145 for (i = 0; i <= (I32) HvMAX(stash); i++) {
147 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
148 const GV * const gv = (const GV *)HeVAL(entry);
149 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
152 dump_sub_perl(gv, justperl);
155 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
156 const HV * const hv = GvHV(gv);
157 if (hv && (hv != PL_defstash))
158 dump_packsubs_perl(hv, justperl); /* nested package */
165 Perl_dump_sub(pTHX_ const GV *gv)
167 PERL_ARGS_ASSERT_DUMP_SUB;
168 dump_sub_perl(gv, FALSE);
172 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
176 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
178 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
182 gv_fullname3(sv, gv, NULL);
183 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
184 if (CvISXSUB(GvCV(gv)))
185 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
186 PTR2UV(CvXSUB(GvCV(gv))),
187 (int)CvXSUBANY(GvCV(gv)).any_i32);
188 else if (CvROOT(GvCV(gv)))
189 op_dump(CvROOT(GvCV(gv)));
191 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
195 Perl_dump_form(pTHX_ const GV *gv)
197 SV * const sv = sv_newmortal();
199 PERL_ARGS_ASSERT_DUMP_FORM;
201 gv_fullname3(sv, gv, NULL);
202 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
203 if (CvROOT(GvFORM(gv)))
204 op_dump(CvROOT(GvFORM(gv)));
206 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
213 op_dump(PL_eval_root);
218 =for apidoc pv_escape
220 Escapes at most the first "count" chars of pv and puts the results into
221 dsv such that the size of the escaped string will not exceed "max" chars
222 and will not contain any incomplete escape sequences.
224 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
225 will also be escaped.
227 Normally the SV will be cleared before the escaped string is prepared,
228 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
230 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
231 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
232 using C<is_utf8_string()> to determine if it is Unicode.
234 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
235 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
236 chars above 127 will be escaped using this style; otherwise, only chars above
237 255 will be so escaped; other non printable chars will use octal or
238 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
239 then all chars below 255 will be treated as printable and
240 will be output as literals.
242 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
243 string will be escaped, regardless of max. If the output is to be in hex,
244 then it will be returned as a plain hex
245 sequence. Thus the output will either be a single char,
246 an octal escape sequence, a special escape like C<\n> or a hex value.
248 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
249 not a '\\'. This is because regexes very often contain backslashed
250 sequences, whereas '%' is not a particularly common character in patterns.
252 Returns a pointer to the escaped text as held by dsv.
256 #define PV_ESCAPE_OCTBUFSIZE 32
259 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
260 const STRLEN count, const STRLEN max,
261 STRLEN * const escaped, const U32 flags )
263 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
264 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
265 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
266 STRLEN wrote = 0; /* chars written so far */
267 STRLEN chsize = 0; /* size of data to be written */
268 STRLEN readsize = 1; /* size of data just read */
269 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
270 const char *pv = str;
271 const char * const end = pv + count; /* end of string */
274 PERL_ARGS_ASSERT_PV_ESCAPE;
276 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
277 /* This won't alter the UTF-8 flag */
281 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
284 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
285 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
286 const U8 c = (U8)u & 0xFF;
289 || (flags & PERL_PV_ESCAPE_ALL)
290 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
292 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
293 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
296 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
297 "%cx{%"UVxf"}", esc, u);
298 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
301 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
305 case '\\' : /* fallthrough */
306 case '%' : if ( c == esc ) {
312 case '\v' : octbuf[1] = 'v'; break;
313 case '\t' : octbuf[1] = 't'; break;
314 case '\r' : octbuf[1] = 'r'; break;
315 case '\n' : octbuf[1] = 'n'; break;
316 case '\f' : octbuf[1] = 'f'; break;
324 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
325 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
328 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
335 if ( max && (wrote + chsize > max) ) {
337 } else if (chsize > 1) {
338 sv_catpvn(dsv, octbuf, chsize);
341 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
342 128-255 can be appended raw to the dsv. If dsv happens to be
343 UTF-8 then we need catpvf to upgrade them for us.
344 Or add a new API call sv_catpvc(). Think about that name, and
345 how to keep it clear that it's unlike the s of catpvs, which is
346 really an array octets, not a string. */
347 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
350 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
358 =for apidoc pv_pretty
360 Converts a string into something presentable, handling escaping via
361 pv_escape() and supporting quoting and ellipses.
363 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
364 double quoted with any double quotes in the string escaped. Otherwise
365 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
368 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
369 string were output then an ellipsis C<...> will be appended to the
370 string. Note that this happens AFTER it has been quoted.
372 If start_color is non-null then it will be inserted after the opening
373 quote (if there is one) but before the escaped text. If end_color
374 is non-null then it will be inserted after the escaped text but before
375 any quotes or ellipses.
377 Returns a pointer to the prettified text as held by dsv.
383 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
384 const STRLEN max, char const * const start_color, char const * const end_color,
387 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
390 PERL_ARGS_ASSERT_PV_PRETTY;
392 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
393 /* This won't alter the UTF-8 flag */
398 sv_catpvs(dsv, "\"");
399 else if ( flags & PERL_PV_PRETTY_LTGT )
402 if ( start_color != NULL )
403 sv_catpv(dsv, start_color);
405 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
407 if ( end_color != NULL )
408 sv_catpv(dsv, end_color);
411 sv_catpvs( dsv, "\"");
412 else if ( flags & PERL_PV_PRETTY_LTGT )
415 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
416 sv_catpvs(dsv, "...");
422 =for apidoc pv_display
426 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
428 except that an additional "\0" will be appended to the string when
429 len > cur and pv[cur] is "\0".
431 Note that the final string may be up to 7 chars longer than pvlim.
437 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
439 PERL_ARGS_ASSERT_PV_DISPLAY;
441 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
442 if (len > cur && pv[cur] == '\0')
443 sv_catpvs( dsv, "\\0");
448 Perl_sv_peek(pTHX_ SV *sv)
451 SV * const t = sv_newmortal();
461 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
465 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
466 if (sv == &PL_sv_undef) {
467 sv_catpv(t, "SV_UNDEF");
468 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
469 SVs_GMG|SVs_SMG|SVs_RMG)) &&
473 else if (sv == &PL_sv_no) {
474 sv_catpv(t, "SV_NO");
475 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
476 SVs_GMG|SVs_SMG|SVs_RMG)) &&
477 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
483 else if (sv == &PL_sv_yes) {
484 sv_catpv(t, "SV_YES");
485 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
486 SVs_GMG|SVs_SMG|SVs_RMG)) &&
487 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
490 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
495 sv_catpv(t, "SV_PLACEHOLDER");
496 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
497 SVs_GMG|SVs_SMG|SVs_RMG)) &&
503 else if (SvREFCNT(sv) == 0) {
507 else if (DEBUG_R_TEST_) {
510 /* is this SV on the tmps stack? */
511 for (ix=PL_tmps_ix; ix>=0; ix--) {
512 if (PL_tmps_stack[ix] == sv) {
517 if (SvREFCNT(sv) > 1)
518 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
526 if (SvCUR(t) + unref > 10) {
527 SvCUR_set(t, unref + 3);
536 if (type == SVt_PVCV) {
537 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
539 } else if (type < SVt_LAST) {
540 sv_catpv(t, svshorttypenames[type]);
542 if (type == SVt_NULL)
545 sv_catpv(t, "FREED");
550 if (!SvPVX_const(sv))
551 sv_catpv(t, "(null)");
553 SV * const tmp = newSVpvs("");
557 SvOOK_offset(sv, delta);
558 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
560 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
562 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
563 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
568 else if (SvNOKp(sv)) {
569 STORE_NUMERIC_LOCAL_SET_STANDARD();
570 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
571 RESTORE_NUMERIC_LOCAL();
573 else if (SvIOKp(sv)) {
575 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
577 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
585 if (PL_tainting && SvTAINTED(sv))
586 sv_catpv(t, " [tainted]");
587 return SvPV_nolen(t);
591 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
595 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
598 Perl_dump_indent(aTHX_ level, file, "{}\n");
601 Perl_dump_indent(aTHX_ level, file, "{\n");
603 if (pm->op_pmflags & PMf_ONCE)
608 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
609 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
610 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
612 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
613 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
614 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
615 op_dump(pm->op_pmreplrootu.op_pmreplroot);
617 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
618 SV * const tmpsv = pm_description(pm);
619 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
623 Perl_dump_indent(aTHX_ level-1, file, "}\n");
626 const struct flag_to_name pmflags_flags_names[] = {
627 {PMf_CONST, ",CONST"},
629 {PMf_GLOBAL, ",GLOBAL"},
630 {PMf_CONTINUE, ",CONTINUE"},
631 {PMf_RETAINT, ",RETAINT"},
633 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
637 S_pm_description(pTHX_ const PMOP *pm)
639 SV * const desc = newSVpvs("");
640 const REGEXP * const regex = PM_GETRE(pm);
641 const U32 pmflags = pm->op_pmflags;
643 PERL_ARGS_ASSERT_PM_DESCRIPTION;
645 if (pmflags & PMf_ONCE)
646 sv_catpv(desc, ",ONCE");
648 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
649 sv_catpv(desc, ":USED");
651 if (pmflags & PMf_USED)
652 sv_catpv(desc, ":USED");
656 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
657 sv_catpv(desc, ",TAINTED");
658 if (RX_CHECK_SUBSTR(regex)) {
659 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
660 sv_catpv(desc, ",SCANFIRST");
661 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
662 sv_catpv(desc, ",ALL");
664 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
665 sv_catpv(desc, ",SKIPWHITE");
668 append_flags(desc, pmflags, pmflags_flags_names);
673 Perl_pmop_dump(pTHX_ PMOP *pm)
675 do_pmop_dump(0, Perl_debug_log, pm);
678 /* An op sequencer. We visit the ops in the order they're to execute. */
681 S_sequence(pTHX_ register const OP *o)
684 const OP *oldop = NULL;
697 for (; o; o = o->op_next) {
699 SV * const op = newSVuv(PTR2UV(o));
700 const char * const key = SvPV_const(op, len);
702 if (hv_exists(Sequence, key, len))
705 switch (o->op_type) {
707 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
708 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
717 if (oldop && o->op_next)
724 if (oldop && o->op_next)
726 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
739 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
740 sequence_tail(cLOGOPo->op_other);
745 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
746 sequence_tail(cLOOPo->op_redoop);
747 sequence_tail(cLOOPo->op_nextop);
748 sequence_tail(cLOOPo->op_lastop);
752 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
753 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
762 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
770 S_sequence_tail(pTHX_ const OP *o)
772 while (o && (o->op_type == OP_NULL))
778 S_sequence_num(pTHX_ const OP *o)
786 op = newSVuv(PTR2UV(o));
787 key = SvPV_const(op, len);
788 seq = hv_fetch(Sequence, key, len, 0);
789 return seq ? SvUV(*seq): 0;
792 const struct flag_to_name op_flags_names[] = {
794 {OPf_PARENS, ",PARENS"},
797 {OPf_STACKED, ",STACKED"},
798 {OPf_SPECIAL, ",SPECIAL"}
801 const struct flag_to_name op_trans_names[] = {
802 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
803 {OPpTRANS_TO_UTF, ",TO_UTF"},
804 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
805 {OPpTRANS_SQUASH, ",SQUASH"},
806 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
807 {OPpTRANS_GROWS, ",GROWS"},
808 {OPpTRANS_DELETE, ",DELETE"}
811 const struct flag_to_name op_entersub_names[] = {
812 {OPpENTERSUB_DB, ",DB"},
813 {OPpENTERSUB_HASTARG, ",HASTARG"},
814 {OPpENTERSUB_NOMOD, ",NOMOD"},
815 {OPpENTERSUB_AMPER, ",AMPER"},
816 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
817 {OPpENTERSUB_INARGS, ",INARGS"}
820 const struct flag_to_name op_const_names[] = {
821 {OPpCONST_NOVER, ",NOVER"},
822 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
823 {OPpCONST_STRICT, ",STRICT"},
824 {OPpCONST_ENTERED, ",ENTERED"},
825 {OPpCONST_ARYBASE, ",ARYBASE"},
826 {OPpCONST_BARE, ",BARE"},
827 {OPpCONST_WARNING, ",WARNING"}
830 const struct flag_to_name op_sort_names[] = {
831 {OPpSORT_NUMERIC, ",NUMERIC"},
832 {OPpSORT_INTEGER, ",INTEGER"},
833 {OPpSORT_REVERSE, ",REVERSE"},
834 {OPpSORT_INPLACE, ",INPLACE"},
835 {OPpSORT_DESCEND, ",DESCEND"},
836 {OPpSORT_QSORT, ",QSORT"},
837 {OPpSORT_STABLE, ",STABLE"}
840 const struct flag_to_name op_open_names[] = {
841 {OPpOPEN_IN_RAW, ",IN_RAW"},
842 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
843 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
844 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
847 const struct flag_to_name op_exit_names[] = {
848 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
849 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
852 #define OP_PRIVATE_ONCE(op, flag, name) \
853 const struct flag_to_name CAT2(op, _names)[] = { \
857 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
858 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
859 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
860 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
861 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
862 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
863 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
864 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
865 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
866 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
867 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
868 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
870 struct op_private_by_op {
873 const struct flag_to_name *start;
876 const struct op_private_by_op op_private_names[] = {
877 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
878 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
879 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
880 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
881 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
882 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
883 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
884 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
885 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
886 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
887 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
888 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
889 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
890 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
891 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
892 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
893 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
894 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
895 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
896 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
897 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
901 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
902 const struct op_private_by_op *start = op_private_names;
903 const struct op_private_by_op *const end
904 = op_private_names + C_ARRAY_LENGTH(op_private_names);
906 /* This is a linear search, but no worse than the code that it replaced.
907 It's debugging code - size is more important than speed. */
909 if (optype == start->op_type) {
910 S_append_flags(aTHX_ tmpsv, op_private, start->start,
911 start->start + start->len);
914 } while (++start < end);
919 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
923 const OPCODE optype = o->op_type;
925 PERL_ARGS_ASSERT_DO_OP_DUMP;
928 Perl_dump_indent(aTHX_ level, file, "{\n");
930 seq = sequence_num(o);
932 PerlIO_printf(file, "%-4"UVuf, seq);
934 PerlIO_printf(file, " ");
936 "%*sTYPE = %s ===> ",
937 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
939 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
940 sequence_num(o->op_next));
942 PerlIO_printf(file, "DONE\n");
944 if (optype == OP_NULL) {
945 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
946 if (o->op_targ == OP_NEXTSTATE) {
948 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
950 if (CopSTASHPV(cCOPo))
951 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
954 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
959 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
962 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
964 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
965 SV * const tmpsv = newSVpvs("");
966 switch (o->op_flags & OPf_WANT) {
968 sv_catpv(tmpsv, ",VOID");
970 case OPf_WANT_SCALAR:
971 sv_catpv(tmpsv, ",SCALAR");
974 sv_catpv(tmpsv, ",LIST");
977 sv_catpv(tmpsv, ",UNKNOWN");
980 append_flags(tmpsv, o->op_flags, op_flags_names);
982 sv_catpv(tmpsv, ",LATEFREE");
984 sv_catpv(tmpsv, ",LATEFREED");
986 sv_catpv(tmpsv, ",ATTACHED");
987 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
991 SV * const tmpsv = newSVpvs("");
992 if (PL_opargs[optype] & OA_TARGLEX) {
993 if (o->op_private & OPpTARGET_MY)
994 sv_catpv(tmpsv, ",TARGET_MY");
996 else if (optype == OP_ENTERSUB ||
997 optype == OP_RV2SV ||
999 optype == OP_RV2AV ||
1000 optype == OP_RV2HV ||
1001 optype == OP_RV2GV ||
1002 optype == OP_AELEM ||
1003 optype == OP_HELEM )
1005 if (optype == OP_ENTERSUB) {
1006 append_flags(tmpsv, o->op_private, op_entersub_names);
1009 switch (o->op_private & OPpDEREF) {
1011 sv_catpv(tmpsv, ",SV");
1014 sv_catpv(tmpsv, ",AV");
1017 sv_catpv(tmpsv, ",HV");
1020 if (o->op_private & OPpMAYBE_LVSUB)
1021 sv_catpv(tmpsv, ",MAYBE_LVSUB");
1024 if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
1025 && (o->op_private & OPpDEREFed))
1026 sv_catpv(tmpsv, ",DEREFed");
1028 if (optype == OP_AELEM || optype == OP_HELEM) {
1029 if (o->op_private & OPpLVAL_DEFER)
1030 sv_catpv(tmpsv, ",LVAL_DEFER");
1033 if (o->op_private & HINT_STRICT_REFS)
1034 sv_catpv(tmpsv, ",STRICT_REFS");
1035 if (o->op_private & OPpOUR_INTRO)
1036 sv_catpv(tmpsv, ",OUR_INTRO");
1039 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
1041 else if (PL_check[optype] != Perl_ck_ftst) {
1042 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1043 sv_catpv(tmpsv, ",FT_ACCESS");
1044 if (o->op_private & OPpFT_STACKED)
1045 sv_catpv(tmpsv, ",FT_STACKED");
1047 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1048 sv_catpv(tmpsv, ",INTRO");
1050 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1051 SvREFCNT_dec(tmpsv);
1055 if (PL_madskills && o->op_madprop) {
1056 SV * const tmpsv = newSVpvs("");
1057 MADPROP* mp = o->op_madprop;
1058 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1061 const char tmp = mp->mad_key;
1062 sv_setpvs(tmpsv,"'");
1064 sv_catpvn(tmpsv, &tmp, 1);
1065 sv_catpv(tmpsv, "'=");
1066 switch (mp->mad_type) {
1068 sv_catpv(tmpsv, "NULL");
1069 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1072 sv_catpv(tmpsv, "<");
1073 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1074 sv_catpv(tmpsv, ">");
1075 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1078 if ((OP*)mp->mad_val) {
1079 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1080 do_op_dump(level, file, (OP*)mp->mad_val);
1084 sv_catpv(tmpsv, "(UNK)");
1085 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1091 Perl_dump_indent(aTHX_ level, file, "}\n");
1093 SvREFCNT_dec(tmpsv);
1102 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1104 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1105 if (cSVOPo->op_sv) {
1106 SV * const tmpsv = newSV(0);
1110 /* FIXME - is this making unwarranted assumptions about the
1111 UTF-8 cleanliness of the dump file handle? */
1114 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1115 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1116 SvPV_nolen_const(tmpsv));
1120 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1126 case OP_METHOD_NAMED:
1127 #ifndef USE_ITHREADS
1128 /* with ITHREADS, consts are stored in the pad, and the right pad
1129 * may not be active here, so skip */
1130 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1136 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1137 (UV)CopLINE(cCOPo));
1138 if (CopSTASHPV(cCOPo))
1139 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1141 if (CopLABEL(cCOPo))
1142 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1146 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1147 if (cLOOPo->op_redoop)
1148 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1150 PerlIO_printf(file, "DONE\n");
1151 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1152 if (cLOOPo->op_nextop)
1153 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1155 PerlIO_printf(file, "DONE\n");
1156 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1157 if (cLOOPo->op_lastop)
1158 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1160 PerlIO_printf(file, "DONE\n");
1168 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1169 if (cLOGOPo->op_other)
1170 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1172 PerlIO_printf(file, "DONE\n");
1178 do_pmop_dump(level, file, cPMOPo);
1186 if (o->op_private & OPpREFCOUNTED)
1187 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1192 if (o->op_flags & OPf_KIDS) {
1194 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1195 do_op_dump(level, file, kid);
1197 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1201 Perl_op_dump(pTHX_ const OP *o)
1203 PERL_ARGS_ASSERT_OP_DUMP;
1204 do_op_dump(0, Perl_debug_log, o);
1208 Perl_gv_dump(pTHX_ GV *gv)
1212 PERL_ARGS_ASSERT_GV_DUMP;
1215 PerlIO_printf(Perl_debug_log, "{}\n");
1218 sv = sv_newmortal();
1219 PerlIO_printf(Perl_debug_log, "{\n");
1220 gv_fullname3(sv, gv, NULL);
1221 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1222 if (gv != GvEGV(gv)) {
1223 gv_efullname3(sv, GvEGV(gv), NULL);
1224 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1226 PerlIO_putc(Perl_debug_log, '\n');
1227 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1231 /* map magic types to the symbolic names
1232 * (with the PERL_MAGIC_ prefixed stripped)
1235 static const struct { const char type; const char *name; } magic_names[] = {
1236 { PERL_MAGIC_sv, "sv(\\0)" },
1237 { PERL_MAGIC_arylen, "arylen(#)" },
1238 { PERL_MAGIC_rhash, "rhash(%)" },
1239 { PERL_MAGIC_pos, "pos(.)" },
1240 { PERL_MAGIC_symtab, "symtab(:)" },
1241 { PERL_MAGIC_backref, "backref(<)" },
1242 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1243 { PERL_MAGIC_overload, "overload(A)" },
1244 { PERL_MAGIC_bm, "bm(B)" },
1245 { PERL_MAGIC_regdata, "regdata(D)" },
1246 { PERL_MAGIC_env, "env(E)" },
1247 { PERL_MAGIC_hints, "hints(H)" },
1248 { PERL_MAGIC_isa, "isa(I)" },
1249 { PERL_MAGIC_dbfile, "dbfile(L)" },
1250 { PERL_MAGIC_shared, "shared(N)" },
1251 { PERL_MAGIC_tied, "tied(P)" },
1252 { PERL_MAGIC_sig, "sig(S)" },
1253 { PERL_MAGIC_uvar, "uvar(U)" },
1254 { PERL_MAGIC_checkcall, "checkcall(])" },
1255 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1256 { PERL_MAGIC_overload_table, "overload_table(c)" },
1257 { PERL_MAGIC_regdatum, "regdatum(d)" },
1258 { PERL_MAGIC_envelem, "envelem(e)" },
1259 { PERL_MAGIC_fm, "fm(f)" },
1260 { PERL_MAGIC_regex_global, "regex_global(g)" },
1261 { PERL_MAGIC_hintselem, "hintselem(h)" },
1262 { PERL_MAGIC_isaelem, "isaelem(i)" },
1263 { PERL_MAGIC_nkeys, "nkeys(k)" },
1264 { PERL_MAGIC_dbline, "dbline(l)" },
1265 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1266 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1267 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1268 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1269 { PERL_MAGIC_qr, "qr(r)" },
1270 { PERL_MAGIC_sigelem, "sigelem(s)" },
1271 { PERL_MAGIC_taint, "taint(t)" },
1272 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1273 { PERL_MAGIC_vec, "vec(v)" },
1274 { PERL_MAGIC_vstring, "vstring(V)" },
1275 { PERL_MAGIC_utf8, "utf8(w)" },
1276 { PERL_MAGIC_substr, "substr(x)" },
1277 { PERL_MAGIC_defelem, "defelem(y)" },
1278 { PERL_MAGIC_ext, "ext(~)" },
1279 /* this null string terminates the list */
1284 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1286 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1288 for (; mg; mg = mg->mg_moremagic) {
1289 Perl_dump_indent(aTHX_ level, file,
1290 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1291 if (mg->mg_virtual) {
1292 const MGVTBL * const v = mg->mg_virtual;
1294 if (v == &PL_vtbl_sv) s = "sv";
1295 else if (v == &PL_vtbl_env) s = "env";
1296 else if (v == &PL_vtbl_envelem) s = "envelem";
1297 else if (v == &PL_vtbl_sig) s = "sig";
1298 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1299 else if (v == &PL_vtbl_pack) s = "pack";
1300 else if (v == &PL_vtbl_packelem) s = "packelem";
1301 else if (v == &PL_vtbl_dbline) s = "dbline";
1302 else if (v == &PL_vtbl_isa) s = "isa";
1303 else if (v == &PL_vtbl_arylen) s = "arylen";
1304 else if (v == &PL_vtbl_mglob) s = "mglob";
1305 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1306 else if (v == &PL_vtbl_taint) s = "taint";
1307 else if (v == &PL_vtbl_substr) s = "substr";
1308 else if (v == &PL_vtbl_vec) s = "vec";
1309 else if (v == &PL_vtbl_pos) s = "pos";
1310 else if (v == &PL_vtbl_bm) s = "bm";
1311 else if (v == &PL_vtbl_fm) s = "fm";
1312 else if (v == &PL_vtbl_uvar) s = "uvar";
1313 else if (v == &PL_vtbl_defelem) s = "defelem";
1314 #ifdef USE_LOCALE_COLLATE
1315 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1317 else if (v == &PL_vtbl_amagic) s = "amagic";
1318 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1319 else if (v == &PL_vtbl_backref) s = "backref";
1320 else if (v == &PL_vtbl_utf8) s = "utf8";
1321 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1322 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1323 else if (v == &PL_vtbl_hints) s = "hints";
1326 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1328 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1331 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1334 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1338 const char *name = NULL;
1339 for (n = 0; magic_names[n].name; n++) {
1340 if (mg->mg_type == magic_names[n].type) {
1341 name = magic_names[n].name;
1346 Perl_dump_indent(aTHX_ level, file,
1347 " MG_TYPE = PERL_MAGIC_%s\n", name);
1349 Perl_dump_indent(aTHX_ level, file,
1350 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1354 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1355 if (mg->mg_type == PERL_MAGIC_envelem &&
1356 mg->mg_flags & MGf_TAINTEDDIR)
1357 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1358 if (mg->mg_type == PERL_MAGIC_regex_global &&
1359 mg->mg_flags & MGf_MINMATCH)
1360 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1361 if (mg->mg_flags & MGf_REFCOUNTED)
1362 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1363 if (mg->mg_flags & MGf_GSKIP)
1364 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1365 if (mg->mg_flags & MGf_COPY)
1366 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1367 if (mg->mg_flags & MGf_DUP)
1368 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1369 if (mg->mg_flags & MGf_LOCAL)
1370 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1373 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1374 PTR2UV(mg->mg_obj));
1375 if (mg->mg_type == PERL_MAGIC_qr) {
1376 REGEXP* const re = (REGEXP *)mg->mg_obj;
1377 SV * const dsv = sv_newmortal();
1378 const char * const s
1379 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1381 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1382 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1384 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1385 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1388 if (mg->mg_flags & MGf_REFCOUNTED)
1389 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1392 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1394 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1395 if (mg->mg_len >= 0) {
1396 if (mg->mg_type != PERL_MAGIC_utf8) {
1397 SV * const sv = newSVpvs("");
1398 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1402 else if (mg->mg_len == HEf_SVKEY) {
1403 PerlIO_puts(file, " => HEf_SVKEY\n");
1404 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1405 maxnest, dumpops, pvlim); /* MG is already +1 */
1408 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1413 " does not know how to handle this MG_LEN"
1415 PerlIO_putc(file, '\n');
1417 if (mg->mg_type == PERL_MAGIC_utf8) {
1418 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1421 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1422 Perl_dump_indent(aTHX_ level, file,
1423 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1426 (UV)cache[i * 2 + 1]);
1433 Perl_magic_dump(pTHX_ const MAGIC *mg)
1435 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1439 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1443 PERL_ARGS_ASSERT_DO_HV_DUMP;
1445 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1446 if (sv && (hvname = HvNAME_get(sv)))
1448 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1449 name which quite legally could contain insane things like tabs, newlines, nulls or
1450 other scary crap - this should produce sane results - except maybe for unicode package
1451 names - but we will wait for someone to file a bug on that - demerphq */
1452 SV * const tmpsv = newSVpvs("");
1453 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1456 PerlIO_putc(file, '\n');
1460 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1462 PERL_ARGS_ASSERT_DO_GV_DUMP;
1464 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1465 if (sv && GvNAME(sv))
1466 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1468 PerlIO_putc(file, '\n');
1472 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1474 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1476 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1477 if (sv && GvNAME(sv)) {
1479 PerlIO_printf(file, "\t\"");
1480 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1481 PerlIO_printf(file, "%s\" :: \"", hvname);
1482 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1485 PerlIO_putc(file, '\n');
1488 const struct flag_to_name first_sv_flags_names[] = {
1489 {SVs_TEMP, "TEMP,"},
1490 {SVs_OBJECT, "OBJECT,"},
1499 const struct flag_to_name second_sv_flags_names[] = {
1501 {SVf_FAKE, "FAKE,"},
1502 {SVf_READONLY, "READONLY,"},
1503 {SVf_BREAK, "BREAK,"},
1504 {SVf_AMAGIC, "OVERLOAD,"},
1510 const struct flag_to_name cv_flags_names[] = {
1511 {CVf_ANON, "ANON,"},
1512 {CVf_UNIQUE, "UNIQUE,"},
1513 {CVf_CLONE, "CLONE,"},
1514 {CVf_CLONED, "CLONED,"},
1515 {CVf_CONST, "CONST,"},
1516 {CVf_NODEBUG, "NODEBUG,"},
1517 {CVf_LVALUE, "LVALUE,"},
1518 {CVf_METHOD, "METHOD,"},
1519 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1520 {CVf_CVGV_RC, "CVGV_RC,"},
1521 {CVf_ISXSUB, "ISXSUB,"}
1524 const struct flag_to_name hv_flags_names[] = {
1525 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1526 {SVphv_LAZYDEL, "LAZYDEL,"},
1527 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1528 {SVphv_REHASH, "REHASH,"},
1529 {SVphv_CLONEABLE, "CLONEABLE,"}
1532 const struct flag_to_name gp_flags_names[] = {
1533 {GVf_INTRO, "INTRO,"},
1534 {GVf_MULTI, "MULTI,"},
1535 {GVf_ASSUMECV, "ASSUMECV,"},
1536 {GVf_IN_PAD, "IN_PAD,"}
1539 const struct flag_to_name gp_flags_imported_names[] = {
1540 {GVf_IMPORTED_SV, " SV"},
1541 {GVf_IMPORTED_AV, " AV"},
1542 {GVf_IMPORTED_HV, " HV"},
1543 {GVf_IMPORTED_CV, " CV"},
1546 const struct flag_to_name regexp_flags_names[] = {
1547 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1548 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1549 {RXf_PMf_FOLD, "PMf_FOLD,"},
1550 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1551 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1552 {RXf_ANCH_BOL, "ANCH_BOL,"},
1553 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1554 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1555 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1556 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1557 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1558 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1559 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1560 {RXf_CANY_SEEN, "CANY_SEEN,"},
1561 {RXf_NOSCAN, "NOSCAN,"},
1562 {RXf_CHECK_ALL, "CHECK_ALL,"},
1563 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1564 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1565 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1566 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1567 {RXf_SPLIT, "SPLIT,"},
1568 {RXf_COPY_DONE, "COPY_DONE,"},
1569 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1570 {RXf_TAINTED, "TAINTED,"},
1571 {RXf_START_ONLY, "START_ONLY,"},
1572 {RXf_SKIPWHITE, "SKIPWHITE,"},
1573 {RXf_WHITE, "WHITE,"},
1574 {RXf_NULL, "NULL,"},
1578 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1586 PERL_ARGS_ASSERT_DO_SV_DUMP;
1589 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1593 flags = SvFLAGS(sv);
1596 /* process general SV flags */
1598 d = Perl_newSVpvf(aTHX_
1599 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1600 PTR2UV(SvANY(sv)), PTR2UV(sv),
1601 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1602 (int)(PL_dumpindent*level), "");
1604 if (!((flags & SVpad_NAME) == SVpad_NAME
1605 && (type == SVt_PVMG || type == SVt_PVNV))) {
1606 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1608 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1609 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1610 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1612 append_flags(d, flags, first_sv_flags_names);
1613 if (flags & SVf_ROK) {
1614 sv_catpv(d, "ROK,");
1615 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1617 append_flags(d, flags, second_sv_flags_names);
1618 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1619 if (SvPCS_IMPORTED(sv))
1620 sv_catpv(d, "PCS_IMPORTED,");
1622 sv_catpv(d, "SCREAM,");
1625 /* process type-specific SV flags */
1630 append_flags(d, CvFLAGS(sv), cv_flags_names);
1633 append_flags(d, flags, hv_flags_names);
1637 if (isGV_with_GP(sv)) {
1638 append_flags(d, GvFLAGS(sv), gp_flags_names);
1640 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1641 sv_catpv(d, "IMPORT");
1642 if (GvIMPORTED(sv) == GVf_IMPORTED)
1643 sv_catpv(d, "ALL,");
1646 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1650 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1651 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1655 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1656 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1659 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1660 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1663 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1668 /* SVphv_SHAREKEYS is also 0x20000000 */
1669 if ((type != SVt_PVHV) && SvUTF8(sv))
1670 sv_catpv(d, "UTF8");
1672 if (*(SvEND(d) - 1) == ',') {
1673 SvCUR_set(d, SvCUR(d) - 1);
1674 SvPVX(d)[SvCUR(d)] = '\0';
1679 /* dump initial SV details */
1681 #ifdef DEBUG_LEAKING_SCALARS
1682 Perl_dump_indent(aTHX_ level, file,
1683 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1684 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1686 sv->sv_debug_inpad ? "for" : "by",
1687 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1688 PTR2UV(sv->sv_debug_parent),
1692 Perl_dump_indent(aTHX_ level, file, "SV = ");
1696 if (type < SVt_LAST) {
1697 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1699 if (type == SVt_NULL) {
1704 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1709 /* Dump general SV fields */
1711 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1712 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1713 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1714 || (type == SVt_IV && !SvROK(sv))) {
1716 #ifdef PERL_OLD_COPY_ON_WRITE
1720 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1722 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1723 #ifdef PERL_OLD_COPY_ON_WRITE
1724 if (SvIsCOW_shared_hash(sv))
1725 PerlIO_printf(file, " (HASH)");
1726 else if (SvIsCOW_normal(sv))
1727 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1729 PerlIO_putc(file, '\n');
1732 if ((type == SVt_PVNV || type == SVt_PVMG)
1733 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1734 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1735 (UV) COP_SEQ_RANGE_LOW(sv));
1736 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1737 (UV) COP_SEQ_RANGE_HIGH(sv));
1738 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1739 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1740 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1741 || type == SVt_NV) {
1742 STORE_NUMERIC_LOCAL_SET_STANDARD();
1743 /* %Vg doesn't work? --jhi */
1744 #ifdef USE_LONG_DOUBLE
1745 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1747 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1749 RESTORE_NUMERIC_LOCAL();
1753 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1755 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1758 if (type < SVt_PV) {
1763 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1764 if (SvPVX_const(sv)) {
1767 SvOOK_offset(sv, delta);
1768 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1773 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1775 PerlIO_printf(file, "( %s . ) ",
1776 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1779 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1780 if (SvUTF8(sv)) /* the 6? \x{....} */
1781 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1782 PerlIO_printf(file, "\n");
1783 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1784 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1787 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1790 if (type >= SVt_PVMG) {
1791 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1792 HV * const ost = SvOURSTASH(sv);
1794 do_hv_dump(level, file, " OURSTASH", ost);
1797 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1800 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1803 /* Dump type-specific SV fields */
1807 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1808 if (AvARRAY(sv) != AvALLOC(sv)) {
1809 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1810 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1813 PerlIO_putc(file, '\n');
1814 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1815 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1816 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1818 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1819 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1820 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1821 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1822 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1824 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1825 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1827 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1829 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1834 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1835 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1836 /* Show distribution of HEs in the ARRAY */
1838 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1841 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1842 NV theoret, sum = 0;
1844 PerlIO_printf(file, " (");
1845 Zero(freq, FREQ_MAX + 1, int);
1846 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1849 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1851 if (count > FREQ_MAX)
1857 for (i = 0; i <= max; i++) {
1859 PerlIO_printf(file, "%d%s:%d", i,
1860 (i == FREQ_MAX) ? "+" : "",
1863 PerlIO_printf(file, ", ");
1866 PerlIO_putc(file, ')');
1867 /* The "quality" of a hash is defined as the total number of
1868 comparisons needed to access every element once, relative
1869 to the expected number needed for a random hash.
1871 The total number of comparisons is equal to the sum of
1872 the squares of the number of entries in each bucket.
1873 For a random hash of n keys into k buckets, the expected
1878 for (i = max; i > 0; i--) { /* Precision: count down. */
1879 sum += freq[i] * i * i;
1881 while ((keys = keys >> 1))
1883 theoret = HvUSEDKEYS(sv);
1884 theoret += theoret * (theoret-1)/pow2;
1885 PerlIO_putc(file, '\n');
1886 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1888 PerlIO_putc(file, '\n');
1889 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1890 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1891 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1892 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1893 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1895 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1896 if (mg && mg->mg_obj) {
1897 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1901 const char * const hvname = HvNAME_get(sv);
1903 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1907 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1908 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1909 if (HvAUX(sv)->xhv_name_count)
1910 Perl_dump_indent(aTHX_
1911 level, file, " NAMECOUNT = %"IVdf"\n",
1912 (IV)HvAUX(sv)->xhv_name_count
1914 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1915 const I32 count = HvAUX(sv)->xhv_name_count;
1917 SV * const names = newSVpvs_flags("", SVs_TEMP);
1918 /* The starting point is the first element if count is
1919 positive and the second element if count is negative. */
1920 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1921 + (count < 0 ? 1 : 0);
1922 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1923 + (count < 0 ? -count : count);
1924 while (hekp < endp) {
1926 sv_catpvs(names, ", \"");
1927 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1928 sv_catpvs(names, "\"");
1930 /* This should never happen. */
1931 sv_catpvs(names, ", (null)");
1935 Perl_dump_indent(aTHX_
1936 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1940 Perl_dump_indent(aTHX_
1941 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1945 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1947 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1951 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1952 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1953 (int)meta->mro_which->length,
1954 meta->mro_which->name,
1955 PTR2UV(meta->mro_which));
1956 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1957 (UV)meta->cache_gen);
1958 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1960 if (meta->mro_linear_all) {
1961 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1962 PTR2UV(meta->mro_linear_all));
1963 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1966 if (meta->mro_linear_current) {
1967 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1968 PTR2UV(meta->mro_linear_current));
1969 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1972 if (meta->mro_nextmethod) {
1973 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1974 PTR2UV(meta->mro_nextmethod));
1975 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1979 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1981 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1986 if (nest < maxnest) {
1987 if (HvEITER_get(sv)) /* preserve iterator */
1988 Perl_dump_indent(aTHX_ level, file,
1989 " (*** Active iterator; skipping element dump ***)\n");
1992 HV * const hv = MUTABLE_HV(sv);
1993 int count = maxnest - nest;
1996 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1999 const U32 hash = HeHASH(he);
2000 SV * const keysv = hv_iterkeysv(he);
2001 const char * const keypv = SvPV_const(keysv, len);
2002 SV * const elt = hv_iterval(hv, he);
2004 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2006 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2008 PerlIO_printf(file, "[REHASH] ");
2009 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
2010 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2012 hv_iterinit(hv); /* Return to status quo */
2020 const char *const proto = SvPV_const(sv, len);
2021 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
2026 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
2027 if (!CvISXSUB(sv)) {
2029 Perl_dump_indent(aTHX_ level, file,
2030 " START = 0x%"UVxf" ===> %"IVdf"\n",
2031 PTR2UV(CvSTART(sv)),
2032 (IV)sequence_num(CvSTART(sv)));
2034 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
2035 PTR2UV(CvROOT(sv)));
2036 if (CvROOT(sv) && dumpops) {
2037 do_op_dump(level+1, file, CvROOT(sv));
2040 SV * const constant = cv_const_sv((const CV *)sv);
2042 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2045 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2047 PTR2UV(CvXSUBANY(sv).any_ptr));
2048 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2051 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2052 (IV)CvXSUBANY(sv).any_i32);
2055 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2056 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2057 if (type == SVt_PVCV)
2058 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2059 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2060 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2061 if (type == SVt_PVFM)
2062 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
2063 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2064 if (nest < maxnest) {
2065 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2068 const CV * const outside = CvOUTSIDE(sv);
2069 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2072 : CvANON(outside) ? "ANON"
2073 : (outside == PL_main_cv) ? "MAIN"
2074 : CvUNIQUE(outside) ? "UNIQUE"
2075 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2077 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2078 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2083 if (type == SVt_PVLV) {
2084 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2085 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2086 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2087 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2088 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2089 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2093 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
2094 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
2095 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
2096 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
2098 if (!isGV_with_GP(sv))
2100 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2101 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2102 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2103 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2106 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2107 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2108 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2109 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2110 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2111 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2112 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2113 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2114 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2115 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2116 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2117 do_gv_dump (level, file, " EGV", GvEGV(sv));
2120 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2121 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2122 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2123 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2124 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2125 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2126 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2128 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2129 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2130 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2132 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2133 PTR2UV(IoTOP_GV(sv)));
2134 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2135 maxnest, dumpops, pvlim);
2137 /* Source filters hide things that are not GVs in these three, so let's
2138 be careful out there. */
2140 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2141 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2142 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2144 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2145 PTR2UV(IoFMT_GV(sv)));
2146 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2147 maxnest, dumpops, pvlim);
2149 if (IoBOTTOM_NAME(sv))
2150 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2151 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2152 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2154 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2155 PTR2UV(IoBOTTOM_GV(sv)));
2156 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2157 maxnest, dumpops, pvlim);
2159 if (isPRINT(IoTYPE(sv)))
2160 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2162 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2163 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2167 struct regexp * const r = (struct regexp *)SvANY(sv);
2168 flags = RX_EXTFLAGS((REGEXP*)sv);
2170 append_flags(d, flags, regexp_flags_names);
2171 if (*(SvEND(d) - 1) == ',') {
2172 SvCUR_set(d, SvCUR(d) - 1);
2173 SvPVX(d)[SvCUR(d)] = '\0';
2175 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2176 (UV)flags, SvPVX_const(d));
2177 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2179 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2181 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2182 (UV)(r->lastparen));
2183 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2184 (UV)(r->lastcloseparen));
2185 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2187 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2188 (IV)(r->minlenret));
2189 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2191 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2192 (UV)(r->pre_prefix));
2193 Perl_dump_indent(aTHX_ level, file, " SEEN_EVALS = %"UVuf"\n",
2194 (UV)(r->seen_evals));
2195 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2198 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2200 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2202 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2203 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2205 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2206 PTR2UV(r->mother_re));
2207 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2208 PTR2UV(r->paren_names));
2209 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2210 PTR2UV(r->substrs));
2211 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2212 PTR2UV(r->pprivate));
2213 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2215 #ifdef PERL_OLD_COPY_ON_WRITE
2216 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2217 PTR2UV(r->saved_copy));
2226 Perl_sv_dump(pTHX_ SV *sv)
2230 PERL_ARGS_ASSERT_SV_DUMP;
2233 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2235 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2239 Perl_runops_debug(pTHX)
2243 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2247 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2250 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2251 PerlIO_printf(Perl_debug_log,
2252 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2253 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2254 PTR2UV(*PL_watchaddr));
2255 if (DEBUG_s_TEST_) {
2256 if (DEBUG_v_TEST_) {
2257 PerlIO_printf(Perl_debug_log, "\n");
2265 if (DEBUG_t_TEST_) debop(PL_op);
2266 if (DEBUG_P_TEST_) debprof(PL_op);
2268 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2269 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2276 Perl_debop(pTHX_ const OP *o)
2280 PERL_ARGS_ASSERT_DEBOP;
2282 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2285 Perl_deb(aTHX_ "%s", OP_NAME(o));
2286 switch (o->op_type) {
2289 /* With ITHREADS, consts are stored in the pad, and the right pad
2290 * may not be active here, so check.
2291 * Looks like only during compiling the pads are illegal.
2294 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2296 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2301 SV * const sv = newSV(0);
2303 /* FIXME - is this making unwarranted assumptions about the
2304 UTF-8 cleanliness of the dump file handle? */
2307 gv_fullname3(sv, cGVOPo_gv, NULL);
2308 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2312 PerlIO_printf(Perl_debug_log, "(NULL)");
2318 /* print the lexical's name */
2319 CV * const cv = deb_curcv(cxstack_ix);
2322 AV * const padlist = CvPADLIST(cv);
2323 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2324 sv = *av_fetch(comppad, o->op_targ, FALSE);
2328 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2330 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2336 PerlIO_printf(Perl_debug_log, "\n");
2341 S_deb_curcv(pTHX_ const I32 ix)
2344 const PERL_CONTEXT * const cx = &cxstack[ix];
2345 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2346 return cx->blk_sub.cv;
2347 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2349 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2354 return deb_curcv(ix - 1);
2358 Perl_watch(pTHX_ char **addr)
2362 PERL_ARGS_ASSERT_WATCH;
2364 PL_watchaddr = addr;
2366 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2367 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2371 S_debprof(pTHX_ const OP *o)
2375 PERL_ARGS_ASSERT_DEBPROF;
2377 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2379 if (!PL_profiledata)
2380 Newxz(PL_profiledata, MAXO, U32);
2381 ++PL_profiledata[o->op_type];
2385 Perl_debprofdump(pTHX)
2389 if (!PL_profiledata)
2391 for (i = 0; i < MAXO; i++) {
2392 if (PL_profiledata[i])
2393 PerlIO_printf(Perl_debug_log,
2394 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2401 * XML variants of most of the above routines
2405 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2409 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2411 PerlIO_printf(file, "\n ");
2412 va_start(args, pat);
2413 xmldump_vindent(level, file, pat, &args);
2419 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2422 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2423 va_start(args, pat);
2424 xmldump_vindent(level, file, pat, &args);
2429 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2431 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2433 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2434 PerlIO_vprintf(file, pat, *args);
2438 Perl_xmldump_all(pTHX)
2440 xmldump_all_perl(FALSE);
2444 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2446 PerlIO_setlinebuf(PL_xmlfp);
2448 op_xmldump(PL_main_root);
2449 /* someday we might call this, when it outputs XML: */
2450 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2451 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2452 PerlIO_close(PL_xmlfp);
2457 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2459 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2460 xmldump_packsubs_perl(stash, FALSE);
2464 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2469 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2471 if (!HvARRAY(stash))
2473 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2474 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2475 GV *gv = MUTABLE_GV(HeVAL(entry));
2477 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2480 xmldump_sub_perl(gv, justperl);
2483 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2484 && (hv = GvHV(gv)) && hv != PL_defstash)
2485 xmldump_packsubs_perl(hv, justperl); /* nested package */
2491 Perl_xmldump_sub(pTHX_ const GV *gv)
2493 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2494 xmldump_sub_perl(gv, FALSE);
2498 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2502 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2504 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2507 sv = sv_newmortal();
2508 gv_fullname3(sv, gv, NULL);
2509 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2510 if (CvXSUB(GvCV(gv)))
2511 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2512 PTR2UV(CvXSUB(GvCV(gv))),
2513 (int)CvXSUBANY(GvCV(gv)).any_i32);
2514 else if (CvROOT(GvCV(gv)))
2515 op_xmldump(CvROOT(GvCV(gv)));
2517 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2521 Perl_xmldump_form(pTHX_ const GV *gv)
2523 SV * const sv = sv_newmortal();
2525 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2527 gv_fullname3(sv, gv, NULL);
2528 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2529 if (CvROOT(GvFORM(gv)))
2530 op_xmldump(CvROOT(GvFORM(gv)));
2532 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2536 Perl_xmldump_eval(pTHX)
2538 op_xmldump(PL_eval_root);
2542 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2544 PERL_ARGS_ASSERT_SV_CATXMLSV;
2545 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2549 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2551 PERL_ARGS_ASSERT_SV_CATXMLPV;
2552 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2556 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2559 const char * const e = pv + len;
2560 const char * const start = pv;
2564 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2567 dsvcur = SvCUR(dsv); /* in case we have to restart */
2572 c = utf8_to_uvchr((U8*)pv, &cl);
2574 SvCUR(dsv) = dsvcur;
2639 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2642 sv_catpvs(dsv, "<");
2645 sv_catpvs(dsv, ">");
2648 sv_catpvs(dsv, "&");
2651 sv_catpvs(dsv, """);
2655 if (c < 32 || c > 127) {
2656 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2659 const char string = (char) c;
2660 sv_catpvn(dsv, &string, 1);
2664 if ((c >= 0xD800 && c <= 0xDB7F) ||
2665 (c >= 0xDC00 && c <= 0xDFFF) ||
2666 (c >= 0xFFF0 && c <= 0xFFFF) ||
2668 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2670 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2683 Perl_sv_xmlpeek(pTHX_ SV *sv)
2685 SV * const t = sv_newmortal();
2689 PERL_ARGS_ASSERT_SV_XMLPEEK;
2695 sv_catpv(t, "VOID=\"\"");
2698 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2699 sv_catpv(t, "WILD=\"\"");
2702 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2703 if (sv == &PL_sv_undef) {
2704 sv_catpv(t, "SV_UNDEF=\"1\"");
2705 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2706 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2710 else if (sv == &PL_sv_no) {
2711 sv_catpv(t, "SV_NO=\"1\"");
2712 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2713 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2714 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2715 SVp_POK|SVp_NOK)) &&
2720 else if (sv == &PL_sv_yes) {
2721 sv_catpv(t, "SV_YES=\"1\"");
2722 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2723 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2724 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2725 SVp_POK|SVp_NOK)) &&
2727 SvPVX(sv) && *SvPVX(sv) == '1' &&
2732 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2733 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2734 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2738 sv_catpv(t, " XXX=\"\" ");
2740 else if (SvREFCNT(sv) == 0) {
2741 sv_catpv(t, " refcnt=\"0\"");
2744 else if (DEBUG_R_TEST_) {
2747 /* is this SV on the tmps stack? */
2748 for (ix=PL_tmps_ix; ix>=0; ix--) {
2749 if (PL_tmps_stack[ix] == sv) {
2754 if (SvREFCNT(sv) > 1)
2755 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2758 sv_catpv(t, " DRT=\"<T>\"");
2762 sv_catpv(t, " ROK=\"\"");
2764 switch (SvTYPE(sv)) {
2766 sv_catpv(t, " FREED=\"1\"");
2770 sv_catpv(t, " UNDEF=\"1\"");
2773 sv_catpv(t, " IV=\"");
2776 sv_catpv(t, " NV=\"");
2779 sv_catpv(t, " PV=\"");
2782 sv_catpv(t, " PVIV=\"");
2785 sv_catpv(t, " PVNV=\"");
2788 sv_catpv(t, " PVMG=\"");
2791 sv_catpv(t, " PVLV=\"");
2794 sv_catpv(t, " AV=\"");
2797 sv_catpv(t, " HV=\"");
2801 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2803 sv_catpv(t, " CV=\"()\"");
2806 sv_catpv(t, " GV=\"");
2809 sv_catpv(t, " BIND=\"");
2812 sv_catpv(t, " REGEXP=\"");
2815 sv_catpv(t, " FM=\"");
2818 sv_catpv(t, " IO=\"");
2827 else if (SvNOKp(sv)) {
2828 STORE_NUMERIC_LOCAL_SET_STANDARD();
2829 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2830 RESTORE_NUMERIC_LOCAL();
2832 else if (SvIOKp(sv)) {
2834 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2836 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2845 return SvPV(t, n_a);
2849 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2851 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2854 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2857 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2860 REGEXP *const r = PM_GETRE(pm);
2861 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2862 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2863 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2865 SvREFCNT_dec(tmpsv);
2866 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2867 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2870 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2871 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2872 SV * const tmpsv = pm_description(pm);
2873 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2874 SvREFCNT_dec(tmpsv);
2878 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2879 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2880 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2881 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2882 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2883 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2886 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2890 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2892 do_pmop_xmldump(0, PL_xmlfp, pm);
2896 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2901 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2906 seq = sequence_num(o);
2907 Perl_xmldump_indent(aTHX_ level, file,
2908 "<op_%s seq=\"%"UVuf" -> ",
2913 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2914 sequence_num(o->op_next));
2916 PerlIO_printf(file, "DONE\"");
2919 if (o->op_type == OP_NULL)
2921 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2922 if (o->op_targ == OP_NEXTSTATE)
2925 PerlIO_printf(file, " line=\"%"UVuf"\"",
2926 (UV)CopLINE(cCOPo));
2927 if (CopSTASHPV(cCOPo))
2928 PerlIO_printf(file, " package=\"%s\"",
2930 if (CopLABEL(cCOPo))
2931 PerlIO_printf(file, " label=\"%s\"",
2936 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2939 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2942 SV * const tmpsv = newSVpvs("");
2943 switch (o->op_flags & OPf_WANT) {
2945 sv_catpv(tmpsv, ",VOID");
2947 case OPf_WANT_SCALAR:
2948 sv_catpv(tmpsv, ",SCALAR");
2951 sv_catpv(tmpsv, ",LIST");
2954 sv_catpv(tmpsv, ",UNKNOWN");
2957 if (o->op_flags & OPf_KIDS)
2958 sv_catpv(tmpsv, ",KIDS");
2959 if (o->op_flags & OPf_PARENS)
2960 sv_catpv(tmpsv, ",PARENS");
2961 if (o->op_flags & OPf_STACKED)
2962 sv_catpv(tmpsv, ",STACKED");
2963 if (o->op_flags & OPf_REF)
2964 sv_catpv(tmpsv, ",REF");
2965 if (o->op_flags & OPf_MOD)
2966 sv_catpv(tmpsv, ",MOD");
2967 if (o->op_flags & OPf_SPECIAL)
2968 sv_catpv(tmpsv, ",SPECIAL");
2969 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2970 SvREFCNT_dec(tmpsv);
2972 if (o->op_private) {
2973 SV * const tmpsv = newSVpvs("");
2974 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2975 if (o->op_private & OPpTARGET_MY)
2976 sv_catpv(tmpsv, ",TARGET_MY");
2978 else if (o->op_type == OP_LEAVESUB ||
2979 o->op_type == OP_LEAVE ||
2980 o->op_type == OP_LEAVESUBLV ||
2981 o->op_type == OP_LEAVEWRITE) {
2982 if (o->op_private & OPpREFCOUNTED)
2983 sv_catpv(tmpsv, ",REFCOUNTED");
2985 else if (o->op_type == OP_AASSIGN) {
2986 if (o->op_private & OPpASSIGN_COMMON)
2987 sv_catpv(tmpsv, ",COMMON");
2989 else if (o->op_type == OP_SASSIGN) {
2990 if (o->op_private & OPpASSIGN_BACKWARDS)
2991 sv_catpv(tmpsv, ",BACKWARDS");
2993 else if (o->op_type == OP_TRANS) {
2994 if (o->op_private & OPpTRANS_SQUASH)
2995 sv_catpv(tmpsv, ",SQUASH");
2996 if (o->op_private & OPpTRANS_DELETE)
2997 sv_catpv(tmpsv, ",DELETE");
2998 if (o->op_private & OPpTRANS_COMPLEMENT)
2999 sv_catpv(tmpsv, ",COMPLEMENT");
3000 if (o->op_private & OPpTRANS_IDENTICAL)
3001 sv_catpv(tmpsv, ",IDENTICAL");
3002 if (o->op_private & OPpTRANS_GROWS)
3003 sv_catpv(tmpsv, ",GROWS");
3005 else if (o->op_type == OP_REPEAT) {
3006 if (o->op_private & OPpREPEAT_DOLIST)
3007 sv_catpv(tmpsv, ",DOLIST");
3009 else if (o->op_type == OP_ENTERSUB ||
3010 o->op_type == OP_RV2SV ||
3011 o->op_type == OP_GVSV ||
3012 o->op_type == OP_RV2AV ||
3013 o->op_type == OP_RV2HV ||
3014 o->op_type == OP_RV2GV ||
3015 o->op_type == OP_AELEM ||
3016 o->op_type == OP_HELEM )
3018 if (o->op_type == OP_ENTERSUB) {
3019 if (o->op_private & OPpENTERSUB_AMPER)
3020 sv_catpv(tmpsv, ",AMPER");
3021 if (o->op_private & OPpENTERSUB_DB)
3022 sv_catpv(tmpsv, ",DB");
3023 if (o->op_private & OPpENTERSUB_HASTARG)
3024 sv_catpv(tmpsv, ",HASTARG");
3025 if (o->op_private & OPpENTERSUB_NOPAREN)
3026 sv_catpv(tmpsv, ",NOPAREN");
3027 if (o->op_private & OPpENTERSUB_INARGS)
3028 sv_catpv(tmpsv, ",INARGS");
3029 if (o->op_private & OPpENTERSUB_NOMOD)
3030 sv_catpv(tmpsv, ",NOMOD");
3033 switch (o->op_private & OPpDEREF) {
3035 sv_catpv(tmpsv, ",SV");
3038 sv_catpv(tmpsv, ",AV");
3041 sv_catpv(tmpsv, ",HV");
3044 if (o->op_private & OPpMAYBE_LVSUB)
3045 sv_catpv(tmpsv, ",MAYBE_LVSUB");
3047 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
3048 if (o->op_private & OPpLVAL_DEFER)
3049 sv_catpv(tmpsv, ",LVAL_DEFER");
3052 if (o->op_private & HINT_STRICT_REFS)
3053 sv_catpv(tmpsv, ",STRICT_REFS");
3054 if (o->op_private & OPpOUR_INTRO)
3055 sv_catpv(tmpsv, ",OUR_INTRO");
3058 else if (o->op_type == OP_CONST) {
3059 if (o->op_private & OPpCONST_BARE)
3060 sv_catpv(tmpsv, ",BARE");
3061 if (o->op_private & OPpCONST_STRICT)
3062 sv_catpv(tmpsv, ",STRICT");
3063 if (o->op_private & OPpCONST_ARYBASE)
3064 sv_catpv(tmpsv, ",ARYBASE");
3065 if (o->op_private & OPpCONST_WARNING)
3066 sv_catpv(tmpsv, ",WARNING");
3067 if (o->op_private & OPpCONST_ENTERED)
3068 sv_catpv(tmpsv, ",ENTERED");
3070 else if (o->op_type == OP_FLIP) {
3071 if (o->op_private & OPpFLIP_LINENUM)
3072 sv_catpv(tmpsv, ",LINENUM");
3074 else if (o->op_type == OP_FLOP) {
3075 if (o->op_private & OPpFLIP_LINENUM)
3076 sv_catpv(tmpsv, ",LINENUM");
3078 else if (o->op_type == OP_RV2CV) {
3079 if (o->op_private & OPpLVAL_INTRO)
3080 sv_catpv(tmpsv, ",INTRO");
3082 else if (o->op_type == OP_GV) {
3083 if (o->op_private & OPpEARLY_CV)
3084 sv_catpv(tmpsv, ",EARLY_CV");
3086 else if (o->op_type == OP_LIST) {
3087 if (o->op_private & OPpLIST_GUESSED)
3088 sv_catpv(tmpsv, ",GUESSED");
3090 else if (o->op_type == OP_DELETE) {
3091 if (o->op_private & OPpSLICE)
3092 sv_catpv(tmpsv, ",SLICE");
3094 else if (o->op_type == OP_EXISTS) {
3095 if (o->op_private & OPpEXISTS_SUB)
3096 sv_catpv(tmpsv, ",EXISTS_SUB");
3098 else if (o->op_type == OP_SORT) {
3099 if (o->op_private & OPpSORT_NUMERIC)
3100 sv_catpv(tmpsv, ",NUMERIC");
3101 if (o->op_private & OPpSORT_INTEGER)
3102 sv_catpv(tmpsv, ",INTEGER");
3103 if (o->op_private & OPpSORT_REVERSE)
3104 sv_catpv(tmpsv, ",REVERSE");
3106 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
3107 if (o->op_private & OPpOPEN_IN_RAW)
3108 sv_catpv(tmpsv, ",IN_RAW");
3109 if (o->op_private & OPpOPEN_IN_CRLF)
3110 sv_catpv(tmpsv, ",IN_CRLF");
3111 if (o->op_private & OPpOPEN_OUT_RAW)
3112 sv_catpv(tmpsv, ",OUT_RAW");
3113 if (o->op_private & OPpOPEN_OUT_CRLF)
3114 sv_catpv(tmpsv, ",OUT_CRLF");
3116 else if (o->op_type == OP_EXIT) {
3117 if (o->op_private & OPpEXIT_VMSISH)
3118 sv_catpv(tmpsv, ",EXIT_VMSISH");
3119 if (o->op_private & OPpHUSH_VMSISH)
3120 sv_catpv(tmpsv, ",HUSH_VMSISH");
3122 else if (o->op_type == OP_DIE) {
3123 if (o->op_private & OPpHUSH_VMSISH)
3124 sv_catpv(tmpsv, ",HUSH_VMSISH");
3126 else if (PL_check[o->op_type] != Perl_ck_ftst) {
3127 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
3128 sv_catpv(tmpsv, ",FT_ACCESS");
3129 if (o->op_private & OPpFT_STACKED)
3130 sv_catpv(tmpsv, ",FT_STACKED");
3132 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
3133 sv_catpv(tmpsv, ",INTRO");
3135 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
3136 SvREFCNT_dec(tmpsv);
3139 switch (o->op_type) {
3141 if (o->op_flags & OPf_SPECIAL) {
3147 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3149 if (cSVOPo->op_sv) {
3150 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3151 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3157 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3158 s = SvPV(tmpsv1,len);
3159 sv_catxmlpvn(tmpsv2, s, len, 1);
3160 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3164 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3169 case OP_METHOD_NAMED:
3170 #ifndef USE_ITHREADS
3171 /* with ITHREADS, consts are stored in the pad, and the right pad
3172 * may not be active here, so skip */
3173 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3179 PerlIO_printf(file, ">\n");
3181 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3186 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3187 (UV)CopLINE(cCOPo));
3188 if (CopSTASHPV(cCOPo))
3189 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3191 if (CopLABEL(cCOPo))
3192 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3196 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3197 if (cLOOPo->op_redoop)
3198 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3200 PerlIO_printf(file, "DONE\"");
3201 S_xmldump_attr(aTHX_ level, file, "next=\"");
3202 if (cLOOPo->op_nextop)
3203 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3205 PerlIO_printf(file, "DONE\"");
3206 S_xmldump_attr(aTHX_ level, file, "last=\"");
3207 if (cLOOPo->op_lastop)
3208 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3210 PerlIO_printf(file, "DONE\"");
3218 S_xmldump_attr(aTHX_ level, file, "other=\"");
3219 if (cLOGOPo->op_other)
3220 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3222 PerlIO_printf(file, "DONE\"");
3230 if (o->op_private & OPpREFCOUNTED)
3231 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3237 if (PL_madskills && o->op_madprop) {
3238 char prevkey = '\0';
3239 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3240 const MADPROP* mp = o->op_madprop;
3244 PerlIO_printf(file, ">\n");
3246 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3249 char tmp = mp->mad_key;
3250 sv_setpvs(tmpsv,"\"");
3252 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3253 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3254 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3257 sv_catpv(tmpsv, "\"");
3258 switch (mp->mad_type) {
3260 sv_catpv(tmpsv, "NULL");
3261 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3264 sv_catpv(tmpsv, " val=\"");
3265 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3266 sv_catpv(tmpsv, "\"");
3267 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3270 sv_catpv(tmpsv, " val=\"");
3271 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3272 sv_catpv(tmpsv, "\"");
3273 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3276 if ((OP*)mp->mad_val) {
3277 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3278 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3279 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3283 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3289 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3291 SvREFCNT_dec(tmpsv);
3294 switch (o->op_type) {
3301 PerlIO_printf(file, ">\n");
3303 do_pmop_xmldump(level, file, cPMOPo);
3309 if (o->op_flags & OPf_KIDS) {
3313 PerlIO_printf(file, ">\n");
3315 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3316 do_op_xmldump(level, file, kid);
3320 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3322 PerlIO_printf(file, " />\n");
3326 Perl_op_xmldump(pTHX_ const OP *o)
3328 PERL_ARGS_ASSERT_OP_XMLDUMP;
3330 do_op_xmldump(0, PL_xmlfp, o);
3336 * c-indentation-style: bsd
3338 * indent-tabs-mode: t
3341 * ex: set ts=8 sts=4 sw=4 noet: