This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix pointer casts.
[perl5.git] / dump.c
1 /*    dump.c
2  *
3  *    Copyright (c) 1991-1999, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
12  * it has not been hard for me to read your mind and memory.'"
13  */
14
15 #include "EXTERN.h"
16 #define PERL_IN_DUMP_C
17 #include "perl.h"
18 #include "regcomp.h"
19
20 void
21 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
22 {
23     va_list args;
24     va_start(args, pat);
25     dump_vindent(level, file, pat, &args);
26     va_end(args);
27 }
28
29 void
30 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
31 {
32     dTHR;
33     PerlIO_printf(file, "%*s", level*PL_dumpindent, "");
34     PerlIO_vprintf(file, pat, *args);
35 }
36
37 void
38 Perl_dump_all(pTHX)
39 {
40     dTHR;
41     PerlIO_setlinebuf(Perl_debug_log);
42     if (PL_main_root)
43         op_dump(PL_main_root);
44     dump_packsubs(PL_defstash);
45 }
46
47 void
48 Perl_dump_packsubs(pTHX_ HV *stash)
49 {
50     dTHR;
51     I32 i;
52     HE  *entry;
53
54     if (!HvARRAY(stash))
55         return;
56     for (i = 0; i <= (I32) HvMAX(stash); i++) {
57         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
58             GV *gv = (GV*)HeVAL(entry);
59             HV *hv;
60             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
61                 continue;
62             if (GvCVu(gv))
63                 dump_sub(gv);
64             if (GvFORM(gv))
65                 dump_form(gv);
66             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
67               (hv = GvHV(gv)) && HvNAME(hv) && hv != PL_defstash)
68                 dump_packsubs(hv);              /* nested package */
69         }
70     }
71 }
72
73 void
74 Perl_dump_sub(pTHX_ GV *gv)
75 {
76     SV *sv = sv_newmortal();
77
78     gv_fullname3(sv, gv, Nullch);
79     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX(sv));
80     if (CvXSUB(GvCV(gv)))
81         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%x %d)\n",
82             (long)CvXSUB(GvCV(gv)),
83             CvXSUBANY(GvCV(gv)).any_i32);
84     else if (CvROOT(GvCV(gv)))
85         op_dump(CvROOT(GvCV(gv)));
86     else
87         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
88 }
89
90 void
91 Perl_dump_form(pTHX_ GV *gv)
92 {
93     SV *sv = sv_newmortal();
94
95     gv_fullname3(sv, gv, Nullch);
96     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX(sv));
97     if (CvROOT(GvFORM(gv)))
98         op_dump(CvROOT(GvFORM(gv)));
99     else
100         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
101 }
102
103 void
104 Perl_dump_eval(pTHX)
105 {
106     op_dump(PL_eval_root);
107 }
108
109 char *
110 Perl_pv_display(pTHX_ SV *sv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
111 {
112     int truncated = 0;
113     int nul_terminated = len > cur && pv[cur] == '\0';
114
115     sv_setpvn(sv, "\"", 1);
116     for (; cur--; pv++) {
117         if (pvlim && SvCUR(sv) >= pvlim) {
118             truncated++;
119             break;
120         }
121         if (isPRINT(*pv)) {
122             switch (*pv) {
123             case '\t': sv_catpvn(sv, "\\t", 2);  break;
124             case '\n': sv_catpvn(sv, "\\n", 2);  break;
125             case '\r': sv_catpvn(sv, "\\r", 2);  break;
126             case '\f': sv_catpvn(sv, "\\f", 2);  break;
127             case '"':  sv_catpvn(sv, "\\\"", 2); break;
128             case '\\': sv_catpvn(sv, "\\\\", 2); break;
129             default:   sv_catpvn(sv, pv, 1);     break;
130             }
131         }
132         else {
133             if (cur && isDIGIT(*(pv+1)))
134                 Perl_sv_catpvf(aTHX_ sv, "\\%03o", *pv);
135             else
136                 Perl_sv_catpvf(aTHX_ sv, "\\%o", *pv);
137         }
138     }
139     sv_catpvn(sv, "\"", 1);
140     if (truncated)
141         sv_catpvn(sv, "...", 3);
142     if (nul_terminated)
143         sv_catpvn(sv, "\\0", 2);
144
145     return SvPVX(sv);
146 }
147
148 char *
149 Perl_sv_peek(pTHX_ SV *sv)
150 {
151     SV *t = sv_newmortal();
152     STRLEN n_a;
153     int unref = 0;
154
155     sv_setpvn(t, "", 0);
156   retry:
157     if (!sv) {
158         sv_catpv(t, "VOID");
159         goto finish;
160     }
161     else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
162         sv_catpv(t, "WILD");
163         goto finish;
164     }
165     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes) {
166         if (sv == &PL_sv_undef) {
167             sv_catpv(t, "SV_UNDEF");
168             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
169                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
170                 SvREADONLY(sv))
171                 goto finish;
172         }
173         else if (sv == &PL_sv_no) {
174             sv_catpv(t, "SV_NO");
175             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
176                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
177                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
178                                   SVp_POK|SVp_NOK)) &&
179                 SvCUR(sv) == 0 &&
180                 SvNVX(sv) == 0.0)
181                 goto finish;
182         }
183         else {
184             sv_catpv(t, "SV_YES");
185             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
186                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
187                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
188                                   SVp_POK|SVp_NOK)) &&
189                 SvCUR(sv) == 1 &&
190                 SvPVX(sv) && *SvPVX(sv) == '1' &&
191                 SvNVX(sv) == 1.0)
192                 goto finish;
193         }
194         sv_catpv(t, ":");
195     }
196     else if (SvREFCNT(sv) == 0) {
197         sv_catpv(t, "(");
198         unref++;
199     }
200     if (SvROK(sv)) {
201         sv_catpv(t, "\\");
202         if (SvCUR(t) + unref > 10) {
203             SvCUR(t) = unref + 3;
204             *SvEND(t) = '\0';
205             sv_catpv(t, "...");
206             goto finish;
207         }
208         sv = (SV*)SvRV(sv);
209         goto retry;
210     }
211     switch (SvTYPE(sv)) {
212     default:
213         sv_catpv(t, "FREED");
214         goto finish;
215
216     case SVt_NULL:
217         sv_catpv(t, "UNDEF");
218         goto finish;
219     case SVt_IV:
220         sv_catpv(t, "IV");
221         break;
222     case SVt_NV:
223         sv_catpv(t, "NV");
224         break;
225     case SVt_RV:
226         sv_catpv(t, "RV");
227         break;
228     case SVt_PV:
229         sv_catpv(t, "PV");
230         break;
231     case SVt_PVIV:
232         sv_catpv(t, "PVIV");
233         break;
234     case SVt_PVNV:
235         sv_catpv(t, "PVNV");
236         break;
237     case SVt_PVMG:
238         sv_catpv(t, "PVMG");
239         break;
240     case SVt_PVLV:
241         sv_catpv(t, "PVLV");
242         break;
243     case SVt_PVAV:
244         sv_catpv(t, "AV");
245         break;
246     case SVt_PVHV:
247         sv_catpv(t, "HV");
248         break;
249     case SVt_PVCV:
250         if (CvGV(sv))
251             Perl_sv_catpvf(aTHX_ t, "CV(%s)", GvNAME(CvGV(sv)));
252         else
253             sv_catpv(t, "CV()");
254         goto finish;
255     case SVt_PVGV:
256         sv_catpv(t, "GV");
257         break;
258     case SVt_PVBM:
259         sv_catpv(t, "BM");
260         break;
261     case SVt_PVFM:
262         sv_catpv(t, "FM");
263         break;
264     case SVt_PVIO:
265         sv_catpv(t, "IO");
266         break;
267     }
268
269     if (SvPOKp(sv)) {
270         if (!SvPVX(sv))
271             sv_catpv(t, "(null)");
272         else {
273             SV *tmp = newSVpvn("", 0);
274             sv_catpv(t, "(");
275             if (SvOOK(sv))
276                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
277             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX(sv), SvCUR(sv), SvLEN(sv), 127));
278             SvREFCNT_dec(tmp);
279         }
280     }
281     else if (SvNOKp(sv)) {
282         RESTORE_NUMERIC_STANDARD();
283         Perl_sv_catpvf(aTHX_ t, "(%g)",SvNVX(sv));
284         RESTORE_NUMERIC_LOCAL();
285     }
286     else if (SvIOKp(sv)) {              /* XXXX: IV, UV? */
287 #ifdef IV_IS_QUAD
288         if (SvIsUV(sv))
289             Perl_sv_catpvf(aTHX_ t, "(%" PERL_PRIu64 ")",(UV)SvUVX(sv));
290         else
291             Perl_sv_catpvf(aTHX_ t, "(%" PERL_PRId64 ")",(IV)SvIVX(sv));
292 #else
293         if (SvIsUV(sv))
294             Perl_sv_catpvf(aTHX_ t, "(%lu)",(unsigned long)SvUVX(sv));
295         else
296             Perl_sv_catpvf(aTHX_ t, "(%ld)",(long)SvIVX(sv));
297 #endif
298     }
299     else
300         sv_catpv(t, "()");
301     
302   finish:
303     if (unref) {
304         while (unref--)
305             sv_catpv(t, ")");
306     }
307     return SvPV(t, n_a);
308 }
309
310 void
311 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm)
312 {
313     char ch;
314
315     if (!pm) {
316         Perl_dump_indent(aTHX_ level, file, "{}\n");
317         return;
318     }
319     Perl_dump_indent(aTHX_ level, file, "{\n");
320     level++;
321     if (pm->op_pmflags & PMf_ONCE)
322         ch = '?';
323     else
324         ch = '/';
325     if (pm->op_pmregexp)
326         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
327              ch, pm->op_pmregexp->precomp, ch,
328              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
329     else
330         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
331     if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
332         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
333         op_dump(pm->op_pmreplroot);
334     }
335     if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) {
336         SV *tmpsv = newSVpvn("", 0);
337         if (pm->op_pmdynflags & PMdf_USED)
338             sv_catpv(tmpsv, ",USED");
339         if (pm->op_pmdynflags & PMdf_TAINTED)
340             sv_catpv(tmpsv, ",TAINTED");
341         if (pm->op_pmflags & PMf_ONCE)
342             sv_catpv(tmpsv, ",ONCE");
343         if (pm->op_pmregexp && pm->op_pmregexp->check_substr
344             && !(pm->op_pmregexp->reganch & ROPT_NOSCAN))
345             sv_catpv(tmpsv, ",SCANFIRST");
346         if (pm->op_pmregexp && pm->op_pmregexp->check_substr
347             && pm->op_pmregexp->reganch & ROPT_CHECK_ALL)
348             sv_catpv(tmpsv, ",ALL");
349         if (pm->op_pmflags & PMf_SKIPWHITE)
350             sv_catpv(tmpsv, ",SKIPWHITE");
351         if (pm->op_pmflags & PMf_CONST)
352             sv_catpv(tmpsv, ",CONST");
353         if (pm->op_pmflags & PMf_KEEP)
354             sv_catpv(tmpsv, ",KEEP");
355         if (pm->op_pmflags & PMf_GLOBAL)
356             sv_catpv(tmpsv, ",GLOBAL");
357         if (pm->op_pmflags & PMf_CONTINUE)
358             sv_catpv(tmpsv, ",CONTINUE");
359         if (pm->op_pmflags & PMf_RETAINT)
360             sv_catpv(tmpsv, ",RETAINT");
361         if (pm->op_pmflags & PMf_EVAL)
362             sv_catpv(tmpsv, ",EVAL");
363         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
364         SvREFCNT_dec(tmpsv);
365     }
366
367     Perl_dump_indent(aTHX_ level-1, file, "}\n");
368 }
369
370 void
371 Perl_pmop_dump(pTHX_ PMOP *pm)
372 {
373     do_pmop_dump(0, Perl_debug_log, pm);
374 }
375
376 void
377 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
378 {
379     dTHR;
380     STRLEN n_a;
381     Perl_dump_indent(aTHX_ level, file, "{\n");
382     level++;
383     if (o->op_seq)
384         PerlIO_printf(file, "%-4d", o->op_seq);
385     else
386         PerlIO_printf(file, "    ");
387     PerlIO_printf(file, "%*sTYPE = %s  ===> ", PL_dumpindent*level-4, "", PL_op_name[o->op_type]);
388     if (o->op_next) {
389         if (o->op_seq)
390             PerlIO_printf(file, "%d\n", o->op_next->op_seq);
391         else
392             PerlIO_printf(file, "(%d)\n", o->op_next->op_seq);
393     }
394     else
395         PerlIO_printf(file, "DONE\n");
396     if (o->op_targ) {
397         if (o->op_type == OP_NULL)
398             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
399         else
400             Perl_dump_indent(aTHX_ level, file, "TARG = %d\n", o->op_targ);
401     }
402 #ifdef DUMPADDR
403 #ifdef IV_IS_QUAD
404     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%" PERL_PRIx64 " => 0x%" PERL_PRIx64 "\n", (IV)o, (IV)o->op_next);
405 #else
406     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%lx => 0x%lx\n", (long)o, (long)o->op_next);
407 #endif
408 #endif
409     if (o->op_flags) {
410         SV *tmpsv = newSVpvn("", 0);
411         switch (o->op_flags & OPf_WANT) {
412         case OPf_WANT_VOID:
413             sv_catpv(tmpsv, ",VOID");
414             break;
415         case OPf_WANT_SCALAR:
416             sv_catpv(tmpsv, ",SCALAR");
417             break;
418         case OPf_WANT_LIST:
419             sv_catpv(tmpsv, ",LIST");
420             break;
421         default:
422             sv_catpv(tmpsv, ",UNKNOWN");
423             break;
424         }
425         if (o->op_flags & OPf_KIDS)
426             sv_catpv(tmpsv, ",KIDS");
427         if (o->op_flags & OPf_PARENS)
428             sv_catpv(tmpsv, ",PARENS");
429         if (o->op_flags & OPf_STACKED)
430             sv_catpv(tmpsv, ",STACKED");
431         if (o->op_flags & OPf_REF)
432             sv_catpv(tmpsv, ",REF");
433         if (o->op_flags & OPf_MOD)
434             sv_catpv(tmpsv, ",MOD");
435         if (o->op_flags & OPf_SPECIAL)
436             sv_catpv(tmpsv, ",SPECIAL");
437         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
438         SvREFCNT_dec(tmpsv);
439     }
440     if (o->op_private) {
441         SV *tmpsv = newSVpvn("", 0);
442         if (o->op_type == OP_AASSIGN) {
443             if (o->op_private & OPpASSIGN_COMMON)
444                 sv_catpv(tmpsv, ",COMMON");
445         }
446         else if (o->op_type == OP_SASSIGN) {
447             if (o->op_private & OPpASSIGN_BACKWARDS)
448                 sv_catpv(tmpsv, ",BACKWARDS");
449         }
450         else if (o->op_type == OP_TRANS) {
451             if (o->op_private & OPpTRANS_SQUASH)
452                 sv_catpv(tmpsv, ",SQUASH");
453             if (o->op_private & OPpTRANS_DELETE)
454                 sv_catpv(tmpsv, ",DELETE");
455             if (o->op_private & OPpTRANS_COMPLEMENT)
456                 sv_catpv(tmpsv, ",COMPLEMENT");
457         }
458         else if (o->op_type == OP_REPEAT) {
459             if (o->op_private & OPpREPEAT_DOLIST)
460                 sv_catpv(tmpsv, ",DOLIST");
461         }
462         else if (o->op_type == OP_ENTERSUB ||
463                  o->op_type == OP_RV2SV ||
464                  o->op_type == OP_RV2AV ||
465                  o->op_type == OP_RV2HV ||
466                  o->op_type == OP_RV2GV ||
467                  o->op_type == OP_AELEM ||
468                  o->op_type == OP_HELEM )
469         {
470             if (o->op_type == OP_ENTERSUB) {
471                 if (o->op_private & OPpENTERSUB_AMPER)
472                     sv_catpv(tmpsv, ",AMPER");
473                 if (o->op_private & OPpENTERSUB_DB)
474                     sv_catpv(tmpsv, ",DB");
475                 if (o->op_private & OPpENTERSUB_HASTARG)
476                     sv_catpv(tmpsv, ",HASTARG");
477             }
478             else 
479                 switch (o->op_private & OPpDEREF) {
480             case OPpDEREF_SV:
481                 sv_catpv(tmpsv, ",SV");
482                 break;
483             case OPpDEREF_AV:
484                 sv_catpv(tmpsv, ",AV");
485                 break;
486             case OPpDEREF_HV:
487                 sv_catpv(tmpsv, ",HV");
488                 break;
489             }
490             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
491                 if (o->op_private & OPpLVAL_DEFER)
492                     sv_catpv(tmpsv, ",LVAL_DEFER");
493             }
494             else {
495                 if (o->op_private & HINT_STRICT_REFS)
496                     sv_catpv(tmpsv, ",STRICT_REFS");
497             }
498         }
499         else if (o->op_type == OP_CONST) {
500             if (o->op_private & OPpCONST_BARE)
501                 sv_catpv(tmpsv, ",BARE");
502             if (o->op_private & OPpCONST_STRICT)
503                 sv_catpv(tmpsv, ",STRICT");
504         }
505         else if (o->op_type == OP_FLIP) {
506             if (o->op_private & OPpFLIP_LINENUM)
507                 sv_catpv(tmpsv, ",LINENUM");
508         }
509         else if (o->op_type == OP_FLOP) {
510             if (o->op_private & OPpFLIP_LINENUM)
511                 sv_catpv(tmpsv, ",LINENUM");
512         } else if (o->op_type == OP_RV2CV) {
513             if (o->op_private & OPpLVAL_INTRO)
514                 sv_catpv(tmpsv, ",INTRO");
515         }
516         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
517             sv_catpv(tmpsv, ",INTRO");
518         if (SvCUR(tmpsv))
519             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX(tmpsv) + 1);
520         SvREFCNT_dec(tmpsv);
521     }
522
523     switch (o->op_type) {
524     case OP_GVSV:
525     case OP_GV:
526         if (cGVOPo->op_gv) {
527             SV *tmpsv = NEWSV(0,0);
528             ENTER;
529             SAVEFREESV(tmpsv);
530             gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch);
531             Perl_dump_indent(aTHX_ level, file, "GV = %s\n", SvPV(tmpsv, n_a));
532             LEAVE;
533         }
534         else
535             Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
536         break;
537     case OP_CONST:
538     case OP_METHOD_NAMED:
539         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo->op_sv));
540         break;
541     case OP_SETSTATE:
542     case OP_NEXTSTATE:
543     case OP_DBSTATE:
544         if (cCOPo->cop_line)
545             Perl_dump_indent(aTHX_ level, file, "LINE = %d\n",cCOPo->cop_line);
546         if (cCOPo->cop_label)
547             Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",cCOPo->cop_label);
548         break;
549     case OP_ENTERLOOP:
550         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
551         if (cLOOPo->op_redoop)
552             PerlIO_printf(file, "%d\n", cLOOPo->op_redoop->op_seq);
553         else
554             PerlIO_printf(file, "DONE\n");
555         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
556         if (cLOOPo->op_nextop)
557             PerlIO_printf(file, "%d\n", cLOOPo->op_nextop->op_seq);
558         else
559             PerlIO_printf(file, "DONE\n");
560         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
561         if (cLOOPo->op_lastop)
562             PerlIO_printf(file, "%d\n", cLOOPo->op_lastop->op_seq);
563         else
564             PerlIO_printf(file, "DONE\n");
565         break;
566     case OP_COND_EXPR:
567     case OP_RANGE:
568     case OP_MAPWHILE:
569     case OP_GREPWHILE:
570     case OP_OR:
571     case OP_AND:
572         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
573         if (cLOGOPo->op_other)
574             PerlIO_printf(file, "%d\n", cLOGOPo->op_other->op_seq);
575         else
576             PerlIO_printf(file, "DONE\n");
577         break;
578     case OP_PUSHRE:
579     case OP_MATCH:
580     case OP_QR:
581     case OP_SUBST:
582         do_pmop_dump(level, file, cPMOPo);
583         break;
584     default:
585         break;
586     }
587     if (o->op_flags & OPf_KIDS) {
588         OP *kid;
589         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
590             do_op_dump(level, file, kid);
591     }
592     Perl_dump_indent(aTHX_ level-1, file, "}\n");
593 }
594
595 void
596 Perl_op_dump(pTHX_ OP *o)
597 {
598     do_op_dump(0, Perl_debug_log, o);
599 }
600
601 void
602 Perl_gv_dump(pTHX_ GV *gv)
603 {
604     SV *sv;
605
606     if (!gv) {
607         PerlIO_printf(Perl_debug_log, "{}\n");
608         return;
609     }
610     sv = sv_newmortal();
611     PerlIO_printf(Perl_debug_log, "{\n");
612     gv_fullname3(sv, gv, Nullch);
613     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX(sv));
614     if (gv != GvEGV(gv)) {
615         gv_efullname3(sv, GvEGV(gv), Nullch);
616         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX(sv));
617     }
618     PerlIO_putc(Perl_debug_log, '\n');
619     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
620 }
621
622 void
623 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
624 {
625     for (; mg; mg = mg->mg_moremagic) {
626         Perl_dump_indent(aTHX_ level, file, "  MAGIC = 0x%lx\n", (long)mg);
627         if (mg->mg_virtual) {
628             MGVTBL *v = mg->mg_virtual;
629             char *s = 0;
630             if      (v == &PL_vtbl_sv)         s = "sv";
631             else if (v == &PL_vtbl_env)        s = "env";
632             else if (v == &PL_vtbl_envelem)    s = "envelem";
633             else if (v == &PL_vtbl_sig)        s = "sig";
634             else if (v == &PL_vtbl_sigelem)    s = "sigelem";
635             else if (v == &PL_vtbl_pack)       s = "pack";
636             else if (v == &PL_vtbl_packelem)   s = "packelem";
637             else if (v == &PL_vtbl_dbline)     s = "dbline";
638             else if (v == &PL_vtbl_isa)        s = "isa";
639             else if (v == &PL_vtbl_arylen)     s = "arylen";
640             else if (v == &PL_vtbl_glob)       s = "glob";
641             else if (v == &PL_vtbl_mglob)      s = "mglob";
642             else if (v == &PL_vtbl_nkeys)      s = "nkeys";
643             else if (v == &PL_vtbl_taint)      s = "taint";
644             else if (v == &PL_vtbl_substr)     s = "substr";
645             else if (v == &PL_vtbl_vec)        s = "vec";
646             else if (v == &PL_vtbl_pos)        s = "pos";
647             else if (v == &PL_vtbl_bm)         s = "bm";
648             else if (v == &PL_vtbl_fm)         s = "fm";
649             else if (v == &PL_vtbl_uvar)       s = "uvar";
650             else if (v == &PL_vtbl_defelem)    s = "defelem";
651 #ifdef USE_LOCALE_COLLATE
652             else if (v == &PL_vtbl_collxfrm)   s = "collxfrm";
653 #endif
654             else if (v == &PL_vtbl_amagic)     s = "amagic";
655             else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
656             else if (v == &PL_vtbl_backref)    s = "backref";
657             if (s)
658                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
659             else
660                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%lx\n", (long)v);
661         }
662         else
663             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
664
665         if (mg->mg_private)
666             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
667
668         if (isPRINT(mg->mg_type))
669             Perl_dump_indent(aTHX_ level, file, "    MG_TYPE = '%c'\n", mg->mg_type);
670         else
671             Perl_dump_indent(aTHX_ level, file, "    MG_TYPE = '\\%o'\n", mg->mg_type);
672
673         if (mg->mg_flags) {
674             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
675             if (mg->mg_flags & MGf_TAINTEDDIR)
676                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
677             if (mg->mg_flags & MGf_REFCOUNTED)
678                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
679             if (mg->mg_flags & MGf_GSKIP)
680                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
681             if (mg->mg_flags & MGf_MINMATCH)
682                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
683         }
684         if (mg->mg_obj) {
685             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%lx\n", (long)mg->mg_obj);
686             if (mg->mg_flags & MGf_REFCOUNTED)
687                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
688         }
689         if (mg->mg_len)
690             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %d\n", mg->mg_len);
691         if (mg->mg_ptr) {
692             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%lx", (long)mg->mg_ptr);
693             if (mg->mg_len >= 0) {
694                 SV *sv = newSVpvn("", 0);
695                 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
696                 SvREFCNT_dec(sv);
697             }
698             else if (mg->mg_len == HEf_SVKEY) {
699                 PerlIO_puts(file, " => HEf_SVKEY\n");
700                 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
701                 continue;
702             }
703             else
704                 PerlIO_puts(file, " ???? - please notify IZ");
705             PerlIO_putc(file, '\n');
706         }
707     }
708 }
709
710 void
711 Perl_magic_dump(pTHX_ MAGIC *mg)
712 {
713     do_magic_dump(0, Perl_debug_log, mg, 0, 0, 0, 0);
714 }
715
716 void
717 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, char *name, HV *sv)
718 {
719     Perl_dump_indent(aTHX_ level, file, "%s = 0x%lx", name, (long)sv);
720     if (sv && HvNAME(sv))
721         PerlIO_printf(file, "\t\"%s\"\n", HvNAME(sv));
722     else
723         PerlIO_putc(file, '\n');
724 }
725
726 void
727 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv)
728 {
729     Perl_dump_indent(aTHX_ level, file, "%s = 0x%lx", name, (long)sv);
730     if (sv && GvNAME(sv))
731         PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
732     else
733         PerlIO_putc(file, '\n');
734 }
735
736 void
737 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv)
738 {
739     Perl_dump_indent(aTHX_ level, file, "%s = 0x%lx", name, (long)sv);
740     if (sv && GvNAME(sv)) {
741         PerlIO_printf(file, "\t\"");
742         if (GvSTASH(sv) && HvNAME(GvSTASH(sv)))
743             PerlIO_printf(file, "%s\" :: \"", HvNAME(GvSTASH(sv)));
744         PerlIO_printf(file, "%s\"\n", GvNAME(sv));
745     }
746     else
747         PerlIO_putc(file, '\n');
748 }
749
750 void
751 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
752 {
753     dTHR;
754     SV *d = sv_newmortal();
755     char *s;
756     U32 flags;
757     U32 type;
758     STRLEN n_a;
759
760     if (!sv) {
761         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
762         return;
763     }
764     
765     flags = SvFLAGS(sv);
766     type = SvTYPE(sv);
767
768 #ifdef IV_IS_QUAD
769     Perl_sv_setpvf(aTHX_ d,
770                    "(0x%" PERL_PRIx64") at 0x%" PERL_PRIx64 "\n%*s  REFCNT = %" PERL_PRId64 "\n%*s  FLAGS = (",
771                    (UV)PTR_CAST SvANY(sv), (UV)PTR_CAST sv,
772                    PL_dumpindent*level, "", (IV)SvREFCNT(sv),
773                    PL_dumpindent*level, "");
774 #else
775     Perl_sv_setpvf(aTHX_ d,
776                    "(0x%lx) at 0x%lx\n%*s  REFCNT = %ld\n%*s  FLAGS = (",
777                    (unsigned long)SvANY(sv), (unsigned long)sv,
778                    PL_dumpindent*level, "", (long)SvREFCNT(sv),
779                    PL_dumpindent*level, "");
780 #endif
781
782     if (flags & SVs_PADBUSY)    sv_catpv(d, "PADBUSY,");
783     if (flags & SVs_PADTMP)     sv_catpv(d, "PADTMP,");
784     if (flags & SVs_PADMY)      sv_catpv(d, "PADMY,");
785     if (flags & SVs_TEMP)       sv_catpv(d, "TEMP,");
786     if (flags & SVs_OBJECT)     sv_catpv(d, "OBJECT,");
787     if (flags & SVs_GMG)        sv_catpv(d, "GMG,");
788     if (flags & SVs_SMG)        sv_catpv(d, "SMG,");
789     if (flags & SVs_RMG)        sv_catpv(d, "RMG,");
790
791     if (flags & SVf_IOK)        sv_catpv(d, "IOK,");
792     if (flags & SVf_NOK)        sv_catpv(d, "NOK,");
793     if (flags & SVf_POK)        sv_catpv(d, "POK,");
794     if (flags & SVf_ROK)  {     
795                                 sv_catpv(d, "ROK,");
796         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
797     }
798     if (flags & SVf_OOK)        sv_catpv(d, "OOK,");
799     if (flags & SVf_FAKE)       sv_catpv(d, "FAKE,");
800     if (flags & SVf_READONLY)   sv_catpv(d, "READONLY,");
801
802     if (flags & SVf_AMAGIC)     sv_catpv(d, "OVERLOAD,");
803     if (flags & SVp_IOK)        sv_catpv(d, "pIOK,");
804     if (flags & SVp_NOK)        sv_catpv(d, "pNOK,");
805     if (flags & SVp_POK)        sv_catpv(d, "pPOK,");
806     if (flags & SVp_SCREAM)     sv_catpv(d, "SCREAM,");
807
808     switch (type) {
809     case SVt_PVCV:
810     case SVt_PVFM:
811         if (CvANON(sv))         sv_catpv(d, "ANON,");
812         if (CvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
813         if (CvCLONE(sv))        sv_catpv(d, "CLONE,");
814         if (CvCLONED(sv))       sv_catpv(d, "CLONED,");
815         if (CvNODEBUG(sv))      sv_catpv(d, "NODEBUG,");
816         if (SvCOMPILED(sv))     sv_catpv(d, "COMPILED,");
817         break;
818     case SVt_PVHV:
819         if (HvSHAREKEYS(sv))    sv_catpv(d, "SHAREKEYS,");
820         if (HvLAZYDEL(sv))      sv_catpv(d, "LAZYDEL,");
821         break;
822     case SVt_PVGV:
823         if (GvINTRO(sv))        sv_catpv(d, "INTRO,");
824         if (GvMULTI(sv))        sv_catpv(d, "MULTI,");
825         if (GvASSUMECV(sv))     sv_catpv(d, "ASSUMECV,");
826         if (GvIMPORTED(sv)) {
827             sv_catpv(d, "IMPORT");
828             if (GvIMPORTED(sv) == GVf_IMPORTED)
829                 sv_catpv(d, "ALL,");
830             else {
831                 sv_catpv(d, "(");
832                 if (GvIMPORTED_SV(sv))  sv_catpv(d, " SV");
833                 if (GvIMPORTED_AV(sv))  sv_catpv(d, " AV");
834                 if (GvIMPORTED_HV(sv))  sv_catpv(d, " HV");
835                 if (GvIMPORTED_CV(sv))  sv_catpv(d, " CV");
836                 sv_catpv(d, " ),");
837             }
838         }
839         /* FALL THROGH */
840     default:
841         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
842         if (SvIsUV(sv))         sv_catpv(d, "IsUV,");
843         break;
844     case SVt_PVBM:
845         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
846         if (SvVALID(sv))        sv_catpv(d, "VALID,");
847         break;
848     }
849
850     if (*(SvEND(d) - 1) == ',')
851         SvPVX(d)[--SvCUR(d)] = '\0';
852     sv_catpv(d, ")");
853     s = SvPVX(d);
854
855     Perl_dump_indent(aTHX_ level, file, "SV = ");
856     switch (type) {
857     case SVt_NULL:
858         PerlIO_printf(file, "NULL%s\n", s);
859         return;
860     case SVt_IV:
861         PerlIO_printf(file, "IV%s\n", s);
862         break;
863     case SVt_NV:
864         PerlIO_printf(file, "NV%s\n", s);
865         break;
866     case SVt_RV:
867         PerlIO_printf(file, "RV%s\n", s);
868         break;
869     case SVt_PV:
870         PerlIO_printf(file, "PV%s\n", s);
871         break;
872     case SVt_PVIV:
873         PerlIO_printf(file, "PVIV%s\n", s);
874         break;
875     case SVt_PVNV:
876         PerlIO_printf(file, "PVNV%s\n", s);
877         break;
878     case SVt_PVBM:
879         PerlIO_printf(file, "PVBM%s\n", s);
880         break;
881     case SVt_PVMG:
882         PerlIO_printf(file, "PVMG%s\n", s);
883         break;
884     case SVt_PVLV:
885         PerlIO_printf(file, "PVLV%s\n", s);
886         break;
887     case SVt_PVAV:
888         PerlIO_printf(file, "PVAV%s\n", s);
889         break;
890     case SVt_PVHV:
891         PerlIO_printf(file, "PVHV%s\n", s);
892         break;
893     case SVt_PVCV:
894         PerlIO_printf(file, "PVCV%s\n", s);
895         break;
896     case SVt_PVGV:
897         PerlIO_printf(file, "PVGV%s\n", s);
898         break;
899     case SVt_PVFM:
900         PerlIO_printf(file, "PVFM%s\n", s);
901         break;
902     case SVt_PVIO:
903         PerlIO_printf(file, "PVIO%s\n", s);
904         break;
905     default:
906         PerlIO_printf(file, "UNKNOWN(0x%x) %s\n", type, s);
907         return;
908     }
909     if (type >= SVt_PVIV || type == SVt_IV) {
910 #ifdef IV_IS_QUAD
911         if (SvIsUV(sv))
912             Perl_dump_indent(aTHX_ level, file, "  UV = %" PERL_PRIu64, (UV)SvUVX(sv));
913         else
914             Perl_dump_indent(aTHX_ level, file, "  IV = %" PERL_PRId64, (IV)SvIVX(sv));
915 #else
916         if (SvIsUV(sv))
917             Perl_dump_indent(aTHX_ level, file, "  UV = %lu", (unsigned long)SvUVX(sv));
918         else
919             Perl_dump_indent(aTHX_ level, file, "  IV = %ld", (long)SvIVX(sv));
920 #endif
921         if (SvOOK(sv))
922             PerlIO_printf(file, "  (OFFSET)");
923         PerlIO_putc(file, '\n');
924     }
925     if (type >= SVt_PVNV || type == SVt_NV) {
926         RESTORE_NUMERIC_STANDARD();
927 #ifdef USE_LONG_DOUBLE
928         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
929 #else
930         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
931 #endif
932         RESTORE_NUMERIC_LOCAL();
933     }
934     if (SvROK(sv)) {
935 #ifdef IV_IS_QUAD
936         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST SvRV(sv));
937 #else
938         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%lx\n", (long)SvRV(sv));
939 #endif
940         if (nest < maxnest)
941             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
942         return;
943     }
944     if (type < SVt_PV)
945         return;
946     if (type <= SVt_PVLV) {
947         if (SvPVX(sv)) {
948 #ifdef IV_IS_QUAD
949             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%" PERL_PRIx64 " ", (IV)PTR_CAST SvPVX(sv));
950 #else
951             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%lx ", (long)SvPVX(sv));
952 #endif
953             if (SvOOK(sv))
954                 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
955             PerlIO_printf(file, "%s\n", pv_display(d, SvPVX(sv), SvCUR(sv), SvLEN(sv), pvlim));
956 #ifdef IV_IS_QUAD
957             Perl_dump_indent(aTHX_ level, file, "  CUR = %" PERL_PRId64 "\n", (IV)SvCUR(sv));
958             Perl_dump_indent(aTHX_ level, file, "  LEN = %" PERL_PRId64 "\n", (IV)SvLEN(sv));
959 #else
960             Perl_dump_indent(aTHX_ level, file, "  CUR = %ld\n", (long)SvCUR(sv));
961             Perl_dump_indent(aTHX_ level, file, "  LEN = %ld\n", (long)SvLEN(sv));
962 #endif
963         }
964         else
965             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
966     }
967     if (type >= SVt_PVMG) {
968         if (SvMAGIC(sv))
969             do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
970         if (SvSTASH(sv))
971             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
972     }
973     switch (type) {
974     case SVt_PVLV:
975         Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
976 #ifdef IV_IS_QUAD
977         Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %" PERL_PRId64 "\n", (IV)LvTARGOFF(sv));
978         Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %" PERL_PRId64 "\n", (IV)LvTARGLEN(sv));
979         Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST LvTARG(sv));
980 #else
981         Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %ld\n", (long)LvTARGOFF(sv));
982         Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %ld\n", (long)LvTARGLEN(sv));
983         Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%lx\n", (long)LvTARG(sv));
984 #endif
985         /* XXX level+1 ??? */
986         do_sv_dump(level, file, LvTARG(sv), nest+1, maxnest, dumpops, pvlim);
987         break;
988     case SVt_PVAV:
989 #ifdef IV_IS_QUAD
990         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" PERL_PRIx64 , (IV)PTR_CAST AvARRAY(sv));
991 #else
992         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%lx", (long)AvARRAY(sv));
993 #endif
994         if (AvARRAY(sv) != AvALLOC(sv)) {
995             PerlIO_printf(file, " (offset=%d)\n", (AvARRAY(sv) - AvALLOC(sv)));
996 #ifdef IV_IS_QUAD
997             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST AvALLOC(sv));
998 #else
999             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%lx\n", (long)AvALLOC(sv));
1000 #endif
1001         }
1002         else
1003             PerlIO_putc(file, '\n');
1004 #ifdef IV_IS_QUAD
1005         Perl_dump_indent(aTHX_ level, file, "  FILL = %" PERL_PRId64 "\n", (IV)AvFILLp(sv));
1006         Perl_dump_indent(aTHX_ level, file, "  MAX = %" PERL_PRId64 "\n", (IV)AvMAX(sv));
1007         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST AvARYLEN(sv));
1008 #else
1009         Perl_dump_indent(aTHX_ level, file, "  FILL = %ld\n", (long)AvFILLp(sv));
1010         Perl_dump_indent(aTHX_ level, file, "  MAX = %ld\n", (long)AvMAX(sv));
1011         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
1012 #endif
1013         flags = AvFLAGS(sv);
1014         sv_setpv(d, "");
1015         if (flags & AVf_REAL)   sv_catpv(d, ",REAL");
1016         if (flags & AVf_REIFY)  sv_catpv(d, ",REIFY");
1017         if (flags & AVf_REUSED) sv_catpv(d, ",REUSED");
1018         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n", SvCUR(d) ? SvPVX(d) + 1 : "");
1019         if (nest < maxnest && av_len((AV*)sv) >= 0) {
1020             int count;
1021             for (count = 0; count <=  av_len((AV*)sv) && count < maxnest; count++) {
1022                 SV** elt = av_fetch((AV*)sv,count,0);
1023
1024 #ifdef IV_IS_QUAD
1025                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" PERL_PRId64 "\n", (IV)count);
1026 #else
1027                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %ld\n", (long)count);
1028 #endif
1029                 if (elt) 
1030                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1031             }
1032         }
1033         break;
1034     case SVt_PVHV:
1035 #ifdef IV_IS_QUAD
1036         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" PERL_PRIx64,(IV)PTR_CAST HvARRAY(sv));
1037 #else
1038         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%lx",(long)HvARRAY(sv));
1039 #endif
1040         if (HvARRAY(sv) && HvKEYS(sv)) {
1041             /* Show distribution of HEs in the ARRAY */
1042             int freq[200];
1043 #define FREQ_MAX (sizeof freq / sizeof freq[0] - 1)
1044             int i;
1045             int max = 0;
1046             U32 pow2 = 2, keys = HvKEYS(sv);
1047             NV theoret, sum = 0;
1048
1049             PerlIO_printf(file, "  (");
1050             Zero(freq, FREQ_MAX + 1, int);
1051             for (i = 0; i <= HvMAX(sv); i++) {
1052                 HE* h; int count = 0;
1053                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1054                     count++;
1055                 if (count > FREQ_MAX)
1056                     count = FREQ_MAX;
1057                 freq[count]++;
1058                 if (max < count)
1059                     max = count;
1060             }
1061             for (i = 0; i <= max; i++) {
1062                 if (freq[i]) {
1063                     PerlIO_printf(file, "%d%s:%d", i,
1064                                   (i == FREQ_MAX) ? "+" : "",
1065                                   freq[i]);
1066                     if (i != max)
1067                         PerlIO_printf(file, ", ");
1068                 }
1069             }
1070             PerlIO_putc(file, ')');
1071             /* Now calculate quality wrt theoretical value */
1072             for (i = max; i > 0; i--) { /* Precision: count down. */
1073                 sum += freq[i] * i * i;
1074             }
1075             while (keys = keys >> 1)
1076                 pow2 = pow2 << 1;
1077             /* Approximate by Poisson distribution */
1078             theoret = HvKEYS(sv);
1079             theoret += theoret * theoret/pow2;
1080             PerlIO_putc(file, '\n');
1081             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1f%%", theoret/sum*100);
1082         }
1083         PerlIO_putc(file, '\n');
1084 #ifdef IV_IS_QUAD
1085         Perl_dump_indent(aTHX_ level, file, "  KEYS = %" PERL_PRId64 "\n", (IV)HvKEYS(sv));
1086         Perl_dump_indent(aTHX_ level, file, "  FILL = %" PERL_PRId64 "\n", (IV)HvFILL(sv));
1087         Perl_dump_indent(aTHX_ level, file, "  MAX = %" PERL_PRId64 "\n", (IV)HvMAX(sv));
1088         Perl_dump_indent(aTHX_ level, file, "  RITER = %" PERL_PRId64 "\n", (IV)HvRITER(sv));
1089         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%" PERL_PRIx64 "\n",(IV)PTR_CAST  HvEITER(sv));
1090 #else
1091         Perl_dump_indent(aTHX_ level, file, "  KEYS = %ld\n", (long)HvKEYS(sv));
1092         Perl_dump_indent(aTHX_ level, file, "  FILL = %ld\n", (long)HvFILL(sv));
1093         Perl_dump_indent(aTHX_ level, file, "  MAX = %ld\n", (long)HvMAX(sv));
1094         Perl_dump_indent(aTHX_ level, file, "  RITER = %ld\n", (long)HvRITER(sv));
1095         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%lx\n",(long) HvEITER(sv));
1096 #endif
1097         if (HvPMROOT(sv))
1098 #ifdef IV_IS_QUAD
1099             Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%" PERL_PRIx64 "\n",(IV)PTR_CAST HvPMROOT(sv));
1100 #else
1101             Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
1102 #endif
1103         if (HvNAME(sv))
1104             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", HvNAME(sv));
1105         if (nest < maxnest && !HvEITER(sv)) { /* Try to preserve iterator */
1106             HE *he;
1107             HV *hv = (HV*)sv;
1108             int count = maxnest - nest;
1109
1110             hv_iterinit(hv);
1111             while ((he = hv_iternext(hv)) && count--) {
1112                 SV *elt;
1113                 char *key;
1114                 I32 len;
1115                 U32 hash = HeHASH(he);
1116
1117                 key = hv_iterkey(he, &len);
1118                 elt = hv_iterval(hv, he);
1119 #ifdef IV_IS_QUAD
1120                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s HASH = 0x%" PERL_PRIx64 "\n", pv_display(d, key, len, 0, pvlim), hash);
1121 #else
1122                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s HASH = 0x%lx\n", pv_display(d, key, len, 0, pvlim), hash);
1123 #endif
1124                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1125             }
1126             hv_iterinit(hv);            /* Return to status quo */
1127         }
1128         break;
1129     case SVt_PVCV:
1130         if (SvPOK(sv))
1131             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n", SvPV(sv,n_a));
1132         /* FALL THROUGH */
1133     case SVt_PVFM:
1134         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1135         if (CvSTART(sv))
1136 #ifdef IV_IS_QAUD
1137             Perl_dump_indent(aTHX_ level, file, "  START = 0x%" PERL_PRIx64 " ===> %d\n", (IV)CvSTART(sv), CvSTART(sv)->op_seq);
1138         Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%" PERL_PRIx64 "\n", (IV)CvROOT(sv));
1139 #else
1140             Perl_dump_indent(aTHX_ level, file, "  START = 0x%lx ===> %d\n", (long)CvSTART(sv), CvSTART(sv)->op_seq);
1141         Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%lx\n", (long)CvROOT(sv));
1142 #endif
1143         if (CvROOT(sv) && dumpops)
1144             do_op_dump(level+1, file, CvROOT(sv));
1145 #ifdef IV_IS_QUAD
1146         Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST CvXSUB(sv));
1147         Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %" PERL_PRId64 "\n", (IV)CvXSUBANY(sv).any_i32);
1148 #else
1149         Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%lx\n", (long)CvXSUB(sv));
1150         Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32);
1151 #endif
1152         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1153         do_gv_dump(level, file, "  FILEGV", CvFILEGV(sv));
1154 #ifdef IV_IS_QUAD
1155         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %" PERL_PRId64 "\n", (IV)CvDEPTH(sv));
1156 #else
1157         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %ld\n", (long)CvDEPTH(sv));
1158 #endif
1159 #ifdef USE_THREADS
1160 #ifdef IV_IS_QUAD
1161         Perl_dump_indent(aTHX_ level, file, "  MUTEXP = 0x%" PERL_PRIx64 "\n", (IV)CvMUTEXP(sv));
1162         Perl_dump_indent(aTHX_ level, file, "  OWNER = 0x%" PERL_PRIx64 "\n", (IV)CvOWNER(sv));
1163 #else
1164         Perl_dump_indent(aTHX_ level, file, "  MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv));
1165         Perl_dump_indent(aTHX_ level, file, "  OWNER = 0x%lx\n", (long)CvOWNER(sv));
1166 #endif /* IV_IS_QUAD */
1167 #endif /* USE_THREADS */
1168 #ifdef IV_IS_QUAD
1169         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" PERL_PRIx64 "\n", (UV)CvFLAGS(sv));
1170 #else
1171         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%lx\n", (unsigned long)CvFLAGS(sv));
1172 #endif
1173         if (type == SVt_PVFM)
1174 #ifdef IV_IS_QUAD
1175             Perl_dump_indent(aTHX_ level, file, "  LINES = %" PERL_PRId64 "\n", (IV)FmLINES(sv));
1176 #else
1177             Perl_dump_indent(aTHX_ level, file, "  LINES = %ld\n", (long)FmLINES(sv));
1178 #endif
1179 #ifdef IV_IS_QUAD
1180         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST CvPADLIST(sv));
1181 #else
1182         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%lx\n", (long)CvPADLIST(sv));
1183 #endif
1184         if (nest < maxnest && CvPADLIST(sv)) {
1185             AV* padlist = CvPADLIST(sv);
1186             AV* pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
1187             AV* pad = (AV*)*av_fetch(padlist, 1, FALSE);
1188             SV** pname = AvARRAY(pad_name);
1189             SV** ppad = AvARRAY(pad);
1190             I32 ix;
1191
1192             for (ix = 1; ix <= AvFILL(pad_name); ix++) {
1193 #ifdef IV_IS_QUAD
1194                 if (SvPOK(pname[ix]))
1195                     Perl_dump_indent(aTHX_ level, /* %5d below is enough whitespace. */
1196                                 file, 
1197                                 "%5d. 0x%" PERL_PRIx64 " (%s\"%s\" %" PERL_PRId64 "-%" PERL_PRId64 ")\n",
1198                                 ix, ppad[ix],
1199                                 SvFAKE(pname[ix]) ? "FAKE " : "",
1200                                 SvPVX(pname[ix]),
1201                                 (IV)SvNVX(pname[ix]),
1202                                 (IV)SvIVX(pname[ix]));
1203 #else
1204                 if (SvPOK(pname[ix]))
1205                     Perl_dump_indent(aTHX_ level, /* %5d below is enough whitespace. */
1206                                 file, 
1207                                 "%5d. 0x%lx (%s\"%s\" %ld-%ld)\n",
1208                                 ix, ppad[ix],
1209                                 SvFAKE(pname[ix]) ? "FAKE " : "",
1210                                 SvPVX(pname[ix]),
1211                                 (long)I_32(SvNVX(pname[ix])),
1212                                 (long)SvIVX(pname[ix]));
1213 #endif
1214             }
1215         }
1216         {
1217             CV *outside = CvOUTSIDE(sv);
1218 #ifdef IV_IS_QUAD
1219             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%" PERL_PRIx64 " (%s)\n", 
1220                         (IV)PTR_CAST outside, 
1221                         (!outside ? "null"
1222                          : CvANON(outside) ? "ANON"
1223                          : (outside == PL_main_cv) ? "MAIN"
1224                          : CvUNIQUE(outside) ? "UNIQUE"
1225                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1226 #else
1227             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%lx (%s)\n", 
1228                         (long)outside, 
1229                         (!outside ? "null"
1230                          : CvANON(outside) ? "ANON"
1231                          : (outside == PL_main_cv) ? "MAIN"
1232                          : CvUNIQUE(outside) ? "UNIQUE"
1233                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1234 #endif
1235         }
1236         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1237             do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1238         break;
1239     case SVt_PVGV:
1240         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1241 #ifdef IV_IS_QUAD
1242         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %" PERL_PRId64 "\n", (IV)GvNAMELEN(sv));
1243 #else
1244         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %ld\n", (long)GvNAMELEN(sv));
1245 #endif
1246         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1247 #ifdef IV_IS_QUAD
1248         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST GvGP(sv));
1249         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST GvSV(sv));
1250         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %" PERL_PRId64 "\n", (IV)GvREFCNT(sv));
1251         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST GvIOp(sv));
1252         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%" PERL_PRIx64 "  \n", (IV)PTR_CAST GvFORM(sv));
1253         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST GvAV(sv));
1254         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST GvHV(sv));
1255         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST GvCV(sv));
1256         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%" PERL_PRIx64 "\n", (IV)GvCVGEN(sv));
1257         Perl_dump_indent(aTHX_ level, file, "    LASTEXPR = %" PERL_PRId64 "\n", (IV)GvLASTEXPR(sv));
1258         Perl_dump_indent(aTHX_ level, file, "    LINE = %" PERL_PRId64 "\n", (IV)GvLINE(sv));
1259 #else
1260         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%lx\n", (long)GvGP(sv));
1261         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%lx\n", (long)GvSV(sv));
1262         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %ld\n", (long)GvREFCNT(sv));
1263         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%lx\n", (long)GvIOp(sv));
1264         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%lx\n", (long)GvFORM(sv));
1265         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%lx\n", (long)GvAV(sv));
1266         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%lx\n", (long)GvHV(sv));
1267         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%lx\n", (long)GvCV(sv));
1268         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%lx\n", (long)GvCVGEN(sv));
1269         Perl_dump_indent(aTHX_ level, file, "    LASTEXPR = %ld\n", (long)GvLASTEXPR(sv));
1270         Perl_dump_indent(aTHX_ level, file, "    LINE = %ld\n", (long)GvLINE(sv));
1271 #endif
1272         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%x\n", (int)GvFLAGS(sv));
1273         do_gv_dump (level, file, "    FILEGV", GvFILEGV(sv));
1274         do_gv_dump (level, file, "    EGV", GvEGV(sv));
1275         break;
1276     case SVt_PVIO:
1277 #ifdef IV_IS_QUAD
1278         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST IoIFP(sv));
1279         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST IoOFP(sv));
1280         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%" PERL_PRIx64 "\n", (IV)PTR_CAST IoDIRP(sv));
1281         Perl_dump_indent(aTHX_ level, file, "  LINES = %" PERL_PRId64 "\n", (IV)IoLINES(sv));
1282         Perl_dump_indent(aTHX_ level, file, "  PAGE = %" PERL_PRId64 "\n", (IV)IoPAGE(sv));
1283         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %" PERL_PRId64 "\n", (IV)IoPAGE_LEN(sv));
1284         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %" PERL_PRId64 "\n", (IV)IoLINES_LEFT(sv));
1285 #else
1286         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%lx\n", (long)IoIFP(sv));
1287         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%lx\n", (long)IoOFP(sv));
1288         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%lx\n", (long)IoDIRP(sv));
1289         Perl_dump_indent(aTHX_ level, file, "  LINES = %ld\n", (long)IoLINES(sv));
1290         Perl_dump_indent(aTHX_ level, file, "  PAGE = %ld\n", (long)IoPAGE(sv));
1291         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv));
1292         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv));
1293 #endif
1294         if (IoTOP_NAME(sv))
1295             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1296         do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1297         if (IoFMT_NAME(sv))
1298             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1299         do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
1300         if (IoBOTTOM_NAME(sv))
1301             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1302         do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
1303 #ifdef IV_IS_QUAD
1304         Perl_dump_indent(aTHX_ level, file, "  SUBPROCESS = %" PERL_PRId64 "\n", (IV)IoSUBPROCESS(sv));
1305 #else
1306         Perl_dump_indent(aTHX_ level, file, "  SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv));
1307 #endif
1308         if (isPRINT(IoTYPE(sv)))
1309             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
1310         else
1311             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
1312 #ifdef IV_IS_QUAD
1313         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" PERL_PRIx64 "\n", (IV)IoFLAGS(sv));
1314 #else
1315         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%lx\n", (long)IoFLAGS(sv));
1316 #endif
1317         break;
1318     }
1319 }
1320
1321 void
1322 Perl_sv_dump(pTHX_ SV *sv)
1323 {
1324     do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1325 }