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