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