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