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