perl 5.0 alpha 6
[perl.git] / dump.c
1 /* $RCSfile: dump.c,v $$Revision: 4.1 $$Date: 92/08/07 17:20:03 $
2  *
3  *    Copyright (c) 1991, 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  * $Log:        dump.c,v $
9  * Revision 4.1  92/08/07  17:20:03  lwall
10  * Stage 6 Snapshot
11  * 
12  * Revision 4.0.1.2  92/06/08  13:14:22  lwall
13  * patch20: removed implicit int declarations on funcions
14  * patch20: fixed confusion between a *var's real name and its effective name
15  * 
16  * Revision 4.0.1.1  91/06/07  10:58:44  lwall
17  * patch4: new copyright notice
18  * 
19  * Revision 4.0  91/03/20  01:08:25  lwall
20  * 4.0 baseline.
21  * 
22  */
23
24 #include "EXTERN.h"
25 #include "perl.h"
26
27 #ifdef DEBUGGING
28
29 static void dump();
30
31 void
32 dump_all()
33 {
34     setlinebuf(stderr);
35     if (main_root)
36         dump_op(main_root);
37     dump_packsubs(defstash);
38 }
39
40 void
41 dump_packsubs(stash)
42 HV* stash;
43 {
44     U32 i;
45     HE  *entry;
46
47     if (!HvARRAY(stash))
48         return;
49     for (i = 0; i <= HvMAX(stash); i++) {
50         for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
51             GV *gv = (GV*)entry->hent_val;
52             HV *hv;
53             if (GvCV(gv))
54                 dump_sub(gv);
55             if (*entry->hent_key == '_' && (hv = GvHV(gv)) && HvNAME(hv) &&
56               hv != defstash)
57                 dump_packsubs(hv);              /* nested package */
58         }
59     }
60 }
61
62 void
63 dump_sub(gv)
64 GV* gv;
65 {
66     SV *sv = sv_newmortal();
67     if (GvCV(gv)) {
68         gv_fullname(sv,gv);
69         dump("\nSUB %s = ", SvPVX(sv));
70         if (CvUSERSUB(GvCV(gv)))
71             dump("(xsub 0x%x %d)\n",
72                 (long)CvUSERSUB(GvCV(gv)),
73                 CvUSERINDEX(GvCV(gv)));
74         else if (CvROOT(GvCV(gv)))
75             dump_op(CvROOT(GvCV(gv)));
76         else
77             dump("<undef>\n");
78     }
79 }
80
81 void
82 dump_eval()
83 {
84     register I32 i;
85     register GV *gv;
86     register HE *entry;
87
88     dump_op(eval_root);
89 }
90
91 void
92 dump_op(op)
93 register OP *op;
94 {
95     SV *tmpsv;
96
97     dump("{\n");
98     if (op->op_seq)
99         fprintf(stderr, "%-4d", op->op_seq);
100     else
101         fprintf(stderr, "    ");
102     dump("TYPE = %s  ===> ", op_name[op->op_type]);
103     if (op->op_next) {
104         if (op->op_seq)
105             fprintf(stderr, "%d\n", op->op_next->op_seq);
106         else
107             fprintf(stderr, "(%d)\n", op->op_next->op_seq);
108     }
109     else
110         fprintf(stderr, "DONE\n");
111     dumplvl++;
112     if (op->op_targ) {
113         if (op->op_type == OP_NULL)
114             dump("  (was %s)\n", op_name[op->op_targ]);
115         else
116             dump("TARG = %d\n", op->op_targ);
117     }
118 #ifdef NOTDEF
119     dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next);
120 #endif
121     if (op->op_flags) {
122         *buf = '\0';
123         if (op->op_flags & OPf_KNOW) {
124             if (op->op_flags & OPf_LIST)
125                 (void)strcat(buf,"LIST,");
126             else
127                 (void)strcat(buf,"SCALAR,");
128         }
129         else
130             (void)strcat(buf,"UNKNOWN,");
131         if (op->op_flags & OPf_KIDS)
132             (void)strcat(buf,"KIDS,");
133         if (op->op_flags & OPf_PARENS)
134             (void)strcat(buf,"PARENS,");
135         if (op->op_flags & OPf_STACKED)
136             (void)strcat(buf,"STACKED,");
137         if (op->op_flags & OPf_LVAL)
138             (void)strcat(buf,"LVAL,");
139         if (op->op_flags & OPf_INTRO)
140             (void)strcat(buf,"INTRO,");
141         if (op->op_flags & OPf_SPECIAL)
142             (void)strcat(buf,"SPECIAL,");
143         if (*buf)
144             buf[strlen(buf)-1] = '\0';
145         dump("FLAGS = (%s)\n",buf);
146     }
147     if (op->op_private) {
148         *buf = '\0';
149         if (op->op_type == OP_AASSIGN) {
150             if (op->op_private & OPpASSIGN_COMMON)
151                 (void)strcat(buf,"COMMON,");
152         }
153         else if (op->op_type == OP_TRANS) {
154             if (op->op_private & OPpTRANS_SQUASH)
155                 (void)strcat(buf,"SQUASH,");
156             if (op->op_private & OPpTRANS_DELETE)
157                 (void)strcat(buf,"DELETE,");
158             if (op->op_private & OPpTRANS_COMPLEMENT)
159                 (void)strcat(buf,"COMPLEMENT,");
160         }
161         else if (op->op_type == OP_REPEAT) {
162             if (op->op_private & OPpREPEAT_DOLIST)
163                 (void)strcat(buf,"DOLIST,");
164         }
165         else if (op->op_type == OP_ENTERSUBR) {
166             if (op->op_private & OPpSUBR_DB)
167                 (void)strcat(buf,"DB,");
168         }
169         else if (op->op_type == OP_CONST) {
170             if (op->op_private & OPpCONST_BARE)
171                 (void)strcat(buf,"BARE,");
172         }
173         else if (op->op_type == OP_FLIP) {
174             if (op->op_private & OPpFLIP_LINENUM)
175                 (void)strcat(buf,"LINENUM,");
176         }
177         else if (op->op_type == OP_FLOP) {
178             if (op->op_private & OPpFLIP_LINENUM)
179                 (void)strcat(buf,"LINENUM,");
180         }
181         if (*buf) {
182             buf[strlen(buf)-1] = '\0';
183             dump("PRIVATE = (%s)\n",buf);
184         }
185     }
186
187     switch (op->op_type) {
188     case OP_GVSV:
189     case OP_GV:
190         if (cGVOP->op_gv) {
191             ENTER;
192             tmpsv = NEWSV(0,0);
193             SAVEFREESV(tmpsv);
194             gv_fullname(tmpsv,cGVOP->op_gv);
195             dump("GV = %s\n", SvPV(tmpsv, na));
196             LEAVE;
197         }
198         else
199             dump("GV = NULL\n");
200         break;
201     case OP_CONST:
202         dump("SV = %s\n", SvPEEK(cSVOP->op_sv));
203         break;
204     case OP_NEXTSTATE:
205     case OP_DBSTATE:
206         if (cCOP->cop_line)
207             dump("LINE = %d\n",cCOP->cop_line);
208         if (cCOP->cop_label)
209             dump("LABEL = \"%s\"\n",cCOP->cop_label);
210         break;
211     case OP_ENTERLOOP:
212         dump("REDO ===> ");
213         if (cLOOP->op_redoop)
214             fprintf(stderr, "%d\n", cLOOP->op_redoop->op_seq);
215         else
216             fprintf(stderr, "DONE\n");
217         dump("NEXT ===> ");
218         if (cLOOP->op_nextop)
219             fprintf(stderr, "%d\n", cLOOP->op_nextop->op_seq);
220         else
221             fprintf(stderr, "DONE\n");
222         dump("LAST ===> ");
223         if (cLOOP->op_lastop)
224             fprintf(stderr, "%d\n", cLOOP->op_lastop->op_seq);
225         else
226             fprintf(stderr, "DONE\n");
227         break;
228     case OP_COND_EXPR:
229         dump("TRUE ===> ");
230         if (cCONDOP->op_true)
231             fprintf(stderr, "%d\n", cCONDOP->op_true->op_seq);
232         else
233             fprintf(stderr, "DONE\n");
234         dump("FALSE ===> ");
235         if (cCONDOP->op_false)
236             fprintf(stderr, "%d\n", cCONDOP->op_false->op_seq);
237         else
238             fprintf(stderr, "DONE\n");
239         break;
240     case OP_GREPWHILE:
241     case OP_OR:
242     case OP_AND:
243     case OP_METHOD:
244         dump("OTHER ===> ");
245         if (cLOGOP->op_other)
246             fprintf(stderr, "%d\n", cLOGOP->op_other->op_seq);
247         else
248             fprintf(stderr, "DONE\n");
249         break;
250     case OP_PUSHRE:
251     case OP_MATCH:
252     case OP_SUBST:
253         dump_pm((PMOP*)op);
254         break;
255     }
256     if (op->op_flags & OPf_KIDS) {
257         OP *kid;
258         for (kid = cUNOP->op_first; kid; kid = kid->op_sibling)
259             dump_op(kid);
260     }
261     dumplvl--;
262     dump("}\n");
263 }
264
265 void
266 dump_gv(gv)
267 register GV *gv;
268 {
269     SV *sv;
270
271     if (!gv) {
272         fprintf(stderr,"{}\n");
273         return;
274     }
275     sv = sv_newmortal();
276     dumplvl++;
277     fprintf(stderr,"{\n");
278     gv_fullname(sv,gv);
279     dump("GV_NAME = %s", SvPVX(sv));
280     if (gv != GvEGV(gv)) {
281         gv_efullname(sv,GvEGV(gv));
282         dump("-> %s", SvPVX(sv));
283     }
284     dump("\n");
285     dumplvl--;
286     dump("}\n");
287 }
288
289 void
290 dump_pm(pm)
291 register PMOP *pm;
292 {
293     char ch;
294
295     if (!pm) {
296         dump("{}\n");
297         return;
298     }
299     dump("{\n");
300     dumplvl++;
301     if (pm->op_pmflags & PMf_ONCE)
302         ch = '?';
303     else
304         ch = '/';
305     if (pm->op_pmregexp)
306         dump("PMf_PRE %c%s%c\n",ch,pm->op_pmregexp->precomp,ch);
307     if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
308         dump("PMf_REPL = ");
309         dump_op(pm->op_pmreplroot);
310     }
311     if (pm->op_pmshort) {
312         dump("PMf_SHORT = %s\n",SvPEEK(pm->op_pmshort));
313     }
314     if (pm->op_pmflags) {
315         *buf = '\0';
316         if (pm->op_pmflags & PMf_USED)
317             (void)strcat(buf,"USED,");
318         if (pm->op_pmflags & PMf_ONCE)
319             (void)strcat(buf,"ONCE,");
320         if (pm->op_pmflags & PMf_SCANFIRST)
321             (void)strcat(buf,"SCANFIRST,");
322         if (pm->op_pmflags & PMf_ALL)
323             (void)strcat(buf,"ALL,");
324         if (pm->op_pmflags & PMf_SKIPWHITE)
325             (void)strcat(buf,"SKIPWHITE,");
326         if (pm->op_pmflags & PMf_FOLD)
327             (void)strcat(buf,"FOLD,");
328         if (pm->op_pmflags & PMf_CONST)
329             (void)strcat(buf,"CONST,");
330         if (pm->op_pmflags & PMf_KEEP)
331             (void)strcat(buf,"KEEP,");
332         if (pm->op_pmflags & PMf_GLOBAL)
333             (void)strcat(buf,"GLOBAL,");
334         if (pm->op_pmflags & PMf_RUNTIME)
335             (void)strcat(buf,"RUNTIME,");
336         if (pm->op_pmflags & PMf_EVAL)
337             (void)strcat(buf,"EVAL,");
338         if (*buf)
339             buf[strlen(buf)-1] = '\0';
340         dump("PMFLAGS = (%s)\n",buf);
341     }
342
343     dumplvl--;
344     dump("}\n");
345 }
346
347 /* VARARGS1 */
348 static void dump(arg1,arg2,arg3,arg4,arg5)
349 char *arg1;
350 long arg2, arg3, arg4, arg5;
351 {
352     I32 i;
353
354     for (i = dumplvl*4; i; i--)
355         (void)putc(' ',stderr);
356     fprintf(stderr,arg1, arg2, arg3, arg4, arg5);
357 }
358 #endif