projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Welcome to 2007! Time to update copyrights from changes earlier
[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",
1cb9cd50 32 "BIND",
5357ca29 33 "IV",
34 "NV",
35 "RV",
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",
1cb9cd50 52 "BIND",
5357ca29 53 "IV",
54 "NV",
55 "RV",
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
7e5d8ed2 742 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
e15d5972 743 SV * const tmpsv = newSVpvs("");
5dc0d613 744 switch (o->op_flags & OPf_WANT) {
54310121 745 case OPf_WANT_VOID:
46fc3d4c 746 sv_catpv(tmpsv, ",VOID");
54310121 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");
7e5d8ed2 774 if (o->op_attached)
775 sv_catpv(tmpsv, ",ATTACHED");
b15aece3 776 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
46fc3d4c 777 SvREFCNT_dec(tmpsv);
79072805 778 }
11343788 779 if (o->op_private) {
e15d5972 780 SV * const tmpsv = newSVpvs("");
781 if (PL_opargs[optype] & OA_TARGLEX) {
07447971 782 if (o->op_private & OPpTARGET_MY)
783 sv_catpv(tmpsv, ",TARGET_MY");
784 }
e15d5972 785 else if (optype == OP_LEAVESUB ||
786 optype == OP_LEAVE ||
787 optype == OP_LEAVESUBLV ||
788 optype == OP_LEAVEWRITE) {
bf91b999 789 if (o->op_private & OPpREFCOUNTED)
790 sv_catpv(tmpsv, ",REFCOUNTED");
791 }
e15d5972 792 else if (optype == OP_AASSIGN) {
11343788 793 if (o->op_private & OPpASSIGN_COMMON)
46fc3d4c 794 sv_catpv(tmpsv, ",COMMON");
8d063cd8 795 }
e15d5972 796 else if (optype == OP_SASSIGN) {
11343788 797 if (o->op_private & OPpASSIGN_BACKWARDS)
46fc3d4c 798 sv_catpv(tmpsv, ",BACKWARDS");
a0d0e21e 799 }
e15d5972 800 else if (optype == OP_TRANS) {
11343788 801 if (o->op_private & OPpTRANS_SQUASH)
46fc3d4c 802 sv_catpv(tmpsv, ",SQUASH");
11343788 803 if (o->op_private & OPpTRANS_DELETE)
46fc3d4c 804 sv_catpv(tmpsv, ",DELETE");
11343788 805 if (o->op_private & OPpTRANS_COMPLEMENT)
46fc3d4c 806 sv_catpv(tmpsv, ",COMPLEMENT");
bf91b999 807 if (o->op_private & OPpTRANS_IDENTICAL)
808 sv_catpv(tmpsv, ",IDENTICAL");
809 if (o->op_private & OPpTRANS_GROWS)
810 sv_catpv(tmpsv, ",GROWS");
8d063cd8 811 }
e15d5972 812 else if (optype == OP_REPEAT) {
11343788 813 if (o->op_private & OPpREPEAT_DOLIST)
46fc3d4c 814 sv_catpv(tmpsv, ",DOLIST");
8d063cd8 815 }
e15d5972 816 else if (optype == OP_ENTERSUB ||
817 optype == OP_RV2SV ||
818 optype == OP_GVSV ||
819 optype == OP_RV2AV ||
820 optype == OP_RV2HV ||
821 optype == OP_RV2GV ||
822 optype == OP_AELEM ||
823 optype == OP_HELEM )
85e6fe83 824 {
e15d5972 825 if (optype == OP_ENTERSUB) {
5dc0d613 826 if (o->op_private & OPpENTERSUB_AMPER)
46fc3d4c 827 sv_catpv(tmpsv, ",AMPER");
5dc0d613 828 if (o->op_private & OPpENTERSUB_DB)
46fc3d4c 829 sv_catpv(tmpsv, ",DB");
d3011074 830 if (o->op_private & OPpENTERSUB_HASTARG)
831 sv_catpv(tmpsv, ",HASTARG");
bf91b999 832 if (o->op_private & OPpENTERSUB_NOPAREN)
833 sv_catpv(tmpsv, ",NOPAREN");
834 if (o->op_private & OPpENTERSUB_INARGS)
835 sv_catpv(tmpsv, ",INARGS");
95f0a2f1 836 if (o->op_private & OPpENTERSUB_NOMOD)
837 sv_catpv(tmpsv, ",NOMOD");
68dc0745 838 }
bf91b999 839 else {
d3011074 840 switch (o->op_private & OPpDEREF) {
b9ac451d 841 case OPpDEREF_SV:
842 sv_catpv(tmpsv, ",SV");
843 break;
844 case OPpDEREF_AV:
845 sv_catpv(tmpsv, ",AV");
846 break;
847 case OPpDEREF_HV:
848 sv_catpv(tmpsv, ",HV");
849 break;
850 }
bf91b999 851 if (o->op_private & OPpMAYBE_LVSUB)
852 sv_catpv(tmpsv, ",MAYBE_LVSUB");
853 }
e15d5972 854 if (optype == OP_AELEM || optype == OP_HELEM) {
5dc0d613 855 if (o->op_private & OPpLVAL_DEFER)
46fc3d4c 856 sv_catpv(tmpsv, ",LVAL_DEFER");
68dc0745 857 }
858 else {
5dc0d613 859 if (o->op_private & HINT_STRICT_REFS)
46fc3d4c 860 sv_catpv(tmpsv, ",STRICT_REFS");
192587c2 861 if (o->op_private & OPpOUR_INTRO)
862 sv_catpv(tmpsv, ",OUR_INTRO");
68dc0745 863 }
8d063cd8 864 }
e15d5972 865 else if (optype == OP_CONST) {
11343788 866 if (o->op_private & OPpCONST_BARE)
46fc3d4c 867 sv_catpv(tmpsv, ",BARE");
7a52d87a 868 if (o->op_private & OPpCONST_STRICT)
869 sv_catpv(tmpsv, ",STRICT");
bf91b999 870 if (o->op_private & OPpCONST_ARYBASE)
871 sv_catpv(tmpsv, ",ARYBASE");
872 if (o->op_private & OPpCONST_WARNING)
873 sv_catpv(tmpsv, ",WARNING");
874 if (o->op_private & OPpCONST_ENTERED)
875 sv_catpv(tmpsv, ",ENTERED");
79072805 876 }
e15d5972 877 else if (optype == OP_FLIP) {
11343788 878 if (o->op_private & OPpFLIP_LINENUM)
46fc3d4c 879 sv_catpv(tmpsv, ",LINENUM");
79072805 880 }
e15d5972 881 else if (optype == OP_FLOP) {
11343788 882 if (o->op_private & OPpFLIP_LINENUM)
46fc3d4c 883 sv_catpv(tmpsv, ",LINENUM");
95f0a2f1 884 }
e15d5972 885 else if (optype == OP_RV2CV) {
cd06dffe 886 if (o->op_private & OPpLVAL_INTRO)
887 sv_catpv(tmpsv, ",INTRO");
79072805 888 }
e15d5972 889 else if (optype == OP_GV) {
bf91b999 890 if (o->op_private & OPpEARLY_CV)
891 sv_catpv(tmpsv, ",EARLY_CV");
892 }
e15d5972 893 else if (optype == OP_LIST) {
bf91b999 894 if (o->op_private & OPpLIST_GUESSED)
895 sv_catpv(tmpsv, ",GUESSED");
896 }
e15d5972 897 else if (optype == OP_DELETE) {
bf91b999 898 if (o->op_private & OPpSLICE)
899 sv_catpv(tmpsv, ",SLICE");
900 }
e15d5972 901 else if (optype == OP_EXISTS) {
bf91b999 902 if (o->op_private & OPpEXISTS_SUB)
903 sv_catpv(tmpsv, ",EXISTS_SUB");
904 }
e15d5972 905 else if (optype == OP_SORT) {
bf91b999 906 if (o->op_private & OPpSORT_NUMERIC)
907 sv_catpv(tmpsv, ",NUMERIC");
908 if (o->op_private & OPpSORT_INTEGER)
909 sv_catpv(tmpsv, ",INTEGER");
910 if (o->op_private & OPpSORT_REVERSE)
911 sv_catpv(tmpsv, ",REVERSE");
912 }
e15d5972 913 else if (optype == OP_THREADSV) {
bf91b999 914 if (o->op_private & OPpDONE_SVREF)
915 sv_catpv(tmpsv, ",SVREF");
916 }
e15d5972 917 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
bf91b999 918 if (o->op_private & OPpOPEN_IN_RAW)
919 sv_catpv(tmpsv, ",IN_RAW");
920 if (o->op_private & OPpOPEN_IN_CRLF)
921 sv_catpv(tmpsv, ",IN_CRLF");
922 if (o->op_private & OPpOPEN_OUT_RAW)
923 sv_catpv(tmpsv, ",OUT_RAW");
924 if (o->op_private & OPpOPEN_OUT_CRLF)
925 sv_catpv(tmpsv, ",OUT_CRLF");
926 }
e15d5972 927 else if (optype == OP_EXIT) {
bf91b999 928 if (o->op_private & OPpEXIT_VMSISH)
96e176bf 929 sv_catpv(tmpsv, ",EXIT_VMSISH");
930 if (o->op_private & OPpHUSH_VMSISH)
931 sv_catpv(tmpsv, ",HUSH_VMSISH");
932 }
e15d5972 933 else if (optype == OP_DIE) {
96e176bf 934 if (o->op_private & OPpHUSH_VMSISH)
935 sv_catpv(tmpsv, ",HUSH_VMSISH");
bf91b999 936 }
e15d5972 937 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
fbb0b3b3 938 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
939 sv_catpv(tmpsv, ",FT_ACCESS");
940 if (o->op_private & OPpFT_STACKED)
941 sv_catpv(tmpsv, ",FT_STACKED");
1af34c76 942 }
11343788 943 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
46fc3d4c 944 sv_catpv(tmpsv, ",INTRO");
945 if (SvCUR(tmpsv))
b15aece3 946 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
46fc3d4c 947 SvREFCNT_dec(tmpsv);
8d063cd8 948 }
8d063cd8 949
3b721df9 950#ifdef PERL_MAD
951 if (PL_madskills && o->op_madprop) {
d4c19fe8 952 SV * const tmpsv = newSVpvn("", 0);
3b721df9 953 MADPROP* mp = o->op_madprop;
954 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
955 level++;
956 while (mp) {
957 char tmp = mp->mad_key;
958 sv_setpvn(tmpsv,"'",1);
959 if (tmp)
960 sv_catpvn(tmpsv, &tmp, 1);
961 sv_catpv(tmpsv, "'=");
962 switch (mp->mad_type) {
963 case MAD_NULL:
964 sv_catpv(tmpsv, "NULL");
965 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
966 break;
967 case MAD_PV:
968 sv_catpv(tmpsv, "<");
969 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
970 sv_catpv(tmpsv, ">");
971 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
972 break;
973 case MAD_OP:
974 if ((OP*)mp->mad_val) {
975 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
976 do_op_dump(level, file, (OP*)mp->mad_val);
977 }
978 break;
979 default:
980 sv_catpv(tmpsv, "(UNK)");
981 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
982 break;
983 }
984 mp = mp->mad_next;
985 }
986 level--;
987 Perl_dump_indent(aTHX_ level, file, "}\n");
988
989 SvREFCNT_dec(tmpsv);
990 }
991#endif
992
e15d5972 993 switch (optype) {
971a9dd3 994 case OP_AELEMFAST:
93a17b20 995 case OP_GVSV:
79072805 996 case OP_GV:
971a9dd3 997#ifdef USE_ITHREADS
c803eecc 998 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
971a9dd3 999#else
38c076c7 1000 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1001 if (cSVOPo->op_sv) {
d4c19fe8 1002 SV * const tmpsv = newSV(0);
38c076c7 1003 ENTER;
1004 SAVEFREESV(tmpsv);
3b721df9 1005#ifdef PERL_MAD
1006 /* FIXME - it this making unwarranted assumptions about the
1007 UTF-8 cleanliness of the dump file handle? */
1008 SvUTF8_on(tmpsv);
1009#endif
bd61b366 1010 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
8b6b16e7 1011 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
d5263905 1012 SvPV_nolen_const(tmpsv));
38c076c7 1013 LEAVE;
1014 }
1015 else
1016 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
378cc40b 1017 }
971a9dd3 1018#endif
79072805 1019 break;
1020 case OP_CONST:
f5d5a27c 1021 case OP_METHOD_NAMED:
b6a15bc5 1022#ifndef USE_ITHREADS
1023 /* with ITHREADS, consts are stored in the pad, and the right pad
1024 * may not be active here, so skip */
3848b962 1025 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
b6a15bc5 1026#endif
79072805 1027 break;
7399586d 1028 case OP_SETSTATE:
93a17b20 1029 case OP_NEXTSTATE:
1030 case OP_DBSTATE:
57843af0 1031 if (CopLINE(cCOPo))
f5992bc4 1032 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 1033 (UV)CopLINE(cCOPo));
ed094faf 1034 if (CopSTASHPV(cCOPo))
1035 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1036 CopSTASHPV(cCOPo));
11343788 1037 if (cCOPo->cop_label)
ed094faf 1038 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1039 cCOPo->cop_label);
79072805 1040 break;
1041 case OP_ENTERLOOP:
cea2e8a9 1042 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
11343788 1043 if (cLOOPo->op_redoop)
f5992bc4 1044 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
79072805 1045 else
3967c732 1046 PerlIO_printf(file, "DONE\n");
cea2e8a9 1047 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
11343788 1048 if (cLOOPo->op_nextop)
f5992bc4 1049 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
79072805 1050 else
3967c732 1051 PerlIO_printf(file, "DONE\n");
cea2e8a9 1052 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
11343788 1053 if (cLOOPo->op_lastop)
f5992bc4 1054 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
79072805 1055 else
3967c732 1056 PerlIO_printf(file, "DONE\n");
79072805 1057 break;
1058 case OP_COND_EXPR:
1a67a97c 1059 case OP_RANGE:
a0d0e21e 1060 case OP_MAPWHILE:
79072805 1061 case OP_GREPWHILE:
1062 case OP_OR:
1063 case OP_AND:
cea2e8a9 1064 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
11343788 1065 if (cLOGOPo->op_other)
f5992bc4 1066 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
79072805 1067 else
3967c732 1068 PerlIO_printf(file, "DONE\n");
79072805 1069 break;
1070 case OP_PUSHRE:
1071 case OP_MATCH:
8782bef2 1072 case OP_QR:
79072805 1073 case OP_SUBST:
3967c732 1074 do_pmop_dump(level, file, cPMOPo);
79072805 1075 break;
7934575e 1076 case OP_LEAVE:
1077 case OP_LEAVEEVAL:
1078 case OP_LEAVESUB:
1079 case OP_LEAVESUBLV:
1080 case OP_LEAVEWRITE:
1081 case OP_SCOPE:
1082 if (o->op_private & OPpREFCOUNTED)
1083 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1084 break;
a0d0e21e 1085 default:
1086 break;
79072805 1087 }
11343788 1088 if (o->op_flags & OPf_KIDS) {
79072805 1089 OP *kid;
11343788 1090 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3967c732 1091 do_op_dump(level, file, kid);
8d063cd8 1092 }
cea2e8a9 1093 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732 1094}
1095
1096void
6867be6d 1097Perl_op_dump(pTHX_ const OP *o)
3967c732 1098{
1099 do_op_dump(0, Perl_debug_log, o);
8d063cd8 1100}
1101
8adcabd8 1102void
864dbfa3 1103Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1104{
79072805 1105 SV *sv;
378cc40b 1106
79072805 1107 if (!gv) {
760ac839 1108 PerlIO_printf(Perl_debug_log, "{}\n");
378cc40b 1109 return;
1110 }
8990e307 1111 sv = sv_newmortal();
760ac839 1112 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1113 gv_fullname3(sv, gv, NULL);
b15aece3 1114 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
79072805 1115 if (gv != GvEGV(gv)) {
bd61b366 1116 gv_efullname3(sv, GvEGV(gv), NULL);
b15aece3 1117 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
8adcabd8 1118 }
3967c732 1119 PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1120 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8 1121}
1122
14befaf4 1123
afe38520 1124/* map magic types to the symbolic names
14befaf4 1125 * (with the PERL_MAGIC_ prefixed stripped)
1126 */
1127
27da23d5 1128static const struct { const char type; const char *name; } magic_names[] = {
516a5887 1129 { PERL_MAGIC_sv, "sv(\\0)" },
1130 { PERL_MAGIC_arylen, "arylen(#)" },
ca732855 1131 { PERL_MAGIC_rhash, "rhash(%)" },
81714fb9 1132 { PERL_MAGIC_regdata_names, "regdata_names(+)" },
516a5887 1133 { PERL_MAGIC_pos, "pos(.)" },
8d2f4536 1134 { PERL_MAGIC_symtab, "symtab(:)" },
516a5887 1135 { PERL_MAGIC_backref, "backref(<)" },
a3874608 1136 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
516a5887 1137 { PERL_MAGIC_overload, "overload(A)" },
1138 { PERL_MAGIC_bm, "bm(B)" },
1139 { PERL_MAGIC_regdata, "regdata(D)" },
1140 { PERL_MAGIC_env, "env(E)" },
b3ca2e83 1141 { PERL_MAGIC_hints, "hints(H)" },
516a5887 1142 { PERL_MAGIC_isa, "isa(I)" },
1143 { PERL_MAGIC_dbfile, "dbfile(L)" },
afe38520 1144 { PERL_MAGIC_shared, "shared(N)" },
516a5887 1145 { PERL_MAGIC_tied, "tied(P)" },
1146 { PERL_MAGIC_sig, "sig(S)" },
1147 { PERL_MAGIC_uvar, "uvar(U)" },
1148 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1149 { PERL_MAGIC_overload_table, "overload_table(c)" },
1150 { PERL_MAGIC_regdatum, "regdatum(d)" },
1151 { PERL_MAGIC_envelem, "envelem(e)" },
1152 { PERL_MAGIC_fm, "fm(f)" },
1153 { PERL_MAGIC_regex_global, "regex_global(g)" },
b3ca2e83 1154 { PERL_MAGIC_hintselem, "hintselem(h)" },
516a5887 1155 { PERL_MAGIC_isaelem, "isaelem(i)" },
1156 { PERL_MAGIC_nkeys, "nkeys(k)" },
1157 { PERL_MAGIC_dbline, "dbline(l)" },
1158 { PERL_MAGIC_mutex, "mutex(m)" },
afe38520 1159 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
516a5887 1160 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1161 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1162 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1163 { PERL_MAGIC_qr, "qr(r)" },
1164 { PERL_MAGIC_sigelem, "sigelem(s)" },
1165 { PERL_MAGIC_taint, "taint(t)" },
afe38520 1166 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
516a5887 1167 { PERL_MAGIC_vec, "vec(v)" },
cb50f42d 1168 { PERL_MAGIC_vstring, "vstring(V)" },
7e8c5dac 1169 { PERL_MAGIC_utf8, "utf8(w)" },
516a5887 1170 { PERL_MAGIC_substr, "substr(x)" },
1171 { PERL_MAGIC_defelem, "defelem(y)" },
1172 { PERL_MAGIC_ext, "ext(~)" },
1173 /* this null string terminates the list */
b9ac451d 1174 { 0, NULL },
14befaf4 1175};
1176
8adcabd8 1177void
6867be6d 1178Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1179{
3967c732 1180 for (; mg; mg = mg->mg_moremagic) {
b900a521 1181 Perl_dump_indent(aTHX_ level, file,
1182 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
3967c732 1183 if (mg->mg_virtual) {
bfed75c6 1184 const MGVTBL * const v = mg->mg_virtual;
b9ac451d 1185 const char *s;
3967c732 1186 if (v == &PL_vtbl_sv) s = "sv";
1187 else if (v == &PL_vtbl_env) s = "env";
1188 else if (v == &PL_vtbl_envelem) s = "envelem";
1189 else if (v == &PL_vtbl_sig) s = "sig";
1190 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1191 else if (v == &PL_vtbl_pack) s = "pack";
1192 else if (v == &PL_vtbl_packelem) s = "packelem";
1193 else if (v == &PL_vtbl_dbline) s = "dbline";
1194 else if (v == &PL_vtbl_isa) s = "isa";
1195 else if (v == &PL_vtbl_arylen) s = "arylen";
3967c732 1196 else if (v == &PL_vtbl_mglob) s = "mglob";
1197 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1198 else if (v == &PL_vtbl_taint) s = "taint";
1199 else if (v == &PL_vtbl_substr) s = "substr";
1200 else if (v == &PL_vtbl_vec) s = "vec";
1201 else if (v == &PL_vtbl_pos) s = "pos";
1202 else if (v == &PL_vtbl_bm) s = "bm";
1203 else if (v == &PL_vtbl_fm) s = "fm";
1204 else if (v == &PL_vtbl_uvar) s = "uvar";
1205 else if (v == &PL_vtbl_defelem) s = "defelem";
1206#ifdef USE_LOCALE_COLLATE
1207 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1208#endif
3967c732 1209 else if (v == &PL_vtbl_amagic) s = "amagic";
1210 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
810b8aa5 1211 else if (v == &PL_vtbl_backref) s = "backref";
7e8c5dac 1212 else if (v == &PL_vtbl_utf8) s = "utf8";
83bf042f 1213 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
b3ca2e83 1214 else if (v == &PL_vtbl_hintselem) s = "hintselem";
b9ac451d 1215 else s = NULL;
3967c732 1216 if (s)
cea2e8a9 1217 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
3967c732 1218 else
b900a521 1219 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
3967c732 1220 }
1221 else
cea2e8a9 1222 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1223
3967c732 1224 if (mg->mg_private)
cea2e8a9 1225 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1226
14befaf4 1227 {
1228 int n;
c445ea15 1229 const char *name = NULL;
27da23d5 1230 for (n = 0; magic_names[n].name; n++) {
14befaf4 1231 if (mg->mg_type == magic_names[n].type) {
1232 name = magic_names[n].name;
1233 break;
1234 }
1235 }
1236 if (name)
1237 Perl_dump_indent(aTHX_ level, file,
1238 " MG_TYPE = PERL_MAGIC_%s\n", name);
1239 else
1240 Perl_dump_indent(aTHX_ level, file,
1241 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1242 }
3967c732 1243
1244 if (mg->mg_flags) {
cea2e8a9 1245 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d 1246 if (mg->mg_type == PERL_MAGIC_envelem &&
1247 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1248 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
3967c732 1249 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1250 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1251 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1252 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
cb50f42d 1253 if (mg->mg_type == PERL_MAGIC_regex_global &&
1254 mg->mg_flags & MGf_MINMATCH)
cea2e8a9 1255 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1256 }
1257 if (mg->mg_obj) {
b900a521 1258 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
3967c732 1259 if (mg->mg_flags & MGf_REFCOUNTED)
1260 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1261 }
1262 if (mg->mg_len)
894356b3 1263 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1264 if (mg->mg_ptr) {
b900a521 1265 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
3967c732 1266 if (mg->mg_len >= 0) {
7e8c5dac 1267 if (mg->mg_type != PERL_MAGIC_utf8) {
396482e1 1268 SV *sv = newSVpvs("");
7e8c5dac 1269 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1270 SvREFCNT_dec(sv);
1271 }
3967c732 1272 }
1273 else if (mg->mg_len == HEf_SVKEY) {
1274 PerlIO_puts(file, " => HEf_SVKEY\n");
1275 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1276 continue;
1277 }
1278 else
1279 PerlIO_puts(file, " ???? - please notify IZ");
1280 PerlIO_putc(file, '\n');
1281 }
7e8c5dac 1282 if (mg->mg_type == PERL_MAGIC_utf8) {
1283 STRLEN *cache = (STRLEN *) mg->mg_ptr;
1284 if (cache) {
1285 IV i;
1286 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1287 Perl_dump_indent(aTHX_ level, file,
1288 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1289 i,
1290 (UV)cache[i * 2],
1291 (UV)cache[i * 2 + 1]);
1292 }
1293 }
378cc40b 1294 }
3967c732 1295}
1296
1297void
6867be6d 1298Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1299{
b9ac451d 1300 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732 1301}
1302
1303void
e1ec3a88 1304Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1305{
bfcb3514 1306 const char *hvname;
b900a521 1307 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
bfcb3514 1308 if (sv && (hvname = HvNAME_get(sv)))
1309 PerlIO_printf(file, "\t\"%s\"\n", hvname);
79072805 1310 else
3967c732 1311 PerlIO_putc(file, '\n');
1312}
1313
1314void
e1ec3a88 1315Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1316{
b900a521 1317 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732 1318 if (sv && GvNAME(sv))
1319 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
c90c0ff4 1320 else
3967c732 1321 PerlIO_putc(file, '\n');
1322}
1323
1324void
e1ec3a88 1325Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1326{
b900a521 1327 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732 1328 if (sv && GvNAME(sv)) {
bfcb3514 1329 const char *hvname;
3967c732 1330 PerlIO_printf(file, "\t\"");
bfcb3514 1331 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1332 PerlIO_printf(file, "%s\" :: \"", hvname);
3967c732 1333 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
8d063cd8 1334 }
3967c732 1335 else
1336 PerlIO_putc(file, '\n');
1337}
1338
1339void
864dbfa3 1340Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1341{
97aff369 1342 dVAR;
cea89e20 1343 SV *d;
e1ec3a88 1344 const char *s;
3967c732 1345 U32 flags;
1346 U32 type;
1347
1348 if (!sv) {
cea2e8a9 1349 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1350 return;
378cc40b 1351 }
2ef28da1 1352
3967c732 1353 flags = SvFLAGS(sv);
1354 type = SvTYPE(sv);
79072805 1355
cea89e20 1356 d = Perl_newSVpvf(aTHX_
57def98f 1357 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
56431972 1358 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3 1359 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1360 (int)(PL_dumpindent*level), "");
8d063cd8 1361
e604303a 1362 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1363 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1364 }
1365 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1366 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1367 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1368 }
3967c732 1369 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1370 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1371 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1372 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1373 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
4db58590 1374
3967c732 1375 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1376 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1377 if (flags & SVf_POK) sv_catpv(d, "POK,");
810b8aa5 1378 if (flags & SVf_ROK) {
1379 sv_catpv(d, "ROK,");
1380 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1381 }
3967c732 1382 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1383 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1384 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
4db58590 1385
dd2eae66 1386 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
3967c732 1387 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1388 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1389 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1ccdb730 1390 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1391 if (SvPCS_IMPORTED(sv))
1392 sv_catpv(d, "PCS_IMPORTED,");
1393 else
9660f481 1394 sv_catpv(d, "SCREAM,");
1ccdb730 1395 }
3967c732 1396
1397 switch (type) {
1398 case SVt_PVCV:
1399 case SVt_PVFM:
1400 if (CvANON(sv)) sv_catpv(d, "ANON,");
1401 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1402 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1403 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
de3f1649 1404 if (CvCONST(sv)) sv_catpv(d, "CONST,");
3967c732 1405 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
25da4f38 1406 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
18f7acf9 1407 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1408 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
662a8415 1409 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
7dafbf52 1410 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
06492da6 1411 if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
3967c732 1412 break;
1413 case SVt_PVHV:
1414 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1415 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
19692e8d 1416 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
afce8e55 1417 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
9660f481 1418 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
3967c732 1419 break;
926fc7b6 1420 case SVt_PVGV:
1421 case SVt_PVLV:
1422 if (isGV_with_GP(sv)) {
1423 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1424 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1425 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1426 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1427 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1428 }
926fc7b6 1429 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732 1430 sv_catpv(d, "IMPORT");
1431 if (GvIMPORTED(sv) == GVf_IMPORTED)
1432 sv_catpv(d, "ALL,");
1433 else {
1434 sv_catpv(d, "(");
1435 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1436 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1437 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1438 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1439 sv_catpv(d, " ),");
1440 }
1441 }
cecf5685 1442 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1443 if (SvVALID(sv)) sv_catpv(d, "VALID,");
addd1794 1444 /* FALL THROUGH */
25da4f38 1445 default:
e604303a 1446 evaled_or_uv:
25da4f38 1447 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
69c678eb 1448 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1449 break;
addd1794 1450 case SVt_PVMG:
00b1698f 1451 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
e604303a 1452 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1453 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
addd1794 1454 break;
e604303a 1455 case SVt_PVNV:
1456 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1457 goto evaled_or_uv;
11ca45c0 1458 case SVt_PVAV:
1459 break;
3967c732 1460 }
86f0d186 1461 /* SVphv_SHAREKEYS is also 0x20000000 */
1462 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1463 sv_catpv(d, "UTF8");
3967c732 1464
b162af07 1465 if (*(SvEND(d) - 1) == ',') {
1466 SvCUR_set(d, SvCUR(d) - 1);
1467 SvPVX(d)[SvCUR(d)] = '\0';
1468 }
3967c732 1469 sv_catpv(d, ")");
b15aece3 1470 s = SvPVX_const(d);
3967c732 1471
fd0854ff 1472#ifdef DEBUG_LEAKING_SCALARS
1473 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1474 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1475 sv->sv_debug_line,
1476 sv->sv_debug_inpad ? "for" : "by",
1477 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1478 sv->sv_debug_cloned ? " (cloned)" : "");
1479#endif
cea2e8a9 1480 Perl_dump_indent(aTHX_ level, file, "SV = ");
5357ca29 1481 if (type < SVt_LAST) {
1482 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1483
1484 if (type == SVt_NULL) {
1485 SvREFCNT_dec(d);
1486 return;
1487 }
1488 } else {
faccc32b 1489 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
cea89e20 1490 SvREFCNT_dec(d);
3967c732 1491 return;
1492 }
27bd069f 1493 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1494 && type != SVt_PVCV && !isGV_with_GP(sv))
1495 || type == SVt_IV) {
765f542d 1496 if (SvIsUV(sv)
f8c7b90f 1497#ifdef PERL_OLD_COPY_ON_WRITE
765f542d 1498 || SvIsCOW(sv)
1499#endif
1500 )
57def98f 1501 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1502 else
57def98f 1503 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
3967c732 1504 if (SvOOK(sv))
1505 PerlIO_printf(file, " (OFFSET)");
f8c7b90f 1506#ifdef PERL_OLD_COPY_ON_WRITE
765f542d 1507 if (SvIsCOW_shared_hash(sv))
1508 PerlIO_printf(file, " (HASH)");
1509 else if (SvIsCOW_normal(sv))
1510 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1511#endif
3967c732 1512 PerlIO_putc(file, '\n');
1513 }
8a27f21b 1514 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
27bd069f 1515 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
e4305a63 1516 || type == SVt_NV) {
e54dc35b 1517 STORE_NUMERIC_LOCAL_SET_STANDARD();
57def98f 1518 /* %Vg doesn't work? --jhi */
cf2093f6 1519#ifdef USE_LONG_DOUBLE
2d4389e4 1520 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
cf2093f6 1521#else
cea2e8a9 1522 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
cf2093f6 1523#endif
e54dc35b 1524 RESTORE_NUMERIC_LOCAL();
3967c732 1525 }
1526 if (SvROK(sv)) {
57def98f 1527 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732 1528 if (nest < maxnest)
1529 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1530 }
cea89e20 1531 if (type < SVt_PV) {
1532 SvREFCNT_dec(d);
3967c732 1533 return;
cea89e20 1534 }
f7877b28 1535 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
b15aece3 1536 if (SvPVX_const(sv)) {
1537 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
3967c732 1538 if (SvOOK(sv))
b15aece3 1539 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1540 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
e6abe6d8 1541 if (SvUTF8(sv)) /* the 8? \x{....} */
c728cb41 1542 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
e6abe6d8 1543 PerlIO_printf(file, "\n");
57def98f 1544 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1545 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
3967c732 1546 }
1547 else
cea2e8a9 1548 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1549 }
1550 if (type >= SVt_PVMG) {
1551 if (SvMAGIC(sv))
1552 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1553 if (SvSTASH(sv))
1554 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1555 }
1556 switch (type) {
3967c732 1557 case SVt_PVAV:
57def98f 1558 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1559 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f 1560 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1561 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732 1562 }
1563 else
1564 PerlIO_putc(file, '\n');
57def98f 1565 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1566 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
a3874608 1567 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
c69006e4 1568 sv_setpvn(d, "", 0);
11ca45c0 1569 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1570 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3 1571 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1572 SvCUR(d) ? SvPVX_const(d) + 1 : "");
3967c732 1573 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1574 int count;
1575 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1576 SV** elt = av_fetch((AV*)sv,count,0);
1577
57def98f 1578 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
2ef28da1 1579 if (elt)
3967c732 1580 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1581 }
1582 }
1583 break;
1584 case SVt_PVHV:
57def98f 1585 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
3967c732 1586 if (HvARRAY(sv) && HvKEYS(sv)) {
1587 /* Show distribution of HEs in the ARRAY */
1588 int freq[200];
bb7a0f54 1589#define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
3967c732 1590 int i;
1591 int max = 0;
1592 U32 pow2 = 2, keys = HvKEYS(sv);
65202027 1593 NV theoret, sum = 0;
3967c732 1594
1595 PerlIO_printf(file, " (");
1596 Zero(freq, FREQ_MAX + 1, int);
eb160463 1597 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15 1598 HE* h;
1599 int count = 0;
3967c732 1600 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1601 count++;
1602 if (count > FREQ_MAX)
1603 count = FREQ_MAX;
1604 freq[count]++;
1605 if (max < count)
1606 max = count;
1607 }
1608 for (i = 0; i <= max; i++) {
1609 if (freq[i]) {
1610 PerlIO_printf(file, "%d%s:%d", i,
1611 (i == FREQ_MAX) ? "+" : "",
1612 freq[i]);
1613 if (i != max)
1614 PerlIO_printf(file, ", ");
1615 }
1616 }
1617 PerlIO_putc(file, ')');
b8fa94d8 1618 /* The "quality" of a hash is defined as the total number of
1619 comparisons needed to access every element once, relative
1620 to the expected number needed for a random hash.
1621
1622 The total number of comparisons is equal to the sum of
e76cd0fa 1623 the squares of the number of entries in each bucket.
1624 For a random hash of n keys into k buckets, the expected
b8fa94d8 1625 value is
1626 n + n(n-1)/2k
1627 */
1628
3967c732 1629 for (i = max; i > 0; i--) { /* Precision: count down. */
1630 sum += freq[i] * i * i;
1631 }
155aba94 1632 while ((keys = keys >> 1))
3967c732 1633 pow2 = pow2 << 1;
3967c732 1634 theoret = HvKEYS(sv);
b8fa94d8 1635 theoret += theoret * (theoret-1)/pow2;
3967c732 1636 PerlIO_putc(file, '\n');
6b4667fc 1637 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732 1638 }
1639 PerlIO_putc(file, '\n');
57def98f 1640 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1641 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1642 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
bfcb3514 1643 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1644 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
8d2f4536 1645 {
b9ac451d 1646 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536 1647 if (mg && mg->mg_obj) {
1648 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1649 }
1650 }
bfcb3514 1651 {
b9ac451d 1652 const char * const hvname = HvNAME_get(sv);
bfcb3514 1653 if (hvname)
1654 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1655 }
86f55936 1656 if (SvOOK(sv)) {
b9ac451d 1657 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
86f55936 1658 if (backrefs) {
1659 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1660 PTR2UV(backrefs));
1661 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1662 dumpops, pvlim);
1663 }
1664 }
bfcb3514 1665 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
3967c732 1666 HE *he;
7a5b473e 1667 HV * const hv = (HV*)sv;
3967c732 1668 int count = maxnest - nest;
1669
1670 hv_iterinit(hv);
e16e2ff8 1671 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1672 && count--) {
98c991d1 1673 SV *elt, *keysv;
e1ec3a88 1674 const char *keypv;
98c991d1 1675 STRLEN len;
7a5b473e 1676 const U32 hash = HeHASH(he);
3967c732 1677
98c991d1 1678 keysv = hv_iterkeysv(he);
93524f2b 1679 keypv = SvPV_const(keysv, len);
3967c732 1680 elt = hv_iterval(hv, he);
98c991d1 1681 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1682 if (SvUTF8(keysv))
c728cb41 1683 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
afce8e55 1684 if (HeKREHASH(he))
1685 PerlIO_printf(file, "[REHASH] ");
98c991d1 1686 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
3967c732 1687 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1688 }
1689 hv_iterinit(hv); /* Return to status quo */
1690 }
1691 break;
1692 case SVt_PVCV:
cbf82dd0 1693 if (SvPOK(sv)) {
1694 STRLEN len;
1695 const char *const proto = SvPV_const(sv, len);
1696 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1697 (int) len, proto);
1698 }
3967c732 1699 /* FALL THROUGH */
1700 case SVt_PVFM:
1701 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589 1702 if (!CvISXSUB(sv)) {
1703 if (CvSTART(sv)) {
1704 Perl_dump_indent(aTHX_ level, file,
1705 " START = 0x%"UVxf" ===> %"IVdf"\n",
1706 PTR2UV(CvSTART(sv)),
1707 (IV)sequence_num(CvSTART(sv)));
1708 }
1709 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1710 PTR2UV(CvROOT(sv)));
1711 if (CvROOT(sv) && dumpops) {
1712 do_op_dump(level+1, file, CvROOT(sv));
1713 }
1714 } else {
b1886099 1715 SV *constant = cv_const_sv((CV *)sv);
1716
d04ba589 1717 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099 1718
1719 if (constant) {
1720 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1721 " (CONST SV)\n",
1722 PTR2UV(CvXSUBANY(sv).any_ptr));
1723 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1724 pvlim);
1725 } else {
1726 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1727 (IV)CvXSUBANY(sv).any_i32);
1728 }
1729 }
3967c732 1730 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1731 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
57def98f 1732 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1733 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1734 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
3967c732 1735 if (type == SVt_PVFM)
57def98f 1736 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1737 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
dd2155a4 1738 if (nest < maxnest) {
1739 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
3967c732 1740 }
1741 {
b9ac451d 1742 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 1743 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 1744 PTR2UV(outside),
cf2093f6 1745 (!outside ? "null"
1746 : CvANON(outside) ? "ANON"
1747 : (outside == PL_main_cv) ? "MAIN"
1748 : CvUNIQUE(outside) ? "UNIQUE"
1749 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
3967c732 1750 }
1751 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1752 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1753 break;
926fc7b6 1754 case SVt_PVGV:
1755 case SVt_PVLV:
b9ac451d 1756 if (type == SVt_PVLV) {
1757 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1758 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1759 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1760 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1761 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1762 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1763 dumpops, pvlim);
1764 }
926fc7b6 1765 if (!isGV_with_GP(sv))
1766 break;
cea2e8a9 1767 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
57def98f 1768 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 1769 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
57def98f 1770 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c 1771 if (!GvGP(sv))
1772 break;
57def98f 1773 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1774 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1775 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1776 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1777 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1778 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1779 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1780 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
57def98f 1781 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 1782 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
e39917cc 1783 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
3967c732 1784 do_gv_dump (level, file, " EGV", GvEGV(sv));
1785 break;
1786 case SVt_PVIO:
57def98f 1787 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1788 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1789 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1790 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1791 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1792 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1793 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 1794 if (IoTOP_NAME(sv))
cea2e8a9 1795 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565 1796 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1797 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1798 else {
1799 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1800 PTR2UV(IoTOP_GV(sv)));
1801 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1802 dumpops, pvlim);
1803 }
1804 /* Source filters hide things that are not GVs in these three, so let's
1805 be careful out there. */
27533608 1806 if (IoFMT_NAME(sv))
cea2e8a9 1807 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565 1808 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1809 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1810 else {
1811 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1812 PTR2UV(IoFMT_GV(sv)));
1813 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1814 dumpops, pvlim);
1815 }
27533608 1816 if (IoBOTTOM_NAME(sv))
cea2e8a9 1817 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565 1818 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1819 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1820 else {
1821 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1822 PTR2UV(IoBOTTOM_GV(sv)));
1823 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1824 dumpops, pvlim);
1825 }
57def98f 1826 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
27533608 1827 if (isPRINT(IoTYPE(sv)))
cea2e8a9 1828 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 1829 else
cea2e8a9 1830 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 1831 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 1832 break;
1833 }
cea89e20 1834 SvREFCNT_dec(d);
3967c732 1835}
1836
1837void
864dbfa3 1838Perl_sv_dump(pTHX_ SV *sv)
3967c732 1839{
97aff369 1840 dVAR;
3967c732 1841 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 1842}
bd16a5f0 1843
1844int
1845Perl_runops_debug(pTHX)
1846{
97aff369 1847 dVAR;
bd16a5f0 1848 if (!PL_op) {
1849 if (ckWARN_d(WARN_DEBUGGING))
9014280d 1850 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0 1851 return 0;
1852 }
1853
9f3673fb 1854 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 1855 do {
1856 PERL_ASYNC_CHECK();
1857 if (PL_debug) {
b9ac451d 1858 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0 1859 PerlIO_printf(Perl_debug_log,
1860 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1861 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1862 PTR2UV(*PL_watchaddr));
d6721266 1863 if (DEBUG_s_TEST_) {
1864 if (DEBUG_v_TEST_) {
1865 PerlIO_printf(Perl_debug_log, "\n");
1866 deb_stack_all();
1867 }
1868 else
1869 debstack();
1870 }
1871
1872
bd16a5f0 1873 if (DEBUG_t_TEST_) debop(PL_op);
1874 if (DEBUG_P_TEST_) debprof(PL_op);
1875 }
1876 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
9f3673fb 1877 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
bd16a5f0 1878
1879 TAINT_NOT;
1880 return 0;
1881}
1882
1883I32
6867be6d 1884Perl_debop(pTHX_ const OP *o)
bd16a5f0 1885{
97aff369 1886 dVAR;
1045810a 1887 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1888 return 0;
1889
bd16a5f0 1890 Perl_deb(aTHX_ "%s", OP_NAME(o));
1891 switch (o->op_type) {
1892 case OP_CONST:
1893 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1894 break;
1895 case OP_GVSV:
1896 case OP_GV:
1897 if (cGVOPo_gv) {
b9ac451d 1898 SV * const sv = newSV(0);
3b721df9 1899#ifdef PERL_MAD
1900 /* FIXME - it this making unwarranted assumptions about the
1901 UTF-8 cleanliness of the dump file handle? */
1902 SvUTF8_on(sv);
1903#endif
bd61b366 1904 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 1905 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0 1906 SvREFCNT_dec(sv);
1907 }
1908 else
1909 PerlIO_printf(Perl_debug_log, "(NULL)");
1910 break;
1911 case OP_PADSV:
1912 case OP_PADAV:
1913 case OP_PADHV:
a3b680e6 1914 {
bd16a5f0 1915 /* print the lexical's name */
b9ac451d 1916 CV * const cv = deb_curcv(cxstack_ix);
a3b680e6 1917 SV *sv;
bd16a5f0 1918 if (cv) {
b9ac451d 1919 AV * const padlist = CvPADLIST(cv);
b464bac0 1920 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
bd16a5f0 1921 sv = *av_fetch(comppad, o->op_targ, FALSE);
1922 } else
a0714e2c 1923 sv = NULL;
bd16a5f0 1924 if (sv)
b9ac451d 1925 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0 1926 else
b9ac451d 1927 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
a3b680e6 1928 }
bd16a5f0 1929 break;
1930 default:
091ab601 1931 break;
bd16a5f0 1932 }
1933 PerlIO_printf(Perl_debug_log, "\n");
1934 return 0;
1935}
1936
1937STATIC CV*
1938S_deb_curcv(pTHX_ I32 ix)
1939{
97aff369 1940 dVAR;
b9ac451d 1941 const PERL_CONTEXT * const cx = &cxstack[ix];
bd16a5f0 1942 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1943 return cx->blk_sub.cv;
1944 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1945 return PL_compcv;
1946 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1947 return PL_main_cv;
1948 else if (ix <= 0)
601f1833 1949 return NULL;
bd16a5f0 1950 else
1951 return deb_curcv(ix - 1);
1952}
1953
1954void
1955Perl_watch(pTHX_ char **addr)
1956{
97aff369 1957 dVAR;
bd16a5f0 1958 PL_watchaddr = addr;
1959 PL_watchok = *addr;
1960 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1961 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1962}
1963
1964STATIC void
e1ec3a88 1965S_debprof(pTHX_ const OP *o)
bd16a5f0 1966{
97aff369 1967 dVAR;
1045810a 1968 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1969 return;
bd16a5f0 1970 if (!PL_profiledata)
a02a5408 1971 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0 1972 ++PL_profiledata[o->op_type];
1973}
1974
1975void
1976Perl_debprofdump(pTHX)
1977{
97aff369 1978 dVAR;
bd16a5f0 1979 unsigned i;
1980 if (!PL_profiledata)
1981 return;
1982 for (i = 0; i < MAXO; i++) {
1983 if (PL_profiledata[i])
1984 PerlIO_printf(Perl_debug_log,
1985 "%5lu %s\n", (unsigned long)PL_profiledata[i],
1986 PL_op_name[i]);
1987 }
1988}
66610fdd 1989
3b721df9 1990#ifdef PERL_MAD
1991/*
1992 * XML variants of most of the above routines
1993 */
1994
1995STATIC
1996void
1997S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
1998{
1999 va_list args;
2000 PerlIO_printf(file, "\n ");
2001 va_start(args, pat);
2002 xmldump_vindent(level, file, pat, &args);
2003 va_end(args);
2004}
2005
2006
2007void
2008Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2009{
2010 va_list args;
2011 va_start(args, pat);
2012 xmldump_vindent(level, file, pat, &args);
2013 va_end(args);
2014}
2015
2016void
2017Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2018{
2019 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2020 PerlIO_vprintf(file, pat, *args);
2021}
2022
2023void
2024Perl_xmldump_all(pTHX)
2025{
2026 PerlIO_setlinebuf(PL_xmlfp);
2027 if (PL_main_root)
2028 op_xmldump(PL_main_root);
2029 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2030 PerlIO_close(PL_xmlfp);
2031 PL_xmlfp = 0;
2032}
2033
2034void
2035Perl_xmldump_packsubs(pTHX_ const HV *stash)
2036{
2037 I32 i;
2038 HE *entry;
2039
2040 if (!HvARRAY(stash))
2041 return;
2042 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2043 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2044 GV *gv = (GV*)HeVAL(entry);
2045 HV *hv;
2046 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2047 continue;
2048 if (GvCVu(gv))
2049 xmldump_sub(gv);
2050 if (GvFORM(gv))
2051 xmldump_form(gv);
2052 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2053 && (hv = GvHV(gv)) && hv != PL_defstash)
2054 xmldump_packsubs(hv); /* nested package */
2055 }
2056 }
2057}
2058
2059void
2060Perl_xmldump_sub(pTHX_ const GV *gv)
2061{
2062 SV *sv = sv_newmortal();
2063
2064 gv_fullname3(sv, gv, Nullch);
2065 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2066 if (CvXSUB(GvCV(gv)))
2067 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2068 PTR2UV(CvXSUB(GvCV(gv))),
2069 (int)CvXSUBANY(GvCV(gv)).any_i32);
2070 else if (CvROOT(GvCV(gv)))
2071 op_xmldump(CvROOT(GvCV(gv)));
2072 else
2073 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2074}
2075
2076void
2077Perl_xmldump_form(pTHX_ const GV *gv)
2078{
2079 SV *sv = sv_newmortal();
2080
2081 gv_fullname3(sv, gv, Nullch);
2082 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2083 if (CvROOT(GvFORM(gv)))
2084 op_xmldump(CvROOT(GvFORM(gv)));
2085 else
2086 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2087}
2088
2089void
2090Perl_xmldump_eval(pTHX)
2091{
2092 op_xmldump(PL_eval_root);
2093}
2094
2095char *
2096Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2097{
2098 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2099}
2100
2101char *
2102Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2103{
2104 unsigned int c;
2105 char *e = pv + len;
2106 char *start = pv;
2107 STRLEN dsvcur;
2108 STRLEN cl;
2109
2110 sv_catpvn(dsv,"",0);
2111 dsvcur = SvCUR(dsv); /* in case we have to restart */
2112
2113 retry:
2114 while (pv < e) {
2115 if (utf8) {
2116 c = utf8_to_uvchr((U8*)pv, &cl);
2117 if (cl == 0) {
2118 SvCUR(dsv) = dsvcur;
2119 pv = start;
2120 utf8 = 0;
2121 goto retry;
2122 }
2123 }
2124 else
2125 c = (*pv & 255);
2126
2127 switch (c) {
2128 case 0x00:
2129 case 0x01:
2130 case 0x02:
2131 case 0x03:
2132 case 0x04:
2133 case 0x05:
2134 case 0x06:
2135 case 0x07:
2136 case 0x08:
2137 case 0x0b:
2138 case 0x0c:
2139 case 0x0e:
2140 case 0x0f:
2141 case 0x10:
2142 case 0x11:
2143 case 0x12:
2144 case 0x13:
2145 case 0x14:
2146 case 0x15:
2147 case 0x16:
2148 case 0x17:
2149 case 0x18:
2150 case 0x19:
2151 case 0x1a:
2152 case 0x1b:
2153 case 0x1c:
2154 case 0x1d:
2155 case 0x1e:
2156 case 0x1f:
2157 case 0x7f:
2158 case 0x80:
2159 case 0x81:
2160 case 0x82:
2161 case 0x83:
2162 case 0x84:
2163 case 0x86:
2164 case 0x87:
2165 case 0x88:
2166 case 0x89:
2167 case 0x90:
2168 case 0x91:
2169 case 0x92:
2170 case 0x93:
2171 case 0x94:
2172 case 0x95:
2173 case 0x96:
2174 case 0x97:
2175 case 0x98:
2176 case 0x99:
2177 case 0x9a:
2178 case 0x9b:
2179 case 0x9c:
2180 case 0x9d:
2181 case 0x9e:
2182 case 0x9f:
2183 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2184 break;
2185 case '<':
2186 Perl_sv_catpvf(aTHX_ dsv, "&lt;");
2187 break;
2188 case '>':
2189 Perl_sv_catpvf(aTHX_ dsv, "&gt;");
2190 break;
2191 case '&':
2192 Perl_sv_catpvf(aTHX_ dsv, "&amp;");
2193 break;
2194 case '"':
2195 Perl_sv_catpvf(aTHX_ dsv, "&#34;");
2196 break;
2197 default:
2198 if (c < 0xD800) {
2199 if (c < 32 || c > 127) {
2200 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2201 }
2202 else {
2203 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2204 }
2205 break;
2206 }
2207 if ((c >= 0xD800 && c <= 0xDB7F) ||
2208 (c >= 0xDC00 && c <= 0xDFFF) ||
2209 (c >= 0xFFF0 && c <= 0xFFFF) ||
2210 c > 0x10ffff)
2211 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2212 else
2213 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2214 }
2215
2216 if (utf8)
2217 pv += UTF8SKIP(pv);
2218 else
2219 pv++;
2220 }
2221
2222 return SvPVX(dsv);
2223}
2224
2225char *
2226Perl_sv_xmlpeek(pTHX_ SV *sv)
2227{
2228 SV *t = sv_newmortal();
2229 STRLEN n_a;
2230 int unref = 0;
2231
2232 sv_utf8_upgrade(t);
2233 sv_setpvn(t, "", 0);
2234 /* retry: */
2235 if (!sv) {
2236 sv_catpv(t, "VOID=\"\"");
2237 goto finish;
2238 }
2239 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2240 sv_catpv(t, "WILD=\"\"");
2241 goto finish;
2242 }
2243 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2244 if (sv == &PL_sv_undef) {
2245 sv_catpv(t, "SV_UNDEF=\"1\"");
2246 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2247 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2248 SvREADONLY(sv))
2249 goto finish;
2250 }
2251 else if (sv == &PL_sv_no) {
2252 sv_catpv(t, "SV_NO=\"1\"");
2253 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2254 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2255 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2256 SVp_POK|SVp_NOK)) &&
2257 SvCUR(sv) == 0 &&
2258 SvNVX(sv) == 0.0)
2259 goto finish;
2260 }
2261 else if (sv == &PL_sv_yes) {
2262 sv_catpv(t, "SV_YES=\"1\"");
2263 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2264 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2265 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2266 SVp_POK|SVp_NOK)) &&
2267 SvCUR(sv) == 1 &&
2268 SvPVX(sv) && *SvPVX(sv) == '1' &&
2269 SvNVX(sv) == 1.0)
2270 goto finish;
2271 }
2272 else {
2273 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2274 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2275 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2276 SvREADONLY(sv))
2277 goto finish;
2278 }
2279 sv_catpv(t, " XXX=\"\" ");
2280 }
2281 else if (SvREFCNT(sv) == 0) {
2282 sv_catpv(t, " refcnt=\"0\"");
2283 unref++;
2284 }
2285 else if (DEBUG_R_TEST_) {
2286 int is_tmp = 0;
2287 I32 ix;
2288 /* is this SV on the tmps stack? */
2289 for (ix=PL_tmps_ix; ix>=0; ix--) {
2290 if (PL_tmps_stack[ix] == sv) {
2291 is_tmp = 1;
2292 break;
2293 }
2294 }
2295 if (SvREFCNT(sv) > 1)
2296 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2297 is_tmp ? "T" : "");
2298 else if (is_tmp)
2299 sv_catpv(t, " DRT=\"<T>\"");
2300 }
2301
2302 if (SvROK(sv)) {
2303 sv_catpv(t, " ROK=\"\"");
2304 }
2305 switch (SvTYPE(sv)) {
2306 default:
2307 sv_catpv(t, " FREED=\"1\"");
2308 goto finish;
2309
2310 case SVt_NULL:
2311 sv_catpv(t, " UNDEF=\"1\"");
2312 goto finish;
2313 case SVt_IV:
2314 sv_catpv(t, " IV=\"");
2315 break;
2316 case SVt_NV:
2317 sv_catpv(t, " NV=\"");
2318 break;
2319 case SVt_RV:
2320 sv_catpv(t, " RV=\"");
2321 break;
2322 case SVt_PV:
2323 sv_catpv(t, " PV=\"");
2324 break;
2325 case SVt_PVIV:
2326 sv_catpv(t, " PVIV=\"");
2327 break;
2328 case SVt_PVNV:
2329 sv_catpv(t, " PVNV=\"");
2330 break;
2331 case SVt_PVMG:
2332 sv_catpv(t, " PVMG=\"");
2333 break;
2334 case SVt_PVLV:
2335 sv_catpv(t, " PVLV=\"");
2336 break;
2337 case SVt_PVAV:
2338 sv_catpv(t, " AV=\"");
2339 break;
2340 case SVt_PVHV:
2341 sv_catpv(t, " HV=\"");
2342 break;
2343 case SVt_PVCV:
2344 if (CvGV(sv))
2345 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2346 else
2347 sv_catpv(t, " CV=\"()\"");
2348 goto finish;
2349 case SVt_PVGV:
2350 sv_catpv(t, " GV=\"");
2351 break;
cecf5685 2352 case SVt_BIND:
2353 sv_catpv(t, " BIND=\"");
3b721df9 2354 break;
2355 case SVt_PVFM:
2356 sv_catpv(t, " FM=\"");
2357 break;
2358 case SVt_PVIO:
2359 sv_catpv(t, " IO=\"");
2360 break;
2361 }
2362
2363 if (SvPOKp(sv)) {
2364 if (SvPVX(sv)) {
2365 sv_catxmlsv(t, sv);
2366 }
2367 }
2368 else if (SvNOKp(sv)) {
2369 STORE_NUMERIC_LOCAL_SET_STANDARD();
2370 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2371 RESTORE_NUMERIC_LOCAL();
2372 }
2373 else if (SvIOKp(sv)) {
2374 if (SvIsUV(sv))
2375 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2376 else
2377 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2378 }
2379 else
2380 sv_catpv(t, "");
2381 sv_catpv(t, "\"");
2382
2383 finish:
2384 if (unref) {
2385 while (unref--)
2386 sv_catpv(t, ")");
2387 }
2388 return SvPV(t, n_a);
2389}
2390
2391void
2392Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2393{
2394 if (!pm) {
2395 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2396 return;
2397 }
2398 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2399 level++;
2400 if (PM_GETRE(pm)) {
2401 char *s = PM_GETRE(pm)->precomp;
29522234 2402 SV *tmpsv = newSVpvn("",0);
3b721df9 2403 SvUTF8_on(tmpsv);
2404 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2405 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2406 SvPVX(tmpsv));
2407 SvREFCNT_dec(tmpsv);
2408 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2409 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2410 }
2411 else
2412 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2413 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
3df43ef7 2414 SV * const tmpsv = pm_description(pm);
3b721df9 2415 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2416 SvREFCNT_dec(tmpsv);
2417 }
2418
2419 level--;
2420 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
2421 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2422 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2423 do_op_xmldump(level+2, file, pm->op_pmreplroot);
2424 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2425 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2426 }
2427 else
2428 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2429}
2430
2431void
2432Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2433{
2434 do_pmop_xmldump(0, PL_xmlfp, pm);
2435}
2436
2437void
2438Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2439{
2440 UV seq;
2441 int contents = 0;
2442 if (!o)
2443 return;
2444 sequence(o);
2445 seq = sequence_num(o);
2446 Perl_xmldump_indent(aTHX_ level, file,
2447 "<op_%s seq=\"%"UVuf" -> ",
2448 OP_NAME(o),
2449 seq);
2450 level++;
2451 if (o->op_next)
2452 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2453 sequence_num(o->op_next));
2454 else
2455 PerlIO_printf(file, "DONE\"");
2456
2457 if (o->op_targ) {
2458 if (o->op_type == OP_NULL)
2459 {
2460 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2461 if (o->op_targ == OP_NEXTSTATE)
2462 {
2463 if (CopLINE(cCOPo))
f5992bc4 2464 PerlIO_printf(file, " line=\"%"UVuf"\"",
3b721df9 2465 (UV)CopLINE(cCOPo));
2466 if (CopSTASHPV(cCOPo))
2467 PerlIO_printf(file, " package=\"%s\"",
2468 CopSTASHPV(cCOPo));
2469 if (cCOPo->cop_label)
2470 PerlIO_printf(file, " label=\"%s\"",
2471 cCOPo->cop_label);
2472 }
2473 }
2474 else
2475 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2476 }
2477#ifdef DUMPADDR
2478 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2479#endif
2480 if (o->op_flags) {
2481 SV *tmpsv = newSVpvn("", 0);
2482 switch (o->op_flags & OPf_WANT) {
2483 case OPf_WANT_VOID:
2484 sv_catpv(tmpsv, ",VOID");
2485 break;
2486 case OPf_WANT_SCALAR:
2487 sv_catpv(tmpsv, ",SCALAR");
2488 break;
2489 case OPf_WANT_LIST:
2490 sv_catpv(tmpsv, ",LIST");
2491 break;
2492 default:
2493 sv_catpv(tmpsv, ",UNKNOWN");
2494 break;
2495 }
2496 if (o->op_flags & OPf_KIDS)
2497 sv_catpv(tmpsv, ",KIDS");
2498 if (o->op_flags & OPf_PARENS)
2499 sv_catpv(tmpsv, ",PARENS");
2500 if (o->op_flags & OPf_STACKED)
2501 sv_catpv(tmpsv, ",STACKED");
2502 if (o->op_flags & OPf_REF)
2503 sv_catpv(tmpsv, ",REF");
2504 if (o->op_flags & OPf_MOD)
2505 sv_catpv(tmpsv, ",MOD");
2506 if (o->op_flags & OPf_SPECIAL)
2507 sv_catpv(tmpsv, ",SPECIAL");
2508 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2509 SvREFCNT_dec(tmpsv);
2510 }
2511 if (o->op_private) {
2512 SV *tmpsv = newSVpvn("", 0);
2513 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2514 if (o->op_private & OPpTARGET_MY)
2515 sv_catpv(tmpsv, ",TARGET_MY");
2516 }
2517 else if (o->op_type == OP_LEAVESUB ||
2518 o->op_type == OP_LEAVE ||
2519 o->op_type == OP_LEAVESUBLV ||
2520 o->op_type == OP_LEAVEWRITE) {
2521 if (o->op_private & OPpREFCOUNTED)
2522 sv_catpv(tmpsv, ",REFCOUNTED");
2523 }
2524 else if (o->op_type == OP_AASSIGN) {
2525 if (o->op_private & OPpASSIGN_COMMON)
2526 sv_catpv(tmpsv, ",COMMON");
2527 }
2528 else if (o->op_type == OP_SASSIGN) {
2529 if (o->op_private & OPpASSIGN_BACKWARDS)
2530 sv_catpv(tmpsv, ",BACKWARDS");
2531 }
2532 else if (o->op_type == OP_TRANS) {
2533 if (o->op_private & OPpTRANS_SQUASH)
2534 sv_catpv(tmpsv, ",SQUASH");
2535 if (o->op_private & OPpTRANS_DELETE)
2536 sv_catpv(tmpsv, ",DELETE");
2537 if (o->op_private & OPpTRANS_COMPLEMENT)
2538 sv_catpv(tmpsv, ",COMPLEMENT");
2539 if (o->op_private & OPpTRANS_IDENTICAL)
2540 sv_catpv(tmpsv, ",IDENTICAL");
2541 if (o->op_private & OPpTRANS_GROWS)
2542 sv_catpv(tmpsv, ",GROWS");
2543 }
2544 else if (o->op_type == OP_REPEAT) {
2545 if (o->op_private & OPpREPEAT_DOLIST)
2546 sv_catpv(tmpsv, ",DOLIST");
2547 }
2548 else if (o->op_type == OP_ENTERSUB ||
2549 o->op_type == OP_RV2SV ||
2550 o->op_type == OP_GVSV ||
2551 o->op_type == OP_RV2AV ||
2552 o->op_type == OP_RV2HV ||
2553 o->op_type == OP_RV2GV ||
2554 o->op_type == OP_AELEM ||
2555 o->op_type == OP_HELEM )
2556 {
2557 if (o->op_type == OP_ENTERSUB) {
2558 if (o->op_private & OPpENTERSUB_AMPER)
2559 sv_catpv(tmpsv, ",AMPER");
2560 if (o->op_private & OPpENTERSUB_DB)
2561 sv_catpv(tmpsv, ",DB");
2562 if (o->op_private & OPpENTERSUB_HASTARG)
2563 sv_catpv(tmpsv, ",HASTARG");
2564 if (o->op_private & OPpENTERSUB_NOPAREN)
2565 sv_catpv(tmpsv, ",NOPAREN");
2566 if (o->op_private & OPpENTERSUB_INARGS)
2567 sv_catpv(tmpsv, ",INARGS");
2568 if (o->op_private & OPpENTERSUB_NOMOD)
2569 sv_catpv(tmpsv, ",NOMOD");
2570 }
2571 else {
2572 switch (o->op_private & OPpDEREF) {
2573 case OPpDEREF_SV:
2574 sv_catpv(tmpsv, ",SV");
2575 break;
2576 case OPpDEREF_AV:
2577 sv_catpv(tmpsv, ",AV");
2578 break;
2579 case OPpDEREF_HV:
2580 sv_catpv(tmpsv, ",HV");
2581 break;
2582 }
2583 if (o->op_private & OPpMAYBE_LVSUB)
2584 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2585 }
2586 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2587 if (o->op_private & OPpLVAL_DEFER)
2588 sv_catpv(tmpsv, ",LVAL_DEFER");
2589 }
2590 else {
2591 if (o->op_private & HINT_STRICT_REFS)
2592 sv_catpv(tmpsv, ",STRICT_REFS");
2593 if (o->op_private & OPpOUR_INTRO)
2594 sv_catpv(tmpsv, ",OUR_INTRO");
2595 }
2596 }
2597 else if (o->op_type == OP_CONST) {
2598 if (o->op_private & OPpCONST_BARE)
2599 sv_catpv(tmpsv, ",BARE");
2600 if (o->op_private & OPpCONST_STRICT)
2601 sv_catpv(tmpsv, ",STRICT");
2602 if (o->op_private & OPpCONST_ARYBASE)
2603 sv_catpv(tmpsv, ",ARYBASE");
2604 if (o->op_private & OPpCONST_WARNING)
2605 sv_catpv(tmpsv, ",WARNING");
2606 if (o->op_private & OPpCONST_ENTERED)
2607 sv_catpv(tmpsv, ",ENTERED");
2608 }
2609 else if (o->op_type == OP_FLIP) {
2610 if (o->op_private & OPpFLIP_LINENUM)
2611 sv_catpv(tmpsv, ",LINENUM");
2612 }
2613 else if (o->op_type == OP_FLOP) {
2614 if (o->op_private & OPpFLIP_LINENUM)
2615 sv_catpv(tmpsv, ",LINENUM");
2616 }
2617 else if (o->op_type == OP_RV2CV) {
2618 if (o->op_private & OPpLVAL_INTRO)
2619 sv_catpv(tmpsv, ",INTRO");
2620 }
2621 else if (o->op_type == OP_GV) {
2622 if (o->op_private & OPpEARLY_CV)
2623 sv_catpv(tmpsv, ",EARLY_CV");
2624 }
2625 else if (o->op_type == OP_LIST) {
2626 if (o->op_private & OPpLIST_GUESSED)
2627 sv_catpv(tmpsv, ",GUESSED");
2628 }
2629 else if (o->op_type == OP_DELETE) {
2630 if (o->op_private & OPpSLICE)
2631 sv_catpv(tmpsv, ",SLICE");
2632 }
2633 else if (o->op_type == OP_EXISTS) {
2634 if (o->op_private & OPpEXISTS_SUB)
2635 sv_catpv(tmpsv, ",EXISTS_SUB");
2636 }
2637 else if (o->op_type == OP_SORT) {
2638 if (o->op_private & OPpSORT_NUMERIC)
2639 sv_catpv(tmpsv, ",NUMERIC");
2640 if (o->op_private & OPpSORT_INTEGER)
2641 sv_catpv(tmpsv, ",INTEGER");
2642 if (o->op_private & OPpSORT_REVERSE)
2643 sv_catpv(tmpsv, ",REVERSE");
2644 }
2645 else if (o->op_type == OP_THREADSV) {
2646 if (o->op_private & OPpDONE_SVREF)
2647 sv_catpv(tmpsv, ",SVREF");
2648 }
2649 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2650 if (o->op_private & OPpOPEN_IN_RAW)
2651 sv_catpv(tmpsv, ",IN_RAW");
2652 if (o->op_private & OPpOPEN_IN_CRLF)
2653 sv_catpv(tmpsv, ",IN_CRLF");
2654 if (o->op_private & OPpOPEN_OUT_RAW)
2655 sv_catpv(tmpsv, ",OUT_RAW");
2656 if (o->op_private & OPpOPEN_OUT_CRLF)
2657 sv_catpv(tmpsv, ",OUT_CRLF");
2658 }
2659 else if (o->op_type == OP_EXIT) {
2660 if (o->op_private & OPpEXIT_VMSISH)
2661 sv_catpv(tmpsv, ",EXIT_VMSISH");
2662 if (o->op_private & OPpHUSH_VMSISH)
2663 sv_catpv(tmpsv, ",HUSH_VMSISH");
2664 }
2665 else if (o->op_type == OP_DIE) {
2666 if (o->op_private & OPpHUSH_VMSISH)
2667 sv_catpv(tmpsv, ",HUSH_VMSISH");
2668 }
2669 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2670 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2671 sv_catpv(tmpsv, ",FT_ACCESS");
2672 if (o->op_private & OPpFT_STACKED)
2673 sv_catpv(tmpsv, ",FT_STACKED");
2674 }
2675 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2676 sv_catpv(tmpsv, ",INTRO");
2677 if (SvCUR(tmpsv))
2678 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2679 SvREFCNT_dec(tmpsv);
2680 }
2681
2682 switch (o->op_type) {
2683 case OP_AELEMFAST:
2684 if (o->op_flags & OPf_SPECIAL) {
2685 break;
2686 }
2687 case OP_GVSV:
2688 case OP_GV:
2689#ifdef USE_ITHREADS
2690 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2691#else
2692 if (cSVOPo->op_sv) {
ef2570c4 2693 SV *tmpsv1 = newSV(0);
29522234 2694 SV *tmpsv2 = newSVpvn("",0);
3b721df9 2695 char *s;
2696 STRLEN len;
b123ab9d 2697 SvUTF8_on(tmpsv1);
2698 SvUTF8_on(tmpsv2);
3b721df9 2699 ENTER;
2700 SAVEFREESV(tmpsv1);
2701 SAVEFREESV(tmpsv2);
2702 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2703 s = SvPV(tmpsv1,len);
2704 sv_catxmlpvn(tmpsv2, s, len, 1);
2705 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2706 LEAVE;
2707 }
2708 else
2709 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2710#endif
2711 break;
2712 case OP_CONST:
2713 case OP_METHOD_NAMED:
2714#ifndef USE_ITHREADS
2715 /* with ITHREADS, consts are stored in the pad, and the right pad
2716 * may not be active here, so skip */
2717 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2718#endif
2719 break;
2720 case OP_ANONCODE:
2721 if (!contents) {
2722 contents = 1;
2723 PerlIO_printf(file, ">\n");
2724 }
2725 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2726 break;
2727 case OP_SETSTATE:
2728 case OP_NEXTSTATE:
2729 case OP_DBSTATE:
2730 if (CopLINE(cCOPo))
f5992bc4 2731 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3b721df9 2732 (UV)CopLINE(cCOPo));
2733 if (CopSTASHPV(cCOPo))
2734 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2735 CopSTASHPV(cCOPo));
2736 if (cCOPo->cop_label)
2737 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2738 cCOPo->cop_label);
2739 break;
2740 case OP_ENTERLOOP:
2741 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2742 if (cLOOPo->op_redoop)
2743 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2744 else
2745 PerlIO_printf(file, "DONE\"");
2746 S_xmldump_attr(aTHX_ level, file, "next=\"");
2747 if (cLOOPo->op_nextop)
2748 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2749 else
2750 PerlIO_printf(file, "DONE\"");
2751 S_xmldump_attr(aTHX_ level, file, "last=\"");
2752 if (cLOOPo->op_lastop)
2753 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2754 else
2755 PerlIO_printf(file, "DONE\"");
2756 break;
2757 case OP_COND_EXPR:
2758 case OP_RANGE:
2759 case OP_MAPWHILE:
2760 case OP_GREPWHILE:
2761 case OP_OR:
2762 case OP_AND:
2763 S_xmldump_attr(aTHX_ level, file, "other=\"");
2764 if (cLOGOPo->op_other)
2765 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2766 else
2767 PerlIO_printf(file, "DONE\"");
2768 break;
2769 case OP_LEAVE:
2770 case OP_LEAVEEVAL:
2771 case OP_LEAVESUB:
2772 case OP_LEAVESUBLV:
2773 case OP_LEAVEWRITE:
2774 case OP_SCOPE:
2775 if (o->op_private & OPpREFCOUNTED)
2776 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2777 break;
2778 default:
2779 break;
2780 }
2781
2782 if (PL_madskills && o->op_madprop) {
2783 SV *tmpsv = newSVpvn("", 0);
2784 MADPROP* mp = o->op_madprop;
2785 sv_utf8_upgrade(tmpsv);
2786 if (!contents) {
2787 contents = 1;
2788 PerlIO_printf(file, ">\n");
2789 }
2790 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2791 level++;
2792 while (mp) {
2793 char tmp = mp->mad_key;
2794 sv_setpvn(tmpsv,"\"",1);
2795 if (tmp)
2796 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2797 sv_catpv(tmpsv, "\"");
2798 switch (mp->mad_type) {
2799 case MAD_NULL:
2800 sv_catpv(tmpsv, "NULL");
2801 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2802 break;
2803 case MAD_PV:
2804 sv_catpv(tmpsv, " val=\"");
2805 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2806 sv_catpv(tmpsv, "\"");
2807 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2808 break;
2809 case MAD_SV:
2810 sv_catpv(tmpsv, " val=\"");
2811 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2812 sv_catpv(tmpsv, "\"");
2813 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2814 break;
2815 case MAD_OP:
2816 if ((OP*)mp->mad_val) {
2817 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2818 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2819 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2820 }
2821 break;
2822 default:
2823 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2824 break;
2825 }
2826 mp = mp->mad_next;
2827 }
2828 level--;
2829 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2830
2831 SvREFCNT_dec(tmpsv);
2832 }
2833
2834 switch (o->op_type) {
2835 case OP_PUSHRE:
2836 case OP_MATCH:
2837 case OP_QR:
2838 case OP_SUBST:
2839 if (!contents) {
2840 contents = 1;
2841 PerlIO_printf(file, ">\n");
2842 }
2843 do_pmop_xmldump(level, file, cPMOPo);
2844 break;
2845 default:
2846 break;
2847 }
2848
2849 if (o->op_flags & OPf_KIDS) {
2850 OP *kid;
2851 if (!contents) {
2852 contents = 1;
2853 PerlIO_printf(file, ">\n");
2854 }
2855 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2856 do_op_xmldump(level, file, kid);
2857 }
2858
2859 if (contents)
2860 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2861 else
2862 PerlIO_printf(file, " />\n");
2863}
2864
2865void
2866Perl_op_xmldump(pTHX_ const OP *o)
2867{
2868 do_op_xmldump(0, PL_xmlfp, o);
2869}
2870#endif
2871
66610fdd 2872/*
2873 * Local variables:
2874 * c-indentation-style: bsd
2875 * c-basic-offset: 4
2876 * indent-tabs-mode: t
2877 * End:
2878 *
37442d52 2879 * ex: set ts=8 sts=4 sw=4 noet:
2880 */
Unnamed repository; edit this file to name it for gitweb.