source: trunk/third/perl/dump.c @ 14545

Revision 14545, 35.5 KB checked in by ghudson, 24 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.
Line 
1/*    dump.c
2 *
3 *    Copyright (c) 1991-2000, 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
20void
21Perl_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
29void
30Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
31{
32    dTHR;
33    PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
34    PerlIO_vprintf(file, pat, *args);
35}
36
37void
38Perl_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
47void
48Perl_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
73void
74Perl_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%lx %d)\n",
82            (long)CvXSUB(GvCV(gv)),
83            (int)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
90void
91Perl_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
103void
104Perl_dump_eval(pTHX)
105{
106    op_dump(PL_eval_root);
107}
108
109char *
110Perl_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", (U8)*pv);
135            else
136                Perl_sv_catpvf(aTHX_ sv, "\\%o", (U8)*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
148char *
149Perl_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)) {
287        if (SvIsUV(sv))
288            Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
289        else
290            Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
291    }
292    else
293        sv_catpv(t, "()");
294   
295  finish:
296    if (unref) {
297        while (unref--)
298            sv_catpv(t, ")");
299    }
300    return SvPV(t, n_a);
301}
302
303void
304Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm)
305{
306    char ch;
307
308    if (!pm) {
309        Perl_dump_indent(aTHX_ level, file, "{}\n");
310        return;
311    }
312    Perl_dump_indent(aTHX_ level, file, "{\n");
313    level++;
314    if (pm->op_pmflags & PMf_ONCE)
315        ch = '?';
316    else
317        ch = '/';
318    if (pm->op_pmregexp)
319        Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
320             ch, pm->op_pmregexp->precomp, ch,
321             (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
322    else
323        Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
324    if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
325        Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
326        op_dump(pm->op_pmreplroot);
327    }
328    if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) {
329        SV *tmpsv = newSVpvn("", 0);
330        if (pm->op_pmdynflags & PMdf_USED)
331            sv_catpv(tmpsv, ",USED");
332        if (pm->op_pmdynflags & PMdf_TAINTED)
333            sv_catpv(tmpsv, ",TAINTED");
334        if (pm->op_pmflags & PMf_ONCE)
335            sv_catpv(tmpsv, ",ONCE");
336        if (pm->op_pmregexp && pm->op_pmregexp->check_substr
337            && !(pm->op_pmregexp->reganch & ROPT_NOSCAN))
338            sv_catpv(tmpsv, ",SCANFIRST");
339        if (pm->op_pmregexp && pm->op_pmregexp->check_substr
340            && pm->op_pmregexp->reganch & ROPT_CHECK_ALL)
341            sv_catpv(tmpsv, ",ALL");
342        if (pm->op_pmflags & PMf_SKIPWHITE)
343            sv_catpv(tmpsv, ",SKIPWHITE");
344        if (pm->op_pmflags & PMf_CONST)
345            sv_catpv(tmpsv, ",CONST");
346        if (pm->op_pmflags & PMf_KEEP)
347            sv_catpv(tmpsv, ",KEEP");
348        if (pm->op_pmflags & PMf_GLOBAL)
349            sv_catpv(tmpsv, ",GLOBAL");
350        if (pm->op_pmflags & PMf_CONTINUE)
351            sv_catpv(tmpsv, ",CONTINUE");
352        if (pm->op_pmflags & PMf_RETAINT)
353            sv_catpv(tmpsv, ",RETAINT");
354        if (pm->op_pmflags & PMf_EVAL)
355            sv_catpv(tmpsv, ",EVAL");
356        Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
357        SvREFCNT_dec(tmpsv);
358    }
359
360    Perl_dump_indent(aTHX_ level-1, file, "}\n");
361}
362
363void
364Perl_pmop_dump(pTHX_ PMOP *pm)
365{
366    do_pmop_dump(0, Perl_debug_log, pm);
367}
368
369void
370Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
371{
372    dTHR;
373    Perl_dump_indent(aTHX_ level, file, "{\n");
374    level++;
375    if (o->op_seq)
376        PerlIO_printf(file, "%-4d", o->op_seq);
377    else
378        PerlIO_printf(file, "    ");
379    PerlIO_printf(file,
380                  "%*sTYPE = %s  ===> ",
381                  (int)(PL_dumpindent*level-4), "", PL_op_name[o->op_type]);
382    if (o->op_next) {
383        if (o->op_seq)
384            PerlIO_printf(file, "%d\n", o->op_next->op_seq);
385        else
386            PerlIO_printf(file, "(%d)\n", o->op_next->op_seq);
387    }
388    else
389        PerlIO_printf(file, "DONE\n");
390    if (o->op_targ) {
391        if (o->op_type == OP_NULL)
392            Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
393        else
394            Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
395    }
396#ifdef DUMPADDR
397    Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
398#endif
399    if (o->op_flags) {
400        SV *tmpsv = newSVpvn("", 0);
401        switch (o->op_flags & OPf_WANT) {
402        case OPf_WANT_VOID:
403            sv_catpv(tmpsv, ",VOID");
404            break;
405        case OPf_WANT_SCALAR:
406            sv_catpv(tmpsv, ",SCALAR");
407            break;
408        case OPf_WANT_LIST:
409            sv_catpv(tmpsv, ",LIST");
410            break;
411        default:
412            sv_catpv(tmpsv, ",UNKNOWN");
413            break;
414        }
415        if (o->op_flags & OPf_KIDS)
416            sv_catpv(tmpsv, ",KIDS");
417        if (o->op_flags & OPf_PARENS)
418            sv_catpv(tmpsv, ",PARENS");
419        if (o->op_flags & OPf_STACKED)
420            sv_catpv(tmpsv, ",STACKED");
421        if (o->op_flags & OPf_REF)
422            sv_catpv(tmpsv, ",REF");
423        if (o->op_flags & OPf_MOD)
424            sv_catpv(tmpsv, ",MOD");
425        if (o->op_flags & OPf_SPECIAL)
426            sv_catpv(tmpsv, ",SPECIAL");
427        Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
428        SvREFCNT_dec(tmpsv);
429    }
430    if (o->op_private) {
431        SV *tmpsv = newSVpvn("", 0);
432        if (PL_opargs[o->op_type] & OA_TARGLEX) {
433            if (o->op_private & OPpTARGET_MY)
434                sv_catpv(tmpsv, ",TARGET_MY");
435        }
436        if (o->op_type == OP_AASSIGN) {
437            if (o->op_private & OPpASSIGN_COMMON)
438                sv_catpv(tmpsv, ",COMMON");
439            if (o->op_private & OPpASSIGN_HASH)
440                sv_catpv(tmpsv, ",HASH");
441        }
442        else if (o->op_type == OP_SASSIGN) {
443            if (o->op_private & OPpASSIGN_BACKWARDS)
444                sv_catpv(tmpsv, ",BACKWARDS");
445        }
446        else if (o->op_type == OP_TRANS) {
447            if (o->op_private & OPpTRANS_SQUASH)
448                sv_catpv(tmpsv, ",SQUASH");
449            if (o->op_private & OPpTRANS_DELETE)
450                sv_catpv(tmpsv, ",DELETE");
451            if (o->op_private & OPpTRANS_COMPLEMENT)
452                sv_catpv(tmpsv, ",COMPLEMENT");
453        }
454        else if (o->op_type == OP_REPEAT) {
455            if (o->op_private & OPpREPEAT_DOLIST)
456                sv_catpv(tmpsv, ",DOLIST");
457        }
458        else if (o->op_type == OP_ENTERSUB ||
459                 o->op_type == OP_RV2SV ||
460                 o->op_type == OP_RV2AV ||
461                 o->op_type == OP_RV2HV ||
462                 o->op_type == OP_RV2GV ||
463                 o->op_type == OP_AELEM ||
464                 o->op_type == OP_HELEM )
465        {
466            if (o->op_type == OP_ENTERSUB) {
467                if (o->op_private & OPpENTERSUB_AMPER)
468                    sv_catpv(tmpsv, ",AMPER");
469                if (o->op_private & OPpENTERSUB_DB)
470                    sv_catpv(tmpsv, ",DB");
471                if (o->op_private & OPpENTERSUB_HASTARG)
472                    sv_catpv(tmpsv, ",HASTARG");
473            }
474            else
475                switch (o->op_private & OPpDEREF) {
476            case OPpDEREF_SV:
477                sv_catpv(tmpsv, ",SV");
478                break;
479            case OPpDEREF_AV:
480                sv_catpv(tmpsv, ",AV");
481                break;
482            case OPpDEREF_HV:
483                sv_catpv(tmpsv, ",HV");
484                break;
485            }
486            if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
487                if (o->op_private & OPpLVAL_DEFER)
488                    sv_catpv(tmpsv, ",LVAL_DEFER");
489            }
490            else {
491                if (o->op_private & HINT_STRICT_REFS)
492                    sv_catpv(tmpsv, ",STRICT_REFS");
493                if (o->op_private & OPpOUR_INTRO)
494                    sv_catpv(tmpsv, ",OUR_INTRO");
495            }
496        }
497        else if (o->op_type == OP_CONST) {
498            if (o->op_private & OPpCONST_BARE)
499                sv_catpv(tmpsv, ",BARE");
500            if (o->op_private & OPpCONST_STRICT)
501                sv_catpv(tmpsv, ",STRICT");
502        }
503        else if (o->op_type == OP_FLIP) {
504            if (o->op_private & OPpFLIP_LINENUM)
505                sv_catpv(tmpsv, ",LINENUM");
506        }
507        else if (o->op_type == OP_FLOP) {
508            if (o->op_private & OPpFLIP_LINENUM)
509                sv_catpv(tmpsv, ",LINENUM");
510        } else if (o->op_type == OP_RV2CV) {
511            if (o->op_private & OPpLVAL_INTRO)
512                sv_catpv(tmpsv, ",INTRO");
513        }
514        if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
515            sv_catpv(tmpsv, ",INTRO");
516        if (SvCUR(tmpsv))
517            Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX(tmpsv) + 1);
518        SvREFCNT_dec(tmpsv);
519    }
520
521    switch (o->op_type) {
522    case OP_AELEMFAST:
523    case OP_GVSV:
524    case OP_GV:
525#ifdef USE_ITHREADS
526        Perl_dump_indent(aTHX_ level, file, "PADIX = %d\n", cPADOPo->op_padix);
527#else
528        if (cSVOPo->op_sv) {
529            SV *tmpsv = NEWSV(0,0);
530            STRLEN n_a;
531            ENTER;
532            SAVEFREESV(tmpsv);
533            gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, Nullch);
534            Perl_dump_indent(aTHX_ level, file, "GV = %s\n", SvPV(tmpsv, n_a));
535            LEAVE;
536        }
537        else
538            Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
539#endif
540        break;
541    case OP_CONST:
542    case OP_METHOD_NAMED:
543        Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo->op_sv));
544        break;
545    case OP_SETSTATE:
546    case OP_NEXTSTATE:
547    case OP_DBSTATE:
548        if (CopLINE(cCOPo))
549            Perl_dump_indent(aTHX_ level, file, "LINE = %d\n",CopLINE(cCOPo));
550        if (CopSTASHPV(cCOPo))
551            Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
552                             CopSTASHPV(cCOPo));
553        if (cCOPo->cop_label)
554            Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
555                             cCOPo->cop_label);
556        break;
557    case OP_ENTERLOOP:
558        Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
559        if (cLOOPo->op_redoop)
560            PerlIO_printf(file, "%d\n", cLOOPo->op_redoop->op_seq);
561        else
562            PerlIO_printf(file, "DONE\n");
563        Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
564        if (cLOOPo->op_nextop)
565            PerlIO_printf(file, "%d\n", cLOOPo->op_nextop->op_seq);
566        else
567            PerlIO_printf(file, "DONE\n");
568        Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
569        if (cLOOPo->op_lastop)
570            PerlIO_printf(file, "%d\n", cLOOPo->op_lastop->op_seq);
571        else
572            PerlIO_printf(file, "DONE\n");
573        break;
574    case OP_COND_EXPR:
575    case OP_RANGE:
576    case OP_MAPWHILE:
577    case OP_GREPWHILE:
578    case OP_OR:
579    case OP_AND:
580        Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
581        if (cLOGOPo->op_other)
582            PerlIO_printf(file, "%d\n", cLOGOPo->op_other->op_seq);
583        else
584            PerlIO_printf(file, "DONE\n");
585        break;
586    case OP_PUSHRE:
587    case OP_MATCH:
588    case OP_QR:
589    case OP_SUBST:
590        do_pmop_dump(level, file, cPMOPo);
591        break;
592    case OP_LEAVE:
593    case OP_LEAVEEVAL:
594    case OP_LEAVESUB:
595    case OP_LEAVESUBLV:
596    case OP_LEAVEWRITE:
597    case OP_SCOPE:
598        if (o->op_private & OPpREFCOUNTED)
599            Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
600        break;
601    default:
602        break;
603    }
604    if (o->op_flags & OPf_KIDS) {
605        OP *kid;
606        for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
607            do_op_dump(level, file, kid);
608    }
609    Perl_dump_indent(aTHX_ level-1, file, "}\n");
610}
611
612void
613Perl_op_dump(pTHX_ OP *o)
614{
615    do_op_dump(0, Perl_debug_log, o);
616}
617
618void
619Perl_gv_dump(pTHX_ GV *gv)
620{
621    SV *sv;
622
623    if (!gv) {
624        PerlIO_printf(Perl_debug_log, "{}\n");
625        return;
626    }
627    sv = sv_newmortal();
628    PerlIO_printf(Perl_debug_log, "{\n");
629    gv_fullname3(sv, gv, Nullch);
630    Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX(sv));
631    if (gv != GvEGV(gv)) {
632        gv_efullname3(sv, GvEGV(gv), Nullch);
633        Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX(sv));
634    }
635    PerlIO_putc(Perl_debug_log, '\n');
636    Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
637}
638
639void
640Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
641{
642    for (; mg; mg = mg->mg_moremagic) {
643        Perl_dump_indent(aTHX_ level, file,
644                         "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
645        if (mg->mg_virtual) {
646            MGVTBL *v = mg->mg_virtual;
647            char *s = 0;
648            if      (v == &PL_vtbl_sv)         s = "sv";
649            else if (v == &PL_vtbl_env)        s = "env";
650            else if (v == &PL_vtbl_envelem)    s = "envelem";
651            else if (v == &PL_vtbl_sig)        s = "sig";
652            else if (v == &PL_vtbl_sigelem)    s = "sigelem";
653            else if (v == &PL_vtbl_pack)       s = "pack";
654            else if (v == &PL_vtbl_packelem)   s = "packelem";
655            else if (v == &PL_vtbl_dbline)     s = "dbline";
656            else if (v == &PL_vtbl_isa)        s = "isa";
657            else if (v == &PL_vtbl_arylen)     s = "arylen";
658            else if (v == &PL_vtbl_glob)       s = "glob";
659            else if (v == &PL_vtbl_mglob)      s = "mglob";
660            else if (v == &PL_vtbl_nkeys)      s = "nkeys";
661            else if (v == &PL_vtbl_taint)      s = "taint";
662            else if (v == &PL_vtbl_substr)     s = "substr";
663            else if (v == &PL_vtbl_vec)        s = "vec";
664            else if (v == &PL_vtbl_pos)        s = "pos";
665            else if (v == &PL_vtbl_bm)         s = "bm";
666            else if (v == &PL_vtbl_fm)         s = "fm";
667            else if (v == &PL_vtbl_uvar)       s = "uvar";
668            else if (v == &PL_vtbl_defelem)    s = "defelem";
669#ifdef USE_LOCALE_COLLATE
670            else if (v == &PL_vtbl_collxfrm)   s = "collxfrm";
671#endif
672            else if (v == &PL_vtbl_amagic)     s = "amagic";
673            else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
674            else if (v == &PL_vtbl_backref)    s = "backref";
675            if (s)
676                Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
677            else
678                Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
679        }
680        else
681            Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
682
683        if (mg->mg_private)
684            Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
685
686        if (isPRINT(mg->mg_type))
687            Perl_dump_indent(aTHX_ level, file, "    MG_TYPE = '%c'\n", mg->mg_type);
688        else
689            Perl_dump_indent(aTHX_ level, file, "    MG_TYPE = '\\%o'\n", mg->mg_type);
690
691        if (mg->mg_flags) {
692            Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
693            if (mg->mg_flags & MGf_TAINTEDDIR)
694                Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
695            if (mg->mg_flags & MGf_REFCOUNTED)
696                Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
697            if (mg->mg_flags & MGf_GSKIP)
698                Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
699            if (mg->mg_flags & MGf_MINMATCH)
700                Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
701        }
702        if (mg->mg_obj) {
703            Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
704            if (mg->mg_flags & MGf_REFCOUNTED)
705                do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
706        }
707        if (mg->mg_len)
708            Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
709        if (mg->mg_ptr) {
710            Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
711            if (mg->mg_len >= 0) {
712                SV *sv = newSVpvn("", 0);
713                PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
714                SvREFCNT_dec(sv);
715            }
716            else if (mg->mg_len == HEf_SVKEY) {
717                PerlIO_puts(file, " => HEf_SVKEY\n");
718                do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
719                continue;
720            }
721            else
722                PerlIO_puts(file, " ???? - please notify IZ");
723            PerlIO_putc(file, '\n');
724        }
725    }
726}
727
728void
729Perl_magic_dump(pTHX_ MAGIC *mg)
730{
731    do_magic_dump(0, Perl_debug_log, mg, 0, 0, 0, 0);
732}
733
734void
735Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, char *name, HV *sv)
736{
737    Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
738    if (sv && HvNAME(sv))
739        PerlIO_printf(file, "\t\"%s\"\n", HvNAME(sv));
740    else
741        PerlIO_putc(file, '\n');
742}
743
744void
745Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv)
746{
747    Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
748    if (sv && GvNAME(sv))
749        PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
750    else
751        PerlIO_putc(file, '\n');
752}
753
754void
755Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv)
756{
757    Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
758    if (sv && GvNAME(sv)) {
759        PerlIO_printf(file, "\t\"");
760        if (GvSTASH(sv) && HvNAME(GvSTASH(sv)))
761            PerlIO_printf(file, "%s\" :: \"", HvNAME(GvSTASH(sv)));
762        PerlIO_printf(file, "%s\"\n", GvNAME(sv));
763    }
764    else
765        PerlIO_putc(file, '\n');
766}
767
768void
769Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
770{
771    dTHR;
772    SV *d = sv_newmortal();
773    char *s;
774    U32 flags;
775    U32 type;
776    STRLEN n_a;
777
778    if (!sv) {
779        Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
780        return;
781    }
782   
783    flags = SvFLAGS(sv);
784    type = SvTYPE(sv);
785
786    Perl_sv_setpvf(aTHX_ d,
787                   "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
788                   PTR2UV(SvANY(sv)), PTR2UV(sv),
789                   (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
790                   (int)(PL_dumpindent*level), "");
791
792    if (flags & SVs_PADBUSY)    sv_catpv(d, "PADBUSY,");
793    if (flags & SVs_PADTMP)     sv_catpv(d, "PADTMP,");
794    if (flags & SVs_PADMY)      sv_catpv(d, "PADMY,");
795    if (flags & SVs_TEMP)       sv_catpv(d, "TEMP,");
796    if (flags & SVs_OBJECT)     sv_catpv(d, "OBJECT,");
797    if (flags & SVs_GMG)        sv_catpv(d, "GMG,");
798    if (flags & SVs_SMG)        sv_catpv(d, "SMG,");
799    if (flags & SVs_RMG)        sv_catpv(d, "RMG,");
800
801    if (flags & SVf_IOK)        sv_catpv(d, "IOK,");
802    if (flags & SVf_NOK)        sv_catpv(d, "NOK,");
803    if (flags & SVf_POK)        sv_catpv(d, "POK,");
804    if (flags & SVf_ROK)  {     
805                                sv_catpv(d, "ROK,");
806        if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
807    }
808    if (flags & SVf_OOK)        sv_catpv(d, "OOK,");
809    if (flags & SVf_FAKE)       sv_catpv(d, "FAKE,");
810    if (flags & SVf_READONLY)   sv_catpv(d, "READONLY,");
811
812    if (flags & SVf_AMAGIC)     sv_catpv(d, "OVERLOAD,");
813    if (flags & SVp_IOK)        sv_catpv(d, "pIOK,");
814    if (flags & SVp_NOK)        sv_catpv(d, "pNOK,");
815    if (flags & SVp_POK)        sv_catpv(d, "pPOK,");
816    if (flags & SVp_SCREAM)     sv_catpv(d, "SCREAM,");
817
818    switch (type) {
819    case SVt_PVCV:
820    case SVt_PVFM:
821        if (CvANON(sv))         sv_catpv(d, "ANON,");
822        if (CvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
823        if (CvCLONE(sv))        sv_catpv(d, "CLONE,");
824        if (CvCLONED(sv))       sv_catpv(d, "CLONED,");
825        if (CvNODEBUG(sv))      sv_catpv(d, "NODEBUG,");
826        if (SvCOMPILED(sv))     sv_catpv(d, "COMPILED,");
827        break;
828    case SVt_PVHV:
829        if (HvSHAREKEYS(sv))    sv_catpv(d, "SHAREKEYS,");
830        if (HvLAZYDEL(sv))      sv_catpv(d, "LAZYDEL,");
831        break;
832    case SVt_PVGV:
833        if (GvINTRO(sv))        sv_catpv(d, "INTRO,");
834        if (GvMULTI(sv))        sv_catpv(d, "MULTI,");
835        if (GvASSUMECV(sv))     sv_catpv(d, "ASSUMECV,");
836        if (GvIMPORTED(sv)) {
837            sv_catpv(d, "IMPORT");
838            if (GvIMPORTED(sv) == GVf_IMPORTED)
839                sv_catpv(d, "ALL,");
840            else {
841                sv_catpv(d, "(");
842                if (GvIMPORTED_SV(sv))  sv_catpv(d, " SV");
843                if (GvIMPORTED_AV(sv))  sv_catpv(d, " AV");
844                if (GvIMPORTED_HV(sv))  sv_catpv(d, " HV");
845                if (GvIMPORTED_CV(sv))  sv_catpv(d, " CV");
846                sv_catpv(d, " ),");
847            }
848        }
849        /* FALL THROGH */
850    default:
851        if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
852        if (SvIsUV(sv))         sv_catpv(d, "IsUV,");
853        if (SvUTF8(sv))         sv_catpv(d, "UTF8");
854        break;
855    case SVt_PVBM:
856        if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
857        if (SvVALID(sv))        sv_catpv(d, "VALID,");
858        break;
859    }
860
861    if (*(SvEND(d) - 1) == ',')
862        SvPVX(d)[--SvCUR(d)] = '\0';
863    sv_catpv(d, ")");
864    s = SvPVX(d);
865
866    Perl_dump_indent(aTHX_ level, file, "SV = ");
867    switch (type) {
868    case SVt_NULL:
869        PerlIO_printf(file, "NULL%s\n", s);
870        return;
871    case SVt_IV:
872        PerlIO_printf(file, "IV%s\n", s);
873        break;
874    case SVt_NV:
875        PerlIO_printf(file, "NV%s\n", s);
876        break;
877    case SVt_RV:
878        PerlIO_printf(file, "RV%s\n", s);
879        break;
880    case SVt_PV:
881        PerlIO_printf(file, "PV%s\n", s);
882        break;
883    case SVt_PVIV:
884        PerlIO_printf(file, "PVIV%s\n", s);
885        break;
886    case SVt_PVNV:
887        PerlIO_printf(file, "PVNV%s\n", s);
888        break;
889    case SVt_PVBM:
890        PerlIO_printf(file, "PVBM%s\n", s);
891        break;
892    case SVt_PVMG:
893        PerlIO_printf(file, "PVMG%s\n", s);
894        break;
895    case SVt_PVLV:
896        PerlIO_printf(file, "PVLV%s\n", s);
897        break;
898    case SVt_PVAV:
899        PerlIO_printf(file, "PVAV%s\n", s);
900        break;
901    case SVt_PVHV:
902        PerlIO_printf(file, "PVHV%s\n", s);
903        break;
904    case SVt_PVCV:
905        PerlIO_printf(file, "PVCV%s\n", s);
906        break;
907    case SVt_PVGV:
908        PerlIO_printf(file, "PVGV%s\n", s);
909        break;
910    case SVt_PVFM:
911        PerlIO_printf(file, "PVFM%s\n", s);
912        break;
913    case SVt_PVIO:
914        PerlIO_printf(file, "PVIO%s\n", s);
915        break;
916    default:
917        PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
918        return;
919    }
920    if (type >= SVt_PVIV || type == SVt_IV) {
921        if (SvIsUV(sv))
922            Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
923        else
924            Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
925        if (SvOOK(sv))
926            PerlIO_printf(file, "  (OFFSET)");
927        PerlIO_putc(file, '\n');
928    }
929    if (type >= SVt_PVNV || type == SVt_NV) {
930        RESTORE_NUMERIC_STANDARD();
931        /* %Vg doesn't work? --jhi */
932#ifdef USE_LONG_DOUBLE
933        Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
934#else
935        Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
936#endif
937        RESTORE_NUMERIC_LOCAL();
938    }
939    if (SvROK(sv)) {
940        Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
941        if (nest < maxnest)
942            do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
943        return;
944    }
945    if (type < SVt_PV)
946        return;
947    if (type <= SVt_PVLV) {
948        if (SvPVX(sv)) {
949            Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX(sv)));
950            if (SvOOK(sv))
951                PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
952            PerlIO_printf(file, "%s\n", pv_display(d, SvPVX(sv), SvCUR(sv), SvLEN(sv), pvlim));
953            Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
954            Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
955        }
956        else
957            Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
958    }
959    if (type >= SVt_PVMG) {
960        if (SvMAGIC(sv))
961            do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
962        if (SvSTASH(sv))
963            do_hv_dump(level, file, "  STASH", SvSTASH(sv));
964    }
965    switch (type) {
966    case SVt_PVLV:
967        Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
968        Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
969        Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
970        Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
971        /* XXX level+1 ??? */
972        do_sv_dump(level, file, LvTARG(sv), nest+1, maxnest, dumpops, pvlim);
973        break;
974    case SVt_PVAV:
975        Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
976        if (AvARRAY(sv) != AvALLOC(sv)) {
977            PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
978            Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
979        }
980        else
981            PerlIO_putc(file, '\n');
982        Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
983        Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
984        Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", PTR2UV(AvARYLEN(sv)));
985        flags = AvFLAGS(sv);
986        sv_setpv(d, "");
987        if (flags & AVf_REAL)   sv_catpv(d, ",REAL");
988        if (flags & AVf_REIFY)  sv_catpv(d, ",REIFY");
989        if (flags & AVf_REUSED) sv_catpv(d, ",REUSED");
990        Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n", SvCUR(d) ? SvPVX(d) + 1 : "");
991        if (nest < maxnest && av_len((AV*)sv) >= 0) {
992            int count;
993            for (count = 0; count <=  av_len((AV*)sv) && count < maxnest; count++) {
994                SV** elt = av_fetch((AV*)sv,count,0);
995
996                Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
997                if (elt)
998                    do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
999            }
1000        }
1001        break;
1002    case SVt_PVHV:
1003        Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1004        if (HvARRAY(sv) && HvKEYS(sv)) {
1005            /* Show distribution of HEs in the ARRAY */
1006            int freq[200];
1007#define FREQ_MAX (sizeof freq / sizeof freq[0] - 1)
1008            int i;
1009            int max = 0;
1010            U32 pow2 = 2, keys = HvKEYS(sv);
1011            NV theoret, sum = 0;
1012
1013            PerlIO_printf(file, "  (");
1014            Zero(freq, FREQ_MAX + 1, int);
1015            for (i = 0; i <= HvMAX(sv); i++) {
1016                HE* h; int count = 0;
1017                for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1018                    count++;
1019                if (count > FREQ_MAX)
1020                    count = FREQ_MAX;
1021                freq[count]++;
1022                if (max < count)
1023                    max = count;
1024            }
1025            for (i = 0; i <= max; i++) {
1026                if (freq[i]) {
1027                    PerlIO_printf(file, "%d%s:%d", i,
1028                                  (i == FREQ_MAX) ? "+" : "",
1029                                  freq[i]);
1030                    if (i != max)
1031                        PerlIO_printf(file, ", ");
1032                }
1033            }
1034            PerlIO_putc(file, ')');
1035            /* Now calculate quality wrt theoretical value */
1036            for (i = max; i > 0; i--) { /* Precision: count down. */
1037                sum += freq[i] * i * i;
1038            }
1039            while ((keys = keys >> 1))
1040                pow2 = pow2 << 1;
1041            /* Approximate by Poisson distribution */
1042            theoret = HvKEYS(sv);
1043            theoret += theoret * theoret/pow2;
1044            PerlIO_putc(file, '\n');
1045            Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1f%%", theoret/sum*100);
1046        }
1047        PerlIO_putc(file, '\n');
1048        Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1049        Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1050        Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1051        Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER(sv));
1052        Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER(sv)));
1053        if (HvPMROOT(sv))
1054            Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(HvPMROOT(sv)));
1055        if (HvNAME(sv))
1056            Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", HvNAME(sv));
1057        if (nest < maxnest && !HvEITER(sv)) { /* Try to preserve iterator */
1058            HE *he;
1059            HV *hv = (HV*)sv;
1060            int count = maxnest - nest;
1061
1062            hv_iterinit(hv);
1063            while ((he = hv_iternext(hv)) && count--) {
1064                SV *elt;
1065                char *key;
1066                I32 len;
1067                U32 hash = HeHASH(he);
1068
1069                key = hv_iterkey(he, &len);
1070                elt = hv_iterval(hv, he);
1071                Perl_dump_indent(aTHX_ level+1, file, "Elt %s HASH = 0x%"UVxf"\n", pv_display(d, key, len, 0, pvlim), (UV)hash);
1072                do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1073            }
1074            hv_iterinit(hv);            /* Return to status quo */
1075        }
1076        break;
1077    case SVt_PVCV:
1078        if (SvPOK(sv))
1079            Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n", SvPV(sv,n_a));
1080        /* FALL THROUGH */
1081    case SVt_PVFM:
1082        do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1083        if (CvSTART(sv))
1084            Perl_dump_indent(aTHX_ level, file, "  START = 0x%"UVxf" ===> %"IVdf"\n", PTR2UV(CvSTART(sv)), (IV)CvSTART(sv)->op_seq);
1085        Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n", PTR2UV(CvROOT(sv)));
1086        if (CvROOT(sv) && dumpops)
1087            do_op_dump(level+1, file, CvROOT(sv));
1088        Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1089        Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n", (IV)CvXSUBANY(sv).any_i32);
1090        do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1091        Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1092        Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1093#ifdef USE_THREADS
1094        Perl_dump_indent(aTHX_ level, file, "  MUTEXP = 0x%"UVxf"\n", PTR2UV(CvMUTEXP(sv)));
1095        Perl_dump_indent(aTHX_ level, file, "  OWNER = 0x%"UVxf"\n",  PTR2UV(CvOWNER(sv)));
1096#endif /* USE_THREADS */
1097        Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1098        if (type == SVt_PVFM)
1099            Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1100        Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1101        if (nest < maxnest && CvPADLIST(sv)) {
1102            AV* padlist = CvPADLIST(sv);
1103            AV* pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
1104            AV* pad = (AV*)*av_fetch(padlist, 1, FALSE);
1105            SV** pname = AvARRAY(pad_name);
1106            SV** ppad = AvARRAY(pad);
1107            I32 ix;
1108
1109            for (ix = 1; ix <= AvFILL(pad_name); ix++) {
1110                if (SvPOK(pname[ix]))
1111                    Perl_dump_indent(aTHX_ level,
1112                                /* %5d below is enough whitespace. */
1113                                file,
1114                                "%5d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
1115                                (int)ix, PTR2UV(ppad[ix]),
1116                                SvFAKE(pname[ix]) ? "FAKE " : "",
1117                                SvPVX(pname[ix]),
1118                                (IV)SvNVX(pname[ix]),
1119                                (IV)SvIVX(pname[ix]));
1120            }
1121        }
1122        {
1123            CV *outside = CvOUTSIDE(sv);
1124            Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1125                        PTR2UV(outside),
1126                        (!outside ? "null"
1127                         : CvANON(outside) ? "ANON"
1128                         : (outside == PL_main_cv) ? "MAIN"
1129                         : CvUNIQUE(outside) ? "UNIQUE"
1130                         : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1131        }
1132        if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1133            do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1134        break;
1135    case SVt_PVGV:
1136        Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1137        Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1138        do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1139        Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1140        if (!GvGP(sv))
1141            break;
1142        Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1143        Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1144        Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1145        Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
1146        Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1147        Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1148        Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1149        Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1150        Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf"\n", (UV)GvGPFLAGS(sv));
1151        Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
1152        Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
1153        Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1154        do_gv_dump (level, file, "    EGV", GvEGV(sv));
1155        break;
1156    case SVt_PVIO:
1157        Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1158        Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1159        Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1160        Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
1161        Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1162        Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1163        Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1164        if (IoTOP_NAME(sv))
1165            Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1166        do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1167        if (IoFMT_NAME(sv))
1168            Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1169        do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
1170        if (IoBOTTOM_NAME(sv))
1171            Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1172        do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
1173        Perl_dump_indent(aTHX_ level, file, "  SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1174        if (isPRINT(IoTYPE(sv)))
1175            Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
1176        else
1177            Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
1178        Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1179        break;
1180    }
1181}
1182
1183void
1184Perl_sv_dump(pTHX_ SV *sv)
1185{
1186    do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1187}
Note: See TracBrowser for help on using the repository browser.