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