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