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