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