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