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