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