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