projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Allow regexp.t to take a command line argument for the filename of
[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
1015 /* FIXME - it this making unwarranted assumptions about the
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) {
b900a521 1266 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
3967c732 1267 if (mg->mg_flags & MGf_REFCOUNTED)
1268 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1269 }
1270 if (mg->mg_len)
894356b3 1271 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1272 if (mg->mg_ptr) {
b900a521 1273 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
3967c732 1274 if (mg->mg_len >= 0) {
7e8c5dac 1275 if (mg->mg_type != PERL_MAGIC_utf8) {
396482e1 1276 SV *sv = newSVpvs("");
7e8c5dac 1277 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1278 SvREFCNT_dec(sv);
1279 }
3967c732 1280 }
1281 else if (mg->mg_len == HEf_SVKEY) {
1282 PerlIO_puts(file, " => HEf_SVKEY\n");
1283 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1284 continue;
1285 }
1286 else
1287 PerlIO_puts(file, " ???? - please notify IZ");
1288 PerlIO_putc(file, '\n');
1289 }
7e8c5dac 1290 if (mg->mg_type == PERL_MAGIC_utf8) {
1291 STRLEN *cache = (STRLEN *) mg->mg_ptr;
1292 if (cache) {
1293 IV i;
1294 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1295 Perl_dump_indent(aTHX_ level, file,
1296 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1297 i,
1298 (UV)cache[i * 2],
1299 (UV)cache[i * 2 + 1]);
1300 }
1301 }
378cc40b 1302 }
3967c732 1303}
1304
1305void
6867be6d 1306Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1307{
b9ac451d 1308 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732 1309}
1310
1311void
e1ec3a88 1312Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1313{
bfcb3514 1314 const char *hvname;
b900a521 1315 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
bfcb3514 1316 if (sv && (hvname = HvNAME_get(sv)))
1317 PerlIO_printf(file, "\t\"%s\"\n", hvname);
79072805 1318 else
3967c732 1319 PerlIO_putc(file, '\n');
1320}
1321
1322void
e1ec3a88 1323Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1324{
b900a521 1325 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732 1326 if (sv && GvNAME(sv))
1327 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
c90c0ff4 1328 else
3967c732 1329 PerlIO_putc(file, '\n');
1330}
1331
1332void
e1ec3a88 1333Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1334{
b900a521 1335 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732 1336 if (sv && GvNAME(sv)) {
bfcb3514 1337 const char *hvname;
3967c732 1338 PerlIO_printf(file, "\t\"");
bfcb3514 1339 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1340 PerlIO_printf(file, "%s\" :: \"", hvname);
3967c732 1341 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
8d063cd8 1342 }
3967c732 1343 else
1344 PerlIO_putc(file, '\n');
1345}
1346
1347void
864dbfa3 1348Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1349{
97aff369 1350 dVAR;
cea89e20 1351 SV *d;
e1ec3a88 1352 const char *s;
3967c732 1353 U32 flags;
1354 U32 type;
1355
1356 if (!sv) {
cea2e8a9 1357 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1358 return;
378cc40b 1359 }
2ef28da1 1360
3967c732 1361 flags = SvFLAGS(sv);
1362 type = SvTYPE(sv);
79072805 1363
cea89e20 1364 d = Perl_newSVpvf(aTHX_
57def98f 1365 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
56431972 1366 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3 1367 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1368 (int)(PL_dumpindent*level), "");
8d063cd8 1369
e604303a 1370 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1371 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1372 }
1373 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1374 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1375 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1376 }
3967c732 1377 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1378 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1379 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1380 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1381 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
4db58590 1382
3967c732 1383 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1384 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1385 if (flags & SVf_POK) sv_catpv(d, "POK,");
810b8aa5 1386 if (flags & SVf_ROK) {
1387 sv_catpv(d, "ROK,");
1388 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1389 }
3967c732 1390 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1391 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1392 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
de6bd8a1 1393 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
4db58590 1394
dd2eae66 1395 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
3967c732 1396 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1397 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1398 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1ccdb730 1399 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1400 if (SvPCS_IMPORTED(sv))
1401 sv_catpv(d, "PCS_IMPORTED,");
1402 else
9660f481 1403 sv_catpv(d, "SCREAM,");
1ccdb730 1404 }
3967c732 1405
1406 switch (type) {
1407 case SVt_PVCV:
1408 case SVt_PVFM:
1409 if (CvANON(sv)) sv_catpv(d, "ANON,");
1410 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1411 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1412 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
de3f1649 1413 if (CvCONST(sv)) sv_catpv(d, "CONST,");
3967c732 1414 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
25da4f38 1415 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
18f7acf9 1416 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1417 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
662a8415 1418 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
7dafbf52 1419 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
06492da6 1420 if (CvASSERTION(sv)) sv_catpv(d, "ASSERTION,");
3967c732 1421 break;
1422 case SVt_PVHV:
1423 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1424 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
19692e8d 1425 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
afce8e55 1426 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
9660f481 1427 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
3967c732 1428 break;
926fc7b6 1429 case SVt_PVGV:
1430 case SVt_PVLV:
1431 if (isGV_with_GP(sv)) {
1432 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1433 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1434 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1435 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1436 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1437 }
926fc7b6 1438 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732 1439 sv_catpv(d, "IMPORT");
1440 if (GvIMPORTED(sv) == GVf_IMPORTED)
1441 sv_catpv(d, "ALL,");
1442 else {
1443 sv_catpv(d, "(");
1444 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1445 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1446 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1447 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1448 sv_catpv(d, " ),");
1449 }
1450 }
cecf5685 1451 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1452 if (SvVALID(sv)) sv_catpv(d, "VALID,");
addd1794 1453 /* FALL THROUGH */
25da4f38 1454 default:
e604303a 1455 evaled_or_uv:
25da4f38 1456 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
69c678eb 1457 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1458 break;
addd1794 1459 case SVt_PVMG:
00b1698f 1460 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
e604303a 1461 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
2e94196c 1462 /* FALL THROUGH */
e604303a 1463 case SVt_PVNV:
1464 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1465 goto evaled_or_uv;
11ca45c0 1466 case SVt_PVAV:
1467 break;
3967c732 1468 }
86f0d186 1469 /* SVphv_SHAREKEYS is also 0x20000000 */
1470 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1471 sv_catpv(d, "UTF8");
3967c732 1472
b162af07 1473 if (*(SvEND(d) - 1) == ',') {
1474 SvCUR_set(d, SvCUR(d) - 1);
1475 SvPVX(d)[SvCUR(d)] = '\0';
1476 }
3967c732 1477 sv_catpv(d, ")");
b15aece3 1478 s = SvPVX_const(d);
3967c732 1479
fd0854ff 1480#ifdef DEBUG_LEAKING_SCALARS
1481 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1482 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1483 sv->sv_debug_line,
1484 sv->sv_debug_inpad ? "for" : "by",
1485 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1486 sv->sv_debug_cloned ? " (cloned)" : "");
1487#endif
cea2e8a9 1488 Perl_dump_indent(aTHX_ level, file, "SV = ");
5357ca29 1489 if (type < SVt_LAST) {
1490 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1491
1492 if (type == SVt_NULL) {
1493 SvREFCNT_dec(d);
1494 return;
1495 }
1496 } else {
faccc32b 1497 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
cea89e20 1498 SvREFCNT_dec(d);
3967c732 1499 return;
1500 }
27bd069f 1501 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1502 && type != SVt_PVCV && !isGV_with_GP(sv))
1503 || type == SVt_IV) {
765f542d 1504 if (SvIsUV(sv)
f8c7b90f 1505#ifdef PERL_OLD_COPY_ON_WRITE
765f542d 1506 || SvIsCOW(sv)
1507#endif
1508 )
57def98f 1509 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1510 else
57def98f 1511 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
3967c732 1512 if (SvOOK(sv))
1513 PerlIO_printf(file, " (OFFSET)");
f8c7b90f 1514#ifdef PERL_OLD_COPY_ON_WRITE
765f542d 1515 if (SvIsCOW_shared_hash(sv))
1516 PerlIO_printf(file, " (HASH)");
1517 else if (SvIsCOW_normal(sv))
1518 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1519#endif
3967c732 1520 PerlIO_putc(file, '\n');
1521 }
0e4c4423 1522 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1523 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1524 (UV) COP_SEQ_RANGE_LOW(sv));
1525 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1526 (UV) COP_SEQ_RANGE_HIGH(sv));
1527 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1528 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
1529 || type == SVt_NV) {
e54dc35b 1530 STORE_NUMERIC_LOCAL_SET_STANDARD();
57def98f 1531 /* %Vg doesn't work? --jhi */
cf2093f6 1532#ifdef USE_LONG_DOUBLE
2d4389e4 1533 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
cf2093f6 1534#else
cea2e8a9 1535 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
cf2093f6 1536#endif
e54dc35b 1537 RESTORE_NUMERIC_LOCAL();
3967c732 1538 }
1539 if (SvROK(sv)) {
57def98f 1540 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732 1541 if (nest < maxnest)
1542 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1543 }
cea89e20 1544 if (type < SVt_PV) {
1545 SvREFCNT_dec(d);
3967c732 1546 return;
cea89e20 1547 }
f7877b28 1548 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
b15aece3 1549 if (SvPVX_const(sv)) {
1550 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
3967c732 1551 if (SvOOK(sv))
b15aece3 1552 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1553 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
e6abe6d8 1554 if (SvUTF8(sv)) /* the 8? \x{....} */
c728cb41 1555 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
e6abe6d8 1556 PerlIO_printf(file, "\n");
57def98f 1557 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1558 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
3967c732 1559 }
1560 else
cea2e8a9 1561 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1562 }
1563 if (type >= SVt_PVMG) {
0e4c4423 1564 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
38cbaf55 1565 HV *ost = SvOURSTASH(sv);
1566 if (ost)
1567 do_hv_dump(level, file, " OURSTASH", ost);
0e4c4423 1568 } else {
1569 if (SvMAGIC(sv))
1570 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1571 }
3967c732 1572 if (SvSTASH(sv))
1573 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1574 }
1575 switch (type) {
3967c732 1576 case SVt_PVAV:
57def98f 1577 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1578 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f 1579 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1580 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732 1581 }
1582 else
1583 PerlIO_putc(file, '\n');
57def98f 1584 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1585 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
a3874608 1586 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
c69006e4 1587 sv_setpvn(d, "", 0);
11ca45c0 1588 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1589 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3 1590 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1591 SvCUR(d) ? SvPVX_const(d) + 1 : "");
3967c732 1592 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1593 int count;
1594 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1595 SV** elt = av_fetch((AV*)sv,count,0);
1596
57def98f 1597 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
2ef28da1 1598 if (elt)
3967c732 1599 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1600 }
1601 }
1602 break;
1603 case SVt_PVHV:
57def98f 1604 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
3967c732 1605 if (HvARRAY(sv) && HvKEYS(sv)) {
1606 /* Show distribution of HEs in the ARRAY */
1607 int freq[200];
bb7a0f54 1608#define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
3967c732 1609 int i;
1610 int max = 0;
1611 U32 pow2 = 2, keys = HvKEYS(sv);
65202027 1612 NV theoret, sum = 0;
3967c732 1613
1614 PerlIO_printf(file, " (");
1615 Zero(freq, FREQ_MAX + 1, int);
eb160463 1616 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15 1617 HE* h;
1618 int count = 0;
3967c732 1619 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1620 count++;
1621 if (count > FREQ_MAX)
1622 count = FREQ_MAX;
1623 freq[count]++;
1624 if (max < count)
1625 max = count;
1626 }
1627 for (i = 0; i <= max; i++) {
1628 if (freq[i]) {
1629 PerlIO_printf(file, "%d%s:%d", i,
1630 (i == FREQ_MAX) ? "+" : "",
1631 freq[i]);
1632 if (i != max)
1633 PerlIO_printf(file, ", ");
1634 }
1635 }
1636 PerlIO_putc(file, ')');
b8fa94d8 1637 /* The "quality" of a hash is defined as the total number of
1638 comparisons needed to access every element once, relative
1639 to the expected number needed for a random hash.
1640
1641 The total number of comparisons is equal to the sum of
e76cd0fa 1642 the squares of the number of entries in each bucket.
1643 For a random hash of n keys into k buckets, the expected
b8fa94d8 1644 value is
1645 n + n(n-1)/2k
1646 */
1647
3967c732 1648 for (i = max; i > 0; i--) { /* Precision: count down. */
1649 sum += freq[i] * i * i;
1650 }
155aba94 1651 while ((keys = keys >> 1))
3967c732 1652 pow2 = pow2 << 1;
3967c732 1653 theoret = HvKEYS(sv);
b8fa94d8 1654 theoret += theoret * (theoret-1)/pow2;
3967c732 1655 PerlIO_putc(file, '\n');
6b4667fc 1656 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732 1657 }
1658 PerlIO_putc(file, '\n');
57def98f 1659 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1660 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1661 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
bfcb3514 1662 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1663 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
8d2f4536 1664 {
b9ac451d 1665 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536 1666 if (mg && mg->mg_obj) {
1667 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1668 }
1669 }
bfcb3514 1670 {
b9ac451d 1671 const char * const hvname = HvNAME_get(sv);
bfcb3514 1672 if (hvname)
1673 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1674 }
86f55936 1675 if (SvOOK(sv)) {
b9ac451d 1676 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
86f55936 1677 if (backrefs) {
1678 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1679 PTR2UV(backrefs));
1680 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1681 dumpops, pvlim);
1682 }
1683 }
bfcb3514 1684 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
3967c732 1685 HE *he;
7a5b473e 1686 HV * const hv = (HV*)sv;
3967c732 1687 int count = maxnest - nest;
1688
1689 hv_iterinit(hv);
e16e2ff8 1690 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1691 && count--) {
98c991d1 1692 SV *elt, *keysv;
e1ec3a88 1693 const char *keypv;
98c991d1 1694 STRLEN len;
7a5b473e 1695 const U32 hash = HeHASH(he);
3967c732 1696
98c991d1 1697 keysv = hv_iterkeysv(he);
93524f2b 1698 keypv = SvPV_const(keysv, len);
3967c732 1699 elt = hv_iterval(hv, he);
98c991d1 1700 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1701 if (SvUTF8(keysv))
c728cb41 1702 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
afce8e55 1703 if (HeKREHASH(he))
1704 PerlIO_printf(file, "[REHASH] ");
98c991d1 1705 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
3967c732 1706 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1707 }
1708 hv_iterinit(hv); /* Return to status quo */
1709 }
1710 break;
1711 case SVt_PVCV:
cbf82dd0 1712 if (SvPOK(sv)) {
1713 STRLEN len;
1714 const char *const proto = SvPV_const(sv, len);
1715 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1716 (int) len, proto);
1717 }
3967c732 1718 /* FALL THROUGH */
1719 case SVt_PVFM:
1720 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589 1721 if (!CvISXSUB(sv)) {
1722 if (CvSTART(sv)) {
1723 Perl_dump_indent(aTHX_ level, file,
1724 " START = 0x%"UVxf" ===> %"IVdf"\n",
1725 PTR2UV(CvSTART(sv)),
1726 (IV)sequence_num(CvSTART(sv)));
1727 }
1728 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1729 PTR2UV(CvROOT(sv)));
1730 if (CvROOT(sv) && dumpops) {
1731 do_op_dump(level+1, file, CvROOT(sv));
1732 }
1733 } else {
b1886099 1734 SV *constant = cv_const_sv((CV *)sv);
1735
d04ba589 1736 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099 1737
1738 if (constant) {
1739 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1740 " (CONST SV)\n",
1741 PTR2UV(CvXSUBANY(sv).any_ptr));
1742 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1743 pvlim);
1744 } else {
1745 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1746 (IV)CvXSUBANY(sv).any_i32);
1747 }
1748 }
3967c732 1749 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1750 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
57def98f 1751 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1752 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1753 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
3967c732 1754 if (type == SVt_PVFM)
57def98f 1755 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1756 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
dd2155a4 1757 if (nest < maxnest) {
1758 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
3967c732 1759 }
1760 {
b9ac451d 1761 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 1762 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 1763 PTR2UV(outside),
cf2093f6 1764 (!outside ? "null"
1765 : CvANON(outside) ? "ANON"
1766 : (outside == PL_main_cv) ? "MAIN"
1767 : CvUNIQUE(outside) ? "UNIQUE"
1768 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
3967c732 1769 }
1770 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1771 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1772 break;
926fc7b6 1773 case SVt_PVGV:
1774 case SVt_PVLV:
b9ac451d 1775 if (type == SVt_PVLV) {
1776 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1777 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1778 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1779 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1780 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1781 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1782 dumpops, pvlim);
1783 }
926fc7b6 1784 if (!isGV_with_GP(sv))
1785 break;
cea2e8a9 1786 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
57def98f 1787 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 1788 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
57def98f 1789 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c 1790 if (!GvGP(sv))
1791 break;
57def98f 1792 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1793 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1794 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1795 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1796 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1797 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1798 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1799 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
57def98f 1800 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 1801 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
e39917cc 1802 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
3967c732 1803 do_gv_dump (level, file, " EGV", GvEGV(sv));
1804 break;
1805 case SVt_PVIO:
57def98f 1806 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1807 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1808 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1809 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1810 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1811 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1812 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 1813 if (IoTOP_NAME(sv))
cea2e8a9 1814 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565 1815 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1816 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1817 else {
1818 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1819 PTR2UV(IoTOP_GV(sv)));
1820 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1821 dumpops, pvlim);
1822 }
1823 /* Source filters hide things that are not GVs in these three, so let's
1824 be careful out there. */
27533608 1825 if (IoFMT_NAME(sv))
cea2e8a9 1826 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565 1827 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1828 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1829 else {
1830 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1831 PTR2UV(IoFMT_GV(sv)));
1832 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1833 dumpops, pvlim);
1834 }
27533608 1835 if (IoBOTTOM_NAME(sv))
cea2e8a9 1836 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565 1837 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1838 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1839 else {
1840 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1841 PTR2UV(IoBOTTOM_GV(sv)));
1842 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1843 dumpops, pvlim);
1844 }
57def98f 1845 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
27533608 1846 if (isPRINT(IoTYPE(sv)))
cea2e8a9 1847 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 1848 else
cea2e8a9 1849 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 1850 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 1851 break;
1852 }
cea89e20 1853 SvREFCNT_dec(d);
3967c732 1854}
1855
1856void
864dbfa3 1857Perl_sv_dump(pTHX_ SV *sv)
3967c732 1858{
97aff369 1859 dVAR;
3967c732 1860 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 1861}
bd16a5f0 1862
1863int
1864Perl_runops_debug(pTHX)
1865{
97aff369 1866 dVAR;
bd16a5f0 1867 if (!PL_op) {
1868 if (ckWARN_d(WARN_DEBUGGING))
9014280d 1869 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0 1870 return 0;
1871 }
1872
9f3673fb 1873 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 1874 do {
1875 PERL_ASYNC_CHECK();
1876 if (PL_debug) {
b9ac451d 1877 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0 1878 PerlIO_printf(Perl_debug_log,
1879 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1880 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1881 PTR2UV(*PL_watchaddr));
d6721266 1882 if (DEBUG_s_TEST_) {
1883 if (DEBUG_v_TEST_) {
1884 PerlIO_printf(Perl_debug_log, "\n");
1885 deb_stack_all();
1886 }
1887 else
1888 debstack();
1889 }
1890
1891
bd16a5f0 1892 if (DEBUG_t_TEST_) debop(PL_op);
1893 if (DEBUG_P_TEST_) debprof(PL_op);
1894 }
1895 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
9f3673fb 1896 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
bd16a5f0 1897
1898 TAINT_NOT;
1899 return 0;
1900}
1901
1902I32
6867be6d 1903Perl_debop(pTHX_ const OP *o)
bd16a5f0 1904{
97aff369 1905 dVAR;
1045810a 1906 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1907 return 0;
1908
bd16a5f0 1909 Perl_deb(aTHX_ "%s", OP_NAME(o));
1910 switch (o->op_type) {
1911 case OP_CONST:
1912 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1913 break;
1914 case OP_GVSV:
1915 case OP_GV:
1916 if (cGVOPo_gv) {
b9ac451d 1917 SV * const sv = newSV(0);
3b721df9 1918#ifdef PERL_MAD
1919 /* FIXME - it this making unwarranted assumptions about the
1920 UTF-8 cleanliness of the dump file handle? */
1921 SvUTF8_on(sv);
1922#endif
bd61b366 1923 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 1924 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0 1925 SvREFCNT_dec(sv);
1926 }
1927 else
1928 PerlIO_printf(Perl_debug_log, "(NULL)");
1929 break;
1930 case OP_PADSV:
1931 case OP_PADAV:
1932 case OP_PADHV:
a3b680e6 1933 {
bd16a5f0 1934 /* print the lexical's name */
b9ac451d 1935 CV * const cv = deb_curcv(cxstack_ix);
a3b680e6 1936 SV *sv;
bd16a5f0 1937 if (cv) {
b9ac451d 1938 AV * const padlist = CvPADLIST(cv);
b464bac0 1939 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
bd16a5f0 1940 sv = *av_fetch(comppad, o->op_targ, FALSE);
1941 } else
a0714e2c 1942 sv = NULL;
bd16a5f0 1943 if (sv)
b9ac451d 1944 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0 1945 else
b9ac451d 1946 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
a3b680e6 1947 }
bd16a5f0 1948 break;
1949 default:
091ab601 1950 break;
bd16a5f0 1951 }
1952 PerlIO_printf(Perl_debug_log, "\n");
1953 return 0;
1954}
1955
1956STATIC CV*
1957S_deb_curcv(pTHX_ I32 ix)
1958{
97aff369 1959 dVAR;
b9ac451d 1960 const PERL_CONTEXT * const cx = &cxstack[ix];
bd16a5f0 1961 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1962 return cx->blk_sub.cv;
1963 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1964 return PL_compcv;
1965 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1966 return PL_main_cv;
1967 else if (ix <= 0)
601f1833 1968 return NULL;
bd16a5f0 1969 else
1970 return deb_curcv(ix - 1);
1971}
1972
1973void
1974Perl_watch(pTHX_ char **addr)
1975{
97aff369 1976 dVAR;
bd16a5f0 1977 PL_watchaddr = addr;
1978 PL_watchok = *addr;
1979 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1980 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1981}
1982
1983STATIC void
e1ec3a88 1984S_debprof(pTHX_ const OP *o)
bd16a5f0 1985{
97aff369 1986 dVAR;
1045810a 1987 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1988 return;
bd16a5f0 1989 if (!PL_profiledata)
a02a5408 1990 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0 1991 ++PL_profiledata[o->op_type];
1992}
1993
1994void
1995Perl_debprofdump(pTHX)
1996{
97aff369 1997 dVAR;
bd16a5f0 1998 unsigned i;
1999 if (!PL_profiledata)
2000 return;
2001 for (i = 0; i < MAXO; i++) {
2002 if (PL_profiledata[i])
2003 PerlIO_printf(Perl_debug_log,
2004 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2005 PL_op_name[i]);
2006 }
2007}
66610fdd 2008
3b721df9 2009#ifdef PERL_MAD
2010/*
2011 * XML variants of most of the above routines
2012 */
2013
2014STATIC
2015void
2016S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2017{
2018 va_list args;
2019 PerlIO_printf(file, "\n ");
2020 va_start(args, pat);
2021 xmldump_vindent(level, file, pat, &args);
2022 va_end(args);
2023}
2024
2025
2026void
2027Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2028{
2029 va_list args;
2030 va_start(args, pat);
2031 xmldump_vindent(level, file, pat, &args);
2032 va_end(args);
2033}
2034
2035void
2036Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2037{
2038 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2039 PerlIO_vprintf(file, pat, *args);
2040}
2041
2042void
2043Perl_xmldump_all(pTHX)
2044{
2045 PerlIO_setlinebuf(PL_xmlfp);
2046 if (PL_main_root)
2047 op_xmldump(PL_main_root);
2048 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2049 PerlIO_close(PL_xmlfp);
2050 PL_xmlfp = 0;
2051}
2052
2053void
2054Perl_xmldump_packsubs(pTHX_ const HV *stash)
2055{
2056 I32 i;
2057 HE *entry;
2058
2059 if (!HvARRAY(stash))
2060 return;
2061 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2062 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2063 GV *gv = (GV*)HeVAL(entry);
2064 HV *hv;
2065 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2066 continue;
2067 if (GvCVu(gv))
2068 xmldump_sub(gv);
2069 if (GvFORM(gv))
2070 xmldump_form(gv);
2071 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2072 && (hv = GvHV(gv)) && hv != PL_defstash)
2073 xmldump_packsubs(hv); /* nested package */
2074 }
2075 }
2076}
2077
2078void
2079Perl_xmldump_sub(pTHX_ const GV *gv)
2080{
2081 SV *sv = sv_newmortal();
2082
2083 gv_fullname3(sv, gv, Nullch);
2084 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2085 if (CvXSUB(GvCV(gv)))
2086 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2087 PTR2UV(CvXSUB(GvCV(gv))),
2088 (int)CvXSUBANY(GvCV(gv)).any_i32);
2089 else if (CvROOT(GvCV(gv)))
2090 op_xmldump(CvROOT(GvCV(gv)));
2091 else
2092 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2093}
2094
2095void
2096Perl_xmldump_form(pTHX_ const GV *gv)
2097{
2098 SV *sv = sv_newmortal();
2099
2100 gv_fullname3(sv, gv, Nullch);
2101 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2102 if (CvROOT(GvFORM(gv)))
2103 op_xmldump(CvROOT(GvFORM(gv)));
2104 else
2105 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2106}
2107
2108void
2109Perl_xmldump_eval(pTHX)
2110{
2111 op_xmldump(PL_eval_root);
2112}
2113
2114char *
2115Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2116{
2117 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2118}
2119
2120char *
2121Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2122{
2123 unsigned int c;
2124 char *e = pv + len;
2125 char *start = pv;
2126 STRLEN dsvcur;
2127 STRLEN cl;
2128
2129 sv_catpvn(dsv,"",0);
2130 dsvcur = SvCUR(dsv); /* in case we have to restart */
2131
2132 retry:
2133 while (pv < e) {
2134 if (utf8) {
2135 c = utf8_to_uvchr((U8*)pv, &cl);
2136 if (cl == 0) {
2137 SvCUR(dsv) = dsvcur;
2138 pv = start;
2139 utf8 = 0;
2140 goto retry;
2141 }
2142 }
2143 else
2144 c = (*pv & 255);
2145
2146 switch (c) {
2147 case 0x00:
2148 case 0x01:
2149 case 0x02:
2150 case 0x03:
2151 case 0x04:
2152 case 0x05:
2153 case 0x06:
2154 case 0x07:
2155 case 0x08:
2156 case 0x0b:
2157 case 0x0c:
2158 case 0x0e:
2159 case 0x0f:
2160 case 0x10:
2161 case 0x11:
2162 case 0x12:
2163 case 0x13:
2164 case 0x14:
2165 case 0x15:
2166 case 0x16:
2167 case 0x17:
2168 case 0x18:
2169 case 0x19:
2170 case 0x1a:
2171 case 0x1b:
2172 case 0x1c:
2173 case 0x1d:
2174 case 0x1e:
2175 case 0x1f:
2176 case 0x7f:
2177 case 0x80:
2178 case 0x81:
2179 case 0x82:
2180 case 0x83:
2181 case 0x84:
2182 case 0x86:
2183 case 0x87:
2184 case 0x88:
2185 case 0x89:
2186 case 0x90:
2187 case 0x91:
2188 case 0x92:
2189 case 0x93:
2190 case 0x94:
2191 case 0x95:
2192 case 0x96:
2193 case 0x97:
2194 case 0x98:
2195 case 0x99:
2196 case 0x9a:
2197 case 0x9b:
2198 case 0x9c:
2199 case 0x9d:
2200 case 0x9e:
2201 case 0x9f:
2202 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2203 break;
2204 case '<':
2205 Perl_sv_catpvf(aTHX_ dsv, "&lt;");
2206 break;
2207 case '>':
2208 Perl_sv_catpvf(aTHX_ dsv, "&gt;");
2209 break;
2210 case '&':
2211 Perl_sv_catpvf(aTHX_ dsv, "&amp;");
2212 break;
2213 case '"':
2214 Perl_sv_catpvf(aTHX_ dsv, "&#34;");
2215 break;
2216 default:
2217 if (c < 0xD800) {
2218 if (c < 32 || c > 127) {
2219 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2220 }
2221 else {
2222 Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2223 }
2224 break;
2225 }
2226 if ((c >= 0xD800 && c <= 0xDB7F) ||
2227 (c >= 0xDC00 && c <= 0xDFFF) ||
2228 (c >= 0xFFF0 && c <= 0xFFFF) ||
2229 c > 0x10ffff)
2230 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2231 else
2232 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2233 }
2234
2235 if (utf8)
2236 pv += UTF8SKIP(pv);
2237 else
2238 pv++;
2239 }
2240
2241 return SvPVX(dsv);
2242}
2243
2244char *
2245Perl_sv_xmlpeek(pTHX_ SV *sv)
2246{
2247 SV *t = sv_newmortal();
2248 STRLEN n_a;
2249 int unref = 0;
2250
2251 sv_utf8_upgrade(t);
2252 sv_setpvn(t, "", 0);
2253 /* retry: */
2254 if (!sv) {
2255 sv_catpv(t, "VOID=\"\"");
2256 goto finish;
2257 }
2258 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2259 sv_catpv(t, "WILD=\"\"");
2260 goto finish;
2261 }
2262 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2263 if (sv == &PL_sv_undef) {
2264 sv_catpv(t, "SV_UNDEF=\"1\"");
2265 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2266 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2267 SvREADONLY(sv))
2268 goto finish;
2269 }
2270 else if (sv == &PL_sv_no) {
2271 sv_catpv(t, "SV_NO=\"1\"");
2272 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2273 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2274 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2275 SVp_POK|SVp_NOK)) &&
2276 SvCUR(sv) == 0 &&
2277 SvNVX(sv) == 0.0)
2278 goto finish;
2279 }
2280 else if (sv == &PL_sv_yes) {
2281 sv_catpv(t, "SV_YES=\"1\"");
2282 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2283 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2284 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2285 SVp_POK|SVp_NOK)) &&
2286 SvCUR(sv) == 1 &&
2287 SvPVX(sv) && *SvPVX(sv) == '1' &&
2288 SvNVX(sv) == 1.0)
2289 goto finish;
2290 }
2291 else {
2292 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2293 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2294 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2295 SvREADONLY(sv))
2296 goto finish;
2297 }
2298 sv_catpv(t, " XXX=\"\" ");
2299 }
2300 else if (SvREFCNT(sv) == 0) {
2301 sv_catpv(t, " refcnt=\"0\"");
2302 unref++;
2303 }
2304 else if (DEBUG_R_TEST_) {
2305 int is_tmp = 0;
2306 I32 ix;
2307 /* is this SV on the tmps stack? */
2308 for (ix=PL_tmps_ix; ix>=0; ix--) {
2309 if (PL_tmps_stack[ix] == sv) {
2310 is_tmp = 1;
2311 break;
2312 }
2313 }
2314 if (SvREFCNT(sv) > 1)
2315 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2316 is_tmp ? "T" : "");
2317 else if (is_tmp)
2318 sv_catpv(t, " DRT=\"<T>\"");
2319 }
2320
2321 if (SvROK(sv)) {
2322 sv_catpv(t, " ROK=\"\"");
2323 }
2324 switch (SvTYPE(sv)) {
2325 default:
2326 sv_catpv(t, " FREED=\"1\"");
2327 goto finish;
2328
2329 case SVt_NULL:
2330 sv_catpv(t, " UNDEF=\"1\"");
2331 goto finish;
2332 case SVt_IV:
2333 sv_catpv(t, " IV=\"");
2334 break;
2335 case SVt_NV:
2336 sv_catpv(t, " NV=\"");
2337 break;
2338 case SVt_RV:
2339 sv_catpv(t, " RV=\"");
2340 break;
2341 case SVt_PV:
2342 sv_catpv(t, " PV=\"");
2343 break;
2344 case SVt_PVIV:
2345 sv_catpv(t, " PVIV=\"");
2346 break;
2347 case SVt_PVNV:
2348 sv_catpv(t, " PVNV=\"");
2349 break;
2350 case SVt_PVMG:
2351 sv_catpv(t, " PVMG=\"");
2352 break;
2353 case SVt_PVLV:
2354 sv_catpv(t, " PVLV=\"");
2355 break;
2356 case SVt_PVAV:
2357 sv_catpv(t, " AV=\"");
2358 break;
2359 case SVt_PVHV:
2360 sv_catpv(t, " HV=\"");
2361 break;
2362 case SVt_PVCV:
2363 if (CvGV(sv))
2364 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2365 else
2366 sv_catpv(t, " CV=\"()\"");
2367 goto finish;
2368 case SVt_PVGV:
2369 sv_catpv(t, " GV=\"");
2370 break;
cecf5685 2371 case SVt_BIND:
2372 sv_catpv(t, " BIND=\"");
3b721df9 2373 break;
2374 case SVt_PVFM:
2375 sv_catpv(t, " FM=\"");
2376 break;
2377 case SVt_PVIO:
2378 sv_catpv(t, " IO=\"");
2379 break;
2380 }
2381
2382 if (SvPOKp(sv)) {
2383 if (SvPVX(sv)) {
2384 sv_catxmlsv(t, sv);
2385 }
2386 }
2387 else if (SvNOKp(sv)) {
2388 STORE_NUMERIC_LOCAL_SET_STANDARD();
2389 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2390 RESTORE_NUMERIC_LOCAL();
2391 }
2392 else if (SvIOKp(sv)) {
2393 if (SvIsUV(sv))
2394 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2395 else
2396 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2397 }
2398 else
2399 sv_catpv(t, "");
2400 sv_catpv(t, "\"");
2401
2402 finish:
2403 if (unref) {
2404 while (unref--)
2405 sv_catpv(t, ")");
2406 }
2407 return SvPV(t, n_a);
2408}
2409
2410void
2411Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2412{
2413 if (!pm) {
2414 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2415 return;
2416 }
2417 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2418 level++;
2419 if (PM_GETRE(pm)) {
2420 char *s = PM_GETRE(pm)->precomp;
29522234 2421 SV *tmpsv = newSVpvn("",0);
3b721df9 2422 SvUTF8_on(tmpsv);
2423 sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2424 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2425 SvPVX(tmpsv));
2426 SvREFCNT_dec(tmpsv);
2427 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2428 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2429 }
2430 else
2431 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2432 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
3df43ef7 2433 SV * const tmpsv = pm_description(pm);
3b721df9 2434 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2435 SvREFCNT_dec(tmpsv);
2436 }
2437
2438 level--;
2439 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
2440 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2441 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2442 do_op_xmldump(level+2, file, pm->op_pmreplroot);
2443 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2444 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2445 }
2446 else
2447 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2448}
2449
2450void
2451Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2452{
2453 do_pmop_xmldump(0, PL_xmlfp, pm);
2454}
2455
2456void
2457Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2458{
2459 UV seq;
2460 int contents = 0;
2461 if (!o)
2462 return;
2463 sequence(o);
2464 seq = sequence_num(o);
2465 Perl_xmldump_indent(aTHX_ level, file,
2466 "<op_%s seq=\"%"UVuf" -> ",
2467 OP_NAME(o),
2468 seq);
2469 level++;
2470 if (o->op_next)
2471 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2472 sequence_num(o->op_next));
2473 else
2474 PerlIO_printf(file, "DONE\"");
2475
2476 if (o->op_targ) {
2477 if (o->op_type == OP_NULL)
2478 {
2479 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2480 if (o->op_targ == OP_NEXTSTATE)
2481 {
2482 if (CopLINE(cCOPo))
f5992bc4 2483 PerlIO_printf(file, " line=\"%"UVuf"\"",
3b721df9 2484 (UV)CopLINE(cCOPo));
2485 if (CopSTASHPV(cCOPo))
2486 PerlIO_printf(file, " package=\"%s\"",
2487 CopSTASHPV(cCOPo));
2488 if (cCOPo->cop_label)
2489 PerlIO_printf(file, " label=\"%s\"",
2490 cCOPo->cop_label);
2491 }
2492 }
2493 else
2494 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2495 }
2496#ifdef DUMPADDR
2497 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2498#endif
2499 if (o->op_flags) {
2500 SV *tmpsv = newSVpvn("", 0);
2501 switch (o->op_flags & OPf_WANT) {
2502 case OPf_WANT_VOID:
2503 sv_catpv(tmpsv, ",VOID");
2504 break;
2505 case OPf_WANT_SCALAR:
2506 sv_catpv(tmpsv, ",SCALAR");
2507 break;
2508 case OPf_WANT_LIST:
2509 sv_catpv(tmpsv, ",LIST");
2510 break;
2511 default:
2512 sv_catpv(tmpsv, ",UNKNOWN");
2513 break;
2514 }
2515 if (o->op_flags & OPf_KIDS)
2516 sv_catpv(tmpsv, ",KIDS");
2517 if (o->op_flags & OPf_PARENS)
2518 sv_catpv(tmpsv, ",PARENS");
2519 if (o->op_flags & OPf_STACKED)
2520 sv_catpv(tmpsv, ",STACKED");
2521 if (o->op_flags & OPf_REF)
2522 sv_catpv(tmpsv, ",REF");
2523 if (o->op_flags & OPf_MOD)
2524 sv_catpv(tmpsv, ",MOD");
2525 if (o->op_flags & OPf_SPECIAL)
2526 sv_catpv(tmpsv, ",SPECIAL");
2527 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2528 SvREFCNT_dec(tmpsv);
2529 }
2530 if (o->op_private) {
2531 SV *tmpsv = newSVpvn("", 0);
2532 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2533 if (o->op_private & OPpTARGET_MY)
2534 sv_catpv(tmpsv, ",TARGET_MY");
2535 }
2536 else if (o->op_type == OP_LEAVESUB ||
2537 o->op_type == OP_LEAVE ||
2538 o->op_type == OP_LEAVESUBLV ||
2539 o->op_type == OP_LEAVEWRITE) {
2540 if (o->op_private & OPpREFCOUNTED)
2541 sv_catpv(tmpsv, ",REFCOUNTED");
2542 }
2543 else if (o->op_type == OP_AASSIGN) {
2544 if (o->op_private & OPpASSIGN_COMMON)
2545 sv_catpv(tmpsv, ",COMMON");
2546 }
2547 else if (o->op_type == OP_SASSIGN) {
2548 if (o->op_private & OPpASSIGN_BACKWARDS)
2549 sv_catpv(tmpsv, ",BACKWARDS");
2550 }
2551 else if (o->op_type == OP_TRANS) {
2552 if (o->op_private & OPpTRANS_SQUASH)
2553 sv_catpv(tmpsv, ",SQUASH");
2554 if (o->op_private & OPpTRANS_DELETE)
2555 sv_catpv(tmpsv, ",DELETE");
2556 if (o->op_private & OPpTRANS_COMPLEMENT)
2557 sv_catpv(tmpsv, ",COMPLEMENT");
2558 if (o->op_private & OPpTRANS_IDENTICAL)
2559 sv_catpv(tmpsv, ",IDENTICAL");
2560 if (o->op_private & OPpTRANS_GROWS)
2561 sv_catpv(tmpsv, ",GROWS");
2562 }
2563 else if (o->op_type == OP_REPEAT) {
2564 if (o->op_private & OPpREPEAT_DOLIST)
2565 sv_catpv(tmpsv, ",DOLIST");
2566 }
2567 else if (o->op_type == OP_ENTERSUB ||
2568 o->op_type == OP_RV2SV ||
2569 o->op_type == OP_GVSV ||
2570 o->op_type == OP_RV2AV ||
2571 o->op_type == OP_RV2HV ||
2572 o->op_type == OP_RV2GV ||
2573 o->op_type == OP_AELEM ||
2574 o->op_type == OP_HELEM )
2575 {
2576 if (o->op_type == OP_ENTERSUB) {
2577 if (o->op_private & OPpENTERSUB_AMPER)
2578 sv_catpv(tmpsv, ",AMPER");
2579 if (o->op_private & OPpENTERSUB_DB)
2580 sv_catpv(tmpsv, ",DB");
2581 if (o->op_private & OPpENTERSUB_HASTARG)
2582 sv_catpv(tmpsv, ",HASTARG");
2583 if (o->op_private & OPpENTERSUB_NOPAREN)
2584 sv_catpv(tmpsv, ",NOPAREN");
2585 if (o->op_private & OPpENTERSUB_INARGS)
2586 sv_catpv(tmpsv, ",INARGS");
2587 if (o->op_private & OPpENTERSUB_NOMOD)
2588 sv_catpv(tmpsv, ",NOMOD");
2589 }
2590 else {
2591 switch (o->op_private & OPpDEREF) {
2592 case OPpDEREF_SV:
2593 sv_catpv(tmpsv, ",SV");
2594 break;
2595 case OPpDEREF_AV:
2596 sv_catpv(tmpsv, ",AV");
2597 break;
2598 case OPpDEREF_HV:
2599 sv_catpv(tmpsv, ",HV");
2600 break;
2601 }
2602 if (o->op_private & OPpMAYBE_LVSUB)
2603 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2604 }
2605 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2606 if (o->op_private & OPpLVAL_DEFER)
2607 sv_catpv(tmpsv, ",LVAL_DEFER");
2608 }
2609 else {
2610 if (o->op_private & HINT_STRICT_REFS)
2611 sv_catpv(tmpsv, ",STRICT_REFS");
2612 if (o->op_private & OPpOUR_INTRO)
2613 sv_catpv(tmpsv, ",OUR_INTRO");
2614 }
2615 }
2616 else if (o->op_type == OP_CONST) {
2617 if (o->op_private & OPpCONST_BARE)
2618 sv_catpv(tmpsv, ",BARE");
2619 if (o->op_private & OPpCONST_STRICT)
2620 sv_catpv(tmpsv, ",STRICT");
2621 if (o->op_private & OPpCONST_ARYBASE)
2622 sv_catpv(tmpsv, ",ARYBASE");
2623 if (o->op_private & OPpCONST_WARNING)
2624 sv_catpv(tmpsv, ",WARNING");
2625 if (o->op_private & OPpCONST_ENTERED)
2626 sv_catpv(tmpsv, ",ENTERED");
2627 }
2628 else if (o->op_type == OP_FLIP) {
2629 if (o->op_private & OPpFLIP_LINENUM)
2630 sv_catpv(tmpsv, ",LINENUM");
2631 }
2632 else if (o->op_type == OP_FLOP) {
2633 if (o->op_private & OPpFLIP_LINENUM)
2634 sv_catpv(tmpsv, ",LINENUM");
2635 }
2636 else if (o->op_type == OP_RV2CV) {
2637 if (o->op_private & OPpLVAL_INTRO)
2638 sv_catpv(tmpsv, ",INTRO");
2639 }
2640 else if (o->op_type == OP_GV) {
2641 if (o->op_private & OPpEARLY_CV)
2642 sv_catpv(tmpsv, ",EARLY_CV");
2643 }
2644 else if (o->op_type == OP_LIST) {
2645 if (o->op_private & OPpLIST_GUESSED)
2646 sv_catpv(tmpsv, ",GUESSED");
2647 }
2648 else if (o->op_type == OP_DELETE) {
2649 if (o->op_private & OPpSLICE)
2650 sv_catpv(tmpsv, ",SLICE");
2651 }
2652 else if (o->op_type == OP_EXISTS) {
2653 if (o->op_private & OPpEXISTS_SUB)
2654 sv_catpv(tmpsv, ",EXISTS_SUB");
2655 }
2656 else if (o->op_type == OP_SORT) {
2657 if (o->op_private & OPpSORT_NUMERIC)
2658 sv_catpv(tmpsv, ",NUMERIC");
2659 if (o->op_private & OPpSORT_INTEGER)
2660 sv_catpv(tmpsv, ",INTEGER");
2661 if (o->op_private & OPpSORT_REVERSE)
2662 sv_catpv(tmpsv, ",REVERSE");
2663 }
3b721df9 2664 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2665 if (o->op_private & OPpOPEN_IN_RAW)
2666 sv_catpv(tmpsv, ",IN_RAW");
2667 if (o->op_private & OPpOPEN_IN_CRLF)
2668 sv_catpv(tmpsv, ",IN_CRLF");
2669 if (o->op_private & OPpOPEN_OUT_RAW)
2670 sv_catpv(tmpsv, ",OUT_RAW");
2671 if (o->op_private & OPpOPEN_OUT_CRLF)
2672 sv_catpv(tmpsv, ",OUT_CRLF");
2673 }
2674 else if (o->op_type == OP_EXIT) {
2675 if (o->op_private & OPpEXIT_VMSISH)
2676 sv_catpv(tmpsv, ",EXIT_VMSISH");
2677 if (o->op_private & OPpHUSH_VMSISH)
2678 sv_catpv(tmpsv, ",HUSH_VMSISH");
2679 }
2680 else if (o->op_type == OP_DIE) {
2681 if (o->op_private & OPpHUSH_VMSISH)
2682 sv_catpv(tmpsv, ",HUSH_VMSISH");
2683 }
2684 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2685 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2686 sv_catpv(tmpsv, ",FT_ACCESS");
2687 if (o->op_private & OPpFT_STACKED)
2688 sv_catpv(tmpsv, ",FT_STACKED");
2689 }
2690 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2691 sv_catpv(tmpsv, ",INTRO");
2692 if (SvCUR(tmpsv))
2693 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2694 SvREFCNT_dec(tmpsv);
2695 }
2696
2697 switch (o->op_type) {
2698 case OP_AELEMFAST:
2699 if (o->op_flags & OPf_SPECIAL) {
2700 break;
2701 }
2702 case OP_GVSV:
2703 case OP_GV:
2704#ifdef USE_ITHREADS
2705 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2706#else
2707 if (cSVOPo->op_sv) {
ef2570c4 2708 SV *tmpsv1 = newSV(0);
29522234 2709 SV *tmpsv2 = newSVpvn("",0);
3b721df9 2710 char *s;
2711 STRLEN len;
b123ab9d 2712 SvUTF8_on(tmpsv1);
2713 SvUTF8_on(tmpsv2);
3b721df9 2714 ENTER;
2715 SAVEFREESV(tmpsv1);
2716 SAVEFREESV(tmpsv2);
2717 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2718 s = SvPV(tmpsv1,len);
2719 sv_catxmlpvn(tmpsv2, s, len, 1);
2720 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2721 LEAVE;
2722 }
2723 else
2724 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2725#endif
2726 break;
2727 case OP_CONST:
2728 case OP_METHOD_NAMED:
2729#ifndef USE_ITHREADS
2730 /* with ITHREADS, consts are stored in the pad, and the right pad
2731 * may not be active here, so skip */
2732 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2733#endif
2734 break;
2735 case OP_ANONCODE:
2736 if (!contents) {
2737 contents = 1;
2738 PerlIO_printf(file, ">\n");
2739 }
2740 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2741 break;
2742 case OP_SETSTATE:
2743 case OP_NEXTSTATE:
2744 case OP_DBSTATE:
2745 if (CopLINE(cCOPo))
f5992bc4 2746 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3b721df9 2747 (UV)CopLINE(cCOPo));
2748 if (CopSTASHPV(cCOPo))
2749 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2750 CopSTASHPV(cCOPo));
2751 if (cCOPo->cop_label)
2752 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2753 cCOPo->cop_label);
2754 break;
2755 case OP_ENTERLOOP:
2756 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2757 if (cLOOPo->op_redoop)
2758 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2759 else
2760 PerlIO_printf(file, "DONE\"");
2761 S_xmldump_attr(aTHX_ level, file, "next=\"");
2762 if (cLOOPo->op_nextop)
2763 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2764 else
2765 PerlIO_printf(file, "DONE\"");
2766 S_xmldump_attr(aTHX_ level, file, "last=\"");
2767 if (cLOOPo->op_lastop)
2768 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2769 else
2770 PerlIO_printf(file, "DONE\"");
2771 break;
2772 case OP_COND_EXPR:
2773 case OP_RANGE:
2774 case OP_MAPWHILE:
2775 case OP_GREPWHILE:
2776 case OP_OR:
2777 case OP_AND:
2778 S_xmldump_attr(aTHX_ level, file, "other=\"");
2779 if (cLOGOPo->op_other)
2780 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2781 else
2782 PerlIO_printf(file, "DONE\"");
2783 break;
2784 case OP_LEAVE:
2785 case OP_LEAVEEVAL:
2786 case OP_LEAVESUB:
2787 case OP_LEAVESUBLV:
2788 case OP_LEAVEWRITE:
2789 case OP_SCOPE:
2790 if (o->op_private & OPpREFCOUNTED)
2791 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2792 break;
2793 default:
2794 break;
2795 }
2796
2797 if (PL_madskills && o->op_madprop) {
2798 SV *tmpsv = newSVpvn("", 0);
2799 MADPROP* mp = o->op_madprop;
2800 sv_utf8_upgrade(tmpsv);
2801 if (!contents) {
2802 contents = 1;
2803 PerlIO_printf(file, ">\n");
2804 }
2805 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2806 level++;
2807 while (mp) {
2808 char tmp = mp->mad_key;
2809 sv_setpvn(tmpsv,"\"",1);
2810 if (tmp)
2811 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2812 sv_catpv(tmpsv, "\"");
2813 switch (mp->mad_type) {
2814 case MAD_NULL:
2815 sv_catpv(tmpsv, "NULL");
2816 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2817 break;
2818 case MAD_PV:
2819 sv_catpv(tmpsv, " val=\"");
2820 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2821 sv_catpv(tmpsv, "\"");
2822 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2823 break;
2824 case MAD_SV:
2825 sv_catpv(tmpsv, " val=\"");
2826 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2827 sv_catpv(tmpsv, "\"");
2828 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2829 break;
2830 case MAD_OP:
2831 if ((OP*)mp->mad_val) {
2832 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2833 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2834 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2835 }
2836 break;
2837 default:
2838 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2839 break;
2840 }
2841 mp = mp->mad_next;
2842 }
2843 level--;
2844 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2845
2846 SvREFCNT_dec(tmpsv);
2847 }
2848
2849 switch (o->op_type) {
2850 case OP_PUSHRE:
2851 case OP_MATCH:
2852 case OP_QR:
2853 case OP_SUBST:
2854 if (!contents) {
2855 contents = 1;
2856 PerlIO_printf(file, ">\n");
2857 }
2858 do_pmop_xmldump(level, file, cPMOPo);
2859 break;
2860 default:
2861 break;
2862 }
2863
2864 if (o->op_flags & OPf_KIDS) {
2865 OP *kid;
2866 if (!contents) {
2867 contents = 1;
2868 PerlIO_printf(file, ">\n");
2869 }
2870 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2871 do_op_xmldump(level, file, kid);
2872 }
2873
2874 if (contents)
2875 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2876 else
2877 PerlIO_printf(file, " />\n");
2878}
2879
2880void
2881Perl_op_xmldump(pTHX_ const OP *o)
2882{
2883 do_op_xmldump(0, PL_xmlfp, o);
2884}
2885#endif
2886
66610fdd 2887/*
2888 * Local variables:
2889 * c-indentation-style: bsd
2890 * c-basic-offset: 4
2891 * indent-tabs-mode: t
2892 * End:
2893 *
37442d52 2894 * ex: set ts=8 sts=4 sw=4 noet:
2895 */
Unnamed repository; edit this file to name it for gitweb.