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