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