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