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