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