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