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