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