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