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