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
Silence some VC++ compiler warnings
[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
YO		 183
184 case '\\' : /* fallthrough */
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, ")");
284167a5 474 if (TAINTING_get && 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;
871 const struct op_private_by_op *const end
872 = op_private_names + C_ARRAY_LENGTH(op_private_names);
873
874 /* This is a linear search, but no worse than the code that it replaced.
875 It's debugging code - size is more important than speed. */
876 do {
877 if (optype == start->op_type) {
878 S_append_flags(aTHX_ tmpsv, op_private, start->start,
879 start->start + start->len);
880 return TRUE;
881 }
882 } while (++start < end);
883 return FALSE;
884}
885
75a6ad4a
RU		 886#define DUMP_OP_FLAGS(o,xml,level,file) \
887 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
17605be7 888 SV * const tmpsv = newSVpvs(""); \
75a6ad4a
RU		 889 switch (o->op_flags & OPf_WANT) { \
890 case OPf_WANT_VOID: \
891 sv_catpv(tmpsv, ",VOID"); \
892 break; \
893 case OPf_WANT_SCALAR: \
894 sv_catpv(tmpsv, ",SCALAR"); \
895 break; \
896 case OPf_WANT_LIST: \
897 sv_catpv(tmpsv, ",LIST"); \
898 break; \
899 default: \
900 sv_catpv(tmpsv, ",UNKNOWN"); \
901 break; \
902 } \
903 append_flags(tmpsv, o->op_flags, op_flags_names); \
904 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
905 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \
906 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \
3164fde4 907 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \
75a6ad4a
RU		 908 if (!xml) \
909 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \
910 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
911 else \
912 PerlIO_printf(file, " flags=\"%s\"", \
913 SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); \
75a6ad4a
RU		 914 }
915
916#if !defined(PERL_MAD)
09c75956
FC		 917# define xmldump_attr1(level, file, pat, arg)
918#else
919# define xmldump_attr1(level, file, pat, arg) \
920 S_xmldump_attr(aTHX_ level, file, pat, arg)
75a6ad4a
RU		 921#endif
922
923#define DUMP_OP_PRIVATE(o,xml,level,file) \
924 if (o->op_private) { \
925 U32 optype = o->op_type; \
926 U32 oppriv = o->op_private; \
17605be7 927 SV * const tmpsv = newSVpvs(""); \
75a6ad4a
RU		 928 if (PL_opargs[optype] & OA_TARGLEX) { \
929 if (oppriv & OPpTARGET_MY) \
930 sv_catpv(tmpsv, ",TARGET_MY"); \
931 } \
932 else if (optype == OP_ENTERSUB || \
933 optype == OP_RV2SV || \
934 optype == OP_GVSV || \
935 optype == OP_RV2AV || \
936 optype == OP_RV2HV || \
937 optype == OP_RV2GV || \
938 optype == OP_AELEM || \
939 optype == OP_HELEM ) \
940 { \
941 if (optype == OP_ENTERSUB) { \
942 append_flags(tmpsv, oppriv, op_entersub_names); \
943 } \
944 else { \
945 switch (oppriv & OPpDEREF) { \
946 case OPpDEREF_SV: \
947 sv_catpv(tmpsv, ",SV"); \
948 break; \
949 case OPpDEREF_AV: \
950 sv_catpv(tmpsv, ",AV"); \
951 break; \
952 case OPpDEREF_HV: \
953 sv_catpv(tmpsv, ",HV"); \
954 break; \
955 } \
956 if (oppriv & OPpMAYBE_LVSUB) \
957 sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
958 } \
959 if (optype == OP_AELEM || optype == OP_HELEM) { \
960 if (oppriv & OPpLVAL_DEFER) \
961 sv_catpv(tmpsv, ",LVAL_DEFER"); \
962 } \
963 else if (optype == OP_RV2HV || optype == OP_PADHV) { \
964 if (oppriv & OPpMAYBE_TRUEBOOL) \
965 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
966 if (oppriv & OPpTRUEBOOL) \
967 sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
968 } \
969 else { \
970 if (oppriv & HINT_STRICT_REFS) \
971 sv_catpv(tmpsv, ",STRICT_REFS"); \
972 if (oppriv & OPpOUR_INTRO) \
973 sv_catpv(tmpsv, ",OUR_INTRO"); \
974 } \
975 } \
976 else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
977 } \
978 else if (OP_IS_FILETEST(o->op_type)) { \
979 if (oppriv & OPpFT_ACCESS) \
980 sv_catpv(tmpsv, ",FT_ACCESS"); \
981 if (oppriv & OPpFT_STACKED) \
982 sv_catpv(tmpsv, ",FT_STACKED"); \
983 if (oppriv & OPpFT_STACKING) \
984 sv_catpv(tmpsv, ",FT_STACKING"); \
985 if (oppriv & OPpFT_AFTER_t) \
986 sv_catpv(tmpsv, ",AFTER_t"); \
987 } \
631dbaa2
FC		 988 else if (o->op_type == OP_AASSIGN) { \
989 if (oppriv & OPpASSIGN_COMMON) \
990 sv_catpvs(tmpsv, ",COMMON"); \
991 if (oppriv & OPpMAYBE_LVSUB) \
992 sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
993 } \
75a6ad4a
RU		 994 if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
995 sv_catpv(tmpsv, ",INTRO"); \
996 if (o->op_type == OP_PADRANGE) \
997 Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
998 (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
95a31aad 999 if ( (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV || \
61c85d89 1000 o->op_type == OP_PADAV || o->op_type == OP_PADHV || \
2186f873 1001 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) \
95a31aad
FC		 1002 && oppriv & OPpSLICEWARNING ) \
1003 sv_catpvs(tmpsv, ",SLICEWARNING"); \
75a6ad4a
RU		 1004 if (SvCUR(tmpsv)) { \
1005 if (xml) \
09c75956 1006 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
75a6ad4a
RU		 1007 else \
1008 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
1009 } else if (!xml) \
1010 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
1011 (UV)oppriv); \
75a6ad4a
RU		 1012 }
1013
1014
79072805 1015void
6867be6d 1016Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
79072805 1017{
27da23d5 1018 dVAR;
2814eb74 1019 UV seq;
e15d5972
AL		 1020 const OPCODE optype = o->op_type;
1021
7918f24d
NC		 1022 PERL_ARGS_ASSERT_DO_OP_DUMP;
1023
cea2e8a9 1024 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732 1025 level++;
0bd48802 1026 seq = sequence_num(o);
2814eb74 1027 if (seq)
f5992bc4 1028 PerlIO_printf(file, "%-4"UVuf, seq);
93a17b20 1029 else
b6f05621 1030 PerlIO_printf(file, "????");
c8db6e60
JH		 1031 PerlIO_printf(file,
1032 "%*sTYPE = %s ===> ",
53e06cf0 1033 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
2814eb74 1034 if (o->op_next)
b6f05621
DM		 1035 PerlIO_printf(file,
1036 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
666ea192 1037 sequence_num(o->op_next));
79072805 1038 else
e75ab6ad 1039 PerlIO_printf(file, "NULL\n");
11343788 1040 if (o->op_targ) {
e15d5972 1041 if (optype == OP_NULL) {
cea2e8a9 1042 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
e15d5972 1043 if (o->op_targ == OP_NEXTSTATE) {
ae7d165c 1044 if (CopLINE(cCOPo))
f5992bc4 1045 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 1046 (UV)CopLINE(cCOPo));
0eb335df
BF		 1047 if (CopSTASHPV(cCOPo)) {
1048 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1049 HV *stash = CopSTASH(cCOPo);
1050 const char * const hvname = HvNAME_get(stash);
1051
ae7d165c 1052 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
0eb335df
BF		 1053 generic_pv_escape( tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash)));
1054 }
1055 if (CopLABEL(cCOPo)) {
1056 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1057 STRLEN label_len;
1058 U32 label_flags;
1059 const char *label = CopLABEL_len_flags(cCOPo,
1060 &label_len,
1061 &label_flags);
ae7d165c 1062 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
0eb335df
BF		 1063 generic_pv_escape( tmpsv, label, label_len,(label_flags & SVf_UTF8)));
1064 }
1065
ae7d165c
PJ		 1066 }
1067 }
8990e307 1068 else
894356b3 1069 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
8990e307 1070 }
748a9306 1071#ifdef DUMPADDR
57def98f 1072 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
79072805 1073#endif
a7fd8ef6 1074
75a6ad4a
RU		 1075 DUMP_OP_FLAGS(o,0,level,file);
1076 DUMP_OP_PRIVATE(o,0,level,file);
8d063cd8 1077
3b721df9
NC		 1078#ifdef PERL_MAD
1079 if (PL_madskills && o->op_madprop) {
17605be7 1080 SV * const tmpsv = newSVpvs("");
3b721df9
NC		 1081 MADPROP* mp = o->op_madprop;
1082 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1083 level++;
1084 while (mp) {
61f9802b 1085 const char tmp = mp->mad_key;
76f68e9b 1086 sv_setpvs(tmpsv,"'");
3b721df9
NC		 1087 if (tmp)
1088 sv_catpvn(tmpsv, &tmp, 1);
1089 sv_catpv(tmpsv, "'=");
1090 switch (mp->mad_type) {
1091 case MAD_NULL:
1092 sv_catpv(tmpsv, "NULL");
1093 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1094 break;
1095 case MAD_PV:
1096 sv_catpv(tmpsv, "<");
1097 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1098 sv_catpv(tmpsv, ">");
1099 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1100 break;
1101 case MAD_OP:
1102 if ((OP*)mp->mad_val) {
1103 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1104 do_op_dump(level, file, (OP*)mp->mad_val);
1105 }
1106 break;
1107 default:
1108 sv_catpv(tmpsv, "(UNK)");
1109 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1110 break;
1111 }
1112 mp = mp->mad_next;
1113 }
1114 level--;
1115 Perl_dump_indent(aTHX_ level, file, "}\n");
3b721df9
NC		 1116 }
1117#endif
1118
e15d5972 1119 switch (optype) {
971a9dd3 1120 case OP_AELEMFAST:
93a17b20 1121 case OP_GVSV:
79072805 1122 case OP_GV:
971a9dd3 1123#ifdef USE_ITHREADS
c803eecc 1124 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
971a9dd3 1125#else
1640e9f0 1126 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
38c076c7 1127 if (cSVOPo->op_sv) {
0eb335df
BF		 1128 STRLEN len;
1129 const char * name;
1130 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1131 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
3b721df9 1132#ifdef PERL_MAD
84021b46 1133 /* FIXME - is this making unwarranted assumptions about the
3b721df9
NC		 1134 UTF-8 cleanliness of the dump file handle? */
1135 SvUTF8_on(tmpsv);
1136#endif
159b6efe 1137 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
0eb335df 1138 name = SvPV_const(tmpsv, len);
8b6b16e7 1139 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
0eb335df 1140 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
38c076c7
DM		 1141 }
1142 else
1143 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
378cc40b 1144 }
971a9dd3 1145#endif
79072805
LW		 1146 break;
1147 case OP_CONST:
996c9baa 1148 case OP_HINTSEVAL:
f5d5a27c 1149 case OP_METHOD_NAMED:
b6a15bc5
DM		 1150#ifndef USE_ITHREADS
1151 /* with ITHREADS, consts are stored in the pad, and the right pad
1152 * may not be active here, so skip */
3848b962 1153 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
b6a15bc5 1154#endif
79072805 1155 break;
93a17b20
LW		 1156 case OP_NEXTSTATE:
1157 case OP_DBSTATE:
57843af0 1158 if (CopLINE(cCOPo))
f5992bc4 1159 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 1160 (UV)CopLINE(cCOPo));
0eb335df
BF		 1161 if (CopSTASHPV(cCOPo)) {
1162 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1163 HV *stash = CopSTASH(cCOPo);
1164 const char * const hvname = HvNAME_get(stash);
1165
ed094faf 1166 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
0eb335df
BF		 1167 generic_pv_escape(tmpsv, hvname,
1168 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1169 }
1170 if (CopLABEL(cCOPo)) {
1171 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1172 STRLEN label_len;
1173 U32 label_flags;
1174 const char *label = CopLABEL_len_flags(cCOPo,
1175 &label_len, &label_flags);
1176 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1177 generic_pv_escape( tmpsv, label, label_len,
1178 (label_flags & SVf_UTF8)));
1179 }
79072805
LW		 1180 break;
1181 case OP_ENTERLOOP:
cea2e8a9 1182 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
11343788 1183 if (cLOOPo->op_redoop)
f5992bc4 1184 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
79072805 1185 else
3967c732 1186 PerlIO_printf(file, "DONE\n");
cea2e8a9 1187 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
11343788 1188 if (cLOOPo->op_nextop)
f5992bc4 1189 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
79072805 1190 else
3967c732 1191 PerlIO_printf(file, "DONE\n");
cea2e8a9 1192 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
11343788 1193 if (cLOOPo->op_lastop)
f5992bc4 1194 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
79072805 1195 else
3967c732 1196 PerlIO_printf(file, "DONE\n");
79072805
LW		 1197 break;
1198 case OP_COND_EXPR:
1a67a97c 1199 case OP_RANGE:
a0d0e21e 1200 case OP_MAPWHILE:
79072805
LW		 1201 case OP_GREPWHILE:
1202 case OP_OR:
1203 case OP_AND:
cea2e8a9 1204 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
11343788 1205 if (cLOGOPo->op_other)
f5992bc4 1206 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
79072805 1207 else
3967c732 1208 PerlIO_printf(file, "DONE\n");
79072805
LW		 1209 break;
1210 case OP_PUSHRE:
1211 case OP_MATCH:
8782bef2 1212 case OP_QR:
79072805 1213 case OP_SUBST:
3967c732 1214 do_pmop_dump(level, file, cPMOPo);
79072805 1215 break;
7934575e
GS		 1216 case OP_LEAVE:
1217 case OP_LEAVEEVAL:
1218 case OP_LEAVESUB:
1219 case OP_LEAVESUBLV:
1220 case OP_LEAVEWRITE:
1221 case OP_SCOPE:
1222 if (o->op_private & OPpREFCOUNTED)
1223 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1224 break;
a0d0e21e
LW		 1225 default:
1226 break;
79072805 1227 }
11343788 1228 if (o->op_flags & OPf_KIDS) {
79072805 1229 OP *kid;
11343788 1230 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3967c732 1231 do_op_dump(level, file, kid);
8d063cd8 1232 }
cea2e8a9 1233 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732
JD		 1234}
1235
36b1c95c
MH		 1236/*
1237=for apidoc op_dump
1238
1239Dumps the optree starting at OP C<o> to C<STDERR>.
1240
1241=cut
1242*/
1243
3967c732 1244void
6867be6d 1245Perl_op_dump(pTHX_ const OP *o)
3967c732 1246{
7918f24d 1247 PERL_ARGS_ASSERT_OP_DUMP;
3967c732 1248 do_op_dump(0, Perl_debug_log, o);
8d063cd8
LW		 1249}
1250
8adcabd8 1251void
864dbfa3 1252Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1253{
0eb335df
BF		 1254 STRLEN len;
1255 const char* name;
1256 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1257
378cc40b 1258
7918f24d
NC		 1259 PERL_ARGS_ASSERT_GV_DUMP;
1260
79072805 1261 if (!gv) {
760ac839 1262 PerlIO_printf(Perl_debug_log, "{}\n");
378cc40b
LW		 1263 return;
1264 }
8990e307 1265 sv = sv_newmortal();
760ac839 1266 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1267 gv_fullname3(sv, gv, NULL);
0eb335df
BF		 1268 name = SvPV_const(sv, len);
1269 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1270 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
79072805 1271 if (gv != GvEGV(gv)) {
bd61b366 1272 gv_efullname3(sv, GvEGV(gv), NULL);
0eb335df
BF		 1273 name = SvPV_const(sv, len);
1274 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1275 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
8adcabd8 1276 }
3967c732 1277 PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1278 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8
LW		 1279}
1280
14befaf4 1281
afe38520 1282/* map magic types to the symbolic names
14befaf4
DM		 1283 * (with the PERL_MAGIC_ prefixed stripped)
1284 */
1285
27da23d5 1286static const struct { const char type; const char *name; } magic_names[] = {
52f49505 1287#include "mg_names.c"
516a5887 1288 /* this null string terminates the list */
b9ac451d 1289 { 0, NULL },
14befaf4
DM		 1290};
1291
8adcabd8 1292void
6867be6d 1293Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1294{
7918f24d
NC		 1295 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1296
3967c732 1297 for (; mg; mg = mg->mg_moremagic) {
b900a521
JH		 1298 Perl_dump_indent(aTHX_ level, file,
1299 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
3967c732 1300 if (mg->mg_virtual) {
bfed75c6 1301 const MGVTBL * const v = mg->mg_virtual;
2d1f1fe5
NC		 1302 if (v >= PL_magic_vtables
1303 && v < PL_magic_vtables + magic_vtable_max) {
1304 const U32 i = v - PL_magic_vtables;
1305 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1306 }
3967c732 1307 else
b900a521 1308 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
3967c732
JD		 1309 }
1310 else
cea2e8a9 1311 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1312
3967c732 1313 if (mg->mg_private)
cea2e8a9 1314 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1315
14befaf4
DM		 1316 {
1317 int n;
c445ea15 1318 const char *name = NULL;
27da23d5 1319 for (n = 0; magic_names[n].name; n++) {
14befaf4
DM		 1320 if (mg->mg_type == magic_names[n].type) {
1321 name = magic_names[n].name;
1322 break;
1323 }
1324 }
1325 if (name)
1326 Perl_dump_indent(aTHX_ level, file,
1327 " MG_TYPE = PERL_MAGIC_%s\n", name);
1328 else
1329 Perl_dump_indent(aTHX_ level, file,
1330 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1331 }
3967c732
JD		 1332
1333 if (mg->mg_flags) {
cea2e8a9 1334 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d
YST		 1335 if (mg->mg_type == PERL_MAGIC_envelem &&
1336 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1337 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
4c02285a
FR		 1338 if (mg->mg_type == PERL_MAGIC_regex_global &&
1339 mg->mg_flags & MGf_MINMATCH)
1340 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1341 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1342 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1343 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1344 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
4c02285a
FR		 1345 if (mg->mg_flags & MGf_COPY)
1346 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1347 if (mg->mg_flags & MGf_DUP)
1348 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1349 if (mg->mg_flags & MGf_LOCAL)
1350 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
25fdce4a
FC		 1351 if (mg->mg_type == PERL_MAGIC_regex_global &&
1352 mg->mg_flags & MGf_BYTES)
1353 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
3967c732
JD		 1354 }
1355 if (mg->mg_obj) {
4c02285a 1356 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
28d8d7f4
YO		 1357 PTR2UV(mg->mg_obj));
1358 if (mg->mg_type == PERL_MAGIC_qr) {
07bc277f 1359 REGEXP* const re = (REGEXP *)mg->mg_obj;
61f9802b 1360 SV * const dsv = sv_newmortal();
866c78d1 1361 const char * const s
4c02285a 1362 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1363 60, NULL, NULL,
95b611b0 1364 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1365 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1366 );
6483fb35
RGS		 1367 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1368 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
07bc277f 1369 (IV)RX_REFCNT(re));
28d8d7f4
YO		 1370 }
1371 if (mg->mg_flags & MGf_REFCOUNTED)
3967c732
JD		 1372 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1373 }
1374 if (mg->mg_len)
894356b3 1375 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1376 if (mg->mg_ptr) {
b900a521 1377 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
3967c732 1378 if (mg->mg_len >= 0) {
7e8c5dac 1379 if (mg->mg_type != PERL_MAGIC_utf8) {
17605be7 1380 SV * const sv = newSVpvs("");
7e8c5dac 1381 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
17605be7 1382 SvREFCNT_dec_NN(sv);
7e8c5dac 1383 }
3967c732
JD		 1384 }
1385 else if (mg->mg_len == HEf_SVKEY) {
1386 PerlIO_puts(file, " => HEf_SVKEY\n");
ad64d0ec
NC		 1387 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1388 maxnest, dumpops, pvlim); /* MG is already +1 */
3967c732
JD		 1389 continue;
1390 }
866f9d6c 1391 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
3967c732 1392 else
866f9d6c
FC		 1393 PerlIO_puts(
1394 file,
1395 " ???? - " __FILE__
1396 " does not know how to handle this MG_LEN"
1397 );
3967c732
JD		 1398 PerlIO_putc(file, '\n');
1399 }
7e8c5dac 1400 if (mg->mg_type == PERL_MAGIC_utf8) {
61f9802b 1401 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7e8c5dac
HS		 1402 if (cache) {
1403 IV i;
1404 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1405 Perl_dump_indent(aTHX_ level, file,
1406 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1407 i,
1408 (UV)cache[i * 2],
1409 (UV)cache[i * 2 + 1]);
1410 }
1411 }
378cc40b 1412 }
3967c732
JD		 1413}
1414
1415void
6867be6d 1416Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1417{
b9ac451d 1418 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD		 1419}
1420
1421void
e1ec3a88 1422Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1423{
bfcb3514 1424 const char *hvname;
7918f24d
NC		 1425
1426 PERL_ARGS_ASSERT_DO_HV_DUMP;
1427
b900a521 1428 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
bfcb3514 1429 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b
YO		 1430 {
1431 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1432 name which quite legally could contain insane things like tabs, newlines, nulls or
1433 other scary crap - this should produce sane results - except maybe for unicode package
1434 names - but we will wait for someone to file a bug on that - demerphq */
0eb335df
BF		 1435 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1436 PerlIO_printf(file, "\t\"%s\"\n",
1437 generic_pv_escape( tmpsv, hvname,
1438 HvNAMELEN(sv), HvNAMEUTF8(sv)));
d7d51f4b 1439 }
79072805 1440 else
3967c732
JD		 1441 PerlIO_putc(file, '\n');
1442}
1443
1444void
e1ec3a88 1445Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1446{
7918f24d
NC		 1447 PERL_ARGS_ASSERT_DO_GV_DUMP;
1448
b900a521 1449 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
0eb335df
BF		 1450 if (sv && GvNAME(sv)) {
1451 SV * const tmpsv = newSVpvs("");
1452 PerlIO_printf(file, "\t\"%s\"\n",
1453 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1454 }
c90c0ff4 1455 else
3967c732
JD		 1456 PerlIO_putc(file, '\n');
1457}
1458
1459void
e1ec3a88 1460Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1461{
7918f24d
NC		 1462 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1463
b900a521 1464 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732 1465 if (sv && GvNAME(sv)) {
0eb335df 1466 SV *tmp = newSVpvs_flags("", SVs_TEMP);
bfcb3514 1467 const char *hvname;
0eb335df
BF		 1468 HV * const stash = GvSTASH(sv);
1469 PerlIO_printf(file, "\t");
1470 /* TODO might have an extra \" here */
1471 if (stash && (hvname = HvNAME_get(stash))) {
1472 PerlIO_printf(file, "\"%s\" :: \"",
1473 generic_pv_escape(tmp, hvname,
1474 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1475 }
1476 PerlIO_printf(file, "%s\"\n",
1477 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
8d063cd8 1478 }
3967c732
JD		 1479 else
1480 PerlIO_putc(file, '\n');
1481}
1482
a0c2f4dd
NC		 1483const struct flag_to_name first_sv_flags_names[] = {
1484 {SVs_TEMP, "TEMP,"},
1485 {SVs_OBJECT, "OBJECT,"},
1486 {SVs_GMG, "GMG,"},
1487 {SVs_SMG, "SMG,"},
1488 {SVs_RMG, "RMG,"},
1489 {SVf_IOK, "IOK,"},
1490 {SVf_NOK, "NOK,"},
1491 {SVf_POK, "POK,"}
1492};
1493
1494const struct flag_to_name second_sv_flags_names[] = {
1495 {SVf_OOK, "OOK,"},
1496 {SVf_FAKE, "FAKE,"},
1497 {SVf_READONLY, "READONLY,"},
e3918bb7 1498 {SVf_IsCOW, "IsCOW,"},
a0c2f4dd
NC		 1499 {SVf_BREAK, "BREAK,"},
1500 {SVf_AMAGIC, "OVERLOAD,"},
1501 {SVp_IOK, "pIOK,"},
1502 {SVp_NOK, "pNOK,"},
1503 {SVp_POK, "pPOK,"}
1504};
1505
ae1f06a1
NC		 1506const struct flag_to_name cv_flags_names[] = {
1507 {CVf_ANON, "ANON,"},
1508 {CVf_UNIQUE, "UNIQUE,"},
1509 {CVf_CLONE, "CLONE,"},
1510 {CVf_CLONED, "CLONED,"},
1511 {CVf_CONST, "CONST,"},
1512 {CVf_NODEBUG, "NODEBUG,"},
1513 {CVf_LVALUE, "LVALUE,"},
1514 {CVf_METHOD, "METHOD,"},
cfc1e951 1515 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1516 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1517 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1518 {CVf_AUTOLOAD, "AUTOLOAD,"},
55f7f8ab 1519 {CVf_HASEVAL, "HASEVAL"},
bfbc3ad9 1520 {CVf_SLABBED, "SLABBED,"},
31d45e0c 1521 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC		 1522};
1523
1524const struct flag_to_name hv_flags_names[] = {
1525 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1526 {SVphv_LAZYDEL, "LAZYDEL,"},
1527 {SVphv_HASKFLAGS, "HASKFLAGS,"},
ae1f06a1
NC		 1528 {SVphv_CLONEABLE, "CLONEABLE,"}
1529};
1530
1531const struct flag_to_name gp_flags_names[] = {
1532 {GVf_INTRO, "INTRO,"},
1533 {GVf_MULTI, "MULTI,"},
1534 {GVf_ASSUMECV, "ASSUMECV,"},
1535 {GVf_IN_PAD, "IN_PAD,"}
1536};
1537
1538const struct flag_to_name gp_flags_imported_names[] = {
1539 {GVf_IMPORTED_SV, " SV"},
1540 {GVf_IMPORTED_AV, " AV"},
1541 {GVf_IMPORTED_HV, " HV"},
1542 {GVf_IMPORTED_CV, " CV"},
1543};
1544
0d331aaf
YO		 1545/* NOTE: this structure is mostly duplicative of one generated by
1546 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1547 * the two. - Yves */
e3e400ec 1548const struct flag_to_name regexp_extflags_names[] = {
d63e6659
DM		 1549 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1550 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1551 {RXf_PMf_FOLD, "PMf_FOLD,"},
1552 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1553 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
8e1490ee 1554 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
dbc200c5 1555 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
d63e6659 1556 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
d63e6659
DM		 1557 {RXf_CHECK_ALL, "CHECK_ALL,"},
1558 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1559 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1560 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1561 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
dbc200c5 1562 {RXf_SPLIT, "SPLIT,"},
d63e6659
DM		 1563 {RXf_COPY_DONE, "COPY_DONE,"},
1564 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1565 {RXf_TAINTED, "TAINTED,"},
1566 {RXf_START_ONLY, "START_ONLY,"},
dbc200c5 1567 {RXf_SKIPWHITE, "SKIPWHITE,"},
d63e6659
DM		 1568 {RXf_WHITE, "WHITE,"},
1569 {RXf_NULL, "NULL,"},
1570};
1571
0d331aaf
YO		 1572/* NOTE: this structure is mostly duplicative of one generated by
1573 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1574 * the two. - Yves */
e3e400ec
YO		 1575const struct flag_to_name regexp_core_intflags_names[] = {
1576 {PREGf_SKIP, "SKIP,"},
0d331aaf
YO		 1577 {PREGf_IMPLICIT, "IMPLICIT,"},
1578 {PREGf_NAUGHTY, "NAUGHTY,"},
e3e400ec
YO		 1579 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1580 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
0d331aaf 1581 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
e3e400ec 1582 {PREGf_NOSCAN, "NOSCAN,"},
0d331aaf 1583 {PREGf_CANY_SEEN, "CANY_SEEN,"},
58430ea8
YO		 1584 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1585 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
8e1490ee
YO		 1586 {PREGf_ANCH_BOL, "ANCH_BOL,"},
1587 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1588 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1589 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
e3e400ec
YO		 1590};
1591
3967c732 1592void
864dbfa3 1593Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1594{
97aff369 1595 dVAR;
cea89e20 1596 SV *d;
e1ec3a88 1597 const char *s;
3967c732
JD		 1598 U32 flags;
1599 U32 type;
1600
7918f24d
NC		 1601 PERL_ARGS_ASSERT_DO_SV_DUMP;
1602
3967c732 1603 if (!sv) {
cea2e8a9 1604 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1605 return;
378cc40b 1606 }
2ef28da1 1607
3967c732
JD		 1608 flags = SvFLAGS(sv);
1609 type = SvTYPE(sv);
79072805 1610
e0bbf362
DM		 1611 /* process general SV flags */
1612
cea89e20 1613 d = Perl_newSVpvf(aTHX_
57def98f 1614 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
56431972 1615 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS		 1616 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1617 (int)(PL_dumpindent*level), "");
8d063cd8 1618
1979170b
NC		 1619 if (!((flags & SVpad_NAME) == SVpad_NAME
1620 && (type == SVt_PVMG || type == SVt_PVNV))) {
9a214eec
DM		 1621 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1622 sv_catpv(d, "PADSTALE,");
e604303a 1623 }
1979170b 1624 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
9a214eec
DM		 1625 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1626 sv_catpv(d, "PADTMP,");
e604303a
NC		 1627 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1628 }
a0c2f4dd 1629 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS		 1630 if (flags & SVf_ROK) {
1631 sv_catpv(d, "ROK,");
1632 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1633 }
a0c2f4dd 1634 append_flags(d, flags, second_sv_flags_names);
7db6405c
FC		 1635 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1636 && type != SVt_PVAV) {
1ccdb730
NC		 1637 if (SvPCS_IMPORTED(sv))
1638 sv_catpv(d, "PCS_IMPORTED,");
1639 else
9660f481 1640 sv_catpv(d, "SCREAM,");
1ccdb730 1641 }
3967c732 1642
e0bbf362
DM		 1643 /* process type-specific SV flags */
1644
3967c732
JD		 1645 switch (type) {
1646 case SVt_PVCV:
1647 case SVt_PVFM:
ae1f06a1 1648 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD		 1649 break;
1650 case SVt_PVHV:
ae1f06a1 1651 append_flags(d, flags, hv_flags_names);
3967c732 1652 break;
926fc7b6
DM		 1653 case SVt_PVGV:
1654 case SVt_PVLV:
1655 if (isGV_with_GP(sv)) {
ae1f06a1 1656 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1657 }
926fc7b6 1658 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD		 1659 sv_catpv(d, "IMPORT");
1660 if (GvIMPORTED(sv) == GVf_IMPORTED)
1661 sv_catpv(d, "ALL,");
1662 else {
1663 sv_catpv(d, "(");
ae1f06a1 1664 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD		 1665 sv_catpv(d, " ),");
1666 }
1667 }
addd1794 1668 /* FALL THROUGH */
25da4f38 1669 default:
e604303a 1670 evaled_or_uv:
25da4f38 1671 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
69c678eb 1672 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1673 break;
addd1794 1674 case SVt_PVMG:
c13a5c80
NC		 1675 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1676 if (SvVALID(sv)) sv_catpv(d, "VALID,");
00b1698f 1677 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
e604303a 1678 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
2e94196c 1679 /* FALL THROUGH */
e604303a
NC		 1680 case SVt_PVNV:
1681 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1682 goto evaled_or_uv;
11ca45c0 1683 case SVt_PVAV:
7db6405c 1684 if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
11ca45c0 1685 break;
3967c732 1686 }
86f0d186
NC		 1687 /* SVphv_SHAREKEYS is also 0x20000000 */
1688 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1689 sv_catpv(d, "UTF8");
3967c732 1690
b162af07
SP		 1691 if (*(SvEND(d) - 1) == ',') {
1692 SvCUR_set(d, SvCUR(d) - 1);
1693 SvPVX(d)[SvCUR(d)] = '\0';
1694 }
3967c732 1695 sv_catpv(d, ")");
b15aece3 1696 s = SvPVX_const(d);
3967c732 1697
e0bbf362
DM		 1698 /* dump initial SV details */
1699
fd0854ff 1700#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1701 Perl_dump_indent(aTHX_ level, file,
cd676548 1702 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
fd0854ff
DM		 1703 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1704 sv->sv_debug_line,
1705 sv->sv_debug_inpad ? "for" : "by",
1706 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1707 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM		 1708 sv->sv_debug_serial
1709 );
fd0854ff 1710#endif
cea2e8a9 1711 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM		 1712
1713 /* Dump SV type */
1714
5357ca29
NC		 1715 if (type < SVt_LAST) {
1716 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1717
1718 if (type == SVt_NULL) {
5f954473 1719 SvREFCNT_dec_NN(d);
5357ca29
NC		 1720 return;
1721 }
1722 } else {
faccc32b 1723 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
5f954473 1724 SvREFCNT_dec_NN(d);
3967c732
JD		 1725 return;
1726 }
e0bbf362
DM		 1727
1728 /* Dump general SV fields */
1729
27bd069f 1730 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC		 1731 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1732 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1733 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1734 if (SvIsUV(sv)
f8c7b90f 1735#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC		 1736 || SvIsCOW(sv)
1737#endif
1738 )
57def98f 1739 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1740 else
57def98f 1741 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
f8c7b90f 1742#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC		 1743 if (SvIsCOW_shared_hash(sv))
1744 PerlIO_printf(file, " (HASH)");
1745 else if (SvIsCOW_normal(sv))
1746 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1747#endif
3967c732
JD		 1748 PerlIO_putc(file, '\n');
1749 }
e0bbf362 1750
1979170b
NC		 1751 if ((type == SVt_PVNV || type == SVt_PVMG)
1752 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
0e4c4423
NC		 1753 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1754 (UV) COP_SEQ_RANGE_LOW(sv));
1755 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1756 (UV) COP_SEQ_RANGE_HIGH(sv));
1757 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1758 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1759 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1760 || type == SVt_NV) {
e54dc35b 1761 STORE_NUMERIC_LOCAL_SET_STANDARD();
57def98f 1762 /* %Vg doesn't work? --jhi */
cf2093f6 1763#ifdef USE_LONG_DOUBLE
2d4389e4 1764 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
cf2093f6 1765#else
cea2e8a9 1766 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
cf2093f6 1767#endif
e54dc35b 1768 RESTORE_NUMERIC_LOCAL();
3967c732 1769 }
e0bbf362 1770
3967c732 1771 if (SvROK(sv)) {
57def98f 1772 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732
JD		 1773 if (nest < maxnest)
1774 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1775 }
e0bbf362 1776
cea89e20 1777 if (type < SVt_PV) {
5f954473 1778 SvREFCNT_dec_NN(d);
3967c732 1779 return;
cea89e20 1780 }
e0bbf362 1781
5a3c7349
FC		 1782 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1783 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC		 1784 const bool re = isREGEXP(sv);
1785 const char * const ptr =
1786 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1787 if (ptr) {
69240efd 1788 STRLEN delta;
7a4bba22 1789 if (SvOOK(sv)) {
69240efd 1790 SvOOK_offset(sv, delta);
7a4bba22 1791 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
5186cc12 1792 (UV) delta);
69240efd
NC		 1793 } else {
1794 delta = 0;
7a4bba22 1795 }
8d919b0a 1796 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
7a4bba22
NC		 1797 if (SvOOK(sv)) {
1798 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1799 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC		 1800 pvlim));
1801 }
ad3f05ad
KW		 1802 if (type == SVt_INVLIST) {
1803 PerlIO_printf(file, "\n");
1804 /* 4 blanks indents 2 beyond the PV, etc */
1805 _invlist_dump(file, level, " ", sv);
1806 }
1807 else {
685bfc3c
KW		 1808 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1809 re ? 0 : SvLEN(sv),
1810 pvlim));
1811 if (SvUTF8(sv)) /* the 6? \x{....} */
1812 PerlIO_printf(file, " [UTF8 \"%s\"]",
1813 sv_uni_display(d, sv, 6 * SvCUR(sv),
1814 UNI_DISPLAY_QQ));
1815 PerlIO_printf(file, "\n");
ad3f05ad 1816 }
57def98f 1817 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
8d919b0a
FC		 1818 if (!re)
1819 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1820 (IV)SvLEN(sv));
db2c6cb3
FC		 1821#ifdef PERL_NEW_COPY_ON_WRITE
1822 if (SvIsCOW(sv) && SvLEN(sv))
1823 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1824 CowREFCNT(sv));
1825#endif
3967c732
JD		 1826 }
1827 else
cea2e8a9 1828 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1829 }
e0bbf362 1830
3967c732 1831 if (type >= SVt_PVMG) {
0e4c4423 1832 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
61f9802b 1833 HV * const ost = SvOURSTASH(sv);
38cbaf55
RGS		 1834 if (ost)
1835 do_hv_dump(level, file, " OURSTASH", ost);
7db6405c
FC		 1836 } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1837 Perl_dump_indent(aTHX_ level, file, " MAXNAMED = %"UVuf"\n",
1838 (UV)PadnamelistMAXNAMED(sv));
0e4c4423
NC		 1839 } else {
1840 if (SvMAGIC(sv))
8530ff28 1841 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
0e4c4423 1842 }
3967c732
JD		 1843 if (SvSTASH(sv))
1844 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC		 1845
1846 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
c13a5c80
NC		 1847 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1848 }
3967c732 1849 }
e0bbf362
DM		 1850
1851 /* Dump type-specific SV fields */
1852
3967c732 1853 switch (type) {
3967c732 1854 case SVt_PVAV:
57def98f 1855 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1856 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f
JH		 1857 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1858 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732
JD		 1859 }
1860 else
1861 PerlIO_putc(file, '\n');
57def98f
JH		 1862 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1863 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
7db6405c
FC		 1864 /* arylen is stored in magic, and padnamelists use SvMAGIC for
1865 something else. */
1866 if (!AvPAD_NAMELIST(sv))
1867 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1868 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
76f68e9b 1869 sv_setpvs(d, "");
11ca45c0
NC		 1870 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1871 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP		 1872 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1873 SvCUR(d) ? SvPVX_const(d) + 1 : "");
b9f2b683 1874 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
c70927a6 1875 SSize_t count;
b9f2b683 1876 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
502c6561 1877 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
3967c732 1878
57def98f 1879 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
2ef28da1 1880 if (elt)
3967c732
JD		 1881 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1882 }
1883 }
1884 break;
1885 case SVt_PVHV:
57def98f 1886 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1b95d04f 1887 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
3967c732
JD		 1888 /* Show distribution of HEs in the ARRAY */
1889 int freq[200];
bb7a0f54 1890#define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
3967c732
JD		 1891 int i;
1892 int max = 0;
1b95d04f 1893 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
65202027 1894 NV theoret, sum = 0;
3967c732
JD		 1895
1896 PerlIO_printf(file, " (");
1897 Zero(freq, FREQ_MAX + 1, int);
eb160463 1898 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL		 1899 HE* h;
1900 int count = 0;
3967c732
JD		 1901 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1902 count++;
1903 if (count > FREQ_MAX)
1904 count = FREQ_MAX;
1905 freq[count]++;
1906 if (max < count)
1907 max = count;
1908 }
1909 for (i = 0; i <= max; i++) {
1910 if (freq[i]) {
1911 PerlIO_printf(file, "%d%s:%d", i,
1912 (i == FREQ_MAX) ? "+" : "",
1913 freq[i]);
1914 if (i != max)
1915 PerlIO_printf(file, ", ");
1916 }
1917 }
1918 PerlIO_putc(file, ')');
b8fa94d8
MG		 1919 /* The "quality" of a hash is defined as the total number of
1920 comparisons needed to access every element once, relative
1921 to the expected number needed for a random hash.
1922
1923 The total number of comparisons is equal to the sum of
e76cd0fa
AMS		 1924 the squares of the number of entries in each bucket.
1925 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG		 1926 value is
1927 n + n(n-1)/2k
1928 */
1929
3967c732
JD		 1930 for (i = max; i > 0; i--) { /* Precision: count down. */
1931 sum += freq[i] * i * i;
1932 }
155aba94 1933 while ((keys = keys >> 1))
3967c732 1934 pow2 = pow2 << 1;
1b95d04f 1935 theoret = HvUSEDKEYS(sv);
b8fa94d8 1936 theoret += theoret * (theoret-1)/pow2;
3967c732 1937 PerlIO_putc(file, '\n');
6b4667fc 1938 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732
JD		 1939 }
1940 PerlIO_putc(file, '\n');
1b95d04f 1941 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
9faf471a
NC		 1942 {
1943 STRLEN count = 0;
1944 HE **ents = HvARRAY(sv);
1945
1946 if (ents) {
1947 HE *const *const last = ents + HvMAX(sv);
1948 count = last + 1 - ents;
1949
1950 do {
1951 if (!*ents)
1952 --count;
1953 } while (++ents <= last);
1954 }
1955
1956 if (SvOOK(sv)) {
1957 struct xpvhv_aux *const aux = HvAUX(sv);
1958 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1959 " (cached = %"UVuf")\n",
1960 (UV)count, (UV)aux->xhv_fill_lazy);
1961 } else {
1962 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1963 (UV)count);
1964 }
1965 }
57def98f 1966 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
e1a7ec8d
YO		 1967 if (SvOOK(sv)) {
1968 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1969 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
6a5b4183 1970#ifdef PERL_HASH_RANDOMIZE_KEYS
e1a7ec8d
YO		 1971 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1972 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
6a5b4183 1973 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
e1a7ec8d 1974 }
6a5b4183
YO		 1975#endif
1976 PerlIO_putc(file, '\n');
e1a7ec8d 1977 }
8d2f4536 1978 {
b9ac451d 1979 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536
NC		 1980 if (mg && mg->mg_obj) {
1981 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1982 }
1983 }
bfcb3514 1984 {
b9ac451d 1985 const char * const hvname = HvNAME_get(sv);
0eb335df
BF		 1986 if (hvname) {
1987 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1988 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1989 generic_pv_escape( tmpsv, hvname,
1990 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1991 }
bfcb3514 1992 }
86f55936 1993 if (SvOOK(sv)) {
ad64d0ec 1994 AV * const backrefs
85fbaab2 1995 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1996 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC		 1997 if (HvAUX(sv)->xhv_name_count)
1998 Perl_dump_indent(aTHX_
7afc2217
FC		 1999 level, file, " NAMECOUNT = %"IVdf"\n",
2000 (IV)HvAUX(sv)->xhv_name_count
67e04715 2001 );
15d9236d 2002 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC		 2003 const I32 count = HvAUX(sv)->xhv_name_count;
2004 if (count) {
2005 SV * const names = newSVpvs_flags("", SVs_TEMP);
2006 /* The starting point is the first element if count is
2007 positive and the second element if count is negative. */
2008 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2009 + (count < 0 ? 1 : 0);
2010 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2011 + (count < 0 ? -count : count);
2012 while (hekp < endp) {
0eb335df
BF		 2013 if (HEK_LEN(*hekp)) {
2014 SV *tmp = newSVpvs_flags("", SVs_TEMP);
2015 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2016 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC		 2017 } else {
2018 /* This should never happen. */
2019 sv_catpvs(names, ", (null)");
67e04715 2020 }
ec3405c8
NC		 2021 ++hekp;
2022 }
67e04715
FC		 2023 Perl_dump_indent(aTHX_
2024 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2025 );
2026 }
0eb335df
BF		 2027 else {
2028 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2029 const char *const hvename = HvENAME_get(sv);
67e04715 2030 Perl_dump_indent(aTHX_
0eb335df
BF		 2031 level, file, " ENAME = \"%s\"\n",
2032 generic_pv_escape(tmp, hvename,
2033 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2034 }
67e04715 2035 }
86f55936
NC		 2036 if (backrefs) {
2037 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
2038 PTR2UV(backrefs));
ad64d0ec 2039 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC		 2040 dumpops, pvlim);
2041 }
7d88e6c4 2042 if (meta) {
0eb335df
BF		 2043 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2044 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
2045 generic_pv_escape( tmpsv, meta->mro_which->name,
2046 meta->mro_which->length,
2047 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4
NC		 2048 PTR2UV(meta->mro_which));
2049 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
2050 (UV)meta->cache_gen);
2051 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
2052 (UV)meta->pkg_gen);
2053 if (meta->mro_linear_all) {
2054 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
2055 PTR2UV(meta->mro_linear_all));
2056 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2057 dumpops, pvlim);
2058 }
2059 if (meta->mro_linear_current) {
2060 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
2061 PTR2UV(meta->mro_linear_current));
2062 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2063 dumpops, pvlim);
2064 }
2065 if (meta->mro_nextmethod) {
2066 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
2067 PTR2UV(meta->mro_nextmethod));
2068 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2069 dumpops, pvlim);
2070 }
2071 if (meta->isa) {
2072 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
2073 PTR2UV(meta->isa));
2074 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2075 dumpops, pvlim);
2076 }
2077 }
86f55936 2078 }
b5698553 2079 if (nest < maxnest) {
cbab3169 2080 HV * const hv = MUTABLE_HV(sv);
b5698553
TH		 2081 STRLEN i;
2082 HE *he;
cbab3169 2083
b5698553
TH		 2084 if (HvARRAY(hv)) {
2085 int count = maxnest - nest;
2086 for (i=0; i <= HvMAX(hv); i++) {
2087 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2088 U32 hash;
2089 SV * keysv;
2090 const char * keypv;
2091 SV * elt;
7dc86639 2092 STRLEN len;
b5698553
TH		 2093
2094 if (count-- <= 0) goto DONEHV;
2095
2096 hash = HeHASH(he);
2097 keysv = hv_iterkeysv(he);
2098 keypv = SvPV_const(keysv, len);
2099 elt = HeVAL(he);
cbab3169 2100
7dc86639
YO		 2101 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2102 if (SvUTF8(keysv))
2103 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH		 2104 if (HvEITER_get(hv) == he)
2105 PerlIO_printf(file, "[CURRENT] ");
7dc86639
YO		 2106 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
2107 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2108 }
b5698553
TH		 2109 }
2110 DONEHV:;
2111 }
3967c732
JD		 2112 }
2113 break;
e0bbf362 2114
3967c732 2115 case SVt_PVCV:
8fa6a409 2116 if (CvAUTOLOAD(sv)) {
0eb335df
BF		 2117 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2118 STRLEN len;
8fa6a409 2119 const char *const name = SvPV_const(sv, len);
0eb335df
BF		 2120 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2121 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC		 2122 }
2123 if (SvPOK(sv)) {
0eb335df
BF		 2124 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2125 const char *const proto = CvPROTO(sv);
2126 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2127 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2128 SvUTF8(sv)));
cbf82dd0 2129 }
3967c732
JD		 2130 /* FALL THROUGH */
2131 case SVt_PVFM:
2132 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC		 2133 if (!CvISXSUB(sv)) {
2134 if (CvSTART(sv)) {
2135 Perl_dump_indent(aTHX_ level, file,
2136 " START = 0x%"UVxf" ===> %"IVdf"\n",
2137 PTR2UV(CvSTART(sv)),
2138 (IV)sequence_num(CvSTART(sv)));
2139 }
2140 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
2141 PTR2UV(CvROOT(sv)));
2142 if (CvROOT(sv) && dumpops) {
2143 do_op_dump(level+1, file, CvROOT(sv));
2144 }
2145 } else {
126f53f3 2146 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 2147
d04ba589 2148 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099
NC		 2149
2150 if (constant) {
2151 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
2152 " (CONST SV)\n",
2153 PTR2UV(CvXSUBANY(sv).any_ptr));
2154 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2155 pvlim);
2156 } else {
2157 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2158 (IV)CvXSUBANY(sv).any_i32);
2159 }
2160 }
3610c89f
FC		 2161 if (CvNAMED(sv))
2162 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2163 HEK_KEY(CvNAME_HEK((CV *)sv)));
2164 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 2165 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
bb02a38f 2166 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 2167 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 2168 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
57def98f 2169 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
dd2155a4
DM		 2170 if (nest < maxnest) {
2171 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
3967c732
JD		 2172 }
2173 {
b9ac451d 2174 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 2175 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 2176 PTR2UV(outside),
cf2093f6
JH		 2177 (!outside ? "null"
2178 : CvANON(outside) ? "ANON"
2179 : (outside == PL_main_cv) ? "MAIN"
2180 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF		 2181 : CvGV(outside) ?
2182 generic_pv_escape(
2183 newSVpvs_flags("", SVs_TEMP),
2184 GvNAME(CvGV(outside)),
2185 GvNAMELEN(CvGV(outside)),
2186 GvNAMEUTF8(CvGV(outside)))
2187 : "UNDEFINED"));
3967c732
JD		 2188 }
2189 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
ad64d0ec 2190 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2191 break;
e0bbf362 2192
926fc7b6
DM		 2193 case SVt_PVGV:
2194 case SVt_PVLV:
b9ac451d
AL		 2195 if (type == SVt_PVLV) {
2196 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2197 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2198 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2199 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
83f78d1a 2200 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
b9ac451d
AL		 2201 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2202 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2203 dumpops, pvlim);
2204 }
8d919b0a 2205 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM		 2206 if (!isGV_with_GP(sv))
2207 break;
0eb335df
BF		 2208 {
2209 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2210 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2211 generic_pv_escape(tmpsv, GvNAME(sv),
2212 GvNAMELEN(sv),
2213 GvNAMEUTF8(sv)));
2214 }
57def98f 2215 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 2216 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
57def98f 2217 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c
GS		 2218 if (!GvGP(sv))
2219 break;
57def98f
JH		 2220 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2221 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2222 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2223 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2224 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2225 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2226 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2227 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
57def98f 2228 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 2229 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
e39917cc 2230 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
3967c732
JD		 2231 do_gv_dump (level, file, " EGV", GvEGV(sv));
2232 break;
2233 case SVt_PVIO:
57def98f
JH		 2234 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2235 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2236 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2237 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2238 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2239 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2240 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 2241 if (IoTOP_NAME(sv))
cea2e8a9 2242 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC		 2243 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2244 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2245 else {
2246 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2247 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC		 2248 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2249 maxnest, dumpops, pvlim);
9ba1f565
NC		 2250 }
2251 /* Source filters hide things that are not GVs in these three, so let's
2252 be careful out there. */
27533608 2253 if (IoFMT_NAME(sv))
cea2e8a9 2254 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC		 2255 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2256 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2257 else {
2258 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2259 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC		 2260 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2261 maxnest, dumpops, pvlim);
9ba1f565 2262 }
27533608 2263 if (IoBOTTOM_NAME(sv))
cea2e8a9 2264 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC		 2265 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2266 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2267 else {
2268 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2269 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC		 2270 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2271 maxnest, dumpops, pvlim);
9ba1f565 2272 }
27533608 2273 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2274 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2275 else
cea2e8a9 2276 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 2277 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 2278 break;
206ee256 2279 case SVt_REGEXP:
8d919b0a 2280 dumpregexp:
d63e6659 2281 {
8d919b0a 2282 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO		 2283
2284#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2285 sv_setpv(d,""); \
e3e400ec 2286 append_flags(d, flags, names); \
ec16d31f
YO		 2287 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2288 SvCUR_set(d, SvCUR(d) - 1); \
2289 SvPVX(d)[SvCUR(d)] = '\0'; \
2290 } \
2291} STMT_END
e3e400ec 2292 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
dbc200c5
YO		 2293 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2294 (UV)(r->compflags), SvPVX_const(d));
2295
e3e400ec 2296 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
d63e6659 2297 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
dbc200c5
YO		 2298 (UV)(r->extflags), SvPVX_const(d));
2299
e3e400ec
YO		 2300 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2301 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2302 if (r->engine == &PL_core_reg_engine) {
2303 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2304 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2305 (UV)(r->intflags), SvPVX_const(d));
2306 } else {
2307 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
d63e6659 2308 (UV)(r->intflags));
e3e400ec
YO		 2309 }
2310#undef SV_SET_STRINGIFY_REGEXP_FLAGS
d63e6659
DM		 2311 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2312 (UV)(r->nparens));
2313 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2314 (UV)(r->lastparen));
2315 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2316 (UV)(r->lastcloseparen));
2317 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2318 (IV)(r->minlen));
2319 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2320 (IV)(r->minlenret));
2321 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2322 (UV)(r->gofs));
2323 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2324 (UV)(r->pre_prefix));
d63e6659
DM		 2325 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2326 (IV)(r->sublen));
6502e081
DM		 2327 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2328 (IV)(r->suboffset));
2329 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2330 (IV)(r->subcoffset));
d63e6659
DM		 2331 if (r->subbeg)
2332 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2333 PTR2UV(r->subbeg),
2334 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2335 else
2336 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
d63e6659
DM		 2337 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2338 PTR2UV(r->mother_re));
01ffd0f1
FC		 2339 if (nest < maxnest && r->mother_re)
2340 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2341 maxnest, dumpops, pvlim);
d63e6659
DM		 2342 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2343 PTR2UV(r->paren_names));
2344 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2345 PTR2UV(r->substrs));
2346 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2347 PTR2UV(r->pprivate));
2348 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2349 PTR2UV(r->offs));
d63c20f2
DM		 2350 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2351 PTR2UV(r->qr_anoncv));
db2c6cb3 2352#ifdef PERL_ANY_COW
d63e6659
DM		 2353 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2354 PTR2UV(r->saved_copy));
2355#endif
2356 }
206ee256 2357 break;
3967c732 2358 }
5f954473 2359 SvREFCNT_dec_NN(d);
3967c732
JD		 2360}
2361
36b1c95c
MH		 2362/*
2363=for apidoc sv_dump
2364
2365Dumps the contents of an SV to the C<STDERR> filehandle.
2366
2367For an example of its output, see L<Devel::Peek>.
2368
2369=cut
2370*/
2371
3967c732 2372void
864dbfa3 2373Perl_sv_dump(pTHX_ SV *sv)
3967c732 2374{
97aff369 2375 dVAR;
7918f24d
NC		 2376
2377 PERL_ARGS_ASSERT_SV_DUMP;
2378
d1029faa
JP		 2379 if (SvROK(sv))
2380 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2381 else
2382 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2383}
bd16a5f0
IZ		 2384
2385int
2386Perl_runops_debug(pTHX)
2387{
97aff369 2388 dVAR;
bd16a5f0 2389 if (!PL_op) {
9b387841 2390 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ		 2391 return 0;
2392 }
2393
9f3673fb 2394 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2395 do {
75d476e2
S		 2396#ifdef PERL_TRACE_OPS
2397 ++PL_op_exec_cnt[PL_op->op_type];
2398#endif
bd16a5f0 2399 if (PL_debug) {
b9ac451d 2400 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0
IZ		 2401 PerlIO_printf(Perl_debug_log,
2402 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2403 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2404 PTR2UV(*PL_watchaddr));
d6721266
DM		 2405 if (DEBUG_s_TEST_) {
2406 if (DEBUG_v_TEST_) {
2407 PerlIO_printf(Perl_debug_log, "\n");
2408 deb_stack_all();
2409 }
2410 else
2411 debstack();
2412 }
2413
2414
bd16a5f0
IZ		 2415 if (DEBUG_t_TEST_) debop(PL_op);
2416 if (DEBUG_P_TEST_) debprof(PL_op);
2417 }
fe83c362
SM		 2418
2419 OP_ENTRY_PROBE(OP_NAME(PL_op));
16c91539 2420 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2421 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2422 PERL_ASYNC_CHECK();
bd16a5f0
IZ		 2423
2424 TAINT_NOT;
2425 return 0;
2426}
2427
2428I32
6867be6d 2429Perl_debop(pTHX_ const OP *o)
bd16a5f0 2430{
97aff369 2431 dVAR;
7918f24d
NC		 2432
2433 PERL_ARGS_ASSERT_DEBOP;
2434
1045810a
IZ		 2435 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2436 return 0;
2437
bd16a5f0
IZ		 2438 Perl_deb(aTHX_ "%s", OP_NAME(o));
2439 switch (o->op_type) {
2440 case OP_CONST:
996c9baa 2441 case OP_HINTSEVAL:
6cefa69e 2442 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2443 * may not be active here, so check.
6cefa69e 2444 * Looks like only during compiling the pads are illegal.
7367e658 2445 */
6cefa69e
RU		 2446#ifdef USE_ITHREADS
2447 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2448#endif
7367e658 2449 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ		 2450 break;
2451 case OP_GVSV:
2452 case OP_GV:
2453 if (cGVOPo_gv) {
b9ac451d 2454 SV * const sv = newSV(0);
3b721df9 2455#ifdef PERL_MAD
84021b46 2456 /* FIXME - is this making unwarranted assumptions about the
3b721df9
NC		 2457 UTF-8 cleanliness of the dump file handle? */
2458 SvUTF8_on(sv);
2459#endif
bd61b366 2460 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2461 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
5f954473 2462 SvREFCNT_dec_NN(sv);
bd16a5f0
IZ		 2463 }
2464 else
2465 PerlIO_printf(Perl_debug_log, "(NULL)");
2466 break;
a7fd8ef6
DM		 2467
2468 {
2469 int count;
2470
bd16a5f0
IZ		 2471 case OP_PADSV:
2472 case OP_PADAV:
2473 case OP_PADHV:
a7fd8ef6
DM		 2474 count = 1;
2475 goto dump_padop;
2476 case OP_PADRANGE:
2477 count = o->op_private & OPpPADRANGE_COUNTMASK;
2478 dump_padop:
bd16a5f0 2479 /* print the lexical's name */
a7fd8ef6
DM		 2480 {
2481 CV * const cv = deb_curcv(cxstack_ix);
2482 SV *sv;
2483 PAD * comppad = NULL;
2484 int i;
2485
2486 if (cv) {
2487 PADLIST * const padlist = CvPADLIST(cv);
2488 comppad = *PadlistARRAY(padlist);
2489 }
2490 PerlIO_printf(Perl_debug_log, "(");
2491 for (i = 0; i < count; i++) {
2492 if (comppad &&
2493 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2494 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2495 else
2496 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2497 (UV)o->op_targ+i);
2498 if (i < count-1)
2499 PerlIO_printf(Perl_debug_log, ",");
2500 }
2501 PerlIO_printf(Perl_debug_log, ")");
2502 }
bd16a5f0 2503 break;
a7fd8ef6
DM		 2504 }
2505
bd16a5f0 2506 default:
091ab601 2507 break;
bd16a5f0
IZ		 2508 }
2509 PerlIO_printf(Perl_debug_log, "\n");
2510 return 0;
2511}
2512
2513STATIC CV*
61f9802b 2514S_deb_curcv(pTHX_ const I32 ix)
bd16a5f0 2515{
97aff369 2516 dVAR;
b9ac451d 2517 const PERL_CONTEXT * const cx = &cxstack[ix];
bd16a5f0
IZ		 2518 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2519 return cx->blk_sub.cv;
2520 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
676a678a 2521 return cx->blk_eval.cv;
bd16a5f0
IZ		 2522 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2523 return PL_main_cv;
2524 else if (ix <= 0)
601f1833 2525 return NULL;
bd16a5f0
IZ		 2526 else
2527 return deb_curcv(ix - 1);
2528}
2529
2530void
2531Perl_watch(pTHX_ char **addr)
2532{
97aff369 2533 dVAR;
7918f24d
NC		 2534
2535 PERL_ARGS_ASSERT_WATCH;
2536
bd16a5f0
IZ		 2537 PL_watchaddr = addr;
2538 PL_watchok = *addr;
2539 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2540 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2541}
2542
2543STATIC void
e1ec3a88 2544S_debprof(pTHX_ const OP *o)
bd16a5f0 2545{
97aff369 2546 dVAR;
7918f24d
NC		 2547
2548 PERL_ARGS_ASSERT_DEBPROF;
2549
61f9802b 2550 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2551 return;
bd16a5f0 2552 if (!PL_profiledata)
a02a5408 2553 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ		 2554 ++PL_profiledata[o->op_type];
2555}
2556
2557void
2558Perl_debprofdump(pTHX)
2559{
97aff369 2560 dVAR;
bd16a5f0
IZ		 2561 unsigned i;
2562 if (!PL_profiledata)
2563 return;
2564 for (i = 0; i < MAXO; i++) {
2565 if (PL_profiledata[i])
2566 PerlIO_printf(Perl_debug_log,
2567 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2568 PL_op_name[i]);
2569 }
2570}
66610fdd 2571
3b721df9
NC		 2572#ifdef PERL_MAD
2573/*
2574 * XML variants of most of the above routines
2575 */
2576
4136a0f7 2577STATIC void
3b721df9
NC		 2578S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2579{
2580 va_list args;
7918f24d
NC		 2581
2582 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2583
3b721df9
NC		 2584 PerlIO_printf(file, "\n ");
2585 va_start(args, pat);
2586 xmldump_vindent(level, file, pat, &args);
2587 va_end(args);
2588}
2589
2590
2591void
2592Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2593{
2594 va_list args;
7918f24d 2595 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
3b721df9
NC		 2596 va_start(args, pat);
2597 xmldump_vindent(level, file, pat, &args);
2598 va_end(args);
2599}
2600
2601void
2602Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2603{
7918f24d
NC		 2604 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2605
3b721df9
NC		 2606 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2607 PerlIO_vprintf(file, pat, *args);
2608}
2609
2610void
2611Perl_xmldump_all(pTHX)
2612{
f0e3f042
CS		 2613 xmldump_all_perl(FALSE);
2614}
2615
2616void
0190d5ef 2617Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
f0e3f042 2618{
3b721df9
NC		 2619 PerlIO_setlinebuf(PL_xmlfp);
2620 if (PL_main_root)
2621 op_xmldump(PL_main_root);
0190d5ef
CS		 2622 /* someday we might call this, when it outputs XML: */
2623 /* xmldump_packsubs_perl(PL_defstash, justperl); */
3b721df9
NC		 2624 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2625 PerlIO_close(PL_xmlfp);
2626 PL_xmlfp = 0;
2627}
2628
2629void
2630Perl_xmldump_packsubs(pTHX_ const HV *stash)
2631{
28eb953d 2632 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
3ab0c9fa
NC		 2633 xmldump_packsubs_perl(stash, FALSE);
2634}
2635
2636void
2637Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2638{
3b721df9
NC		 2639 I32 i;
2640 HE *entry;
2641
28eb953d 2642 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
7918f24d 2643
3b721df9
NC		 2644 if (!HvARRAY(stash))
2645 return;
2646 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2647 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
159b6efe 2648 GV *gv = MUTABLE_GV(HeVAL(entry));
3b721df9
NC		 2649 HV *hv;
2650 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2651 continue;
2652 if (GvCVu(gv))
3ab0c9fa 2653 xmldump_sub_perl(gv, justperl);
3b721df9
NC		 2654 if (GvFORM(gv))
2655 xmldump_form(gv);
2656 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2657 && (hv = GvHV(gv)) && hv != PL_defstash)
3ab0c9fa 2658 xmldump_packsubs_perl(hv, justperl); /* nested package */
3b721df9
NC		 2659 }
2660 }
2661}
2662
2663void
2664Perl_xmldump_sub(pTHX_ const GV *gv)
2665{
28eb953d 2666 PERL_ARGS_ASSERT_XMLDUMP_SUB;
f0e3f042
CS		 2667 xmldump_sub_perl(gv, FALSE);
2668}
2669
2670void
2671Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2672{
2673 SV * sv;
3b721df9 2674
28eb953d 2675 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
7918f24d 2676
f0e3f042
CS		 2677 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2678 return;
2679
2680 sv = sv_newmortal();
1a9a51d4 2681 gv_fullname3(sv, gv, NULL);
3b721df9
NC		 2682 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2683 if (CvXSUB(GvCV(gv)))
2684 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2685 PTR2UV(CvXSUB(GvCV(gv))),
2686 (int)CvXSUBANY(GvCV(gv)).any_i32);
2687 else if (CvROOT(GvCV(gv)))
2688 op_xmldump(CvROOT(GvCV(gv)));
2689 else
2690 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2691}
2692
2693void
2694Perl_xmldump_form(pTHX_ const GV *gv)
2695{
61f9802b 2696 SV * const sv = sv_newmortal();
3b721df9 2697
7918f24d
NC		 2698 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2699
1a9a51d4 2700 gv_fullname3(sv, gv, NULL);
3b721df9
NC		 2701 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2702 if (CvROOT(GvFORM(gv)))
2703 op_xmldump(CvROOT(GvFORM(gv)));
2704 else
2705 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2706}
2707
2708void
2709Perl_xmldump_eval(pTHX)
2710{
2711 op_xmldump(PL_eval_root);
2712}
2713
2714char *
2715Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2716{
7918f24d 2717 PERL_ARGS_ASSERT_SV_CATXMLSV;
3b721df9
NC		 2718 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2719}
2720
2721char *
9dcc53ea
Z		 2722Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2723{
2724 PERL_ARGS_ASSERT_SV_CATXMLPV;
2725 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2726}
2727
2728char *
20f84293 2729Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
3b721df9
NC		 2730{
2731 unsigned int c;
61f9802b 2732 const char * const e = pv + len;
20f84293 2733 const char * const start = pv;
3b721df9
NC		 2734 STRLEN dsvcur;
2735 STRLEN cl;
2736
7918f24d
NC		 2737 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2738
76f68e9b 2739 sv_catpvs(dsv,"");
3b721df9
NC		 2740 dsvcur = SvCUR(dsv); /* in case we have to restart */
2741
2742 retry:
2743 while (pv < e) {
2744 if (utf8) {
4b88fb76 2745 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
3b721df9
NC		 2746 if (cl == 0) {
2747 SvCUR(dsv) = dsvcur;
2748 pv = start;
2749 utf8 = 0;
2750 goto retry;
2751 }
2752 }
2753 else
2754 c = (*pv & 255);
2755
951cbe24
KW		 2756 if (isCNTRL_L1(c)
2757 && c != '\t'
2758 && c != '\n'
2759 && c != '\r'
2760 && c != LATIN1_TO_NATIVE(0x85))
2761 {
3b721df9 2762 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
951cbe24
KW		 2763 }
2764 else switch (c) {
3b721df9 2765 case '<':
f3a2811a 2766 sv_catpvs(dsv, "&lt;");
3b721df9
NC		 2767 break;
2768 case '>':
f3a2811a 2769 sv_catpvs(dsv, "&gt;");
3b721df9
NC		 2770 break;
2771 case '&':
f3a2811a 2772 sv_catpvs(dsv, "&amp;");
3b721df9
NC		 2773 break;
2774 case '"':
49de0815 2775 sv_catpvs(dsv, "&#34;");
3b721df9
NC		 2776 break;
2777 default:
2778 if (c < 0xD800) {
951cbe24 2779 if (! isPRINT(c)) {
3b721df9
NC		 2780 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2781 }
2782 else {
5e7aa789
NC		 2783 const char string = (char) c;
2784 sv_catpvn(dsv, &string, 1);
3b721df9
NC		 2785 }
2786 break;
2787 }
2788 if ((c >= 0xD800 && c <= 0xDB7F) ||
2789 (c >= 0xDC00 && c <= 0xDFFF) ||
2790 (c >= 0xFFF0 && c <= 0xFFFF) ||
2791 c > 0x10ffff)
2792 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2793 else
2794 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2795 }
2796
2797 if (utf8)
2798 pv += UTF8SKIP(pv);
2799 else
2800 pv++;
2801 }
2802
2803 return SvPVX(dsv);
2804}
2805
2806char *
2807Perl_sv_xmlpeek(pTHX_ SV *sv)
2808{
61f9802b 2809 SV * const t = sv_newmortal();
3b721df9
NC		 2810 STRLEN n_a;
2811 int unref = 0;
2812
7918f24d
NC		 2813 PERL_ARGS_ASSERT_SV_XMLPEEK;
2814
3b721df9 2815 sv_utf8_upgrade(t);
76f68e9b 2816 sv_setpvs(t, "");
3b721df9
NC		 2817 /* retry: */
2818 if (!sv) {
2819 sv_catpv(t, "VOID=\"\"");
2820 goto finish;
2821 }
299ef33b 2822 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
3b721df9
NC		 2823 sv_catpv(t, "WILD=\"\"");
2824 goto finish;
2825 }
2826 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2827 if (sv == &PL_sv_undef) {
2828 sv_catpv(t, "SV_UNDEF=\"1\"");
2829 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2830 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2831 SvREADONLY(sv))
2832 goto finish;
2833 }
2834 else if (sv == &PL_sv_no) {
2835 sv_catpv(t, "SV_NO=\"1\"");
2836 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2837 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2838 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2839 SVp_POK|SVp_NOK)) &&
2840 SvCUR(sv) == 0 &&
2841 SvNVX(sv) == 0.0)
2842 goto finish;
2843 }
2844 else if (sv == &PL_sv_yes) {
2845 sv_catpv(t, "SV_YES=\"1\"");
2846 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2847 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2848 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2849 SVp_POK|SVp_NOK)) &&
2850 SvCUR(sv) == 1 &&
2851 SvPVX(sv) && *SvPVX(sv) == '1' &&
2852 SvNVX(sv) == 1.0)
2853 goto finish;
2854 }
2855 else {
2856 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2857 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2858 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2859 SvREADONLY(sv))
2860 goto finish;
2861 }
2862 sv_catpv(t, " XXX=\"\" ");
2863 }
2864 else if (SvREFCNT(sv) == 0) {
2865 sv_catpv(t, " refcnt=\"0\"");
2866 unref++;
2867 }
2868 else if (DEBUG_R_TEST_) {
2869 int is_tmp = 0;
e8eb279c 2870 SSize_t ix;
3b721df9
NC		 2871 /* is this SV on the tmps stack? */
2872 for (ix=PL_tmps_ix; ix>=0; ix--) {
2873 if (PL_tmps_stack[ix] == sv) {
2874 is_tmp = 1;
2875 break;
2876 }
2877 }
2878 if (SvREFCNT(sv) > 1)
2879 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2880 is_tmp ? "T" : "");
2881 else if (is_tmp)
2882 sv_catpv(t, " DRT=\"<T>\"");
2883 }
2884
2885 if (SvROK(sv)) {
2886 sv_catpv(t, " ROK=\"\"");
2887 }
2888 switch (SvTYPE(sv)) {
2889 default:
2890 sv_catpv(t, " FREED=\"1\"");
2891 goto finish;
2892
2893 case SVt_NULL:
2894 sv_catpv(t, " UNDEF=\"1\"");
2895 goto finish;
2896 case SVt_IV:
2897 sv_catpv(t, " IV=\"");
2898 break;
2899 case SVt_NV:
2900 sv_catpv(t, " NV=\"");
2901 break;
3b721df9
NC		 2902 case SVt_PV:
2903 sv_catpv(t, " PV=\"");
2904 break;
2905 case SVt_PVIV:
2906 sv_catpv(t, " PVIV=\"");
2907 break;
2908 case SVt_PVNV:
2909 sv_catpv(t, " PVNV=\"");
2910 break;
2911 case SVt_PVMG:
2912 sv_catpv(t, " PVMG=\"");
2913 break;
2914 case SVt_PVLV:
2915 sv_catpv(t, " PVLV=\"");
2916 break;
2917 case SVt_PVAV:
2918 sv_catpv(t, " AV=\"");
2919 break;
2920 case SVt_PVHV:
2921 sv_catpv(t, " HV=\"");
2922 break;
2923 case SVt_PVCV:
2924 if (CvGV(sv))
2925 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2926 else
2927 sv_catpv(t, " CV=\"()\"");
2928 goto finish;
2929 case SVt_PVGV:
2930 sv_catpv(t, " GV=\"");
2931 break;
e94d9b54 2932 case SVt_INVLIST:
a9032aa0 2933 sv_catpv(t, " DUMMY=\"");
3b721df9 2934 break;
d914baab 2935 case SVt_REGEXP:
8619e557 2936 sv_catpv(t, " REGEXP=\"");
4df7f6af 2937 break;
3b721df9
NC		 2938 case SVt_PVFM:
2939 sv_catpv(t, " FM=\"");
2940 break;
2941 case SVt_PVIO:
2942 sv_catpv(t, " IO=\"");
2943 break;
2944 }
2945
2946 if (SvPOKp(sv)) {
2947 if (SvPVX(sv)) {
2948 sv_catxmlsv(t, sv);
2949 }
2950 }
2951 else if (SvNOKp(sv)) {
2952 STORE_NUMERIC_LOCAL_SET_STANDARD();
2953 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2954 RESTORE_NUMERIC_LOCAL();
2955 }
2956 else if (SvIOKp(sv)) {
2957 if (SvIsUV(sv))
2958 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2959 else
2960 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2961 }
2962 else
2963 sv_catpv(t, "");
2964 sv_catpv(t, "\"");
2965
2966 finish:
61f9802b
AL		 2967 while (unref--)
2968 sv_catpv(t, ")");
3b721df9
NC		 2969 return SvPV(t, n_a);
2970}
2971
2972void
2973Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2974{
7918f24d
NC		 2975 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2976
3b721df9
NC		 2977 if (!pm) {
2978 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2979 return;
2980 }
2981 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2982 level++;
2983 if (PM_GETRE(pm)) {
d914baab 2984 REGEXP *const r = PM_GETRE(pm);
643e696a 2985 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
ad64d0ec 2986 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
3b721df9
NC		 2987 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2988 SvPVX(tmpsv));
5f954473 2989 SvREFCNT_dec_NN(tmpsv);
3b721df9
NC		 2990 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2991 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2992 }
2993 else
2994 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
d914baab 2995 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
3df43ef7 2996 SV * const tmpsv = pm_description(pm);
3b721df9 2997 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
5f954473 2998 SvREFCNT_dec_NN(tmpsv);
3b721df9
NC		 2999 }
3000
3001 level--;
20e98b0f 3002 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
3b721df9
NC		 3003 Perl_xmldump_indent(aTHX_ level, file, ">\n");
3004 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
20e98b0f 3005 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
3b721df9
NC		 3006 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
3007 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
3008 }
3009 else
3010 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
3011}
3012
3013void
3014Perl_pmop_xmldump(pTHX_ const PMOP *pm)
3015{
3016 do_pmop_xmldump(0, PL_xmlfp, pm);
3017}
3018
3019void
3020Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
3021{
3022 UV seq;
3023 int contents = 0;
75a6ad4a 3024 const OPCODE optype = o->op_type;
7918f24d
NC		 3025
3026 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
3027
3b721df9
NC		 3028 if (!o)
3029 return;
3b721df9
NC		 3030 seq = sequence_num(o);
3031 Perl_xmldump_indent(aTHX_ level, file,
3032 "<op_%s seq=\"%"UVuf" -> ",
3033 OP_NAME(o),
3034 seq);
3035 level++;
3036 if (o->op_next)
3037 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
3038 sequence_num(o->op_next));
3039 else
3040 PerlIO_printf(file, "DONE\"");
3041
3042 if (o->op_targ) {
75a6ad4a 3043 if (optype == OP_NULL)
3b721df9
NC		 3044 {
3045 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
3046 if (o->op_targ == OP_NEXTSTATE)
3047 {
3048 if (CopLINE(cCOPo))
f5992bc4 3049 PerlIO_printf(file, " line=\"%"UVuf"\"",
3b721df9
NC		 3050 (UV)CopLINE(cCOPo));
3051 if (CopSTASHPV(cCOPo))
3052 PerlIO_printf(file, " package=\"%s\"",
3053 CopSTASHPV(cCOPo));
4b65a919 3054 if (CopLABEL(cCOPo))
3b721df9 3055 PerlIO_printf(file, " label=\"%s\"",
4b65a919 3056 CopLABEL(cCOPo));
3b721df9
NC		 3057 }
3058 }
3059 else
3060 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
3061 }
3062#ifdef DUMPADDR
3063 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
3064#endif
3b721df9 3065
75a6ad4a
RU		 3066 DUMP_OP_FLAGS(o,1,0,file);
3067 DUMP_OP_PRIVATE(o,1,0,file);
3068
3069 switch (optype) {
3b721df9
NC		 3070 case OP_AELEMFAST:
3071 if (o->op_flags & OPf_SPECIAL) {
3072 break;
3073 }
3074 case OP_GVSV:
3075 case OP_GV:
3076#ifdef USE_ITHREADS
3077 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3078#else
3079 if (cSVOPo->op_sv) {
d914baab
NC		 3080 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3081 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3b721df9
NC		 3082 char *s;
3083 STRLEN len;
3084 ENTER;
3085 SAVEFREESV(tmpsv1);
3086 SAVEFREESV(tmpsv2);
159b6efe 3087 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3b721df9
NC		 3088 s = SvPV(tmpsv1,len);
3089 sv_catxmlpvn(tmpsv2, s, len, 1);
3090 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3091 LEAVE;
3092 }
3093 else
3094 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3095#endif
3096 break;
3097 case OP_CONST:
996c9baa 3098 case OP_HINTSEVAL:
3b721df9
NC		 3099 case OP_METHOD_NAMED:
3100#ifndef USE_ITHREADS
3101 /* with ITHREADS, consts are stored in the pad, and the right pad
3102 * may not be active here, so skip */
3103 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3104#endif
3105 break;
3106 case OP_ANONCODE:
3107 if (!contents) {
3108 contents = 1;
3109 PerlIO_printf(file, ">\n");
3110 }
3111 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3112 break;
3b721df9
NC		 3113 case OP_NEXTSTATE:
3114 case OP_DBSTATE:
3115 if (CopLINE(cCOPo))
f5992bc4 3116 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3b721df9
NC		 3117 (UV)CopLINE(cCOPo));
3118 if (CopSTASHPV(cCOPo))
3119 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3120 CopSTASHPV(cCOPo));
4b65a919 3121 if (CopLABEL(cCOPo))
3b721df9 3122 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
4b65a919 3123 CopLABEL(cCOPo));
3b721df9
NC		 3124 break;
3125 case OP_ENTERLOOP:
3126 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3127 if (cLOOPo->op_redoop)
3128 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3129 else
3130 PerlIO_printf(file, "DONE\"");
3131 S_xmldump_attr(aTHX_ level, file, "next=\"");
3132 if (cLOOPo->op_nextop)
3133 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3134 else
3135 PerlIO_printf(file, "DONE\"");
3136 S_xmldump_attr(aTHX_ level, file, "last=\"");
3137 if (cLOOPo->op_lastop)
3138 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3139 else
3140 PerlIO_printf(file, "DONE\"");
3141 break;
3142 case OP_COND_EXPR:
3143 case OP_RANGE:
3144 case OP_MAPWHILE:
3145 case OP_GREPWHILE:
3146 case OP_OR:
3147 case OP_AND:
3148 S_xmldump_attr(aTHX_ level, file, "other=\"");
3149 if (cLOGOPo->op_other)
3150 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3151 else
3152 PerlIO_printf(file, "DONE\"");
3153 break;
3154 case OP_LEAVE:
3155 case OP_LEAVEEVAL:
3156 case OP_LEAVESUB:
3157 case OP_LEAVESUBLV:
3158 case OP_LEAVEWRITE:
3159 case OP_SCOPE:
3160 if (o->op_private & OPpREFCOUNTED)
3161 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3162 break;
3163 default:
3164 break;
3165 }
3166
3167 if (PL_madskills && o->op_madprop) {
fb2b694a 3168 char prevkey = '\0';
d914baab 3169 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
20f84293 3170 const MADPROP* mp = o->op_madprop;
61f9802b 3171
3b721df9
NC		 3172 if (!contents) {
3173 contents = 1;
3174 PerlIO_printf(file, ">\n");
3175 }
3176 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3177 level++;
3178 while (mp) {
3179 char tmp = mp->mad_key;
76f68e9b 3180 sv_setpvs(tmpsv,"\"");
3b721df9
NC		 3181 if (tmp)
3182 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
fb2b694a
GG		 3183 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3184 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3185 else
3186 prevkey = tmp;
3b721df9
NC		 3187 sv_catpv(tmpsv, "\"");
3188 switch (mp->mad_type) {
3189 case MAD_NULL:
3190 sv_catpv(tmpsv, "NULL");
3191 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3192 break;
3193 case MAD_PV:
3194 sv_catpv(tmpsv, " val=\"");
3195 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3196 sv_catpv(tmpsv, "\"");
3197 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3198 break;
3199 case MAD_SV:
3200 sv_catpv(tmpsv, " val=\"");
ad64d0ec 3201 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3b721df9
NC		 3202 sv_catpv(tmpsv, "\"");
3203 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3204 break;
3205 case MAD_OP:
3206 if ((OP*)mp->mad_val) {
3207 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3208 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3209 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3210 }
3211 break;
3212 default:
3213 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3214 break;
3215 }
3216 mp = mp->mad_next;
3217 }
3218 level--;
3219 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3220
5f954473 3221 SvREFCNT_dec_NN(tmpsv);
3b721df9
NC		 3222 }
3223
75a6ad4a 3224 switch (optype) {
3b721df9
NC		 3225 case OP_PUSHRE:
3226 case OP_MATCH:
3227 case OP_QR:
3228 case OP_SUBST:
3229 if (!contents) {
3230 contents = 1;
3231 PerlIO_printf(file, ">\n");
3232 }
3233 do_pmop_xmldump(level, file, cPMOPo);
3234 break;
3235 default:
3236 break;
3237 }
3238
3239 if (o->op_flags & OPf_KIDS) {
3240 OP *kid;
3241 if (!contents) {
3242 contents = 1;
3243 PerlIO_printf(file, ">\n");
3244 }
3245 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3246 do_op_xmldump(level, file, kid);
3247 }
3248
3249 if (contents)
3250 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3251 else
3252 PerlIO_printf(file, " />\n");
3253}
3254
3255void
3256Perl_op_xmldump(pTHX_ const OP *o)
3257{
7918f24d
NC		 3258 PERL_ARGS_ASSERT_OP_XMLDUMP;
3259
3b721df9
NC		 3260 do_op_xmldump(0, PL_xmlfp, o);
3261}
3262#endif
3263
66610fdd
RGS		 3264/*
3265 * Local variables:
3266 * c-indentation-style: bsd
3267 * c-basic-offset: 4
14d04a33 3268 * indent-tabs-mode: nil
66610fdd
RGS		 3269 * End:
3270 *
14d04a33 3271 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3272 */
Unnamed repository; edit this file 'description' to name the repository.