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