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