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