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 only chars above 255 will be
236 escaped using this style, other non printable chars will use octal or
237 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
238 then all chars below 255 will be treated as printable and
239 will be output as literals.
241 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
242 string will be escaped, regardles of max. If the string is utf8 and
243 the chars value is >255 then it will be returned as a plain hex
244 sequence. Thus the output will either be a single char,
245 an octal escape sequence, a special escape like C<\n> or a 3 or
246 more digit 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;
288 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
289 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
290 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
293 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
294 "%cx{%"UVxf"}", esc, u);
295 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
298 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
302 case '\\' : /* fallthrough */
303 case '%' : if ( c == esc ) {
309 case '\v' : octbuf[1] = 'v'; break;
310 case '\t' : octbuf[1] = 't'; break;
311 case '\r' : octbuf[1] = 'r'; break;
312 case '\n' : octbuf[1] = 'n'; break;
313 case '\f' : octbuf[1] = 'f'; break;
321 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
322 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
325 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
332 if ( max && (wrote + chsize > max) ) {
334 } else if (chsize > 1) {
335 sv_catpvn(dsv, octbuf, chsize);
338 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
339 128-255 can be appended raw to the dsv. If dsv happens to be
340 UTF-8 then we need catpvf to upgrade them for us.
341 Or add a new API call sv_catpvc(). Think about that name, and
342 how to keep it clear that it's unlike the s of catpvs, which is
343 really an array octets, not a string. */
344 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
347 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
355 =for apidoc pv_pretty
357 Converts a string into something presentable, handling escaping via
358 pv_escape() and supporting quoting and ellipses.
360 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
361 double quoted with any double quotes in the string escaped. Otherwise
362 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
365 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
366 string were output then an ellipsis C<...> will be appended to the
367 string. Note that this happens AFTER it has been quoted.
369 If start_color is non-null then it will be inserted after the opening
370 quote (if there is one) but before the escaped text. If end_color
371 is non-null then it will be inserted after the escaped text but before
372 any quotes or ellipses.
374 Returns a pointer to the prettified text as held by dsv.
380 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
381 const STRLEN max, char const * const start_color, char const * const end_color,
384 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
387 PERL_ARGS_ASSERT_PV_PRETTY;
389 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
390 /* This won't alter the UTF-8 flag */
395 sv_catpvs(dsv, "\"");
396 else if ( flags & PERL_PV_PRETTY_LTGT )
399 if ( start_color != NULL )
400 sv_catpv(dsv, start_color);
402 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
404 if ( end_color != NULL )
405 sv_catpv(dsv, end_color);
408 sv_catpvs( dsv, "\"");
409 else if ( flags & PERL_PV_PRETTY_LTGT )
412 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
413 sv_catpvs(dsv, "...");
419 =for apidoc pv_display
423 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
425 except that an additional "\0" will be appended to the string when
426 len > cur and pv[cur] is "\0".
428 Note that the final string may be up to 7 chars longer than pvlim.
434 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
436 PERL_ARGS_ASSERT_PV_DISPLAY;
438 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
439 if (len > cur && pv[cur] == '\0')
440 sv_catpvs( dsv, "\\0");
445 Perl_sv_peek(pTHX_ SV *sv)
448 SV * const t = sv_newmortal();
458 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
462 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
463 if (sv == &PL_sv_undef) {
464 sv_catpv(t, "SV_UNDEF");
465 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
466 SVs_GMG|SVs_SMG|SVs_RMG)) &&
470 else if (sv == &PL_sv_no) {
471 sv_catpv(t, "SV_NO");
472 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
473 SVs_GMG|SVs_SMG|SVs_RMG)) &&
474 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
480 else if (sv == &PL_sv_yes) {
481 sv_catpv(t, "SV_YES");
482 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
483 SVs_GMG|SVs_SMG|SVs_RMG)) &&
484 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
487 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
492 sv_catpv(t, "SV_PLACEHOLDER");
493 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
494 SVs_GMG|SVs_SMG|SVs_RMG)) &&
500 else if (SvREFCNT(sv) == 0) {
504 else if (DEBUG_R_TEST_) {
507 /* is this SV on the tmps stack? */
508 for (ix=PL_tmps_ix; ix>=0; ix--) {
509 if (PL_tmps_stack[ix] == sv) {
514 if (SvREFCNT(sv) > 1)
515 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
523 if (SvCUR(t) + unref > 10) {
524 SvCUR_set(t, unref + 3);
533 if (type == SVt_PVCV) {
534 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
536 } else if (type < SVt_LAST) {
537 sv_catpv(t, svshorttypenames[type]);
539 if (type == SVt_NULL)
542 sv_catpv(t, "FREED");
547 if (!SvPVX_const(sv))
548 sv_catpv(t, "(null)");
550 SV * const tmp = newSVpvs("");
554 SvOOK_offset(sv, delta);
555 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
557 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
559 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
560 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
565 else if (SvNOKp(sv)) {
566 STORE_NUMERIC_LOCAL_SET_STANDARD();
567 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
568 RESTORE_NUMERIC_LOCAL();
570 else if (SvIOKp(sv)) {
572 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
574 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
582 if (PL_tainting && SvTAINTED(sv))
583 sv_catpv(t, " [tainted]");
584 return SvPV_nolen(t);
588 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
592 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
595 Perl_dump_indent(aTHX_ level, file, "{}\n");
598 Perl_dump_indent(aTHX_ level, file, "{\n");
600 if (pm->op_pmflags & PMf_ONCE)
605 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
606 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
607 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
609 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
610 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
611 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
612 op_dump(pm->op_pmreplrootu.op_pmreplroot);
614 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
615 SV * const tmpsv = pm_description(pm);
616 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
620 Perl_dump_indent(aTHX_ level-1, file, "}\n");
623 const struct flag_to_name pmflags_flags_names[] = {
624 {PMf_CONST, ",CONST"},
626 {PMf_GLOBAL, ",GLOBAL"},
627 {PMf_CONTINUE, ",CONTINUE"},
628 {PMf_RETAINT, ",RETAINT"},
630 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
634 S_pm_description(pTHX_ const PMOP *pm)
636 SV * const desc = newSVpvs("");
637 const REGEXP * const regex = PM_GETRE(pm);
638 const U32 pmflags = pm->op_pmflags;
640 PERL_ARGS_ASSERT_PM_DESCRIPTION;
642 if (pmflags & PMf_ONCE)
643 sv_catpv(desc, ",ONCE");
645 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
646 sv_catpv(desc, ":USED");
648 if (pmflags & PMf_USED)
649 sv_catpv(desc, ":USED");
653 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
654 sv_catpv(desc, ",TAINTED");
655 if (RX_CHECK_SUBSTR(regex)) {
656 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
657 sv_catpv(desc, ",SCANFIRST");
658 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
659 sv_catpv(desc, ",ALL");
661 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
662 sv_catpv(desc, ",SKIPWHITE");
665 append_flags(desc, pmflags, pmflags_flags_names);
670 Perl_pmop_dump(pTHX_ PMOP *pm)
672 do_pmop_dump(0, Perl_debug_log, pm);
675 /* An op sequencer. We visit the ops in the order they're to execute. */
678 S_sequence(pTHX_ register const OP *o)
681 const OP *oldop = NULL;
694 for (; o; o = o->op_next) {
696 SV * const op = newSVuv(PTR2UV(o));
697 const char * const key = SvPV_const(op, len);
699 if (hv_exists(Sequence, key, len))
702 switch (o->op_type) {
704 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
705 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
714 if (oldop && o->op_next)
721 if (oldop && o->op_next)
723 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
736 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
737 sequence_tail(cLOGOPo->op_other);
742 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
743 sequence_tail(cLOOPo->op_redoop);
744 sequence_tail(cLOOPo->op_nextop);
745 sequence_tail(cLOOPo->op_lastop);
749 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
750 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
759 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
767 S_sequence_tail(pTHX_ const OP *o)
769 while (o && (o->op_type == OP_NULL))
775 S_sequence_num(pTHX_ const OP *o)
783 op = newSVuv(PTR2UV(o));
784 key = SvPV_const(op, len);
785 seq = hv_fetch(Sequence, key, len, 0);
786 return seq ? SvUV(*seq): 0;
789 const struct flag_to_name op_flags_names[] = {
791 {OPf_PARENS, ",PARENS"},
792 {OPf_STACKED, ",STACKED"},
795 {OPf_SPECIAL, ",SPECIAL"}
798 const struct flag_to_name op_trans_names[] = {
799 {OPpTRANS_SQUASH, ",SQUASH"},
800 {OPpTRANS_DELETE, ",DELETE"},
801 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
802 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
803 {OPpTRANS_GROWS, ",GROWS"}
806 const struct flag_to_name op_entersub_names[] = {
807 {OPpENTERSUB_AMPER, ",AMPER"},
808 {OPpENTERSUB_DB, ",DB"},
809 {OPpENTERSUB_HASTARG, ",HASTARG"},
810 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
811 {OPpENTERSUB_INARGS, ",INARGS"},
812 {OPpENTERSUB_NOMOD, ",NOMOD"}
815 const struct flag_to_name op_const_names[] = {
816 {OPpCONST_BARE, ",BARE"},
817 {OPpCONST_STRICT, ",STRICT"},
818 {OPpCONST_ARYBASE, ",ARYBASE"},
819 {OPpCONST_WARNING, ",WARNING"},
820 {OPpCONST_ENTERED, ",ENTERED"}
823 const struct flag_to_name op_sort_names[] = {
824 {OPpSORT_NUMERIC, ",NUMERIC"},
825 {OPpSORT_INTEGER, ",INTEGER"},
826 {OPpSORT_REVERSE, ",REVERSE"}
829 const struct flag_to_name op_open_names[] = {
830 {OPpOPEN_IN_RAW, ",IN_RAW"},
831 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
832 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
833 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
836 const struct flag_to_name op_exit_names[] = {
837 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
838 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
841 #define OP_PRIVATE_ONCE(op, flag, name) \
842 const struct flag_to_name CAT2(op, _names)[] = { \
846 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
847 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
848 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
849 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
850 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
851 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
852 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
853 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
854 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
855 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
856 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
858 struct op_private_by_op {
861 const struct flag_to_name *start;
864 const struct op_private_by_op op_private_names[] = {
865 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
866 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
867 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
868 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
869 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
870 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
871 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
872 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
873 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
874 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
875 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
876 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
877 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
878 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
879 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
880 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
881 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
882 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
883 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
884 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
885 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
889 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
890 const struct op_private_by_op *start = op_private_names;
891 const struct op_private_by_op *const end
892 = op_private_names + C_ARRAY_LENGTH(op_private_names);
894 /* This is a linear search, but no worse than the code that it replaced.
895 It's debugging code - size is more important than speed. */
897 if (optype == start->op_type) {
898 S_append_flags(aTHX_ tmpsv, op_private, start->start,
899 start->start + start->len);
902 } while (++start < end);
907 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
911 const OPCODE optype = o->op_type;
913 PERL_ARGS_ASSERT_DO_OP_DUMP;
916 Perl_dump_indent(aTHX_ level, file, "{\n");
918 seq = sequence_num(o);
920 PerlIO_printf(file, "%-4"UVuf, seq);
922 PerlIO_printf(file, " ");
924 "%*sTYPE = %s ===> ",
925 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
927 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
928 sequence_num(o->op_next));
930 PerlIO_printf(file, "DONE\n");
932 if (optype == OP_NULL) {
933 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
934 if (o->op_targ == OP_NEXTSTATE) {
936 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
938 if (CopSTASHPV(cCOPo))
939 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
942 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
947 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
950 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
952 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
953 SV * const tmpsv = newSVpvs("");
954 switch (o->op_flags & OPf_WANT) {
956 sv_catpv(tmpsv, ",VOID");
958 case OPf_WANT_SCALAR:
959 sv_catpv(tmpsv, ",SCALAR");
962 sv_catpv(tmpsv, ",LIST");
965 sv_catpv(tmpsv, ",UNKNOWN");
968 append_flags(tmpsv, o->op_flags, op_flags_names);
970 sv_catpv(tmpsv, ",LATEFREE");
972 sv_catpv(tmpsv, ",LATEFREED");
974 sv_catpv(tmpsv, ",ATTACHED");
975 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
979 SV * const tmpsv = newSVpvs("");
980 if (PL_opargs[optype] & OA_TARGLEX) {
981 if (o->op_private & OPpTARGET_MY)
982 sv_catpv(tmpsv, ",TARGET_MY");
984 else if (optype == OP_ENTERSUB ||
985 optype == OP_RV2SV ||
987 optype == OP_RV2AV ||
988 optype == OP_RV2HV ||
989 optype == OP_RV2GV ||
990 optype == OP_AELEM ||
993 if (optype == OP_ENTERSUB) {
994 append_flags(tmpsv, o->op_private, op_entersub_names);
997 switch (o->op_private & OPpDEREF) {
999 sv_catpv(tmpsv, ",SV");
1002 sv_catpv(tmpsv, ",AV");
1005 sv_catpv(tmpsv, ",HV");
1008 if (o->op_private & OPpMAYBE_LVSUB)
1009 sv_catpv(tmpsv, ",MAYBE_LVSUB");
1012 if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
1013 && (o->op_private & OPpDEREFed))
1014 sv_catpv(tmpsv, ",DEREFed");
1016 if (optype == OP_AELEM || optype == OP_HELEM) {
1017 if (o->op_private & OPpLVAL_DEFER)
1018 sv_catpv(tmpsv, ",LVAL_DEFER");
1021 if (o->op_private & HINT_STRICT_REFS)
1022 sv_catpv(tmpsv, ",STRICT_REFS");
1023 if (o->op_private & OPpOUR_INTRO)
1024 sv_catpv(tmpsv, ",OUR_INTRO");
1027 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
1029 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
1030 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1031 sv_catpv(tmpsv, ",FT_ACCESS");
1032 if (o->op_private & OPpFT_STACKED)
1033 sv_catpv(tmpsv, ",FT_STACKED");
1035 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1036 sv_catpv(tmpsv, ",INTRO");
1038 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1039 SvREFCNT_dec(tmpsv);
1043 if (PL_madskills && o->op_madprop) {
1044 SV * const tmpsv = newSVpvs("");
1045 MADPROP* mp = o->op_madprop;
1046 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1049 const char tmp = mp->mad_key;
1050 sv_setpvs(tmpsv,"'");
1052 sv_catpvn(tmpsv, &tmp, 1);
1053 sv_catpv(tmpsv, "'=");
1054 switch (mp->mad_type) {
1056 sv_catpv(tmpsv, "NULL");
1057 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1060 sv_catpv(tmpsv, "<");
1061 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1062 sv_catpv(tmpsv, ">");
1063 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1066 if ((OP*)mp->mad_val) {
1067 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1068 do_op_dump(level, file, (OP*)mp->mad_val);
1072 sv_catpv(tmpsv, "(UNK)");
1073 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1079 Perl_dump_indent(aTHX_ level, file, "}\n");
1081 SvREFCNT_dec(tmpsv);
1090 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1092 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1093 if (cSVOPo->op_sv) {
1094 SV * const tmpsv = newSV(0);
1098 /* FIXME - is this making unwarranted assumptions about the
1099 UTF-8 cleanliness of the dump file handle? */
1102 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1103 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1104 SvPV_nolen_const(tmpsv));
1108 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1114 case OP_METHOD_NAMED:
1115 #ifndef USE_ITHREADS
1116 /* with ITHREADS, consts are stored in the pad, and the right pad
1117 * may not be active here, so skip */
1118 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1124 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1125 (UV)CopLINE(cCOPo));
1126 if (CopSTASHPV(cCOPo))
1127 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1129 if (CopLABEL(cCOPo))
1130 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1134 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1135 if (cLOOPo->op_redoop)
1136 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1138 PerlIO_printf(file, "DONE\n");
1139 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1140 if (cLOOPo->op_nextop)
1141 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1143 PerlIO_printf(file, "DONE\n");
1144 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1145 if (cLOOPo->op_lastop)
1146 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1148 PerlIO_printf(file, "DONE\n");
1156 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1157 if (cLOGOPo->op_other)
1158 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1160 PerlIO_printf(file, "DONE\n");
1166 do_pmop_dump(level, file, cPMOPo);
1174 if (o->op_private & OPpREFCOUNTED)
1175 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1180 if (o->op_flags & OPf_KIDS) {
1182 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1183 do_op_dump(level, file, kid);
1185 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1189 Perl_op_dump(pTHX_ const OP *o)
1191 PERL_ARGS_ASSERT_OP_DUMP;
1192 do_op_dump(0, Perl_debug_log, o);
1196 Perl_gv_dump(pTHX_ GV *gv)
1200 PERL_ARGS_ASSERT_GV_DUMP;
1203 PerlIO_printf(Perl_debug_log, "{}\n");
1206 sv = sv_newmortal();
1207 PerlIO_printf(Perl_debug_log, "{\n");
1208 gv_fullname3(sv, gv, NULL);
1209 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1210 if (gv != GvEGV(gv)) {
1211 gv_efullname3(sv, GvEGV(gv), NULL);
1212 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1214 PerlIO_putc(Perl_debug_log, '\n');
1215 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1219 /* map magic types to the symbolic names
1220 * (with the PERL_MAGIC_ prefixed stripped)
1223 static const struct { const char type; const char *name; } magic_names[] = {
1224 { PERL_MAGIC_sv, "sv(\\0)" },
1225 { PERL_MAGIC_arylen, "arylen(#)" },
1226 { PERL_MAGIC_rhash, "rhash(%)" },
1227 { PERL_MAGIC_pos, "pos(.)" },
1228 { PERL_MAGIC_symtab, "symtab(:)" },
1229 { PERL_MAGIC_backref, "backref(<)" },
1230 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1231 { PERL_MAGIC_overload, "overload(A)" },
1232 { PERL_MAGIC_bm, "bm(B)" },
1233 { PERL_MAGIC_regdata, "regdata(D)" },
1234 { PERL_MAGIC_env, "env(E)" },
1235 { PERL_MAGIC_hints, "hints(H)" },
1236 { PERL_MAGIC_isa, "isa(I)" },
1237 { PERL_MAGIC_dbfile, "dbfile(L)" },
1238 { PERL_MAGIC_shared, "shared(N)" },
1239 { PERL_MAGIC_tied, "tied(P)" },
1240 { PERL_MAGIC_sig, "sig(S)" },
1241 { PERL_MAGIC_uvar, "uvar(U)" },
1242 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1243 { PERL_MAGIC_overload_table, "overload_table(c)" },
1244 { PERL_MAGIC_regdatum, "regdatum(d)" },
1245 { PERL_MAGIC_envelem, "envelem(e)" },
1246 { PERL_MAGIC_fm, "fm(f)" },
1247 { PERL_MAGIC_regex_global, "regex_global(g)" },
1248 { PERL_MAGIC_hintselem, "hintselem(h)" },
1249 { PERL_MAGIC_isaelem, "isaelem(i)" },
1250 { PERL_MAGIC_nkeys, "nkeys(k)" },
1251 { PERL_MAGIC_dbline, "dbline(l)" },
1252 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1253 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1254 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1255 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1256 { PERL_MAGIC_qr, "qr(r)" },
1257 { PERL_MAGIC_sigelem, "sigelem(s)" },
1258 { PERL_MAGIC_taint, "taint(t)" },
1259 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1260 { PERL_MAGIC_vec, "vec(v)" },
1261 { PERL_MAGIC_vstring, "vstring(V)" },
1262 { PERL_MAGIC_utf8, "utf8(w)" },
1263 { PERL_MAGIC_substr, "substr(x)" },
1264 { PERL_MAGIC_defelem, "defelem(y)" },
1265 { PERL_MAGIC_ext, "ext(~)" },
1266 /* this null string terminates the list */
1271 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1273 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1275 for (; mg; mg = mg->mg_moremagic) {
1276 Perl_dump_indent(aTHX_ level, file,
1277 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1278 if (mg->mg_virtual) {
1279 const MGVTBL * const v = mg->mg_virtual;
1281 if (v == &PL_vtbl_sv) s = "sv";
1282 else if (v == &PL_vtbl_env) s = "env";
1283 else if (v == &PL_vtbl_envelem) s = "envelem";
1284 else if (v == &PL_vtbl_sig) s = "sig";
1285 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1286 else if (v == &PL_vtbl_pack) s = "pack";
1287 else if (v == &PL_vtbl_packelem) s = "packelem";
1288 else if (v == &PL_vtbl_dbline) s = "dbline";
1289 else if (v == &PL_vtbl_isa) s = "isa";
1290 else if (v == &PL_vtbl_arylen) s = "arylen";
1291 else if (v == &PL_vtbl_mglob) s = "mglob";
1292 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1293 else if (v == &PL_vtbl_taint) s = "taint";
1294 else if (v == &PL_vtbl_substr) s = "substr";
1295 else if (v == &PL_vtbl_vec) s = "vec";
1296 else if (v == &PL_vtbl_pos) s = "pos";
1297 else if (v == &PL_vtbl_bm) s = "bm";
1298 else if (v == &PL_vtbl_fm) s = "fm";
1299 else if (v == &PL_vtbl_uvar) s = "uvar";
1300 else if (v == &PL_vtbl_defelem) s = "defelem";
1301 #ifdef USE_LOCALE_COLLATE
1302 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1304 else if (v == &PL_vtbl_amagic) s = "amagic";
1305 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1306 else if (v == &PL_vtbl_backref) s = "backref";
1307 else if (v == &PL_vtbl_utf8) s = "utf8";
1308 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1309 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1310 else if (v == &PL_vtbl_hints) s = "hints";
1313 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1315 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1318 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1321 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1325 const char *name = NULL;
1326 for (n = 0; magic_names[n].name; n++) {
1327 if (mg->mg_type == magic_names[n].type) {
1328 name = magic_names[n].name;
1333 Perl_dump_indent(aTHX_ level, file,
1334 " MG_TYPE = PERL_MAGIC_%s\n", name);
1336 Perl_dump_indent(aTHX_ level, file,
1337 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1341 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1342 if (mg->mg_type == PERL_MAGIC_envelem &&
1343 mg->mg_flags & MGf_TAINTEDDIR)
1344 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1345 if (mg->mg_flags & MGf_REFCOUNTED)
1346 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1347 if (mg->mg_flags & MGf_GSKIP)
1348 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1349 if (mg->mg_type == PERL_MAGIC_regex_global &&
1350 mg->mg_flags & MGf_MINMATCH)
1351 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1354 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1355 PTR2UV(mg->mg_obj));
1356 if (mg->mg_type == PERL_MAGIC_qr) {
1357 REGEXP* const re = (REGEXP *)mg->mg_obj;
1358 SV * const dsv = sv_newmortal();
1359 const char * const s
1360 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1362 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1363 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1365 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1366 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1369 if (mg->mg_flags & MGf_REFCOUNTED)
1370 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1373 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1375 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1376 if (mg->mg_len >= 0) {
1377 if (mg->mg_type != PERL_MAGIC_utf8) {
1378 SV * const sv = newSVpvs("");
1379 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1383 else if (mg->mg_len == HEf_SVKEY) {
1384 PerlIO_puts(file, " => HEf_SVKEY\n");
1385 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1386 maxnest, dumpops, pvlim); /* MG is already +1 */
1389 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1394 " does not know how to handle this MG_LEN"
1396 PerlIO_putc(file, '\n');
1398 if (mg->mg_type == PERL_MAGIC_utf8) {
1399 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1402 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1403 Perl_dump_indent(aTHX_ level, file,
1404 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1407 (UV)cache[i * 2 + 1]);
1414 Perl_magic_dump(pTHX_ const MAGIC *mg)
1416 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1420 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1424 PERL_ARGS_ASSERT_DO_HV_DUMP;
1426 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1427 if (sv && (hvname = HvNAME_get(sv)))
1428 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1430 PerlIO_putc(file, '\n');
1434 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1436 PERL_ARGS_ASSERT_DO_GV_DUMP;
1438 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1439 if (sv && GvNAME(sv))
1440 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1442 PerlIO_putc(file, '\n');
1446 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1448 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1450 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1451 if (sv && GvNAME(sv)) {
1453 PerlIO_printf(file, "\t\"");
1454 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1455 PerlIO_printf(file, "%s\" :: \"", hvname);
1456 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1459 PerlIO_putc(file, '\n');
1462 const struct flag_to_name first_sv_flags_names[] = {
1463 {SVs_TEMP, "TEMP,"},
1464 {SVs_OBJECT, "OBJECT,"},
1473 const struct flag_to_name second_sv_flags_names[] = {
1475 {SVf_FAKE, "FAKE,"},
1476 {SVf_READONLY, "READONLY,"},
1477 {SVf_BREAK, "BREAK,"},
1478 {SVf_AMAGIC, "OVERLOAD,"},
1484 const struct flag_to_name cv_flags_names[] = {
1485 {CVf_ANON, "ANON,"},
1486 {CVf_UNIQUE, "UNIQUE,"},
1487 {CVf_CLONE, "CLONE,"},
1488 {CVf_CLONED, "CLONED,"},
1489 {CVf_CONST, "CONST,"},
1490 {CVf_NODEBUG, "NODEBUG,"},
1491 {CVf_LVALUE, "LVALUE,"},
1492 {CVf_METHOD, "METHOD,"},
1493 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"}
1496 const struct flag_to_name hv_flags_names[] = {
1497 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1498 {SVphv_LAZYDEL, "LAZYDEL,"},
1499 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1500 {SVphv_REHASH, "REHASH,"},
1501 {SVphv_CLONEABLE, "CLONEABLE,"}
1504 const struct flag_to_name gp_flags_names[] = {
1505 {GVf_INTRO, "INTRO,"},
1506 {GVf_MULTI, "MULTI,"},
1507 {GVf_ASSUMECV, "ASSUMECV,"},
1508 {GVf_IN_PAD, "IN_PAD,"}
1511 const struct flag_to_name gp_flags_imported_names[] = {
1512 {GVf_IMPORTED_SV, " SV"},
1513 {GVf_IMPORTED_AV, " AV"},
1514 {GVf_IMPORTED_HV, " HV"},
1515 {GVf_IMPORTED_CV, " CV"},
1519 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1527 PERL_ARGS_ASSERT_DO_SV_DUMP;
1530 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1534 flags = SvFLAGS(sv);
1537 d = Perl_newSVpvf(aTHX_
1538 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1539 PTR2UV(SvANY(sv)), PTR2UV(sv),
1540 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1541 (int)(PL_dumpindent*level), "");
1543 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1544 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1546 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1547 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1548 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1550 append_flags(d, flags, first_sv_flags_names);
1551 if (flags & SVf_ROK) {
1552 sv_catpv(d, "ROK,");
1553 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1555 append_flags(d, flags, second_sv_flags_names);
1556 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1557 if (SvPCS_IMPORTED(sv))
1558 sv_catpv(d, "PCS_IMPORTED,");
1560 sv_catpv(d, "SCREAM,");
1566 append_flags(d, CvFLAGS(sv), cv_flags_names);
1567 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1570 append_flags(d, flags, hv_flags_names);
1574 if (isGV_with_GP(sv)) {
1575 append_flags(d, GvFLAGS(sv), gp_flags_names);
1577 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1578 sv_catpv(d, "IMPORT");
1579 if (GvIMPORTED(sv) == GVf_IMPORTED)
1580 sv_catpv(d, "ALL,");
1583 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1587 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1588 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1592 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1593 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1596 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1597 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1600 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1605 /* SVphv_SHAREKEYS is also 0x20000000 */
1606 if ((type != SVt_PVHV) && SvUTF8(sv))
1607 sv_catpv(d, "UTF8");
1609 if (*(SvEND(d) - 1) == ',') {
1610 SvCUR_set(d, SvCUR(d) - 1);
1611 SvPVX(d)[SvCUR(d)] = '\0';
1616 #ifdef DEBUG_LEAKING_SCALARS
1617 Perl_dump_indent(aTHX_ level, file,
1618 "ALLOCATED at %s:%d %s %s%s; serial %"UVuf"\n",
1619 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1621 sv->sv_debug_inpad ? "for" : "by",
1622 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1623 sv->sv_debug_cloned ? " (cloned)" : "",
1627 Perl_dump_indent(aTHX_ level, file, "SV = ");
1628 if (type < SVt_LAST) {
1629 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1631 if (type == SVt_NULL) {
1636 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1640 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1641 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
1642 && type != SVt_PVIO && type != SVt_REGEXP)
1643 || (type == SVt_IV && !SvROK(sv))) {
1645 #ifdef PERL_OLD_COPY_ON_WRITE
1649 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1651 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1652 #ifdef PERL_OLD_COPY_ON_WRITE
1653 if (SvIsCOW_shared_hash(sv))
1654 PerlIO_printf(file, " (HASH)");
1655 else if (SvIsCOW_normal(sv))
1656 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1658 PerlIO_putc(file, '\n');
1660 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1661 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1662 (UV) COP_SEQ_RANGE_LOW(sv));
1663 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1664 (UV) COP_SEQ_RANGE_HIGH(sv));
1665 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1666 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1667 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1668 || type == SVt_NV) {
1669 STORE_NUMERIC_LOCAL_SET_STANDARD();
1670 /* %Vg doesn't work? --jhi */
1671 #ifdef USE_LONG_DOUBLE
1672 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1674 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1676 RESTORE_NUMERIC_LOCAL();
1679 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1681 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1683 if (type < SVt_PV) {
1687 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1688 if (SvPVX_const(sv)) {
1691 SvOOK_offset(sv, delta);
1692 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1697 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1699 PerlIO_printf(file, "( %s . ) ",
1700 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1703 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1704 if (SvUTF8(sv)) /* the 6? \x{....} */
1705 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1706 PerlIO_printf(file, "\n");
1707 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1708 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1711 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1713 if (type == SVt_REGEXP) {
1715 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1716 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1719 if (type >= SVt_PVMG) {
1720 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1721 HV * const ost = SvOURSTASH(sv);
1723 do_hv_dump(level, file, " OURSTASH", ost);
1726 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1729 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1733 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1734 if (AvARRAY(sv) != AvALLOC(sv)) {
1735 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1736 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1739 PerlIO_putc(file, '\n');
1740 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1741 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1742 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1744 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1745 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1746 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1747 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1748 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1750 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1751 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1753 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1755 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1760 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1761 if (HvARRAY(sv) && HvKEYS(sv)) {
1762 /* Show distribution of HEs in the ARRAY */
1764 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1767 U32 pow2 = 2, keys = HvKEYS(sv);
1768 NV theoret, sum = 0;
1770 PerlIO_printf(file, " (");
1771 Zero(freq, FREQ_MAX + 1, int);
1772 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1775 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1777 if (count > FREQ_MAX)
1783 for (i = 0; i <= max; i++) {
1785 PerlIO_printf(file, "%d%s:%d", i,
1786 (i == FREQ_MAX) ? "+" : "",
1789 PerlIO_printf(file, ", ");
1792 PerlIO_putc(file, ')');
1793 /* The "quality" of a hash is defined as the total number of
1794 comparisons needed to access every element once, relative
1795 to the expected number needed for a random hash.
1797 The total number of comparisons is equal to the sum of
1798 the squares of the number of entries in each bucket.
1799 For a random hash of n keys into k buckets, the expected
1804 for (i = max; i > 0; i--) { /* Precision: count down. */
1805 sum += freq[i] * i * i;
1807 while ((keys = keys >> 1))
1809 theoret = HvKEYS(sv);
1810 theoret += theoret * (theoret-1)/pow2;
1811 PerlIO_putc(file, '\n');
1812 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1814 PerlIO_putc(file, '\n');
1815 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1816 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1817 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1818 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1819 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1821 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1822 if (mg && mg->mg_obj) {
1823 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1827 const char * const hvname = HvNAME_get(sv);
1829 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1833 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1834 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1836 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1838 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1842 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1843 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1844 (int)meta->mro_which->length,
1845 meta->mro_which->name,
1846 PTR2UV(meta->mro_which));
1847 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1848 (UV)meta->cache_gen);
1849 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1851 if (meta->mro_linear_all) {
1852 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1853 PTR2UV(meta->mro_linear_all));
1854 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1857 if (meta->mro_linear_current) {
1858 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1859 PTR2UV(meta->mro_linear_current));
1860 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1863 if (meta->mro_nextmethod) {
1864 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1865 PTR2UV(meta->mro_nextmethod));
1866 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1870 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1872 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1877 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1879 HV * const hv = MUTABLE_HV(sv);
1880 int count = maxnest - nest;
1883 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1886 const U32 hash = HeHASH(he);
1887 SV * const keysv = hv_iterkeysv(he);
1888 const char * const keypv = SvPV_const(keysv, len);
1889 SV * const elt = hv_iterval(hv, he);
1891 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1893 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1895 PerlIO_printf(file, "[REHASH] ");
1896 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1897 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1899 hv_iterinit(hv); /* Return to status quo */
1905 const char *const proto = SvPV_const(sv, len);
1906 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1911 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1912 if (!CvISXSUB(sv)) {
1914 Perl_dump_indent(aTHX_ level, file,
1915 " START = 0x%"UVxf" ===> %"IVdf"\n",
1916 PTR2UV(CvSTART(sv)),
1917 (IV)sequence_num(CvSTART(sv)));
1919 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1920 PTR2UV(CvROOT(sv)));
1921 if (CvROOT(sv) && dumpops) {
1922 do_op_dump(level+1, file, CvROOT(sv));
1925 SV * const constant = cv_const_sv((const CV *)sv);
1927 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1930 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1932 PTR2UV(CvXSUBANY(sv).any_ptr));
1933 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1936 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1937 (IV)CvXSUBANY(sv).any_i32);
1940 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1941 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1942 if (type == SVt_PVCV)
1943 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1944 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1945 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1946 if (type == SVt_PVFM)
1947 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1948 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1949 if (nest < maxnest) {
1950 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1953 const CV * const outside = CvOUTSIDE(sv);
1954 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1957 : CvANON(outside) ? "ANON"
1958 : (outside == PL_main_cv) ? "MAIN"
1959 : CvUNIQUE(outside) ? "UNIQUE"
1960 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1962 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1963 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1967 if (type == SVt_PVLV) {
1968 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1969 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1970 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1971 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1972 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1973 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1977 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1978 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1979 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1980 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1982 if (!isGV_with_GP(sv))
1984 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1985 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1986 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1987 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1990 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1991 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1992 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1993 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1994 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1995 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1996 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1997 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1998 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1999 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2000 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2001 do_gv_dump (level, file, " EGV", GvEGV(sv));
2004 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2005 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2006 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2007 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2008 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2009 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2010 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2012 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2013 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2014 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2016 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2017 PTR2UV(IoTOP_GV(sv)));
2018 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2019 maxnest, dumpops, pvlim);
2021 /* Source filters hide things that are not GVs in these three, so let's
2022 be careful out there. */
2024 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2025 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2026 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2028 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2029 PTR2UV(IoFMT_GV(sv)));
2030 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2031 maxnest, dumpops, pvlim);
2033 if (IoBOTTOM_NAME(sv))
2034 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2035 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2036 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2038 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2039 PTR2UV(IoBOTTOM_GV(sv)));
2040 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2041 maxnest, dumpops, pvlim);
2043 if (isPRINT(IoTYPE(sv)))
2044 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2046 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2047 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2054 Perl_sv_dump(pTHX_ SV *sv)
2058 PERL_ARGS_ASSERT_SV_DUMP;
2061 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2063 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2067 Perl_runops_debug(pTHX)
2071 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2075 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2078 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2079 PerlIO_printf(Perl_debug_log,
2080 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2081 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2082 PTR2UV(*PL_watchaddr));
2083 if (DEBUG_s_TEST_) {
2084 if (DEBUG_v_TEST_) {
2085 PerlIO_printf(Perl_debug_log, "\n");
2093 if (DEBUG_t_TEST_) debop(PL_op);
2094 if (DEBUG_P_TEST_) debprof(PL_op);
2096 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2097 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2104 Perl_debop(pTHX_ const OP *o)
2108 PERL_ARGS_ASSERT_DEBOP;
2110 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2113 Perl_deb(aTHX_ "%s", OP_NAME(o));
2114 switch (o->op_type) {
2117 /* With ITHREADS, consts are stored in the pad, and the right pad
2118 * may not be active here, so check.
2119 * Looks like only during compiling the pads are illegal.
2122 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2124 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2129 SV * const sv = newSV(0);
2131 /* FIXME - is this making unwarranted assumptions about the
2132 UTF-8 cleanliness of the dump file handle? */
2135 gv_fullname3(sv, cGVOPo_gv, NULL);
2136 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2140 PerlIO_printf(Perl_debug_log, "(NULL)");
2146 /* print the lexical's name */
2147 CV * const cv = deb_curcv(cxstack_ix);
2150 AV * const padlist = CvPADLIST(cv);
2151 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2152 sv = *av_fetch(comppad, o->op_targ, FALSE);
2156 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2158 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2164 PerlIO_printf(Perl_debug_log, "\n");
2169 S_deb_curcv(pTHX_ const I32 ix)
2172 const PERL_CONTEXT * const cx = &cxstack[ix];
2173 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2174 return cx->blk_sub.cv;
2175 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2177 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2182 return deb_curcv(ix - 1);
2186 Perl_watch(pTHX_ char **addr)
2190 PERL_ARGS_ASSERT_WATCH;
2192 PL_watchaddr = addr;
2194 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2195 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2199 S_debprof(pTHX_ const OP *o)
2203 PERL_ARGS_ASSERT_DEBPROF;
2205 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2207 if (!PL_profiledata)
2208 Newxz(PL_profiledata, MAXO, U32);
2209 ++PL_profiledata[o->op_type];
2213 Perl_debprofdump(pTHX)
2217 if (!PL_profiledata)
2219 for (i = 0; i < MAXO; i++) {
2220 if (PL_profiledata[i])
2221 PerlIO_printf(Perl_debug_log,
2222 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2229 * XML variants of most of the above routines
2233 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2237 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2239 PerlIO_printf(file, "\n ");
2240 va_start(args, pat);
2241 xmldump_vindent(level, file, pat, &args);
2247 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2250 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2251 va_start(args, pat);
2252 xmldump_vindent(level, file, pat, &args);
2257 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2259 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2261 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2262 PerlIO_vprintf(file, pat, *args);
2266 Perl_xmldump_all(pTHX)
2268 xmldump_all_perl(FALSE);
2272 Perl_xmldump_all_perl(pTHX_ bool justperl)
2274 PerlIO_setlinebuf(PL_xmlfp);
2276 op_xmldump(PL_main_root);
2277 xmldump_packsubs_perl(PL_defstash, justperl);
2278 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2279 PerlIO_close(PL_xmlfp);
2284 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2286 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2287 xmldump_packsubs_perl(stash, FALSE);
2291 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2296 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2298 if (!HvARRAY(stash))
2300 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2301 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2302 GV *gv = MUTABLE_GV(HeVAL(entry));
2304 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2307 xmldump_sub_perl(gv, justperl);
2310 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2311 && (hv = GvHV(gv)) && hv != PL_defstash)
2312 xmldump_packsubs_perl(hv, justperl); /* nested package */
2318 Perl_xmldump_sub(pTHX_ const GV *gv)
2320 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2321 xmldump_sub_perl(gv, FALSE);
2325 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2329 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2331 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2334 sv = sv_newmortal();
2335 gv_fullname3(sv, gv, NULL);
2336 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2337 if (CvXSUB(GvCV(gv)))
2338 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2339 PTR2UV(CvXSUB(GvCV(gv))),
2340 (int)CvXSUBANY(GvCV(gv)).any_i32);
2341 else if (CvROOT(GvCV(gv)))
2342 op_xmldump(CvROOT(GvCV(gv)));
2344 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2348 Perl_xmldump_form(pTHX_ const GV *gv)
2350 SV * const sv = sv_newmortal();
2352 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2354 gv_fullname3(sv, gv, NULL);
2355 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2356 if (CvROOT(GvFORM(gv)))
2357 op_xmldump(CvROOT(GvFORM(gv)));
2359 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2363 Perl_xmldump_eval(pTHX)
2365 op_xmldump(PL_eval_root);
2369 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2371 PERL_ARGS_ASSERT_SV_CATXMLSV;
2372 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2376 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2379 const char * const e = pv + len;
2380 const char * const start = pv;
2384 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2387 dsvcur = SvCUR(dsv); /* in case we have to restart */
2392 c = utf8_to_uvchr((U8*)pv, &cl);
2394 SvCUR(dsv) = dsvcur;
2459 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2462 sv_catpvs(dsv, "<");
2465 sv_catpvs(dsv, ">");
2468 sv_catpvs(dsv, "&");
2471 sv_catpvs(dsv, """);
2475 if (c < 32 || c > 127) {
2476 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2479 const char string = (char) c;
2480 sv_catpvn(dsv, &string, 1);
2484 if ((c >= 0xD800 && c <= 0xDB7F) ||
2485 (c >= 0xDC00 && c <= 0xDFFF) ||
2486 (c >= 0xFFF0 && c <= 0xFFFF) ||
2488 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2490 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2503 Perl_sv_xmlpeek(pTHX_ SV *sv)
2505 SV * const t = sv_newmortal();
2509 PERL_ARGS_ASSERT_SV_XMLPEEK;
2515 sv_catpv(t, "VOID=\"\"");
2518 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2519 sv_catpv(t, "WILD=\"\"");
2522 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2523 if (sv == &PL_sv_undef) {
2524 sv_catpv(t, "SV_UNDEF=\"1\"");
2525 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2526 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2530 else if (sv == &PL_sv_no) {
2531 sv_catpv(t, "SV_NO=\"1\"");
2532 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2533 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2534 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2535 SVp_POK|SVp_NOK)) &&
2540 else if (sv == &PL_sv_yes) {
2541 sv_catpv(t, "SV_YES=\"1\"");
2542 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2543 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2544 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2545 SVp_POK|SVp_NOK)) &&
2547 SvPVX(sv) && *SvPVX(sv) == '1' &&
2552 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2553 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2554 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2558 sv_catpv(t, " XXX=\"\" ");
2560 else if (SvREFCNT(sv) == 0) {
2561 sv_catpv(t, " refcnt=\"0\"");
2564 else if (DEBUG_R_TEST_) {
2567 /* is this SV on the tmps stack? */
2568 for (ix=PL_tmps_ix; ix>=0; ix--) {
2569 if (PL_tmps_stack[ix] == sv) {
2574 if (SvREFCNT(sv) > 1)
2575 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2578 sv_catpv(t, " DRT=\"<T>\"");
2582 sv_catpv(t, " ROK=\"\"");
2584 switch (SvTYPE(sv)) {
2586 sv_catpv(t, " FREED=\"1\"");
2590 sv_catpv(t, " UNDEF=\"1\"");
2593 sv_catpv(t, " IV=\"");
2596 sv_catpv(t, " NV=\"");
2599 sv_catpv(t, " PV=\"");
2602 sv_catpv(t, " PVIV=\"");
2605 sv_catpv(t, " PVNV=\"");
2608 sv_catpv(t, " PVMG=\"");
2611 sv_catpv(t, " PVLV=\"");
2614 sv_catpv(t, " AV=\"");
2617 sv_catpv(t, " HV=\"");
2621 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2623 sv_catpv(t, " CV=\"()\"");
2626 sv_catpv(t, " GV=\"");
2629 sv_catpv(t, " BIND=\"");
2632 sv_catpv(t, " ORANGE=\"");
2635 sv_catpv(t, " FM=\"");
2638 sv_catpv(t, " IO=\"");
2647 else if (SvNOKp(sv)) {
2648 STORE_NUMERIC_LOCAL_SET_STANDARD();
2649 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2650 RESTORE_NUMERIC_LOCAL();
2652 else if (SvIOKp(sv)) {
2654 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2656 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2665 return SvPV(t, n_a);
2669 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2671 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2674 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2677 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2680 REGEXP *const r = PM_GETRE(pm);
2681 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2682 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2683 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2685 SvREFCNT_dec(tmpsv);
2686 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2687 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2690 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2691 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2692 SV * const tmpsv = pm_description(pm);
2693 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2694 SvREFCNT_dec(tmpsv);
2698 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2699 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2700 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2701 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2702 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2703 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2706 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2710 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2712 do_pmop_xmldump(0, PL_xmlfp, pm);
2716 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2721 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2726 seq = sequence_num(o);
2727 Perl_xmldump_indent(aTHX_ level, file,
2728 "<op_%s seq=\"%"UVuf" -> ",
2733 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2734 sequence_num(o->op_next));
2736 PerlIO_printf(file, "DONE\"");
2739 if (o->op_type == OP_NULL)
2741 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2742 if (o->op_targ == OP_NEXTSTATE)
2745 PerlIO_printf(file, " line=\"%"UVuf"\"",
2746 (UV)CopLINE(cCOPo));
2747 if (CopSTASHPV(cCOPo))
2748 PerlIO_printf(file, " package=\"%s\"",
2750 if (CopLABEL(cCOPo))
2751 PerlIO_printf(file, " label=\"%s\"",
2756 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2759 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2762 SV * const tmpsv = newSVpvs("");
2763 switch (o->op_flags & OPf_WANT) {
2765 sv_catpv(tmpsv, ",VOID");
2767 case OPf_WANT_SCALAR:
2768 sv_catpv(tmpsv, ",SCALAR");
2771 sv_catpv(tmpsv, ",LIST");
2774 sv_catpv(tmpsv, ",UNKNOWN");
2777 if (o->op_flags & OPf_KIDS)
2778 sv_catpv(tmpsv, ",KIDS");
2779 if (o->op_flags & OPf_PARENS)
2780 sv_catpv(tmpsv, ",PARENS");
2781 if (o->op_flags & OPf_STACKED)
2782 sv_catpv(tmpsv, ",STACKED");
2783 if (o->op_flags & OPf_REF)
2784 sv_catpv(tmpsv, ",REF");
2785 if (o->op_flags & OPf_MOD)
2786 sv_catpv(tmpsv, ",MOD");
2787 if (o->op_flags & OPf_SPECIAL)
2788 sv_catpv(tmpsv, ",SPECIAL");
2789 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2790 SvREFCNT_dec(tmpsv);
2792 if (o->op_private) {
2793 SV * const tmpsv = newSVpvs("");
2794 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2795 if (o->op_private & OPpTARGET_MY)
2796 sv_catpv(tmpsv, ",TARGET_MY");
2798 else if (o->op_type == OP_LEAVESUB ||
2799 o->op_type == OP_LEAVE ||
2800 o->op_type == OP_LEAVESUBLV ||
2801 o->op_type == OP_LEAVEWRITE) {
2802 if (o->op_private & OPpREFCOUNTED)
2803 sv_catpv(tmpsv, ",REFCOUNTED");
2805 else if (o->op_type == OP_AASSIGN) {
2806 if (o->op_private & OPpASSIGN_COMMON)
2807 sv_catpv(tmpsv, ",COMMON");
2809 else if (o->op_type == OP_SASSIGN) {
2810 if (o->op_private & OPpASSIGN_BACKWARDS)
2811 sv_catpv(tmpsv, ",BACKWARDS");
2813 else if (o->op_type == OP_TRANS) {
2814 if (o->op_private & OPpTRANS_SQUASH)
2815 sv_catpv(tmpsv, ",SQUASH");
2816 if (o->op_private & OPpTRANS_DELETE)
2817 sv_catpv(tmpsv, ",DELETE");
2818 if (o->op_private & OPpTRANS_COMPLEMENT)
2819 sv_catpv(tmpsv, ",COMPLEMENT");
2820 if (o->op_private & OPpTRANS_IDENTICAL)
2821 sv_catpv(tmpsv, ",IDENTICAL");
2822 if (o->op_private & OPpTRANS_GROWS)
2823 sv_catpv(tmpsv, ",GROWS");
2825 else if (o->op_type == OP_REPEAT) {
2826 if (o->op_private & OPpREPEAT_DOLIST)
2827 sv_catpv(tmpsv, ",DOLIST");
2829 else if (o->op_type == OP_ENTERSUB ||
2830 o->op_type == OP_RV2SV ||
2831 o->op_type == OP_GVSV ||
2832 o->op_type == OP_RV2AV ||
2833 o->op_type == OP_RV2HV ||
2834 o->op_type == OP_RV2GV ||
2835 o->op_type == OP_AELEM ||
2836 o->op_type == OP_HELEM )
2838 if (o->op_type == OP_ENTERSUB) {
2839 if (o->op_private & OPpENTERSUB_AMPER)
2840 sv_catpv(tmpsv, ",AMPER");
2841 if (o->op_private & OPpENTERSUB_DB)
2842 sv_catpv(tmpsv, ",DB");
2843 if (o->op_private & OPpENTERSUB_HASTARG)
2844 sv_catpv(tmpsv, ",HASTARG");
2845 if (o->op_private & OPpENTERSUB_NOPAREN)
2846 sv_catpv(tmpsv, ",NOPAREN");
2847 if (o->op_private & OPpENTERSUB_INARGS)
2848 sv_catpv(tmpsv, ",INARGS");
2849 if (o->op_private & OPpENTERSUB_NOMOD)
2850 sv_catpv(tmpsv, ",NOMOD");
2853 switch (o->op_private & OPpDEREF) {
2855 sv_catpv(tmpsv, ",SV");
2858 sv_catpv(tmpsv, ",AV");
2861 sv_catpv(tmpsv, ",HV");
2864 if (o->op_private & OPpMAYBE_LVSUB)
2865 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2867 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2868 if (o->op_private & OPpLVAL_DEFER)
2869 sv_catpv(tmpsv, ",LVAL_DEFER");
2872 if (o->op_private & HINT_STRICT_REFS)
2873 sv_catpv(tmpsv, ",STRICT_REFS");
2874 if (o->op_private & OPpOUR_INTRO)
2875 sv_catpv(tmpsv, ",OUR_INTRO");
2878 else if (o->op_type == OP_CONST) {
2879 if (o->op_private & OPpCONST_BARE)
2880 sv_catpv(tmpsv, ",BARE");
2881 if (o->op_private & OPpCONST_STRICT)
2882 sv_catpv(tmpsv, ",STRICT");
2883 if (o->op_private & OPpCONST_ARYBASE)
2884 sv_catpv(tmpsv, ",ARYBASE");
2885 if (o->op_private & OPpCONST_WARNING)
2886 sv_catpv(tmpsv, ",WARNING");
2887 if (o->op_private & OPpCONST_ENTERED)
2888 sv_catpv(tmpsv, ",ENTERED");
2890 else if (o->op_type == OP_FLIP) {
2891 if (o->op_private & OPpFLIP_LINENUM)
2892 sv_catpv(tmpsv, ",LINENUM");
2894 else if (o->op_type == OP_FLOP) {
2895 if (o->op_private & OPpFLIP_LINENUM)
2896 sv_catpv(tmpsv, ",LINENUM");
2898 else if (o->op_type == OP_RV2CV) {
2899 if (o->op_private & OPpLVAL_INTRO)
2900 sv_catpv(tmpsv, ",INTRO");
2902 else if (o->op_type == OP_GV) {
2903 if (o->op_private & OPpEARLY_CV)
2904 sv_catpv(tmpsv, ",EARLY_CV");
2906 else if (o->op_type == OP_LIST) {
2907 if (o->op_private & OPpLIST_GUESSED)
2908 sv_catpv(tmpsv, ",GUESSED");
2910 else if (o->op_type == OP_DELETE) {
2911 if (o->op_private & OPpSLICE)
2912 sv_catpv(tmpsv, ",SLICE");
2914 else if (o->op_type == OP_EXISTS) {
2915 if (o->op_private & OPpEXISTS_SUB)
2916 sv_catpv(tmpsv, ",EXISTS_SUB");
2918 else if (o->op_type == OP_SORT) {
2919 if (o->op_private & OPpSORT_NUMERIC)
2920 sv_catpv(tmpsv, ",NUMERIC");
2921 if (o->op_private & OPpSORT_INTEGER)
2922 sv_catpv(tmpsv, ",INTEGER");
2923 if (o->op_private & OPpSORT_REVERSE)
2924 sv_catpv(tmpsv, ",REVERSE");
2926 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2927 if (o->op_private & OPpOPEN_IN_RAW)
2928 sv_catpv(tmpsv, ",IN_RAW");
2929 if (o->op_private & OPpOPEN_IN_CRLF)
2930 sv_catpv(tmpsv, ",IN_CRLF");
2931 if (o->op_private & OPpOPEN_OUT_RAW)
2932 sv_catpv(tmpsv, ",OUT_RAW");
2933 if (o->op_private & OPpOPEN_OUT_CRLF)
2934 sv_catpv(tmpsv, ",OUT_CRLF");
2936 else if (o->op_type == OP_EXIT) {
2937 if (o->op_private & OPpEXIT_VMSISH)
2938 sv_catpv(tmpsv, ",EXIT_VMSISH");
2939 if (o->op_private & OPpHUSH_VMSISH)
2940 sv_catpv(tmpsv, ",HUSH_VMSISH");
2942 else if (o->op_type == OP_DIE) {
2943 if (o->op_private & OPpHUSH_VMSISH)
2944 sv_catpv(tmpsv, ",HUSH_VMSISH");
2946 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2947 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2948 sv_catpv(tmpsv, ",FT_ACCESS");
2949 if (o->op_private & OPpFT_STACKED)
2950 sv_catpv(tmpsv, ",FT_STACKED");
2952 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2953 sv_catpv(tmpsv, ",INTRO");
2955 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2956 SvREFCNT_dec(tmpsv);
2959 switch (o->op_type) {
2961 if (o->op_flags & OPf_SPECIAL) {
2967 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2969 if (cSVOPo->op_sv) {
2970 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2971 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2977 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2978 s = SvPV(tmpsv1,len);
2979 sv_catxmlpvn(tmpsv2, s, len, 1);
2980 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2984 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2989 case OP_METHOD_NAMED:
2990 #ifndef USE_ITHREADS
2991 /* with ITHREADS, consts are stored in the pad, and the right pad
2992 * may not be active here, so skip */
2993 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2999 PerlIO_printf(file, ">\n");
3001 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3006 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3007 (UV)CopLINE(cCOPo));
3008 if (CopSTASHPV(cCOPo))
3009 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3011 if (CopLABEL(cCOPo))
3012 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3016 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3017 if (cLOOPo->op_redoop)
3018 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3020 PerlIO_printf(file, "DONE\"");
3021 S_xmldump_attr(aTHX_ level, file, "next=\"");
3022 if (cLOOPo->op_nextop)
3023 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3025 PerlIO_printf(file, "DONE\"");
3026 S_xmldump_attr(aTHX_ level, file, "last=\"");
3027 if (cLOOPo->op_lastop)
3028 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3030 PerlIO_printf(file, "DONE\"");
3038 S_xmldump_attr(aTHX_ level, file, "other=\"");
3039 if (cLOGOPo->op_other)
3040 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3042 PerlIO_printf(file, "DONE\"");
3050 if (o->op_private & OPpREFCOUNTED)
3051 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3057 if (PL_madskills && o->op_madprop) {
3058 char prevkey = '\0';
3059 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3060 const MADPROP* mp = o->op_madprop;
3064 PerlIO_printf(file, ">\n");
3066 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3069 char tmp = mp->mad_key;
3070 sv_setpvs(tmpsv,"\"");
3072 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3073 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3074 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3077 sv_catpv(tmpsv, "\"");
3078 switch (mp->mad_type) {
3080 sv_catpv(tmpsv, "NULL");
3081 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3084 sv_catpv(tmpsv, " val=\"");
3085 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3086 sv_catpv(tmpsv, "\"");
3087 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3090 sv_catpv(tmpsv, " val=\"");
3091 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3092 sv_catpv(tmpsv, "\"");
3093 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3096 if ((OP*)mp->mad_val) {
3097 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3098 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3099 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3103 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3109 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3111 SvREFCNT_dec(tmpsv);
3114 switch (o->op_type) {
3121 PerlIO_printf(file, ">\n");
3123 do_pmop_xmldump(level, file, cPMOPo);
3129 if (o->op_flags & OPf_KIDS) {
3133 PerlIO_printf(file, ">\n");
3135 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3136 do_op_xmldump(level, file, kid);
3140 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3142 PerlIO_printf(file, " />\n");
3146 Perl_op_xmldump(pTHX_ const OP *o)
3148 PERL_ARGS_ASSERT_OP_XMLDUMP;
3150 do_op_xmldump(0, PL_xmlfp, o);
3156 * c-indentation-style: bsd
3158 * indent-tabs-mode: t
3161 * ex: set ts=8 sts=4 sw=4 noet: