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