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