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

Revision 10724, 9.7 KB checked in by ghudson, 27 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r10723, which included commits to RCS files with non-trunk default branches.
Line 
1/*    dump.c
2 *
3 *    Copyright (c) 1991-1997, 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#include "perl.h"
17
18#ifndef DEBUGGING
19void
20dump_all()
21{
22}
23#else  /* Rest of file is for DEBUGGING */
24
25#ifdef I_STDARG
26static void dump(char *pat, ...);
27#else
28static void dump();
29#endif
30
31void
32dump_all()
33{
34    PerlIO_setlinebuf(Perl_debug_log);
35    if (main_root)
36        dump_op(main_root);
37    dump_packsubs(defstash);
38}
39
40void
41dump_packsubs(stash)
42HV* stash;
43{
44    I32 i;
45    HE  *entry;
46
47    if (!HvARRAY(stash))
48        return;
49    for (i = 0; i <= (I32) HvMAX(stash); i++) {
50        for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
51            GV *gv = (GV*)HeVAL(entry);
52            HV *hv;
53            if (GvCVu(gv))
54                dump_sub(gv);
55            if (GvFORM(gv))
56                dump_form(gv);
57            if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
58              (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
59                dump_packsubs(hv);              /* nested package */
60        }
61    }
62}
63
64void
65dump_sub(gv)
66GV* gv;
67{
68    SV *sv = sv_newmortal();
69
70    gv_fullname3(sv, gv, Nullch);
71    dump("\nSUB %s = ", SvPVX(sv));
72    if (CvXSUB(GvCV(gv)))
73        dump("(xsub 0x%x %d)\n",
74            (long)CvXSUB(GvCV(gv)),
75            CvXSUBANY(GvCV(gv)).any_i32);
76    else if (CvROOT(GvCV(gv)))
77        dump_op(CvROOT(GvCV(gv)));
78    else
79        dump("<undef>\n");
80}
81
82void
83dump_form(gv)
84GV* gv;
85{
86    SV *sv = sv_newmortal();
87
88    gv_fullname3(sv, gv, Nullch);
89    dump("\nFORMAT %s = ", SvPVX(sv));
90    if (CvROOT(GvFORM(gv)))
91        dump_op(CvROOT(GvFORM(gv)));
92    else
93        dump("<undef>\n");
94}
95
96void
97dump_eval()
98{
99    dump_op(eval_root);
100}
101
102void
103dump_op(op)
104register OP *op;
105{
106    dump("{\n");
107    if (op->op_seq)
108        PerlIO_printf(Perl_debug_log, "%-4d", op->op_seq);
109    else
110        PerlIO_printf(Perl_debug_log, "    ");
111    dump("TYPE = %s  ===> ", op_name[op->op_type]);
112    if (op->op_next) {
113        if (op->op_seq)
114            PerlIO_printf(Perl_debug_log, "%d\n", op->op_next->op_seq);
115        else
116            PerlIO_printf(Perl_debug_log, "(%d)\n", op->op_next->op_seq);
117    }
118    else
119        PerlIO_printf(Perl_debug_log, "DONE\n");
120    dumplvl++;
121    if (op->op_targ) {
122        if (op->op_type == OP_NULL)
123            dump("  (was %s)\n", op_name[op->op_targ]);
124        else
125            dump("TARG = %d\n", op->op_targ);
126    }
127#ifdef DUMPADDR
128    dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next);
129#endif
130    if (op->op_flags) {
131        SV *tmpsv = newSVpv("", 0);
132        switch (op->op_flags & OPf_WANT) {
133        case OPf_WANT_VOID:
134            sv_catpv(tmpsv, ",VOID");
135            break;
136        case OPf_WANT_SCALAR:
137            sv_catpv(tmpsv, ",SCALAR");
138            break;
139        case OPf_WANT_LIST:
140            sv_catpv(tmpsv, ",LIST");
141            break;
142        default:
143            sv_catpv(tmpsv, ",UNKNOWN");
144            break;
145        }
146        if (op->op_flags & OPf_KIDS)
147            sv_catpv(tmpsv, ",KIDS");
148        if (op->op_flags & OPf_PARENS)
149            sv_catpv(tmpsv, ",PARENS");
150        if (op->op_flags & OPf_STACKED)
151            sv_catpv(tmpsv, ",STACKED");
152        if (op->op_flags & OPf_REF)
153            sv_catpv(tmpsv, ",REF");
154        if (op->op_flags & OPf_MOD)
155            sv_catpv(tmpsv, ",MOD");
156        if (op->op_flags & OPf_SPECIAL)
157            sv_catpv(tmpsv, ",SPECIAL");
158        dump("FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
159        SvREFCNT_dec(tmpsv);
160    }
161    if (op->op_private) {
162        SV *tmpsv = newSVpv("", 0);
163        if (op->op_type == OP_AASSIGN) {
164            if (op->op_private & OPpASSIGN_COMMON)
165                sv_catpv(tmpsv, ",COMMON");
166        }
167        else if (op->op_type == OP_SASSIGN) {
168            if (op->op_private & OPpASSIGN_BACKWARDS)
169                sv_catpv(tmpsv, ",BACKWARDS");
170        }
171        else if (op->op_type == OP_TRANS) {
172            if (op->op_private & OPpTRANS_SQUASH)
173                sv_catpv(tmpsv, ",SQUASH");
174            if (op->op_private & OPpTRANS_DELETE)
175                sv_catpv(tmpsv, ",DELETE");
176            if (op->op_private & OPpTRANS_COMPLEMENT)
177                sv_catpv(tmpsv, ",COMPLEMENT");
178        }
179        else if (op->op_type == OP_REPEAT) {
180            if (op->op_private & OPpREPEAT_DOLIST)
181                sv_catpv(tmpsv, ",DOLIST");
182        }
183        else if (op->op_type == OP_ENTERSUB ||
184                 op->op_type == OP_RV2SV ||
185                 op->op_type == OP_RV2AV ||
186                 op->op_type == OP_RV2HV ||
187                 op->op_type == OP_RV2GV ||
188                 op->op_type == OP_AELEM ||
189                 op->op_type == OP_HELEM )
190        {
191            if (op->op_type == OP_ENTERSUB) {
192                if (op->op_private & OPpENTERSUB_AMPER)
193                    sv_catpv(tmpsv, ",AMPER");
194                if (op->op_private & OPpENTERSUB_DB)
195                    sv_catpv(tmpsv, ",DB");
196            }
197            switch (op->op_private & OPpDEREF) {
198            case OPpDEREF_SV:
199                sv_catpv(tmpsv, ",SV");
200                break;
201            case OPpDEREF_AV:
202                sv_catpv(tmpsv, ",AV");
203                break;
204            case OPpDEREF_HV:
205                sv_catpv(tmpsv, ",HV");
206                break;
207            }
208            if (op->op_type == OP_AELEM || op->op_type == OP_HELEM) {
209                if (op->op_private & OPpLVAL_DEFER)
210                    sv_catpv(tmpsv, ",LVAL_DEFER");
211            }
212            else {
213                if (op->op_private & HINT_STRICT_REFS)
214                    sv_catpv(tmpsv, ",STRICT_REFS");
215            }
216        }
217        else if (op->op_type == OP_CONST) {
218            if (op->op_private & OPpCONST_BARE)
219                sv_catpv(tmpsv, ",BARE");
220        }
221        else if (op->op_type == OP_FLIP) {
222            if (op->op_private & OPpFLIP_LINENUM)
223                sv_catpv(tmpsv, ",LINENUM");
224        }
225        else if (op->op_type == OP_FLOP) {
226            if (op->op_private & OPpFLIP_LINENUM)
227                sv_catpv(tmpsv, ",LINENUM");
228        }
229        if (op->op_flags & OPf_MOD && op->op_private & OPpLVAL_INTRO)
230            sv_catpv(tmpsv, ",INTRO");
231        if (SvCUR(tmpsv))
232            dump("PRIVATE = (%s)\n", SvPVX(tmpsv) + 1);
233        SvREFCNT_dec(tmpsv);
234    }
235
236    switch (op->op_type) {
237    case OP_GVSV:
238    case OP_GV:
239        if (cGVOP->op_gv) {
240            SV *tmpsv = NEWSV(0,0);
241            ENTER;
242            SAVEFREESV(tmpsv);
243            gv_fullname3(tmpsv, cGVOP->op_gv, Nullch);
244            dump("GV = %s\n", SvPV(tmpsv, na));
245            LEAVE;
246        }
247        else
248            dump("GV = NULL\n");
249        break;
250    case OP_CONST:
251        dump("SV = %s\n", SvPEEK(cSVOP->op_sv));
252        break;
253    case OP_NEXTSTATE:
254    case OP_DBSTATE:
255        if (cCOP->cop_line)
256            dump("LINE = %d\n",cCOP->cop_line);
257        if (cCOP->cop_label)
258            dump("LABEL = \"%s\"\n",cCOP->cop_label);
259        break;
260    case OP_ENTERLOOP:
261        dump("REDO ===> ");
262        if (cLOOP->op_redoop)
263            PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq);
264        else
265            PerlIO_printf(Perl_debug_log, "DONE\n");
266        dump("NEXT ===> ");
267        if (cLOOP->op_nextop)
268            PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq);
269        else
270            PerlIO_printf(Perl_debug_log, "DONE\n");
271        dump("LAST ===> ");
272        if (cLOOP->op_lastop)
273            PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq);
274        else
275            PerlIO_printf(Perl_debug_log, "DONE\n");
276        break;
277    case OP_COND_EXPR:
278        dump("TRUE ===> ");
279        if (cCONDOP->op_true)
280            PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq);
281        else
282            PerlIO_printf(Perl_debug_log, "DONE\n");
283        dump("FALSE ===> ");
284        if (cCONDOP->op_false)
285            PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq);
286        else
287            PerlIO_printf(Perl_debug_log, "DONE\n");
288        break;
289    case OP_MAPWHILE:
290    case OP_GREPWHILE:
291    case OP_OR:
292    case OP_AND:
293        dump("OTHER ===> ");
294        if (cLOGOP->op_other)
295            PerlIO_printf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq);
296        else
297            PerlIO_printf(Perl_debug_log, "DONE\n");
298        break;
299    case OP_PUSHRE:
300    case OP_MATCH:
301    case OP_SUBST:
302        dump_pm((PMOP*)op);
303        break;
304    default:
305        break;
306    }
307    if (op->op_flags & OPf_KIDS) {
308        OP *kid;
309        for (kid = cUNOP->op_first; kid; kid = kid->op_sibling)
310            dump_op(kid);
311    }
312    dumplvl--;
313    dump("}\n");
314}
315
316void
317dump_gv(gv)
318register GV *gv;
319{
320    SV *sv;
321
322    if (!gv) {
323        PerlIO_printf(Perl_debug_log, "{}\n");
324        return;
325    }
326    sv = sv_newmortal();
327    dumplvl++;
328    PerlIO_printf(Perl_debug_log, "{\n");
329    gv_fullname3(sv, gv, Nullch);
330    dump("GV_NAME = %s", SvPVX(sv));
331    if (gv != GvEGV(gv)) {
332        gv_efullname3(sv, GvEGV(gv), Nullch);
333        dump("-> %s", SvPVX(sv));
334    }
335    dump("\n");
336    dumplvl--;
337    dump("}\n");
338}
339
340void
341dump_pm(pm)
342register PMOP *pm;
343{
344    char ch;
345
346    if (!pm) {
347        dump("{}\n");
348        return;
349    }
350    dump("{\n");
351    dumplvl++;
352    if (pm->op_pmflags & PMf_ONCE)
353        ch = '?';
354    else
355        ch = '/';
356    if (pm->op_pmregexp)
357        dump("PMf_PRE %c%s%c%s\n",
358             ch, pm->op_pmregexp->precomp, ch,
359             (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
360    else
361        dump("PMf_PRE (RUNTIME)\n");
362    if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
363        dump("PMf_REPL = ");
364        dump_op(pm->op_pmreplroot);
365    }
366    if (pm->op_pmshort) {
367        dump("PMf_SHORT = %s\n",SvPEEK(pm->op_pmshort));
368    }
369    if (pm->op_pmflags) {
370        SV *tmpsv = newSVpv("", 0);
371        if (pm->op_pmflags & PMf_USED)
372            sv_catpv(tmpsv, ",USED");
373        if (pm->op_pmflags & PMf_ONCE)
374            sv_catpv(tmpsv, ",ONCE");
375        if (pm->op_pmflags & PMf_SCANFIRST)
376            sv_catpv(tmpsv, ",SCANFIRST");
377        if (pm->op_pmflags & PMf_ALL)
378            sv_catpv(tmpsv, ",ALL");
379        if (pm->op_pmflags & PMf_SKIPWHITE)
380            sv_catpv(tmpsv, ",SKIPWHITE");
381        if (pm->op_pmflags & PMf_CONST)
382            sv_catpv(tmpsv, ",CONST");
383        if (pm->op_pmflags & PMf_KEEP)
384            sv_catpv(tmpsv, ",KEEP");
385        if (pm->op_pmflags & PMf_GLOBAL)
386            sv_catpv(tmpsv, ",GLOBAL");
387        if (pm->op_pmflags & PMf_CONTINUE)
388            sv_catpv(tmpsv, ",CONTINUE");
389        if (pm->op_pmflags & PMf_EVAL)
390            sv_catpv(tmpsv, ",EVAL");
391        dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
392        SvREFCNT_dec(tmpsv);
393    }
394
395    dumplvl--;
396    dump("}\n");
397}
398
399
400#if !defined(I_STDARG) && !defined(I_VARARGS)
401/* VARARGS1 */
402static void dump(arg1,arg2,arg3,arg4,arg5)
403char *arg1;
404long arg2, arg3, arg4, arg5;
405{
406    I32 i;
407
408    for (i = dumplvl*4; i; i--)
409        (void)PerlIO_putc(Perl_debug_log,' ');
410    PerlIO_printf(Perl_debug_log, arg1, arg2, arg3, arg4, arg5);
411}
412
413#else
414
415#ifdef I_STDARG
416static void
417dump(char *pat,...)
418#else
419/*VARARGS0*/
420static void
421dump(pat,va_alist)
422    char *pat;
423    va_dcl
424#endif
425{
426    I32 i;
427    va_list args;
428
429#ifdef I_STDARG
430    va_start(args, pat);
431#else
432    va_start(args);
433#endif
434    for (i = dumplvl*4; i; i--)
435        (void)PerlIO_putc(Perl_debug_log,' ');
436    PerlIO_vprintf(Perl_debug_log,pat,args);
437    va_end(args);
438}
439#endif
440
441#endif
Note: See TracBrowser for help on using the repository browser.