This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
utf8.c: Add locale support to functions
[perl5.git] / dump.c
CommitLineData
a0d0e21e 1/* dump.c
a687059c 2 *
1129b882
NC		 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
a687059c 5 *
6e21c824
LW		 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.
8d063cd8 8 *
a0d0e21e
LW		 9 */
10
11/*
4ac71550
TC		 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.'
14 *
15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
8d063cd8
LW		 16 */
17
166f8a29 18/* This file contains utility routines to dump the contents of SV and OP
61296642 19 * structures, as used by command-line options like -Dt and -Dx, and
166f8a29
DM		 20 * by Devel::Peek.
21 *
22 * It also holds the debugging version of the runops function.
23 */
24
8d063cd8 25#include "EXTERN.h"
864dbfa3 26#define PERL_IN_DUMP_C
8d063cd8 27#include "perl.h"
f722798b 28#include "regcomp.h"
0bd48802 29
8d063cd8 30
5357ca29
NC		 31static const char* const svtypenames[SVt_LAST] = {
32 "NULL",
1cb9cd50 33 "BIND",
5357ca29 34 "IV",
b53eecb4 35 "NV",
5357ca29
NC		 36 "PV",
37 "PVIV",
38 "PVNV",
39 "PVMG",
5c35adbb 40 "REGEXP",
5357ca29
NC		 41 "PVGV",
42 "PVLV",
43 "PVAV",
44 "PVHV",
45 "PVCV",
46 "PVFM",
47 "PVIO"
48};
49
50
51static const char* const svshorttypenames[SVt_LAST] = {
52 "UNDEF",
1cb9cd50 53 "BIND",
5357ca29 54 "IV",
b53eecb4 55 "NV",
5357ca29
NC		 56 "PV",
57 "PVIV",
58 "PVNV",
59 "PVMG",
5c35adbb 60 "REGEXP",
5357ca29
NC		 61 "GV",
62 "PVLV",
63 "AV",
64 "HV",
65 "CV",
66 "FM",
67 "IO"
68};
69
a0c2f4dd
NC		 70struct flag_to_name {
71 U32 flag;
72 const char *name;
73};
74
75static void
76S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
77 const struct flag_to_name *const end)
78{
79 do {
80 if (flags & start->flag)
81 sv_catpv(sv, start->name);
82 } while (++start < end);
83}
84
85#define append_flags(sv, f, flags) \
cd431fde 86 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
a0c2f4dd
NC		 87
88
2814eb74 89
3967c732 90void
864dbfa3 91Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
3967c732 92{
3967c732 93 va_list args;
7918f24d 94 PERL_ARGS_ASSERT_DUMP_INDENT;
3967c732 95 va_start(args, pat);
c5be433b 96 dump_vindent(level, file, pat, &args);
3967c732
JD		 97 va_end(args);
98}
8adcabd8
LW		 99
100void
c5be433b
GS		 101Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
102{
97aff369 103 dVAR;
7918f24d 104 PERL_ARGS_ASSERT_DUMP_VINDENT;
c8db6e60 105 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
c5be433b
GS		 106 PerlIO_vprintf(file, pat, *args);
107}
108
109void
864dbfa3 110Perl_dump_all(pTHX)
79072805 111{
712a6fe4 112 dump_all_perl(FALSE);
f0e3f042
CS		 113}
114
115void
116Perl_dump_all_perl(pTHX_ bool justperl)
117{
118
97aff369 119 dVAR;
760ac839 120 PerlIO_setlinebuf(Perl_debug_log);
3280af22 121 if (PL_main_root)
3967c732 122 op_dump(PL_main_root);
f0e3f042 123 dump_packsubs_perl(PL_defstash, justperl);
463ee0b2
LW		 124}
125
126void
e1ec3a88 127Perl_dump_packsubs(pTHX_ const HV *stash)
463ee0b2 128{
28eb953d 129 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
f0e3f042
CS		 130 dump_packsubs_perl(stash, FALSE);
131}
132
133void
134Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
135{
97aff369 136 dVAR;
a0d0e21e 137 I32 i;
463ee0b2 138
28eb953d 139 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
7918f24d 140
8990e307
LW		 141 if (!HvARRAY(stash))
142 return;
a0d0e21e 143 for (i = 0; i <= (I32) HvMAX(stash); i++) {
e1ec3a88 144 const HE *entry;
4db58590 145 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
159b6efe 146 const GV * const gv = (const GV *)HeVAL(entry);
e29cdcb3
GS		 147 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
148 continue;
8ebc5c01 149 if (GvCVu(gv))
f0e3f042 150 dump_sub_perl(gv, justperl);
85e6fe83
LW		 151 if (GvFORM(gv))
152 dump_form(gv);
61f9802b
AL		 153 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
154 const HV * const hv = GvHV(gv);
155 if (hv && (hv != PL_defstash))
f0e3f042 156 dump_packsubs_perl(hv, justperl); /* nested package */
61f9802b 157 }
463ee0b2 158 }
79072805
LW		 159 }
160}
161
162void
e1ec3a88 163Perl_dump_sub(pTHX_ const GV *gv)
a687059c 164{
28eb953d 165 PERL_ARGS_ASSERT_DUMP_SUB;
f0e3f042
CS		 166 dump_sub_perl(gv, FALSE);
167}
168
169void
170Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
171{
172 SV * sv;
85e6fe83 173
28eb953d 174 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
7918f24d 175
f0e3f042
CS		 176 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
177 return;
178
179 sv = sv_newmortal();
bd61b366 180 gv_fullname3(sv, gv, NULL);
b15aece3 181 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
aed2304a 182 if (CvISXSUB(GvCV(gv)))
91f3b821
GS		 183 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
184 PTR2UV(CvXSUB(GvCV(gv))),
894356b3 185 (int)CvXSUBANY(GvCV(gv)).any_i32);
85e6fe83 186 else if (CvROOT(GvCV(gv)))
3967c732 187 op_dump(CvROOT(GvCV(gv)));
85e6fe83 188 else
cea2e8a9 189 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
85e6fe83
LW		 190}
191
192void
e1ec3a88 193Perl_dump_form(pTHX_ const GV *gv)
85e6fe83 194{
b464bac0 195 SV * const sv = sv_newmortal();
85e6fe83 196
7918f24d
NC		 197 PERL_ARGS_ASSERT_DUMP_FORM;
198
bd61b366 199 gv_fullname3(sv, gv, NULL);
b15aece3 200 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
85e6fe83 201 if (CvROOT(GvFORM(gv)))
3967c732 202 op_dump(CvROOT(GvFORM(gv)));
85e6fe83 203 else
cea2e8a9 204 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
a687059c
LW		 205}
206
8adcabd8 207void
864dbfa3 208Perl_dump_eval(pTHX)
8d063cd8 209{
97aff369 210 dVAR;
3967c732
JD		 211 op_dump(PL_eval_root);
212}
213
3df15adc
YO		 214
215/*
87cea99e 216=for apidoc pv_escape
3df15adc
YO		 217
218Escapes at most the first "count" chars of pv and puts the results into
ab3bbdeb 219dsv such that the size of the escaped string will not exceed "max" chars
3df15adc
YO		 220and will not contain any incomplete escape sequences.
221
ab3bbdeb
YO		 222If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
223will also be escaped.
3df15adc
YO		 224
225Normally the SV will be cleared before the escaped string is prepared,
ab3bbdeb
YO		 226but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
227
38a44b82 228If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
ab3bbdeb 229if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
38a44b82 230using C<is_utf8_string()> to determine if it is Unicode.
ab3bbdeb
YO		 231
232If PERL_PV_ESCAPE_ALL is set then all input chars will be output
681f01c2
KW		 233using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
234chars above 127 will be escaped using this style; otherwise, only chars above
235255 will be so escaped; other non printable chars will use octal or
236common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
237then all chars below 255 will be treated as printable and
ab3bbdeb
YO		 238will be output as literals.
239
240If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
c8536afa
KW		 241string will be escaped, regardless of max. If the output is to be in hex,
242then it will be returned as a plain hex
243sequence. Thus the output will either be a single char,
244an octal escape sequence, a special escape like C<\n> or a hex value.
3df15adc 245
44a2ac75
YO		 246If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
247not a '\\'. This is because regexes very often contain backslashed
248sequences, whereas '%' is not a particularly common character in patterns.
249
ab3bbdeb 250Returns a pointer to the escaped text as held by dsv.
3df15adc
YO		 251
252=cut
253*/
ab3bbdeb 254#define PV_ESCAPE_OCTBUFSIZE 32
ddc5bc0f 255
3967c732 256char *
ddc5bc0f 257Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
ab3bbdeb
YO		 258 const STRLEN count, const STRLEN max,
259 STRLEN * const escaped, const U32 flags )
260{
61f9802b
AL		 261 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
262 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
44a2ac75 263 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
ab3bbdeb
YO		 264 STRLEN wrote = 0; /* chars written so far */
265 STRLEN chsize = 0; /* size of data to be written */
266 STRLEN readsize = 1; /* size of data just read */
38a44b82 267 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
ddc5bc0f 268 const char *pv = str;
61f9802b 269 const char * const end = pv + count; /* end of string */
44a2ac75 270 octbuf[0] = esc;
ab3bbdeb 271
7918f24d
NC		 272 PERL_ARGS_ASSERT_PV_ESCAPE;
273
9ed8b5e5 274 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
7fddd944 275 /* This won't alter the UTF-8 flag */
76f68e9b 276 sv_setpvs(dsv, "");
7fddd944 277 }
ab3bbdeb 278
ddc5bc0f 279 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
ab3bbdeb
YO		 280 isuni = 1;
281
282 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
4b88fb76 283 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
ab3bbdeb
YO		 284 const U8 c = (U8)u & 0xFF;
285
681f01c2
KW		 286 if ( ( u > 255 )
287 || (flags & PERL_PV_ESCAPE_ALL)
288 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
289 {
ab3bbdeb
YO		 290 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
291 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
292 "%"UVxf, u);
293 else
294 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75 295 "%cx{%"UVxf"}", esc, u);
ab3bbdeb
YO		 296 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
297 chsize = 1;
298 } else {
44a2ac75
YO		 299 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
300 chsize = 2;
ab3bbdeb 301 switch (c) {
44a2ac75
YO		 302
303 case '\\' : /* fallthrough */
304 case '%' : if ( c == esc ) {
305 octbuf[1] = esc;
306 } else {
307 chsize = 1;
308 }
309 break;
3df15adc
YO		 310 case '\v' : octbuf[1] = 'v'; break;
311 case '\t' : octbuf[1] = 't'; break;
312 case '\r' : octbuf[1] = 'r'; break;
313 case '\n' : octbuf[1] = 'n'; break;
314 case '\f' : octbuf[1] = 'f'; break;
44a2ac75 315 case '"' :
ab3bbdeb 316 if ( dq == '"' )
3df15adc 317 octbuf[1] = '"';
ab3bbdeb
YO		 318 else
319 chsize = 1;
44a2ac75 320 break;
3df15adc 321 default:
bbae360a 322 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
ab3bbdeb 323 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75
YO		 324 "%c%03o", esc, c);
325 else
ab3bbdeb 326 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75 327 "%c%o", esc, c);
ab3bbdeb
YO		 328 }
329 } else {
44a2ac75 330 chsize = 1;
ab3bbdeb 331 }
44a2ac75
YO		 332 }
333 if ( max && (wrote + chsize > max) ) {
334 break;
ab3bbdeb 335 } else if (chsize > 1) {
44a2ac75
YO		 336 sv_catpvn(dsv, octbuf, chsize);
337 wrote += chsize;
3df15adc 338 } else {
7fddd944
NC		 339 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
340 128-255 can be appended raw to the dsv. If dsv happens to be
341 UTF-8 then we need catpvf to upgrade them for us.
342 Or add a new API call sv_catpvc(). Think about that name, and
343 how to keep it clear that it's unlike the s of catpvs, which is
344 really an array octets, not a string. */
345 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
3df15adc
YO		 346 wrote++;
347 }
ab3bbdeb
YO		 348 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
349 break;
3967c732 350 }
ab3bbdeb
YO		 351 if (escaped != NULL)
352 *escaped= pv - str;
353 return SvPVX(dsv);
354}
355/*
87cea99e 356=for apidoc pv_pretty
ab3bbdeb
YO		 357
358Converts a string into something presentable, handling escaping via
95b611b0 359pv_escape() and supporting quoting and ellipses.
ab3bbdeb
YO		 360
361If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
362double quoted with any double quotes in the string escaped. Otherwise
363if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
364angle brackets.
6cba11c8 365
95b611b0
RGS		 366If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
367string were output then an ellipsis C<...> will be appended to the
ab3bbdeb 368string. Note that this happens AFTER it has been quoted.
6cba11c8 369
ab3bbdeb
YO		 370If start_color is non-null then it will be inserted after the opening
371quote (if there is one) but before the escaped text. If end_color
372is non-null then it will be inserted after the escaped text but before
95b611b0 373any quotes or ellipses.
ab3bbdeb
YO		 374
375Returns a pointer to the prettified text as held by dsv.
6cba11c8 376
ab3bbdeb
YO		 377=cut
378*/
379
380char *
ddc5bc0f
YO		 381Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
382 const STRLEN max, char const * const start_color, char const * const end_color,
ab3bbdeb
YO		 383 const U32 flags )
384{
61f9802b 385 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
ab3bbdeb 386 STRLEN escaped;
7918f24d
NC		 387
388 PERL_ARGS_ASSERT_PV_PRETTY;
389
881a015e
NC		 390 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
391 /* This won't alter the UTF-8 flag */
76f68e9b 392 sv_setpvs(dsv, "");
881a015e
NC		 393 }
394
ab3bbdeb 395 if ( dq == '"' )
76f68e9b 396 sv_catpvs(dsv, "\"");
ab3bbdeb 397 else if ( flags & PERL_PV_PRETTY_LTGT )
76f68e9b 398 sv_catpvs(dsv, "<");
ab3bbdeb
YO		 399
400 if ( start_color != NULL )
76f68e9b 401 sv_catpv(dsv, start_color);
ab3bbdeb
YO		 402
403 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
404
405 if ( end_color != NULL )
76f68e9b 406 sv_catpv(dsv, end_color);
ab3bbdeb
YO		 407
408 if ( dq == '"' )
76f68e9b 409 sv_catpvs( dsv, "\"");
ab3bbdeb 410 else if ( flags & PERL_PV_PRETTY_LTGT )
76f68e9b 411 sv_catpvs(dsv, ">");
ab3bbdeb 412
95b611b0 413 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
76f68e9b 414 sv_catpvs(dsv, "...");
ab3bbdeb 415
3df15adc
YO		 416 return SvPVX(dsv);
417}
418
419/*
420=for apidoc pv_display
421
3df15adc 422Similar to
3967c732 423
3df15adc
YO		 424 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
425
426except that an additional "\0" will be appended to the string when
427len > cur and pv[cur] is "\0".
428
429Note that the final string may be up to 7 chars longer than pvlim.
430
431=cut
432*/
433
434char *
435Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
436{
7918f24d
NC		 437 PERL_ARGS_ASSERT_PV_DISPLAY;
438
ddc5bc0f 439 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
3df15adc 440 if (len > cur && pv[cur] == '\0')
76f68e9b 441 sv_catpvs( dsv, "\\0");
e6abe6d8
JH		 442 return SvPVX(dsv);
443}
444
445char *
864dbfa3 446Perl_sv_peek(pTHX_ SV *sv)
3967c732 447{
27da23d5 448 dVAR;
aec46f14 449 SV * const t = sv_newmortal();
3967c732 450 int unref = 0;
5357ca29 451 U32 type;
3967c732 452
76f68e9b 453 sv_setpvs(t, "");
3967c732
JD		 454 retry:
455 if (!sv) {
456 sv_catpv(t, "VOID");
457 goto finish;
458 }
ad64d0ec 459 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
3967c732
JD		 460 sv_catpv(t, "WILD");
461 goto finish;
462 }
7996736c 463 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
3967c732
JD		 464 if (sv == &PL_sv_undef) {
465 sv_catpv(t, "SV_UNDEF");
466 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
467 SVs_GMG|SVs_SMG|SVs_RMG)) &&
468 SvREADONLY(sv))
469 goto finish;
470 }
471 else if (sv == &PL_sv_no) {
472 sv_catpv(t, "SV_NO");
473 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
474 SVs_GMG|SVs_SMG|SVs_RMG)) &&
475 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
476 SVp_POK|SVp_NOK)) &&
477 SvCUR(sv) == 0 &&
478 SvNVX(sv) == 0.0)
479 goto finish;
480 }
7996736c 481 else if (sv == &PL_sv_yes) {
3967c732
JD		 482 sv_catpv(t, "SV_YES");
483 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
484 SVs_GMG|SVs_SMG|SVs_RMG)) &&
485 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
486 SVp_POK|SVp_NOK)) &&
487 SvCUR(sv) == 1 &&
b15aece3 488 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
3967c732
JD		 489 SvNVX(sv) == 1.0)
490 goto finish;
7996736c
MHM		 491 }
492 else {
493 sv_catpv(t, "SV_PLACEHOLDER");
494 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
495 SVs_GMG|SVs_SMG|SVs_RMG)) &&
496 SvREADONLY(sv))
497 goto finish;
3967c732
JD		 498 }
499 sv_catpv(t, ":");
500 }
501 else if (SvREFCNT(sv) == 0) {
502 sv_catpv(t, "(");
503 unref++;
504 }
a3b4c9c6
DM		 505 else if (DEBUG_R_TEST_) {
506 int is_tmp = 0;
507 I32 ix;
508 /* is this SV on the tmps stack? */
509 for (ix=PL_tmps_ix; ix>=0; ix--) {
510 if (PL_tmps_stack[ix] == sv) {
511 is_tmp = 1;
512 break;
513 }
514 }
515 if (SvREFCNT(sv) > 1)
516 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
517 is_tmp ? "T" : "");
518 else if (is_tmp)
519 sv_catpv(t, "<T>");
04932ac8
DM		 520 }
521
3967c732
JD		 522 if (SvROK(sv)) {
523 sv_catpv(t, "\\");
524 if (SvCUR(t) + unref > 10) {
b162af07 525 SvCUR_set(t, unref + 3);
3967c732
JD		 526 *SvEND(t) = '\0';
527 sv_catpv(t, "...");
528 goto finish;
529 }
ad64d0ec 530 sv = SvRV(sv);
3967c732
JD		 531 goto retry;
532 }
5357ca29
NC		 533 type = SvTYPE(sv);
534 if (type == SVt_PVCV) {
535 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
3967c732 536 goto finish;
5357ca29
NC		 537 } else if (type < SVt_LAST) {
538 sv_catpv(t, svshorttypenames[type]);
3967c732 539
5357ca29
NC		 540 if (type == SVt_NULL)
541 goto finish;
542 } else {
543 sv_catpv(t, "FREED");
3967c732 544 goto finish;
3967c732
JD		 545 }
546
547 if (SvPOKp(sv)) {
b15aece3 548 if (!SvPVX_const(sv))
3967c732
JD		 549 sv_catpv(t, "(null)");
550 else {
b9ac451d 551 SV * const tmp = newSVpvs("");
3967c732 552 sv_catpv(t, "(");
5115136b
DM		 553 if (SvOOK(sv)) {
554 STRLEN delta;
555 SvOOK_offset(sv, delta);
556 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
557 }
b15aece3 558 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
32639b87 559 if (SvUTF8(sv))
b2ff9928 560 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
e9569a7a 561 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
c728cb41 562 UNI_DISPLAY_QQ));
3967c732
JD		 563 SvREFCNT_dec(tmp);
564 }
565 }
566 else if (SvNOKp(sv)) {
e54dc35b 567 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 568 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
e54dc35b 569 RESTORE_NUMERIC_LOCAL();
3967c732 570 }
57def98f 571 else if (SvIOKp(sv)) {
cf2093f6 572 if (SvIsUV(sv))
57def98f 573 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
cf2093f6 574 else
57def98f 575 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
25da4f38 576 }
3967c732
JD		 577 else
578 sv_catpv(t, "()");
2ef28da1 579
3967c732 580 finish:
61f9802b
AL		 581 while (unref--)
582 sv_catpv(t, ")");
284167a5 583 if (TAINTING_get && SvTAINTED(sv))
59b714e2 584 sv_catpv(t, " [tainted]");
8b6b16e7 585 return SvPV_nolen(t);
3967c732
JD		 586}
587
588void
6867be6d 589Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
3967c732
JD		 590{
591 char ch;
592
7918f24d
NC		 593 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
594
3967c732 595 if (!pm) {
cea2e8a9 596 Perl_dump_indent(aTHX_ level, file, "{}\n");
3967c732
JD		 597 return;
598 }
cea2e8a9 599 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732
JD		 600 level++;
601 if (pm->op_pmflags & PMf_ONCE)
602 ch = '?';
603 else
604 ch = '/';
aaa362c4 605 if (PM_GETRE(pm))
cea2e8a9 606 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
220fc49f 607 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
3967c732
JD		 608 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
609 else
cea2e8a9 610 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
20e98b0f 611 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
cea2e8a9 612 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
20e98b0f 613 op_dump(pm->op_pmreplrootu.op_pmreplroot);
3967c732 614 }
68e2671b 615 if (pm->op_code_list) {
867940b8
DM		 616 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
617 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
618 do_op_dump(level, file, pm->op_code_list);
619 }
620 else
621 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
622 PTR2UV(pm->op_code_list));
68e2671b 623 }
07bc277f 624 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
4199688e 625 SV * const tmpsv = pm_description(pm);
b15aece3 626 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
3967c732
JD		 627 SvREFCNT_dec(tmpsv);
628 }
629
cea2e8a9 630 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732
JD		 631}
632
a0c2f4dd
NC		 633const struct flag_to_name pmflags_flags_names[] = {
634 {PMf_CONST, ",CONST"},
635 {PMf_KEEP, ",KEEP"},
636 {PMf_GLOBAL, ",GLOBAL"},
637 {PMf_CONTINUE, ",CONTINUE"},
638 {PMf_RETAINT, ",RETAINT"},
639 {PMf_EVAL, ",EVAL"},
640 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
d63c20f2 641 {PMf_HAS_CV, ",HAS_CV"},
2a92a973
DM		 642 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
643 {PMf_IS_QR, ",IS_QR"}
a0c2f4dd
NC		 644};
645
b9ac451d 646static SV *
4199688e
AL		 647S_pm_description(pTHX_ const PMOP *pm)
648{
649 SV * const desc = newSVpvs("");
61f9802b 650 const REGEXP * const regex = PM_GETRE(pm);
4199688e
AL		 651 const U32 pmflags = pm->op_pmflags;
652
7918f24d
NC		 653 PERL_ARGS_ASSERT_PM_DESCRIPTION;
654
4199688e
AL		 655 if (pmflags & PMf_ONCE)
656 sv_catpv(desc, ",ONCE");
c737faaf
YO		 657#ifdef USE_ITHREADS
658 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
659 sv_catpv(desc, ":USED");
660#else
661 if (pmflags & PMf_USED)
662 sv_catpv(desc, ":USED");
663#endif
c737faaf 664
68d4833d 665 if (regex) {
284167a5 666 if (RX_ISTAINTED(regex))
68d4833d 667 sv_catpv(desc, ",TAINTED");
07bc277f
NC		 668 if (RX_CHECK_SUBSTR(regex)) {
669 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
68d4833d 670 sv_catpv(desc, ",SCANFIRST");
07bc277f 671 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
68d4833d
AB		 672 sv_catpv(desc, ",ALL");
673 }
4199688e 674 }
68d4833d 675
a0c2f4dd 676 append_flags(desc, pmflags, pmflags_flags_names);
4199688e
AL		 677 return desc;
678}
679
3967c732 680void
864dbfa3 681Perl_pmop_dump(pTHX_ PMOP *pm)
3967c732
JD		 682{
683 do_pmop_dump(0, Perl_debug_log, pm);
79072805
LW		 684}
685
b6f05621
DM		 686/* Return a unique integer to represent the address of op o.
687 * If it already exists in PL_op_sequence, just return it;
688 * otherwise add it.
689 * *** Note that this isn't thread-safe */
294b3b39 690
2814eb74 691STATIC UV
0bd48802 692S_sequence_num(pTHX_ const OP *o)
2814eb74 693{
27da23d5 694 dVAR;
2814eb74
PJ		 695 SV *op,
696 **seq;
93524f2b 697 const char *key;
2814eb74 698 STRLEN len;
b6f05621
DM		 699 if (!o)
700 return 0;
c0fd1b42 701 op = newSVuv(PTR2UV(o));
b6f05621 702 sv_2mortal(op);
93524f2b 703 key = SvPV_const(op, len);
b6f05621
DM		 704 if (!PL_op_sequence)
705 PL_op_sequence = newHV();
706 seq = hv_fetch(PL_op_sequence, key, len, 0);
707 if (seq)
708 return SvUV(*seq);
709 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
710 return PL_op_seq;
2814eb74
PJ		 711}
712
a0c2f4dd
NC		 713const struct flag_to_name op_flags_names[] = {
714 {OPf_KIDS, ",KIDS"},
715 {OPf_PARENS, ",PARENS"},
a0c2f4dd
NC		 716 {OPf_REF, ",REF"},
717 {OPf_MOD, ",MOD"},
65cccc5e 718 {OPf_STACKED, ",STACKED"},
a0c2f4dd
NC		 719 {OPf_SPECIAL, ",SPECIAL"}
720};
721
ea9ad1f2 722const struct flag_to_name op_trans_names[] = {
65cccc5e
VP		 723 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
724 {OPpTRANS_TO_UTF, ",TO_UTF"},
725 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
ea9ad1f2 726 {OPpTRANS_SQUASH, ",SQUASH"},
ea9ad1f2 727 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
65cccc5e
VP		 728 {OPpTRANS_GROWS, ",GROWS"},
729 {OPpTRANS_DELETE, ",DELETE"}
ea9ad1f2
NC		 730};
731
732const struct flag_to_name op_entersub_names[] = {
ea9ad1f2
NC		 733 {OPpENTERSUB_DB, ",DB"},
734 {OPpENTERSUB_HASTARG, ",HASTARG"},
65cccc5e 735 {OPpENTERSUB_AMPER, ",AMPER"},
ea9ad1f2 736 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
65cccc5e 737 {OPpENTERSUB_INARGS, ",INARGS"}
ea9ad1f2
NC		 738};
739
740const struct flag_to_name op_const_names[] = {
65cccc5e
VP		 741 {OPpCONST_NOVER, ",NOVER"},
742 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
ea9ad1f2 743 {OPpCONST_STRICT, ",STRICT"},
65cccc5e 744 {OPpCONST_ENTERED, ",ENTERED"},
cc2ebcd7 745 {OPpCONST_FOLDED, ",FOLDED"},
63e0918d 746 {OPpCONST_BARE, ",BARE"}
ea9ad1f2
NC		 747};
748
749const struct flag_to_name op_sort_names[] = {
750 {OPpSORT_NUMERIC, ",NUMERIC"},
751 {OPpSORT_INTEGER, ",INTEGER"},
65cccc5e
VP		 752 {OPpSORT_REVERSE, ",REVERSE"},
753 {OPpSORT_INPLACE, ",INPLACE"},
754 {OPpSORT_DESCEND, ",DESCEND"},
755 {OPpSORT_QSORT, ",QSORT"},
756 {OPpSORT_STABLE, ",STABLE"}
ea9ad1f2
NC		 757};
758
759const struct flag_to_name op_open_names[] = {
760 {OPpOPEN_IN_RAW, ",IN_RAW"},
761 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
762 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
763 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
764};
765
261c990e
NC		 766const struct flag_to_name op_exit_names[] = {
767 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
768 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
769};
770
75a6ad4a
RU		 771const struct flag_to_name op_sassign_names[] = {
772 {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
773 {OPpASSIGN_CV_TO_GV, ",CV2GV"}
774};
775
261c990e
NC		 776#define OP_PRIVATE_ONCE(op, flag, name) \
777 const struct flag_to_name CAT2(op, _names)[] = { \
778 {(flag), (name)} \
f58883a1 779 }
261c990e
NC		 780
781OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
782OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
261c990e 783OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
65cccc5e 784OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
261c990e
NC		 785OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
786OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
787OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
788OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
789OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
790OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
791OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
792
1fe3abee
NC		 793struct op_private_by_op {
794 U16 op_type;
795 U16 len;
796 const struct flag_to_name *start;
797};
798
799const struct op_private_by_op op_private_names[] = {
261c990e
NC		 800 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
801 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
802 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
804 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
805 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
806 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
807 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
808 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
809 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
810 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
811 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
812 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
813 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
814 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
815 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
1fe3abee
NC		 816 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
817 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
818 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
819 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
820 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
821};
822
823static bool
824S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
825 const struct op_private_by_op *start = op_private_names;
826 const struct op_private_by_op *const end
827 = op_private_names + C_ARRAY_LENGTH(op_private_names);
828
829 /* This is a linear search, but no worse than the code that it replaced.
830 It's debugging code - size is more important than speed. */
831 do {
832 if (optype == start->op_type) {
833 S_append_flags(aTHX_ tmpsv, op_private, start->start,
834 start->start + start->len);
835 return TRUE;
836 }
837 } while (++start < end);
838 return FALSE;
839}
840
75a6ad4a
RU		 841#define DUMP_OP_FLAGS(o,xml,level,file) \
842 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
843 SV * const tmpsv = newSVpvs(""); \
844 switch (o->op_flags & OPf_WANT) { \
845 case OPf_WANT_VOID: \
846 sv_catpv(tmpsv, ",VOID"); \
847 break; \
848 case OPf_WANT_SCALAR: \
849 sv_catpv(tmpsv, ",SCALAR"); \
850 break; \
851 case OPf_WANT_LIST: \
852 sv_catpv(tmpsv, ",LIST"); \
853 break; \
854 default: \
855 sv_catpv(tmpsv, ",UNKNOWN"); \
856 break; \
857 } \
858 append_flags(tmpsv, o->op_flags, op_flags_names); \
859 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
860 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
861 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
862 if (!xml) \
863 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
864 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
865 else \
866 PerlIO_printf(file, " flags=\"%s\"", \
867 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
868 SvREFCNT_dec(tmpsv); \
869 }
870
871#if !defined(PERL_MAD)
09c75956
FC		 872# define xmldump_attr1(level, file, pat, arg)
873#else
874# define xmldump_attr1(level, file, pat, arg) \
875 S_xmldump_attr(aTHX_ level, file, pat, arg)
75a6ad4a
RU		 876#endif
877
878#define DUMP_OP_PRIVATE(o,xml,level,file) \
879 if (o->op_private) { \
880 U32 optype = o->op_type; \
881 U32 oppriv = o->op_private; \
882 SV * const tmpsv = newSVpvs(""); \
883 if (PL_opargs[optype] & OA_TARGLEX) { \
884 if (oppriv & OPpTARGET_MY) \
885 sv_catpv(tmpsv, ",TARGET_MY"); \
886 } \
887 else if (optype == OP_ENTERSUB || \
888 optype == OP_RV2SV || \
889 optype == OP_GVSV || \
890 optype == OP_RV2AV || \
891 optype == OP_RV2HV || \
892 optype == OP_RV2GV || \
893 optype == OP_AELEM || \
894 optype == OP_HELEM ) \
895 { \
896 if (optype == OP_ENTERSUB) { \
897 append_flags(tmpsv, oppriv, op_entersub_names); \
898 } \
899 else { \
900 switch (oppriv & OPpDEREF) { \
901 case OPpDEREF_SV: \
902 sv_catpv(tmpsv, ",SV"); \
903 break; \
904 case OPpDEREF_AV: \
905 sv_catpv(tmpsv, ",AV"); \
906 break; \
907 case OPpDEREF_HV: \
908 sv_catpv(tmpsv, ",HV"); \
909 break; \
910 } \
911 if (oppriv & OPpMAYBE_LVSUB) \
912 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
913 } \
914 if (optype == OP_AELEM || optype == OP_HELEM) { \
915 if (oppriv & OPpLVAL_DEFER) \
916 sv_catpv(tmpsv, ",LVAL_DEFER"); \
917 } \
918 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
919 if (oppriv & OPpMAYBE_TRUEBOOL) \
920 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
921 if (oppriv & OPpTRUEBOOL) \
922 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
923 } \
924 else { \
925 if (oppriv & HINT_STRICT_REFS) \
926 sv_catpv(tmpsv, ",STRICT_REFS"); \
927 if (oppriv & OPpOUR_INTRO) \
928 sv_catpv(tmpsv, ",OUR_INTRO"); \
929 } \
930 } \
931 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
932 } \
933 else if (OP_IS_FILETEST(o->op_type)) { \
934 if (oppriv & OPpFT_ACCESS) \
935 sv_catpv(tmpsv, ",FT_ACCESS"); \
936 if (oppriv & OPpFT_STACKED) \
937 sv_catpv(tmpsv, ",FT_STACKED"); \
938 if (oppriv & OPpFT_STACKING) \
939 sv_catpv(tmpsv, ",FT_STACKING"); \
940 if (oppriv & OPpFT_AFTER_t) \
941 sv_catpv(tmpsv, ",AFTER_t"); \
942 } \
943 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
944 sv_catpv(tmpsv, ",INTRO"); \
945 if (o->op_type == OP_PADRANGE) \
946 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
947 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
948 if (SvCUR(tmpsv)) { \
949 if (xml) \
09c75956 950 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
75a6ad4a
RU		 951 else \
952 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
953 } else if (!xml) \
954 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
955 (UV)oppriv); \
956 SvREFCNT_dec(tmpsv); \
957 }
958
959
79072805 960void
6867be6d 961Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
79072805 962{
27da23d5 963 dVAR;
2814eb74 964 UV seq;
e15d5972
AL		 965 const OPCODE optype = o->op_type;
966
7918f24d
NC		 967 PERL_ARGS_ASSERT_DO_OP_DUMP;
968
cea2e8a9 969 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732 970 level++;
0bd48802 971 seq = sequence_num(o);
2814eb74 972 if (seq)
f5992bc4 973 PerlIO_printf(file, "%-4"UVuf, seq);
93a17b20 974 else
b6f05621 975 PerlIO_printf(file, "????");
c8db6e60
JH		 976 PerlIO_printf(file,
977 "%*sTYPE = %s ===> ",
53e06cf0 978 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
2814eb74 979 if (o->op_next)
b6f05621
DM		 980 PerlIO_printf(file,
981 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
666ea192 982 sequence_num(o->op_next));
79072805 983 else
e75ab6ad 984 PerlIO_printf(file, "NULL\n");
11343788 985 if (o->op_targ) {
e15d5972 986 if (optype == OP_NULL) {
cea2e8a9 987 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
e15d5972 988 if (o->op_targ == OP_NEXTSTATE) {
ae7d165c 989 if (CopLINE(cCOPo))
f5992bc4 990 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 991 (UV)CopLINE(cCOPo));
ae7d165c
PJ		 992 if (CopSTASHPV(cCOPo))
993 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
994 CopSTASHPV(cCOPo));
4b65a919 995 if (CopLABEL(cCOPo))
ae7d165c 996 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
4b65a919 997 CopLABEL(cCOPo));
ae7d165c
PJ		 998 }
999 }
8990e307 1000 else
894356b3 1001 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
8990e307 1002 }
748a9306 1003#ifdef DUMPADDR
57def98f 1004 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
79072805 1005#endif
a7fd8ef6 1006
75a6ad4a
RU		 1007 DUMP_OP_FLAGS(o,0,level,file);
1008 DUMP_OP_PRIVATE(o,0,level,file);
8d063cd8 1009
3b721df9
NC		 1010#ifdef PERL_MAD
1011 if (PL_madskills && o->op_madprop) {
76f68e9b 1012 SV * const tmpsv = newSVpvs("");
3b721df9
NC		 1013 MADPROP* mp = o->op_madprop;
1014 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1015 level++;
1016 while (mp) {
61f9802b 1017 const char tmp = mp->mad_key;
76f68e9b 1018 sv_setpvs(tmpsv,"'");
3b721df9
NC		 1019 if (tmp)
1020 sv_catpvn(tmpsv, &tmp, 1);
1021 sv_catpv(tmpsv, "'=");
1022 switch (mp->mad_type) {
1023 case MAD_NULL:
1024 sv_catpv(tmpsv, "NULL");
1025 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1026 break;
1027 case MAD_PV:
1028 sv_catpv(tmpsv, "<");
1029 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1030 sv_catpv(tmpsv, ">");
1031 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1032 break;
1033 case MAD_OP:
1034 if ((OP*)mp->mad_val) {
1035 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1036 do_op_dump(level, file, (OP*)mp->mad_val);
1037 }
1038 break;
1039 default:
1040 sv_catpv(tmpsv, "(UNK)");
1041 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1042 break;
1043 }
1044 mp = mp->mad_next;
1045 }
1046 level--;
1047 Perl_dump_indent(aTHX_ level, file, "}\n");
1048
1049 SvREFCNT_dec(tmpsv);
1050 }
1051#endif
1052
e15d5972 1053 switch (optype) {
971a9dd3 1054 case OP_AELEMFAST:
93a17b20 1055 case OP_GVSV:
79072805 1056 case OP_GV:
971a9dd3 1057#ifdef USE_ITHREADS
c803eecc 1058 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
971a9dd3 1059#else
1640e9f0 1060 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
38c076c7 1061 if (cSVOPo->op_sv) {
d4c19fe8 1062 SV * const tmpsv = newSV(0);
38c076c7
DM		 1063 ENTER;
1064 SAVEFREESV(tmpsv);
3b721df9 1065#ifdef PERL_MAD
84021b46 1066 /* FIXME - is this making unwarranted assumptions about the
3b721df9
NC		 1067 UTF-8 cleanliness of the dump file handle? */
1068 SvUTF8_on(tmpsv);
1069#endif
159b6efe 1070 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
8b6b16e7 1071 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
d5263905 1072 SvPV_nolen_const(tmpsv));
38c076c7
DM		 1073 LEAVE;
1074 }
1075 else
1076 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
378cc40b 1077 }
971a9dd3 1078#endif
79072805
LW		 1079 break;
1080 case OP_CONST:
996c9baa 1081 case OP_HINTSEVAL:
f5d5a27c 1082 case OP_METHOD_NAMED:
b6a15bc5
DM		 1083#ifndef USE_ITHREADS
1084 /* with ITHREADS, consts are stored in the pad, and the right pad
1085 * may not be active here, so skip */
3848b962 1086 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
b6a15bc5 1087#endif
79072805 1088 break;
93a17b20
LW		 1089 case OP_NEXTSTATE:
1090 case OP_DBSTATE:
57843af0 1091 if (CopLINE(cCOPo))
f5992bc4 1092 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 1093 (UV)CopLINE(cCOPo));
ed094faf
GS		 1094 if (CopSTASHPV(cCOPo))
1095 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1096 CopSTASHPV(cCOPo));
4b65a919 1097 if (CopLABEL(cCOPo))
ed094faf 1098 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
4b65a919 1099 CopLABEL(cCOPo));
79072805
LW		 1100 break;
1101 case OP_ENTERLOOP:
cea2e8a9 1102 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
11343788 1103 if (cLOOPo->op_redoop)
f5992bc4 1104 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
79072805 1105 else
3967c732 1106 PerlIO_printf(file, "DONE\n");
cea2e8a9 1107 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
11343788 1108 if (cLOOPo->op_nextop)
f5992bc4 1109 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
79072805 1110 else
3967c732 1111 PerlIO_printf(file, "DONE\n");
cea2e8a9 1112 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
11343788 1113 if (cLOOPo->op_lastop)
f5992bc4 1114 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
79072805 1115 else
3967c732 1116 PerlIO_printf(file, "DONE\n");
79072805
LW		 1117 break;
1118 case OP_COND_EXPR:
1a67a97c 1119 case OP_RANGE:
a0d0e21e 1120 case OP_MAPWHILE:
79072805
LW		 1121 case OP_GREPWHILE:
1122 case OP_OR:
1123 case OP_AND:
cea2e8a9 1124 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
11343788 1125 if (cLOGOPo->op_other)
f5992bc4 1126 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
79072805 1127 else
3967c732 1128 PerlIO_printf(file, "DONE\n");
79072805
LW		 1129 break;
1130 case OP_PUSHRE:
1131 case OP_MATCH:
8782bef2 1132 case OP_QR:
79072805 1133 case OP_SUBST:
3967c732 1134 do_pmop_dump(level, file, cPMOPo);
79072805 1135 break;
7934575e
GS		 1136 case OP_LEAVE:
1137 case OP_LEAVEEVAL:
1138 case OP_LEAVESUB:
1139 case OP_LEAVESUBLV:
1140 case OP_LEAVEWRITE:
1141 case OP_SCOPE:
1142 if (o->op_private & OPpREFCOUNTED)
1143 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1144 break;
a0d0e21e
LW		 1145 default:
1146 break;
79072805 1147 }
11343788 1148 if (o->op_flags & OPf_KIDS) {
79072805 1149 OP *kid;
11343788 1150 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3967c732 1151 do_op_dump(level, file, kid);
8d063cd8 1152 }
cea2e8a9 1153 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732
JD		 1154}
1155
1156void
6867be6d 1157Perl_op_dump(pTHX_ const OP *o)
3967c732 1158{
7918f24d 1159 PERL_ARGS_ASSERT_OP_DUMP;
3967c732 1160 do_op_dump(0, Perl_debug_log, o);
8d063cd8
LW		 1161}
1162
8adcabd8 1163void
864dbfa3 1164Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1165{
79072805 1166 SV *sv;
378cc40b 1167
7918f24d
NC		 1168 PERL_ARGS_ASSERT_GV_DUMP;
1169
79072805 1170 if (!gv) {
760ac839 1171 PerlIO_printf(Perl_debug_log, "{}\n");
378cc40b
LW		 1172 return;
1173 }
8990e307 1174 sv = sv_newmortal();
760ac839 1175 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1176 gv_fullname3(sv, gv, NULL);
b15aece3 1177 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
79072805 1178 if (gv != GvEGV(gv)) {
bd61b366 1179 gv_efullname3(sv, GvEGV(gv), NULL);
b15aece3 1180 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
8adcabd8 1181 }
3967c732 1182 PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1183 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8
LW		 1184}
1185
14befaf4 1186
afe38520 1187/* map magic types to the symbolic names
14befaf4
DM		 1188 * (with the PERL_MAGIC_ prefixed stripped)
1189 */
1190
27da23d5 1191static const struct { const char type; const char *name; } magic_names[] = {
52f49505 1192#include "mg_names.c"
516a5887 1193 /* this null string terminates the list */
b9ac451d 1194 { 0, NULL },
14befaf4
DM		 1195};
1196
8adcabd8 1197void
6867be6d 1198Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1199{
7918f24d
NC		 1200 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1201
3967c732 1202 for (; mg; mg = mg->mg_moremagic) {
b900a521
JH		 1203 Perl_dump_indent(aTHX_ level, file,
1204 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
3967c732 1205 if (mg->mg_virtual) {
bfed75c6 1206 const MGVTBL * const v = mg->mg_virtual;
2d1f1fe5
NC		 1207 if (v >= PL_magic_vtables
1208 && v < PL_magic_vtables + magic_vtable_max) {
1209 const U32 i = v - PL_magic_vtables;
1210 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1211 }
3967c732 1212 else
b900a521 1213 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
3967c732
JD		 1214 }
1215 else
cea2e8a9 1216 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1217
3967c732 1218 if (mg->mg_private)
cea2e8a9 1219 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1220
14befaf4
DM		 1221 {
1222 int n;
c445ea15 1223 const char *name = NULL;
27da23d5 1224 for (n = 0; magic_names[n].name; n++) {
14befaf4
DM		 1225 if (mg->mg_type == magic_names[n].type) {
1226 name = magic_names[n].name;
1227 break;
1228 }
1229 }
1230 if (name)
1231 Perl_dump_indent(aTHX_ level, file,
1232 " MG_TYPE = PERL_MAGIC_%s\n", name);
1233 else
1234 Perl_dump_indent(aTHX_ level, file,
1235 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1236 }
3967c732
JD		 1237
1238 if (mg->mg_flags) {
cea2e8a9 1239 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d
YST		 1240 if (mg->mg_type == PERL_MAGIC_envelem &&
1241 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1242 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
4c02285a
FR		 1243 if (mg->mg_type == PERL_MAGIC_regex_global &&
1244 mg->mg_flags & MGf_MINMATCH)
1245 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1246 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1247 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1248 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1249 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
4c02285a
FR		 1250 if (mg->mg_flags & MGf_COPY)
1251 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1252 if (mg->mg_flags & MGf_DUP)
1253 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1254 if (mg->mg_flags & MGf_LOCAL)
1255 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
3967c732
JD		 1256 }
1257 if (mg->mg_obj) {
4c02285a 1258 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
28d8d7f4
YO		 1259 PTR2UV(mg->mg_obj));
1260 if (mg->mg_type == PERL_MAGIC_qr) {
07bc277f 1261 REGEXP* const re = (REGEXP *)mg->mg_obj;
61f9802b 1262 SV * const dsv = sv_newmortal();
866c78d1 1263 const char * const s
4c02285a 1264 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1265 60, NULL, NULL,
95b611b0 1266 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1267 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1268 );
6483fb35
RGS		 1269 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1270 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
07bc277f 1271 (IV)RX_REFCNT(re));
28d8d7f4
YO		 1272 }
1273 if (mg->mg_flags & MGf_REFCOUNTED)
3967c732
JD		 1274 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1275 }
1276 if (mg->mg_len)
894356b3 1277 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1278 if (mg->mg_ptr) {
b900a521 1279 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
3967c732 1280 if (mg->mg_len >= 0) {
7e8c5dac 1281 if (mg->mg_type != PERL_MAGIC_utf8) {
61f9802b 1282 SV * const sv = newSVpvs("");
7e8c5dac
HS		 1283 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1284 SvREFCNT_dec(sv);
1285 }
3967c732
JD		 1286 }
1287 else if (mg->mg_len == HEf_SVKEY) {
1288 PerlIO_puts(file, " => HEf_SVKEY\n");
ad64d0ec
NC		 1289 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1290 maxnest, dumpops, pvlim); /* MG is already +1 */
3967c732
JD		 1291 continue;
1292 }
866f9d6c 1293 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
3967c732 1294 else
866f9d6c
FC		 1295 PerlIO_puts(
1296 file,
1297 " ???? - " __FILE__
1298 " does not know how to handle this MG_LEN"
1299 );
3967c732
JD		 1300 PerlIO_putc(file, '\n');
1301 }
7e8c5dac 1302 if (mg->mg_type == PERL_MAGIC_utf8) {
61f9802b 1303 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7e8c5dac
HS		 1304 if (cache) {
1305 IV i;
1306 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1307 Perl_dump_indent(aTHX_ level, file,
1308 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1309 i,
1310 (UV)cache[i * 2],
1311 (UV)cache[i * 2 + 1]);
1312 }
1313 }
378cc40b 1314 }
3967c732
JD		 1315}
1316
1317void
6867be6d 1318Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1319{
b9ac451d 1320 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD		 1321}
1322
1323void
e1ec3a88 1324Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1325{
bfcb3514 1326 const char *hvname;
7918f24d
NC		 1327
1328 PERL_ARGS_ASSERT_DO_HV_DUMP;
1329
b900a521 1330 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
bfcb3514 1331 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b
YO		 1332 {
1333 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1334 name which quite legally could contain insane things like tabs, newlines, nulls or
1335 other scary crap - this should produce sane results - except maybe for unicode package
1336 names - but we will wait for someone to file a bug on that - demerphq */
1337 SV * const tmpsv = newSVpvs("");
1338 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1339 }
79072805 1340 else
3967c732
JD		 1341 PerlIO_putc(file, '\n');
1342}
1343
1344void
e1ec3a88 1345Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1346{
7918f24d
NC		 1347 PERL_ARGS_ASSERT_DO_GV_DUMP;
1348
b900a521 1349 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732
JD		 1350 if (sv && GvNAME(sv))
1351 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
c90c0ff4 1352 else
3967c732
JD		 1353 PerlIO_putc(file, '\n');
1354}
1355
1356void
e1ec3a88 1357Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1358{
7918f24d
NC		 1359 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1360
b900a521 1361 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732 1362 if (sv && GvNAME(sv)) {
bfcb3514 1363 const char *hvname;
3967c732 1364 PerlIO_printf(file, "\t\"");
bfcb3514
NC		 1365 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1366 PerlIO_printf(file, "%s\" :: \"", hvname);
3967c732 1367 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
8d063cd8 1368 }
3967c732
JD		 1369 else
1370 PerlIO_putc(file, '\n');
1371}
1372
a0c2f4dd
NC		 1373const struct flag_to_name first_sv_flags_names[] = {
1374 {SVs_TEMP, "TEMP,"},
1375 {SVs_OBJECT, "OBJECT,"},
1376 {SVs_GMG, "GMG,"},
1377 {SVs_SMG, "SMG,"},
1378 {SVs_RMG, "RMG,"},
1379 {SVf_IOK, "IOK,"},
1380 {SVf_NOK, "NOK,"},
1381 {SVf_POK, "POK,"}
1382};
1383
1384const struct flag_to_name second_sv_flags_names[] = {
1385 {SVf_OOK, "OOK,"},
1386 {SVf_FAKE, "FAKE,"},
1387 {SVf_READONLY, "READONLY,"},
e3918bb7 1388 {SVf_IsCOW, "IsCOW,"},
a0c2f4dd
NC		 1389 {SVf_BREAK, "BREAK,"},
1390 {SVf_AMAGIC, "OVERLOAD,"},
1391 {SVp_IOK, "pIOK,"},
1392 {SVp_NOK, "pNOK,"},
1393 {SVp_POK, "pPOK,"}
1394};
1395
ae1f06a1
NC		 1396const struct flag_to_name cv_flags_names[] = {
1397 {CVf_ANON, "ANON,"},
1398 {CVf_UNIQUE, "UNIQUE,"},
1399 {CVf_CLONE, "CLONE,"},
1400 {CVf_CLONED, "CLONED,"},
1401 {CVf_CONST, "CONST,"},
1402 {CVf_NODEBUG, "NODEBUG,"},
1403 {CVf_LVALUE, "LVALUE,"},
1404 {CVf_METHOD, "METHOD,"},
cfc1e951 1405 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1406 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1407 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1408 {CVf_AUTOLOAD, "AUTOLOAD,"},
55f7f8ab 1409 {CVf_HASEVAL, "HASEVAL"},
bfbc3ad9 1410 {CVf_SLABBED, "SLABBED,"},
31d45e0c 1411 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC		 1412};
1413
1414const struct flag_to_name hv_flags_names[] = {
1415 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1416 {SVphv_LAZYDEL, "LAZYDEL,"},
1417 {SVphv_HASKFLAGS, "HASKFLAGS,"},
ae1f06a1
NC		 1418 {SVphv_CLONEABLE, "CLONEABLE,"}
1419};
1420
1421const struct flag_to_name gp_flags_names[] = {
1422 {GVf_INTRO, "INTRO,"},
1423 {GVf_MULTI, "MULTI,"},
1424 {GVf_ASSUMECV, "ASSUMECV,"},
1425 {GVf_IN_PAD, "IN_PAD,"}
1426};
1427
1428const struct flag_to_name gp_flags_imported_names[] = {
1429 {GVf_IMPORTED_SV, " SV"},
1430 {GVf_IMPORTED_AV, " AV"},
1431 {GVf_IMPORTED_HV, " HV"},
1432 {GVf_IMPORTED_CV, " CV"},
1433};
1434
d63e6659
DM		 1435const struct flag_to_name regexp_flags_names[] = {
1436 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1437 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1438 {RXf_PMf_FOLD, "PMf_FOLD,"},
1439 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1440 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1441 {RXf_ANCH_BOL, "ANCH_BOL,"},
1442 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1443 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1444 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1445 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1446 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1447 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1448 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1449 {RXf_CANY_SEEN, "CANY_SEEN,"},
1450 {RXf_NOSCAN, "NOSCAN,"},
1451 {RXf_CHECK_ALL, "CHECK_ALL,"},
1452 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1453 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1454 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1455 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
d63e6659
DM		 1456 {RXf_COPY_DONE, "COPY_DONE,"},
1457 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1458 {RXf_TAINTED, "TAINTED,"},
1459 {RXf_START_ONLY, "START_ONLY,"},
d63e6659
DM		 1460 {RXf_WHITE, "WHITE,"},
1461 {RXf_NULL, "NULL,"},
1462};
1463
3967c732 1464void
864dbfa3 1465Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1466{
97aff369 1467 dVAR;
cea89e20 1468 SV *d;
e1ec3a88 1469 const char *s;
3967c732
JD		 1470 U32 flags;
1471 U32 type;
1472
7918f24d
NC		 1473 PERL_ARGS_ASSERT_DO_SV_DUMP;
1474
3967c732 1475 if (!sv) {
cea2e8a9 1476 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1477 return;
378cc40b 1478 }
2ef28da1 1479
3967c732
JD		 1480 flags = SvFLAGS(sv);
1481 type = SvTYPE(sv);
79072805 1482
e0bbf362
DM		 1483 /* process general SV flags */
1484
cea89e20 1485 d = Perl_newSVpvf(aTHX_
57def98f 1486 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
56431972 1487 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS		 1488 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1489 (int)(PL_dumpindent*level), "");
8d063cd8 1490
1979170b
NC		 1491 if (!((flags & SVpad_NAME) == SVpad_NAME
1492 && (type == SVt_PVMG || type == SVt_PVNV))) {
9a214eec
DM		 1493 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1494 sv_catpv(d, "PADSTALE,");
e604303a 1495 }
1979170b 1496 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
9a214eec
DM		 1497 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1498 sv_catpv(d, "PADTMP,");
e604303a
NC		 1499 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1500 }
a0c2f4dd 1501 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS		 1502 if (flags & SVf_ROK) {
1503 sv_catpv(d, "ROK,");
1504 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1505 }
a0c2f4dd 1506 append_flags(d, flags, second_sv_flags_names);
1ccdb730
NC		 1507 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1508 if (SvPCS_IMPORTED(sv))
1509 sv_catpv(d, "PCS_IMPORTED,");
1510 else
9660f481 1511 sv_catpv(d, "SCREAM,");
1ccdb730 1512 }
3967c732 1513
e0bbf362
DM		 1514 /* process type-specific SV flags */
1515
3967c732
JD		 1516 switch (type) {
1517 case SVt_PVCV:
1518 case SVt_PVFM:
ae1f06a1 1519 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD		 1520 break;
1521 case SVt_PVHV:
ae1f06a1 1522 append_flags(d, flags, hv_flags_names);
3967c732 1523 break;
926fc7b6
DM		 1524 case SVt_PVGV:
1525 case SVt_PVLV:
1526 if (isGV_with_GP(sv)) {
ae1f06a1 1527 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1528 }
926fc7b6 1529 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD		 1530 sv_catpv(d, "IMPORT");
1531 if (GvIMPORTED(sv) == GVf_IMPORTED)
1532 sv_catpv(d, "ALL,");
1533 else {
1534 sv_catpv(d, "(");
ae1f06a1 1535 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD		 1536 sv_catpv(d, " ),");
1537 }
1538 }
addd1794 1539 /* FALL THROUGH */
25da4f38 1540 default:
e604303a 1541 evaled_or_uv:
25da4f38 1542 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
69c678eb 1543 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1544 break;
addd1794 1545 case SVt_PVMG:
c13a5c80
NC		 1546 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1547 if (SvVALID(sv)) sv_catpv(d, "VALID,");
00b1698f 1548 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
e604303a 1549 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
2e94196c 1550 /* FALL THROUGH */
e604303a
NC		 1551 case SVt_PVNV:
1552 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1553 goto evaled_or_uv;
11ca45c0
NC		 1554 case SVt_PVAV:
1555 break;
3967c732 1556 }
86f0d186
NC		 1557 /* SVphv_SHAREKEYS is also 0x20000000 */
1558 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1559 sv_catpv(d, "UTF8");
3967c732 1560
b162af07
SP		 1561 if (*(SvEND(d) - 1) == ',') {
1562 SvCUR_set(d, SvCUR(d) - 1);
1563 SvPVX(d)[SvCUR(d)] = '\0';
1564 }
3967c732 1565 sv_catpv(d, ")");
b15aece3 1566 s = SvPVX_const(d);
3967c732 1567
e0bbf362
DM		 1568 /* dump initial SV details */
1569
fd0854ff 1570#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1571 Perl_dump_indent(aTHX_ level, file,
cd676548 1572 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
fd0854ff
DM		 1573 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1574 sv->sv_debug_line,
1575 sv->sv_debug_inpad ? "for" : "by",
1576 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1577 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM		 1578 sv->sv_debug_serial
1579 );
fd0854ff 1580#endif
cea2e8a9 1581 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM		 1582
1583 /* Dump SV type */
1584
5357ca29
NC		 1585 if (type < SVt_LAST) {
1586 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1587
1588 if (type == SVt_NULL) {
1589 SvREFCNT_dec(d);
1590 return;
1591 }
1592 } else {
faccc32b 1593 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
cea89e20 1594 SvREFCNT_dec(d);
3967c732
JD		 1595 return;
1596 }
e0bbf362
DM		 1597
1598 /* Dump general SV fields */
1599
27bd069f 1600 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC		 1601 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1602 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1603 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1604 if (SvIsUV(sv)
f8c7b90f 1605#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC		 1606 || SvIsCOW(sv)
1607#endif
1608 )
57def98f 1609 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1610 else
57def98f 1611 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
f8c7b90f 1612#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC		 1613 if (SvIsCOW_shared_hash(sv))
1614 PerlIO_printf(file, " (HASH)");
1615 else if (SvIsCOW_normal(sv))
1616 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1617#endif
3967c732
JD		 1618 PerlIO_putc(file, '\n');
1619 }
e0bbf362 1620
1979170b
NC		 1621 if ((type == SVt_PVNV || type == SVt_PVMG)
1622 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
0e4c4423
NC		 1623 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1624 (UV) COP_SEQ_RANGE_LOW(sv));
1625 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1626 (UV) COP_SEQ_RANGE_HIGH(sv));
1627 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1628 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1629 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1630 || type == SVt_NV) {
e54dc35b 1631 STORE_NUMERIC_LOCAL_SET_STANDARD();
57def98f 1632 /* %Vg doesn't work? --jhi */
cf2093f6 1633#ifdef USE_LONG_DOUBLE
2d4389e4 1634 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
cf2093f6 1635#else
cea2e8a9 1636 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
cf2093f6 1637#endif
e54dc35b 1638 RESTORE_NUMERIC_LOCAL();
3967c732 1639 }
e0bbf362 1640
3967c732 1641 if (SvROK(sv)) {
57def98f 1642 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732
JD		 1643 if (nest < maxnest)
1644 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1645 }
e0bbf362 1646
cea89e20
JH		 1647 if (type < SVt_PV) {
1648 SvREFCNT_dec(d);
3967c732 1649 return;
cea89e20 1650 }
e0bbf362 1651
dea823b3 1652 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
8d919b0a
FC		 1653 const bool re = isREGEXP(sv);
1654 const char * const ptr =
1655 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1656 if (ptr) {
69240efd 1657 STRLEN delta;
7a4bba22 1658 if (SvOOK(sv)) {
69240efd 1659 SvOOK_offset(sv, delta);
7a4bba22 1660 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
5186cc12 1661 (UV) delta);
69240efd
NC		 1662 } else {
1663 delta = 0;
7a4bba22 1664 }
8d919b0a 1665 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
7a4bba22
NC		 1666 if (SvOOK(sv)) {
1667 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1668 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC		 1669 pvlim));
1670 }
8d919b0a
FC		 1671 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1672 re ? 0 : SvLEN(sv),
1673 pvlim));
e9569a7a
GG		 1674 if (SvUTF8(sv)) /* the 6? \x{....} */
1675 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
e6abe6d8 1676 PerlIO_printf(file, "\n");
57def98f 1677 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
8d919b0a
FC		 1678 if (!re)
1679 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1680 (IV)SvLEN(sv));
db2c6cb3
FC		 1681#ifdef PERL_NEW_COPY_ON_WRITE
1682 if (SvIsCOW(sv) && SvLEN(sv))
1683 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1684 CowREFCNT(sv));
1685#endif
3967c732
JD		 1686 }
1687 else
cea2e8a9 1688 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1689 }
e0bbf362 1690
3967c732 1691 if (type >= SVt_PVMG) {
0e4c4423 1692 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
61f9802b 1693 HV * const ost = SvOURSTASH(sv);
38cbaf55
RGS		 1694 if (ost)
1695 do_hv_dump(level, file, " OURSTASH", ost);
0e4c4423
NC		 1696 } else {
1697 if (SvMAGIC(sv))
8530ff28 1698 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
0e4c4423 1699 }
3967c732
JD		 1700 if (SvSTASH(sv))
1701 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC		 1702
1703 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1704 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1705 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1706 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1707 }
3967c732 1708 }
e0bbf362
DM		 1709
1710 /* Dump type-specific SV fields */
1711
3967c732 1712 switch (type) {
3967c732 1713 case SVt_PVAV:
57def98f 1714 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1715 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f
JH		 1716 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1717 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732
JD		 1718 }
1719 else
1720 PerlIO_putc(file, '\n');
57def98f
JH		 1721 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1722 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
a3874608 1723 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
76f68e9b 1724 sv_setpvs(d, "");
11ca45c0
NC		 1725 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1726 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP		 1727 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1728 SvCUR(d) ? SvPVX_const(d) + 1 : "");
502c6561 1729 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
3967c732 1730 int count;
502c6561
NC		 1731 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1732 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
3967c732 1733
57def98f 1734 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
2ef28da1 1735 if (elt)
3967c732
JD		 1736 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1737 }
1738 }
1739 break;
1740 case SVt_PVHV:
57def98f 1741 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1b95d04f 1742 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
3967c732
JD		 1743 /* Show distribution of HEs in the ARRAY */
1744 int freq[200];
bb7a0f54 1745#define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
3967c732
JD		 1746 int i;
1747 int max = 0;
1b95d04f 1748 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
65202027 1749 NV theoret, sum = 0;
3967c732
JD		 1750
1751 PerlIO_printf(file, " (");
1752 Zero(freq, FREQ_MAX + 1, int);
eb160463 1753 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL		 1754 HE* h;
1755 int count = 0;
3967c732
JD		 1756 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1757 count++;
1758 if (count > FREQ_MAX)
1759 count = FREQ_MAX;
1760 freq[count]++;
1761 if (max < count)
1762 max = count;
1763 }
1764 for (i = 0; i <= max; i++) {
1765 if (freq[i]) {
1766 PerlIO_printf(file, "%d%s:%d", i,
1767 (i == FREQ_MAX) ? "+" : "",
1768 freq[i]);
1769 if (i != max)
1770 PerlIO_printf(file, ", ");
1771 }
1772 }
1773 PerlIO_putc(file, ')');
b8fa94d8
MG		 1774 /* The "quality" of a hash is defined as the total number of
1775 comparisons needed to access every element once, relative
1776 to the expected number needed for a random hash.
1777
1778 The total number of comparisons is equal to the sum of
e76cd0fa
AMS		 1779 the squares of the number of entries in each bucket.
1780 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG		 1781 value is
1782 n + n(n-1)/2k
1783 */
1784
3967c732
JD		 1785 for (i = max; i > 0; i--) { /* Precision: count down. */
1786 sum += freq[i] * i * i;
1787 }
155aba94 1788 while ((keys = keys >> 1))
3967c732 1789 pow2 = pow2 << 1;
1b95d04f 1790 theoret = HvUSEDKEYS(sv);
b8fa94d8 1791 theoret += theoret * (theoret-1)/pow2;
3967c732 1792 PerlIO_putc(file, '\n');
6b4667fc 1793 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732
JD		 1794 }
1795 PerlIO_putc(file, '\n');
1b95d04f 1796 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
57def98f
JH		 1797 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1798 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
bfcb3514
NC		 1799 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1800 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
8d2f4536 1801 {
b9ac451d 1802 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536
NC		 1803 if (mg && mg->mg_obj) {
1804 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1805 }
1806 }
bfcb3514 1807 {
b9ac451d 1808 const char * const hvname = HvNAME_get(sv);
bfcb3514
NC		 1809 if (hvname)
1810 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1811 }
86f55936 1812 if (SvOOK(sv)) {
ad64d0ec 1813 AV * const backrefs
85fbaab2 1814 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1815 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC		 1816 if (HvAUX(sv)->xhv_name_count)
1817 Perl_dump_indent(aTHX_
7afc2217
FC		 1818 level, file, " NAMECOUNT = %"IVdf"\n",
1819 (IV)HvAUX(sv)->xhv_name_count
67e04715 1820 );
15d9236d 1821 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC		 1822 const I32 count = HvAUX(sv)->xhv_name_count;
1823 if (count) {
1824 SV * const names = newSVpvs_flags("", SVs_TEMP);
1825 /* The starting point is the first element if count is
1826 positive and the second element if count is negative. */
1827 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1828 + (count < 0 ? 1 : 0);
1829 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1830 + (count < 0 ? -count : count);
1831 while (hekp < endp) {
67e04715
FC		 1832 if (*hekp) {
1833 sv_catpvs(names, ", \"");
ec3405c8 1834 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
67e04715 1835 sv_catpvs(names, "\"");
ec3405c8
NC		 1836 } else {
1837 /* This should never happen. */
1838 sv_catpvs(names, ", (null)");
67e04715 1839 }
ec3405c8
NC		 1840 ++hekp;
1841 }
67e04715
FC		 1842 Perl_dump_indent(aTHX_
1843 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1844 );
1845 }
1846 else
1847 Perl_dump_indent(aTHX_
1848 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1849 );
1850 }
86f55936
NC		 1851 if (backrefs) {
1852 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1853 PTR2UV(backrefs));
ad64d0ec 1854 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC		 1855 dumpops, pvlim);
1856 }
7d88e6c4
NC		 1857 if (meta) {
1858 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1859 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1860 (int)meta->mro_which->length,
1861 meta->mro_which->name,
1862 PTR2UV(meta->mro_which));
1863 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1864 (UV)meta->cache_gen);
1865 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1866 (UV)meta->pkg_gen);
1867 if (meta->mro_linear_all) {
1868 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1869 PTR2UV(meta->mro_linear_all));
1870 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1871 dumpops, pvlim);
1872 }
1873 if (meta->mro_linear_current) {
1874 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1875 PTR2UV(meta->mro_linear_current));
1876 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1877 dumpops, pvlim);
1878 }
1879 if (meta->mro_nextmethod) {
1880 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1881 PTR2UV(meta->mro_nextmethod));
1882 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1883 dumpops, pvlim);
1884 }
1885 if (meta->isa) {
1886 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1887 PTR2UV(meta->isa));
1888 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1889 dumpops, pvlim);
1890 }
1891 }
86f55936 1892 }
b5698553 1893 if (nest < maxnest) {
cbab3169 1894 HV * const hv = MUTABLE_HV(sv);
b5698553
TH		 1895 STRLEN i;
1896 HE *he;
cbab3169 1897
b5698553
TH		 1898 if (HvARRAY(hv)) {
1899 int count = maxnest - nest;
1900 for (i=0; i <= HvMAX(hv); i++) {
1901 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1902 U32 hash;
1903 SV * keysv;
1904 const char * keypv;
1905 SV * elt;
7dc86639 1906 STRLEN len;
b5698553
TH		 1907
1908 if (count-- <= 0) goto DONEHV;
1909
1910 hash = HeHASH(he);
1911 keysv = hv_iterkeysv(he);
1912 keypv = SvPV_const(keysv, len);
1913 elt = HeVAL(he);
cbab3169 1914
7dc86639
YO		 1915 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1916 if (SvUTF8(keysv))
1917 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH		 1918 if (HvEITER_get(hv) == he)
1919 PerlIO_printf(file, "[CURRENT] ");
7dc86639
YO		 1920 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1921 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1922 }
b5698553
TH		 1923 }
1924 DONEHV:;
1925 }
3967c732
JD		 1926 }
1927 break;
e0bbf362 1928
3967c732 1929 case SVt_PVCV:
8fa6a409 1930 if (CvAUTOLOAD(sv)) {
cbf82dd0 1931 STRLEN len;
8fa6a409
FC		 1932 const char *const name = SvPV_const(sv, len);
1933 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1934 (int) len, name);
1935 }
1936 if (SvPOK(sv)) {
cbf82dd0 1937 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
8fa6a409 1938 (int) CvPROTOLEN(sv), CvPROTO(sv));
cbf82dd0 1939 }
3967c732
JD		 1940 /* FALL THROUGH */
1941 case SVt_PVFM:
1942 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC		 1943 if (!CvISXSUB(sv)) {
1944 if (CvSTART(sv)) {
1945 Perl_dump_indent(aTHX_ level, file,
1946 " START = 0x%"UVxf" ===> %"IVdf"\n",
1947 PTR2UV(CvSTART(sv)),
1948 (IV)sequence_num(CvSTART(sv)));
1949 }
1950 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1951 PTR2UV(CvROOT(sv)));
1952 if (CvROOT(sv) && dumpops) {
1953 do_op_dump(level+1, file, CvROOT(sv));
1954 }
1955 } else {
126f53f3 1956 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1957
d04ba589 1958 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099
NC		 1959
1960 if (constant) {
1961 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1962 " (CONST SV)\n",
1963 PTR2UV(CvXSUBANY(sv).any_ptr));
1964 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1965 pvlim);
1966 } else {
1967 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1968 (IV)CvXSUBANY(sv).any_i32);
1969 }
1970 }
3610c89f
FC		 1971 if (CvNAMED(sv))
1972 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1973 HEK_KEY(CvNAME_HEK((CV *)sv)));
1974 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1975 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
bb02a38f 1976 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1977 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1978 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
57def98f 1979 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
dd2155a4
DM		 1980 if (nest < maxnest) {
1981 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
3967c732
JD		 1982 }
1983 {
b9ac451d 1984 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 1985 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 1986 PTR2UV(outside),
cf2093f6
JH		 1987 (!outside ? "null"
1988 : CvANON(outside) ? "ANON"
1989 : (outside == PL_main_cv) ? "MAIN"
1990 : CvUNIQUE(outside) ? "UNIQUE"
1991 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
3967c732
JD		 1992 }
1993 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
ad64d0ec 1994 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 1995 break;
e0bbf362 1996
926fc7b6
DM		 1997 case SVt_PVGV:
1998 case SVt_PVLV:
b9ac451d
AL		 1999 if (type == SVt_PVLV) {
2000 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2001 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2002 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2003 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
83f78d1a 2004 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
b9ac451d
AL		 2005 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2006 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2007 dumpops, pvlim);
2008 }
8d919b0a 2009 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM		 2010 if (!isGV_with_GP(sv))
2011 break;
cea2e8a9 2012 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
57def98f 2013 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 2014 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
57def98f 2015 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c
GS		 2016 if (!GvGP(sv))
2017 break;
57def98f
JH		 2018 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2019 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2020 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2021 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2022 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2023 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2024 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2025 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
57def98f 2026 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 2027 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
e39917cc 2028 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
3967c732
JD		 2029 do_gv_dump (level, file, " EGV", GvEGV(sv));
2030 break;
2031 case SVt_PVIO:
57def98f
JH		 2032 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2033 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2034 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2036 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2037 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2038 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 2039 if (IoTOP_NAME(sv))
cea2e8a9 2040 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC		 2041 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2042 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2043 else {
2044 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2045 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC		 2046 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2047 maxnest, dumpops, pvlim);
9ba1f565
NC		 2048 }
2049 /* Source filters hide things that are not GVs in these three, so let's
2050 be careful out there. */
27533608 2051 if (IoFMT_NAME(sv))
cea2e8a9 2052 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC		 2053 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2054 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2055 else {
2056 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2057 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC		 2058 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2059 maxnest, dumpops, pvlim);
9ba1f565 2060 }
27533608 2061 if (IoBOTTOM_NAME(sv))
cea2e8a9 2062 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC		 2063 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2064 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2065 else {
2066 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2067 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC		 2068 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2069 maxnest, dumpops, pvlim);
9ba1f565 2070 }
27533608 2071 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2072 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2073 else
cea2e8a9 2074 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 2075 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 2076 break;
206ee256 2077 case SVt_REGEXP:
8d919b0a 2078 dumpregexp:
d63e6659 2079 {
8d919b0a 2080 struct regexp * const r = ReANY((REGEXP*)sv);
d63e6659
DM		 2081 flags = RX_EXTFLAGS((REGEXP*)sv);
2082 sv_setpv(d,"");
2083 append_flags(d, flags, regexp_flags_names);
2084 if (*(SvEND(d) - 1) == ',') {
2085 SvCUR_set(d, SvCUR(d) - 1);
2086 SvPVX(d)[SvCUR(d)] = '\0';
2087 }
2088 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2089 (UV)flags, SvPVX_const(d));
2090 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2091 (UV)(r->intflags));
2092 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2093 (UV)(r->nparens));
2094 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2095 (UV)(r->lastparen));
2096 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2097 (UV)(r->lastcloseparen));
2098 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2099 (IV)(r->minlen));
2100 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2101 (IV)(r->minlenret));
2102 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2103 (UV)(r->gofs));
2104 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2105 (UV)(r->pre_prefix));
d63e6659
DM		 2106 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2107 (IV)(r->sublen));
6502e081
DM		 2108 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2109 (IV)(r->suboffset));
2110 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2111 (IV)(r->subcoffset));
d63e6659
DM		 2112 if (r->subbeg)
2113 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2114 PTR2UV(r->subbeg),
2115 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2116 else
2117 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2118 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2119 PTR2UV(r->engine));
2120 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2121 PTR2UV(r->mother_re));
2122 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2123 PTR2UV(r->paren_names));
2124 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2125 PTR2UV(r->substrs));
2126 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2127 PTR2UV(r->pprivate));
2128 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2129 PTR2UV(r->offs));
d63c20f2
DM		 2130 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2131 PTR2UV(r->qr_anoncv));
db2c6cb3 2132#ifdef PERL_ANY_COW
d63e6659
DM		 2133 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2134 PTR2UV(r->saved_copy));
2135#endif
2136 }
206ee256 2137 break;
3967c732 2138 }
cea89e20 2139 SvREFCNT_dec(d);
3967c732
JD		 2140}
2141
2142void
864dbfa3 2143Perl_sv_dump(pTHX_ SV *sv)
3967c732 2144{
97aff369 2145 dVAR;
7918f24d
NC		 2146
2147 PERL_ARGS_ASSERT_SV_DUMP;
2148
d1029faa
JP		 2149 if (SvROK(sv))
2150 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2151 else
2152 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2153}
bd16a5f0
IZ		 2154
2155int
2156Perl_runops_debug(pTHX)
2157{
97aff369 2158 dVAR;
bd16a5f0 2159 if (!PL_op) {
9b387841 2160 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ		 2161 return 0;
2162 }
2163
9f3673fb 2164 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2165 do {
bd16a5f0 2166 if (PL_debug) {
b9ac451d 2167 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0
IZ		 2168 PerlIO_printf(Perl_debug_log,
2169 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2170 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2171 PTR2UV(*PL_watchaddr));
d6721266
DM		 2172 if (DEBUG_s_TEST_) {
2173 if (DEBUG_v_TEST_) {
2174 PerlIO_printf(Perl_debug_log, "\n");
2175 deb_stack_all();
2176 }
2177 else
2178 debstack();
2179 }
2180
2181
bd16a5f0
IZ		 2182 if (DEBUG_t_TEST_) debop(PL_op);
2183 if (DEBUG_P_TEST_) debprof(PL_op);
2184 }
fe83c362
SM		 2185
2186 OP_ENTRY_PROBE(OP_NAME(PL_op));
16c91539 2187 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2188 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
bd16a5f0
IZ		 2189
2190 TAINT_NOT;
2191 return 0;
2192}
2193
2194I32
6867be6d 2195Perl_debop(pTHX_ const OP *o)
bd16a5f0 2196{
97aff369 2197 dVAR;
7918f24d
NC		 2198
2199 PERL_ARGS_ASSERT_DEBOP;
2200
1045810a
IZ		 2201 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2202 return 0;
2203
bd16a5f0
IZ		 2204 Perl_deb(aTHX_ "%s", OP_NAME(o));
2205 switch (o->op_type) {
2206 case OP_CONST:
996c9baa 2207 case OP_HINTSEVAL:
6cefa69e 2208 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2209 * may not be active here, so check.
6cefa69e 2210 * Looks like only during compiling the pads are illegal.
7367e658 2211 */
6cefa69e
RU		 2212#ifdef USE_ITHREADS
2213 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2214#endif
7367e658 2215 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ		 2216 break;
2217 case OP_GVSV:
2218 case OP_GV:
2219 if (cGVOPo_gv) {
b9ac451d 2220 SV * const sv = newSV(0);
3b721df9 2221#ifdef PERL_MAD
84021b46 2222 /* FIXME - is this making unwarranted assumptions about the
3b721df9
NC		 2223 UTF-8 cleanliness of the dump file handle? */
2224 SvUTF8_on(sv);
2225#endif
bd61b366 2226 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2227 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0
IZ		 2228 SvREFCNT_dec(sv);
2229 }
2230 else
2231 PerlIO_printf(Perl_debug_log, "(NULL)");
2232 break;
a7fd8ef6
DM		 2233
2234 {
2235 int count;
2236
bd16a5f0
IZ		 2237 case OP_PADSV:
2238 case OP_PADAV:
2239 case OP_PADHV:
a7fd8ef6
DM		 2240 count = 1;
2241 goto dump_padop;
2242 case OP_PADRANGE:
2243 count = o->op_private & OPpPADRANGE_COUNTMASK;
2244 dump_padop:
bd16a5f0 2245 /* print the lexical's name */
a7fd8ef6
DM		 2246 {
2247 CV * const cv = deb_curcv(cxstack_ix);
2248 SV *sv;
2249 PAD * comppad = NULL;
2250 int i;
2251
2252 if (cv) {
2253 PADLIST * const padlist = CvPADLIST(cv);
2254 comppad = *PadlistARRAY(padlist);
2255 }
2256 PerlIO_printf(Perl_debug_log, "(");
2257 for (i = 0; i < count; i++) {
2258 if (comppad &&
2259 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2260 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2261 else
2262 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2263 (UV)o->op_targ+i);
2264 if (i < count-1)
2265 PerlIO_printf(Perl_debug_log, ",");
2266 }
2267 PerlIO_printf(Perl_debug_log, ")");
2268 }
bd16a5f0 2269 break;
a7fd8ef6
DM		 2270 }
2271
bd16a5f0 2272 default:
091ab601 2273 break;
bd16a5f0
IZ		 2274 }
2275 PerlIO_printf(Perl_debug_log, "\n");
2276 return 0;
2277}
2278
2279STATIC CV*
61f9802b 2280S_deb_curcv(pTHX_ const I32 ix)
bd16a5f0 2281{
97aff369 2282 dVAR;
b9ac451d 2283 const PERL_CONTEXT * const cx = &cxstack[ix];
bd16a5f0
IZ		 2284 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2285 return cx->blk_sub.cv;
2286 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
676a678a 2287 return cx->blk_eval.cv;
bd16a5f0
IZ		 2288 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2289 return PL_main_cv;
2290 else if (ix <= 0)
601f1833 2291 return NULL;
bd16a5f0
IZ		 2292 else
2293 return deb_curcv(ix - 1);
2294}
2295
2296void
2297Perl_watch(pTHX_ char **addr)
2298{
97aff369 2299 dVAR;
7918f24d
NC		 2300
2301 PERL_ARGS_ASSERT_WATCH;
2302
bd16a5f0
IZ		 2303 PL_watchaddr = addr;
2304 PL_watchok = *addr;
2305 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2306 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2307}
2308
2309STATIC void
e1ec3a88 2310S_debprof(pTHX_ const OP *o)
bd16a5f0 2311{
97aff369 2312 dVAR;
7918f24d
NC		 2313
2314 PERL_ARGS_ASSERT_DEBPROF;
2315
61f9802b 2316 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2317 return;
bd16a5f0 2318 if (!PL_profiledata)
a02a5408 2319 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ		 2320 ++PL_profiledata[o->op_type];
2321}
2322
2323void
2324Perl_debprofdump(pTHX)
2325{
97aff369 2326 dVAR;
bd16a5f0
IZ		 2327 unsigned i;
2328 if (!PL_profiledata)
2329 return;
2330 for (i = 0; i < MAXO; i++) {
2331 if (PL_profiledata[i])
2332 PerlIO_printf(Perl_debug_log,
2333 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2334 PL_op_name[i]);
2335 }
2336}
66610fdd 2337
3b721df9
NC		 2338#ifdef PERL_MAD
2339/*
2340 * XML variants of most of the above routines
2341 */
2342
4136a0f7 2343STATIC void
3b721df9
NC		 2344S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2345{
2346 va_list args;
7918f24d
NC		 2347
2348 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2349
3b721df9
NC		 2350 PerlIO_printf(file, "\n ");
2351 va_start(args, pat);
2352 xmldump_vindent(level, file, pat, &args);
2353 va_end(args);
2354}
2355
2356
2357void
2358Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2359{
2360 va_list args;
7918f24d 2361 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
3b721df9
NC		 2362 va_start(args, pat);
2363 xmldump_vindent(level, file, pat, &args);
2364 va_end(args);
2365}
2366
2367void
2368Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2369{
7918f24d
NC		 2370 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2371
3b721df9
NC		 2372 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2373 PerlIO_vprintf(file, pat, *args);
2374}
2375
2376void
2377Perl_xmldump_all(pTHX)
2378{
f0e3f042
CS		 2379 xmldump_all_perl(FALSE);
2380}
2381
2382void
0190d5ef 2383Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
f0e3f042 2384{
3b721df9
NC		 2385 PerlIO_setlinebuf(PL_xmlfp);
2386 if (PL_main_root)
2387 op_xmldump(PL_main_root);
0190d5ef
CS		 2388 /* someday we might call this, when it outputs XML: */
2389 /* xmldump_packsubs_perl(PL_defstash, justperl); */
3b721df9
NC		 2390 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2391 PerlIO_close(PL_xmlfp);
2392 PL_xmlfp = 0;
2393}
2394
2395void
2396Perl_xmldump_packsubs(pTHX_ const HV *stash)
2397{
28eb953d 2398 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
3ab0c9fa
NC		 2399 xmldump_packsubs_perl(stash, FALSE);
2400}
2401
2402void
2403Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2404{
3b721df9
NC		 2405 I32 i;
2406 HE *entry;
2407
28eb953d 2408 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
7918f24d 2409
3b721df9
NC		 2410 if (!HvARRAY(stash))
2411 return;
2412 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2413 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
159b6efe 2414 GV *gv = MUTABLE_GV(HeVAL(entry));
3b721df9
NC		 2415 HV *hv;
2416 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2417 continue;
2418 if (GvCVu(gv))
3ab0c9fa 2419 xmldump_sub_perl(gv, justperl);
3b721df9
NC		 2420 if (GvFORM(gv))
2421 xmldump_form(gv);
2422 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2423 && (hv = GvHV(gv)) && hv != PL_defstash)
3ab0c9fa 2424 xmldump_packsubs_perl(hv, justperl); /* nested package */
3b721df9
NC		 2425 }
2426 }
2427}
2428
2429void
2430Perl_xmldump_sub(pTHX_ const GV *gv)
2431{
28eb953d 2432 PERL_ARGS_ASSERT_XMLDUMP_SUB;
f0e3f042
CS		 2433 xmldump_sub_perl(gv, FALSE);
2434}
2435
2436void
2437Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2438{
2439 SV * sv;
3b721df9 2440
28eb953d 2441 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
7918f24d 2442
f0e3f042
CS		 2443 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2444 return;
2445
2446 sv = sv_newmortal();
1a9a51d4 2447 gv_fullname3(sv, gv, NULL);
3b721df9
NC		 2448 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2449 if (CvXSUB(GvCV(gv)))
2450 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2451 PTR2UV(CvXSUB(GvCV(gv))),
2452 (int)CvXSUBANY(GvCV(gv)).any_i32);
2453 else if (CvROOT(GvCV(gv)))
2454 op_xmldump(CvROOT(GvCV(gv)));
2455 else
2456 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2457}
2458
2459void
2460Perl_xmldump_form(pTHX_ const GV *gv)
2461{
61f9802b 2462 SV * const sv = sv_newmortal();
3b721df9 2463
7918f24d
NC		 2464 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2465
1a9a51d4 2466 gv_fullname3(sv, gv, NULL);
3b721df9
NC		 2467 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2468 if (CvROOT(GvFORM(gv)))
2469 op_xmldump(CvROOT(GvFORM(gv)));
2470 else
2471 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2472}
2473
2474void
2475Perl_xmldump_eval(pTHX)
2476{
2477 op_xmldump(PL_eval_root);
2478}
2479
2480char *
2481Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2482{
7918f24d 2483 PERL_ARGS_ASSERT_SV_CATXMLSV;
3b721df9
NC		 2484 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2485}
2486
2487char *
9dcc53ea
Z		 2488Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2489{
2490 PERL_ARGS_ASSERT_SV_CATXMLPV;
2491 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2492}
2493
2494char *
20f84293 2495Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
3b721df9
NC		 2496{
2497 unsigned int c;
61f9802b 2498 const char * const e = pv + len;
20f84293 2499 const char * const start = pv;
3b721df9
NC		 2500 STRLEN dsvcur;
2501 STRLEN cl;
2502
7918f24d
NC		 2503 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2504
76f68e9b 2505 sv_catpvs(dsv,"");
3b721df9
NC		 2506 dsvcur = SvCUR(dsv); /* in case we have to restart */
2507
2508 retry:
2509 while (pv < e) {
2510 if (utf8) {
4b88fb76 2511 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
3b721df9
NC		 2512 if (cl == 0) {
2513 SvCUR(dsv) = dsvcur;
2514 pv = start;
2515 utf8 = 0;
2516 goto retry;
2517 }
2518 }
2519 else
2520 c = (*pv & 255);
2521
2522 switch (c) {
2523 case 0x00:
2524 case 0x01:
2525 case 0x02:
2526 case 0x03:
2527 case 0x04:
2528 case 0x05:
2529 case 0x06:
2530 case 0x07:
2531 case 0x08:
2532 case 0x0b:
2533 case 0x0c:
2534 case 0x0e:
2535 case 0x0f:
2536 case 0x10:
2537 case 0x11:
2538 case 0x12:
2539 case 0x13:
2540 case 0x14:
2541 case 0x15:
2542 case 0x16:
2543 case 0x17:
2544 case 0x18:
2545 case 0x19:
2546 case 0x1a:
2547 case 0x1b:
2548 case 0x1c:
2549 case 0x1d:
2550 case 0x1e:
2551 case 0x1f:
2552 case 0x7f:
2553 case 0x80:
2554 case 0x81:
2555 case 0x82:
2556 case 0x83:
2557 case 0x84:
2558 case 0x86:
2559 case 0x87:
2560 case 0x88:
2561 case 0x89:
2562 case 0x90:
2563 case 0x91:
2564 case 0x92:
2565 case 0x93:
2566 case 0x94:
2567 case 0x95:
2568 case 0x96:
2569 case 0x97:
2570 case 0x98:
2571 case 0x99:
2572 case 0x9a:
2573 case 0x9b:
2574 case 0x9c:
2575 case 0x9d:
2576 case 0x9e:
2577 case 0x9f:
2578 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2579 break;
2580 case '<':
f3a2811a 2581 sv_catpvs(dsv, "&lt;");
3b721df9
NC		 2582 break;
2583 case '>':
f3a2811a 2584 sv_catpvs(dsv, "&gt;");
3b721df9
NC		 2585 break;
2586 case '&':
f3a2811a 2587 sv_catpvs(dsv, "&amp;");
3b721df9
NC		 2588 break;
2589 case '"':
49de0815 2590 sv_catpvs(dsv, "&#34;");
3b721df9
NC		 2591 break;
2592 default:
2593 if (c < 0xD800) {
2594 if (c < 32 || c > 127) {
2595 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2596 }
2597 else {
5e7aa789
NC		 2598 const char string = (char) c;
2599 sv_catpvn(dsv, &string, 1);
3b721df9
NC		 2600 }
2601 break;
2602 }
2603 if ((c >= 0xD800 && c <= 0xDB7F) ||
2604 (c >= 0xDC00 && c <= 0xDFFF) ||
2605 (c >= 0xFFF0 && c <= 0xFFFF) ||
2606 c > 0x10ffff)
2607 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2608 else
2609 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2610 }
2611
2612 if (utf8)
2613 pv += UTF8SKIP(pv);
2614 else
2615 pv++;
2616 }
2617
2618 return SvPVX(dsv);
2619}
2620
2621char *
2622Perl_sv_xmlpeek(pTHX_ SV *sv)
2623{
61f9802b 2624 SV * const t = sv_newmortal();
3b721df9
NC		 2625 STRLEN n_a;
2626 int unref = 0;
2627
7918f24d
NC		 2628 PERL_ARGS_ASSERT_SV_XMLPEEK;
2629
3b721df9 2630 sv_utf8_upgrade(t);
76f68e9b 2631 sv_setpvs(t, "");
3b721df9
NC		 2632 /* retry: */
2633 if (!sv) {
2634 sv_catpv(t, "VOID=\"\"");
2635 goto finish;
2636 }
ad64d0ec 2637 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
3b721df9
NC		 2638 sv_catpv(t, "WILD=\"\"");
2639 goto finish;
2640 }
2641 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2642 if (sv == &PL_sv_undef) {
2643 sv_catpv(t, "SV_UNDEF=\"1\"");
2644 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2645 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2646 SvREADONLY(sv))
2647 goto finish;
2648 }
2649 else if (sv == &PL_sv_no) {
2650 sv_catpv(t, "SV_NO=\"1\"");
2651 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2652 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2653 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2654 SVp_POK|SVp_NOK)) &&
2655 SvCUR(sv) == 0 &&
2656 SvNVX(sv) == 0.0)
2657 goto finish;
2658 }
2659 else if (sv == &PL_sv_yes) {
2660 sv_catpv(t, "SV_YES=\"1\"");
2661 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2662 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2663 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2664 SVp_POK|SVp_NOK)) &&
2665 SvCUR(sv) == 1 &&
2666 SvPVX(sv) && *SvPVX(sv) == '1' &&
2667 SvNVX(sv) == 1.0)
2668 goto finish;
2669 }
2670 else {
2671 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2672 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2673 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2674 SvREADONLY(sv))
2675 goto finish;
2676 }
2677 sv_catpv(t, " XXX=\"\" ");
2678 }
2679 else if (SvREFCNT(sv) == 0) {
2680 sv_catpv(t, " refcnt=\"0\"");
2681 unref++;
2682 }
2683 else if (DEBUG_R_TEST_) {
2684 int is_tmp = 0;
2685 I32 ix;
2686 /* is this SV on the tmps stack? */
2687 for (ix=PL_tmps_ix; ix>=0; ix--) {
2688 if (PL_tmps_stack[ix] == sv) {
2689 is_tmp = 1;
2690 break;
2691 }
2692 }
2693 if (SvREFCNT(sv) > 1)
2694 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2695 is_tmp ? "T" : "");
2696 else if (is_tmp)
2697 sv_catpv(t, " DRT=\"<T>\"");
2698 }
2699
2700 if (SvROK(sv)) {
2701 sv_catpv(t, " ROK=\"\"");
2702 }
2703 switch (SvTYPE(sv)) {
2704 default:
2705 sv_catpv(t, " FREED=\"1\"");
2706 goto finish;
2707
2708 case SVt_NULL:
2709 sv_catpv(t, " UNDEF=\"1\"");
2710 goto finish;
2711 case SVt_IV:
2712 sv_catpv(t, " IV=\"");
2713 break;
2714 case SVt_NV:
2715 sv_catpv(t, " NV=\"");
2716 break;
3b721df9
NC		 2717 case SVt_PV:
2718 sv_catpv(t, " PV=\"");
2719 break;
2720 case SVt_PVIV:
2721 sv_catpv(t, " PVIV=\"");
2722 break;
2723 case SVt_PVNV:
2724 sv_catpv(t, " PVNV=\"");
2725 break;
2726 case SVt_PVMG:
2727 sv_catpv(t, " PVMG=\"");
2728 break;
2729 case SVt_PVLV:
2730 sv_catpv(t, " PVLV=\"");
2731 break;
2732 case SVt_PVAV:
2733 sv_catpv(t, " AV=\"");
2734 break;
2735 case SVt_PVHV:
2736 sv_catpv(t, " HV=\"");
2737 break;
2738 case SVt_PVCV:
2739 if (CvGV(sv))
2740 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2741 else
2742 sv_catpv(t, " CV=\"()\"");
2743 goto finish;
2744 case SVt_PVGV:
2745 sv_catpv(t, " GV=\"");
2746 break;
cecf5685
NC		 2747 case SVt_BIND:
2748 sv_catpv(t, " BIND=\"");
3b721df9 2749 break;
d914baab 2750 case SVt_REGEXP:
8619e557 2751 sv_catpv(t, " REGEXP=\"");
4df7f6af 2752 break;
3b721df9
NC		 2753 case SVt_PVFM:
2754 sv_catpv(t, " FM=\"");
2755 break;
2756 case SVt_PVIO:
2757 sv_catpv(t, " IO=\"");
2758 break;
2759 }
2760
2761 if (SvPOKp(sv)) {
2762 if (SvPVX(sv)) {
2763 sv_catxmlsv(t, sv);
2764 }
2765 }
2766 else if (SvNOKp(sv)) {
2767 STORE_NUMERIC_LOCAL_SET_STANDARD();
2768 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2769 RESTORE_NUMERIC_LOCAL();
2770 }
2771 else if (SvIOKp(sv)) {
2772 if (SvIsUV(sv))
2773 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2774 else
2775 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2776 }
2777 else
2778 sv_catpv(t, "");
2779 sv_catpv(t, "\"");
2780
2781 finish:
61f9802b
AL		 2782 while (unref--)
2783 sv_catpv(t, ")");
3b721df9
NC		 2784 return SvPV(t, n_a);
2785}
2786
2787void
2788Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2789{
7918f24d
NC		 2790 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2791
3b721df9
NC		 2792 if (!pm) {
2793 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2794 return;
2795 }
2796 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2797 level++;
2798 if (PM_GETRE(pm)) {
d914baab 2799 REGEXP *const r = PM_GETRE(pm);
643e696a 2800 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
ad64d0ec 2801 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
3b721df9
NC		 2802 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2803 SvPVX(tmpsv));
2804 SvREFCNT_dec(tmpsv);
2805 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2806 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2807 }
2808 else
2809 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
d914baab 2810 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
3df43ef7 2811 SV * const tmpsv = pm_description(pm);
3b721df9
NC		 2812 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2813 SvREFCNT_dec(tmpsv);
2814 }
2815
2816 level--;
20e98b0f 2817 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
3b721df9
NC		 2818 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2819 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
20e98b0f 2820 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
3b721df9
NC		 2821 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2822 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2823 }
2824 else
2825 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2826}
2827
2828void
2829Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2830{
2831 do_pmop_xmldump(0, PL_xmlfp, pm);
2832}
2833
2834void
2835Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2836{
2837 UV seq;
2838 int contents = 0;
75a6ad4a 2839 const OPCODE optype = o->op_type;
7918f24d
NC		 2840
2841 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2842
3b721df9
NC		 2843 if (!o)
2844 return;
3b721df9
NC		 2845 seq = sequence_num(o);
2846 Perl_xmldump_indent(aTHX_ level, file,
2847 "<op_%s seq=\"%"UVuf" -> ",
2848 OP_NAME(o),
2849 seq);
2850 level++;
2851 if (o->op_next)
2852 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2853 sequence_num(o->op_next));
2854 else
2855 PerlIO_printf(file, "DONE\"");
2856
2857 if (o->op_targ) {
75a6ad4a 2858 if (optype == OP_NULL)
3b721df9
NC		 2859 {
2860 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2861 if (o->op_targ == OP_NEXTSTATE)
2862 {
2863 if (CopLINE(cCOPo))
f5992bc4 2864 PerlIO_printf(file, " line=\"%"UVuf"\"",
3b721df9
NC		 2865 (UV)CopLINE(cCOPo));
2866 if (CopSTASHPV(cCOPo))
2867 PerlIO_printf(file, " package=\"%s\"",
2868 CopSTASHPV(cCOPo));
4b65a919 2869 if (CopLABEL(cCOPo))
3b721df9 2870 PerlIO_printf(file, " label=\"%s\"",
4b65a919 2871 CopLABEL(cCOPo));
3b721df9
NC		 2872 }
2873 }
2874 else
2875 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2876 }
2877#ifdef DUMPADDR
2878 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2879#endif
3b721df9 2880
75a6ad4a
RU		 2881 DUMP_OP_FLAGS(o,1,0,file);
2882 DUMP_OP_PRIVATE(o,1,0,file);
2883
2884 switch (optype) {
3b721df9
NC		 2885 case OP_AELEMFAST:
2886 if (o->op_flags & OPf_SPECIAL) {
2887 break;
2888 }
2889 case OP_GVSV:
2890 case OP_GV:
2891#ifdef USE_ITHREADS
2892 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2893#else
2894 if (cSVOPo->op_sv) {
d914baab
NC		 2895 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2896 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3b721df9
NC		 2897 char *s;
2898 STRLEN len;
2899 ENTER;
2900 SAVEFREESV(tmpsv1);
2901 SAVEFREESV(tmpsv2);
159b6efe 2902 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3b721df9
NC		 2903 s = SvPV(tmpsv1,len);
2904 sv_catxmlpvn(tmpsv2, s, len, 1);
2905 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2906 LEAVE;
2907 }
2908 else
2909 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2910#endif
2911 break;
2912 case OP_CONST:
996c9baa 2913 case OP_HINTSEVAL:
3b721df9
NC		 2914 case OP_METHOD_NAMED:
2915#ifndef USE_ITHREADS
2916 /* with ITHREADS, consts are stored in the pad, and the right pad
2917 * may not be active here, so skip */
2918 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2919#endif
2920 break;
2921 case OP_ANONCODE:
2922 if (!contents) {
2923 contents = 1;
2924 PerlIO_printf(file, ">\n");
2925 }
2926 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2927 break;
3b721df9
NC		 2928 case OP_NEXTSTATE:
2929 case OP_DBSTATE:
2930 if (CopLINE(cCOPo))
f5992bc4 2931 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3b721df9
NC		 2932 (UV)CopLINE(cCOPo));
2933 if (CopSTASHPV(cCOPo))
2934 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2935 CopSTASHPV(cCOPo));
4b65a919 2936 if (CopLABEL(cCOPo))
3b721df9 2937 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
4b65a919 2938 CopLABEL(cCOPo));
3b721df9
NC		 2939 break;
2940 case OP_ENTERLOOP:
2941 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2942 if (cLOOPo->op_redoop)
2943 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2944 else
2945 PerlIO_printf(file, "DONE\"");
2946 S_xmldump_attr(aTHX_ level, file, "next=\"");
2947 if (cLOOPo->op_nextop)
2948 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2949 else
2950 PerlIO_printf(file, "DONE\"");
2951 S_xmldump_attr(aTHX_ level, file, "last=\"");
2952 if (cLOOPo->op_lastop)
2953 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2954 else
2955 PerlIO_printf(file, "DONE\"");
2956 break;
2957 case OP_COND_EXPR:
2958 case OP_RANGE:
2959 case OP_MAPWHILE:
2960 case OP_GREPWHILE:
2961 case OP_OR:
2962 case OP_AND:
2963 S_xmldump_attr(aTHX_ level, file, "other=\"");
2964 if (cLOGOPo->op_other)
2965 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2966 else
2967 PerlIO_printf(file, "DONE\"");
2968 break;
2969 case OP_LEAVE:
2970 case OP_LEAVEEVAL:
2971 case OP_LEAVESUB:
2972 case OP_LEAVESUBLV:
2973 case OP_LEAVEWRITE:
2974 case OP_SCOPE:
2975 if (o->op_private & OPpREFCOUNTED)
2976 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2977 break;
2978 default:
2979 break;
2980 }
2981
2982 if (PL_madskills && o->op_madprop) {
fb2b694a 2983 char prevkey = '\0';
d914baab 2984 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
20f84293 2985 const MADPROP* mp = o->op_madprop;
61f9802b 2986
3b721df9
NC		 2987 if (!contents) {
2988 contents = 1;
2989 PerlIO_printf(file, ">\n");
2990 }
2991 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2992 level++;
2993 while (mp) {
2994 char tmp = mp->mad_key;
76f68e9b 2995 sv_setpvs(tmpsv,"\"");
3b721df9
NC		 2996 if (tmp)
2997 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
fb2b694a
GG		 2998 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2999 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3000 else
3001 prevkey = tmp;
3b721df9
NC		 3002 sv_catpv(tmpsv, "\"");
3003 switch (mp->mad_type) {
3004 case MAD_NULL:
3005 sv_catpv(tmpsv, "NULL");
3006 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3007 break;
3008 case MAD_PV:
3009 sv_catpv(tmpsv, " val=\"");
3010 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3011 sv_catpv(tmpsv, "\"");
3012 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3013 break;
3014 case MAD_SV:
3015 sv_catpv(tmpsv, " val=\"");
ad64d0ec 3016 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3b721df9
NC		 3017 sv_catpv(tmpsv, "\"");
3018 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3019 break;
3020 case MAD_OP:
3021 if ((OP*)mp->mad_val) {
3022 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3023 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3024 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3025 }
3026 break;
3027 default:
3028 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3029 break;
3030 }
3031 mp = mp->mad_next;
3032 }
3033 level--;
3034 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3035
3036 SvREFCNT_dec(tmpsv);
3037 }
3038
75a6ad4a 3039 switch (optype) {
3b721df9
NC		 3040 case OP_PUSHRE:
3041 case OP_MATCH:
3042 case OP_QR:
3043 case OP_SUBST:
3044 if (!contents) {
3045 contents = 1;
3046 PerlIO_printf(file, ">\n");
3047 }
3048 do_pmop_xmldump(level, file, cPMOPo);
3049 break;
3050 default:
3051 break;
3052 }
3053
3054 if (o->op_flags & OPf_KIDS) {
3055 OP *kid;
3056 if (!contents) {
3057 contents = 1;
3058 PerlIO_printf(file, ">\n");
3059 }
3060 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3061 do_op_xmldump(level, file, kid);
3062 }
3063
3064 if (contents)
3065 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3066 else
3067 PerlIO_printf(file, " />\n");
3068}
3069
3070void
3071Perl_op_xmldump(pTHX_ const OP *o)
3072{
7918f24d
NC		 3073 PERL_ARGS_ASSERT_OP_XMLDUMP;
3074
3b721df9
NC		 3075 do_op_xmldump(0, PL_xmlfp, o);
3076}
3077#endif
3078
66610fdd
RGS		 3079/*
3080 * Local variables:
3081 * c-indentation-style: bsd
3082 * c-basic-offset: 4
14d04a33 3083 * indent-tabs-mode: nil
66610fdd
RGS		 3084 * End:
3085 *
14d04a33 3086 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3087 */
Unnamed repository; edit this file 'description' to name the repository.