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