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