This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PL_ prefix to all perlvars, part1
[perl5.git] / dump.c
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 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         }
223         else if (o->op_type == OP_FLIP) {
224             if (o->op_private & OPpFLIP_LINENUM)
225                 sv_catpv(tmpsv, ",LINENUM");
226         }
227         else if (o->op_type == OP_FLOP) {
228             if (o->op_private & OPpFLIP_LINENUM)
229                 sv_catpv(tmpsv, ",LINENUM");
230         }
231         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
232             sv_catpv(tmpsv, ",INTRO");
233         if (SvCUR(tmpsv))
234             dump("PRIVATE = (%s)\n", SvPVX(tmpsv) + 1);
235         SvREFCNT_dec(tmpsv);
236     }
237
238     switch (o->op_type) {
239     case OP_GVSV:
240     case OP_GV:
241         if (cGVOPo->op_gv) {
242             SV *tmpsv = NEWSV(0,0);
243             ENTER;
244             SAVEFREESV(tmpsv);
245             gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch);
246             dump("GV = %s\n", SvPV(tmpsv, PL_na));
247             LEAVE;
248         }
249         else
250             dump("GV = NULL\n");
251         break;
252     case OP_CONST:
253         dump("SV = %s\n", SvPEEK(cSVOPo->op_sv));
254         break;
255     case OP_NEXTSTATE:
256     case OP_DBSTATE:
257         if (cCOPo->cop_line)
258             dump("LINE = %d\n",cCOPo->cop_line);
259         if (cCOPo->cop_label)
260             dump("LABEL = \"%s\"\n",cCOPo->cop_label);
261         break;
262     case OP_ENTERLOOP:
263         dump("REDO ===> ");
264         if (cLOOPo->op_redoop)
265             PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_redoop->op_seq);
266         else
267             PerlIO_printf(Perl_debug_log, "DONE\n");
268         dump("NEXT ===> ");
269         if (cLOOPo->op_nextop)
270             PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_nextop->op_seq);
271         else
272             PerlIO_printf(Perl_debug_log, "DONE\n");
273         dump("LAST ===> ");
274         if (cLOOPo->op_lastop)
275             PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_lastop->op_seq);
276         else
277             PerlIO_printf(Perl_debug_log, "DONE\n");
278         break;
279     case OP_COND_EXPR:
280         dump("TRUE ===> ");
281         if (cCONDOPo->op_true)
282             PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_true->op_seq);
283         else
284             PerlIO_printf(Perl_debug_log, "DONE\n");
285         dump("FALSE ===> ");
286         if (cCONDOPo->op_false)
287             PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_false->op_seq);
288         else
289             PerlIO_printf(Perl_debug_log, "DONE\n");
290         break;
291     case OP_MAPWHILE:
292     case OP_GREPWHILE:
293     case OP_OR:
294     case OP_AND:
295         dump("OTHER ===> ");
296         if (cLOGOPo->op_other)
297             PerlIO_printf(Perl_debug_log, "%d\n", cLOGOPo->op_other->op_seq);
298         else
299             PerlIO_printf(Perl_debug_log, "DONE\n");
300         break;
301     case OP_PUSHRE:
302     case OP_MATCH:
303     case OP_QR:
304     case OP_SUBST:
305         dump_pm(cPMOPo);
306         break;
307     default:
308         break;
309     }
310     if (o->op_flags & OPf_KIDS) {
311         OP *kid;
312         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
313             dump_op(kid);
314     }
315     PL_dumplvl--;
316     dump("}\n");
317 #endif  /* DEBUGGING */
318 }
319
320 void
321 dump_gv(GV *gv)
322 {
323 #ifdef DEBUGGING
324     SV *sv;
325
326     if (!gv) {
327         PerlIO_printf(Perl_debug_log, "{}\n");
328         return;
329     }
330     sv = sv_newmortal();
331     PL_dumplvl++;
332     PerlIO_printf(Perl_debug_log, "{\n");
333     gv_fullname3(sv, gv, Nullch);
334     dump("GV_NAME = %s", SvPVX(sv));
335     if (gv != GvEGV(gv)) {
336         gv_efullname3(sv, GvEGV(gv), Nullch);
337         dump("-> %s", SvPVX(sv));
338     }
339     dump("\n");
340     PL_dumplvl--;
341     dump("}\n");
342 #endif  /* DEBUGGING */
343 }
344
345 void
346 dump_pm(PMOP *pm)
347 {
348 #ifdef DEBUGGING
349     char ch;
350
351     if (!pm) {
352         dump("{}\n");
353         return;
354     }
355     dump("{\n");
356     PL_dumplvl++;
357     if (pm->op_pmflags & PMf_ONCE)
358         ch = '?';
359     else
360         ch = '/';
361     if (pm->op_pmregexp)
362         dump("PMf_PRE %c%s%c%s\n",
363              ch, pm->op_pmregexp->precomp, ch,
364              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
365     else
366         dump("PMf_PRE (RUNTIME)\n");
367     if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
368         dump("PMf_REPL = ");
369         dump_op(pm->op_pmreplroot);
370     }
371     if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) {
372         SV *tmpsv = newSVpv("", 0);
373         if (pm->op_pmdynflags & PMdf_USED)
374             sv_catpv(tmpsv, ",USED");
375         if (pm->op_pmdynflags & PMdf_TAINTED)
376             sv_catpv(tmpsv, ",TAINTED");
377         if (pm->op_pmflags & PMf_ONCE)
378             sv_catpv(tmpsv, ",ONCE");
379         if (pm->op_pmregexp && pm->op_pmregexp->check_substr
380             && !(pm->op_pmregexp->reganch & ROPT_NOSCAN))
381             sv_catpv(tmpsv, ",SCANFIRST");
382         if (pm->op_pmregexp && pm->op_pmregexp->check_substr
383             && pm->op_pmregexp->reganch & ROPT_CHECK_ALL)
384             sv_catpv(tmpsv, ",ALL");
385         if (pm->op_pmflags & PMf_SKIPWHITE)
386             sv_catpv(tmpsv, ",SKIPWHITE");
387         if (pm->op_pmflags & PMf_CONST)
388             sv_catpv(tmpsv, ",CONST");
389         if (pm->op_pmflags & PMf_KEEP)
390             sv_catpv(tmpsv, ",KEEP");
391         if (pm->op_pmflags & PMf_GLOBAL)
392             sv_catpv(tmpsv, ",GLOBAL");
393         if (pm->op_pmflags & PMf_CONTINUE)
394             sv_catpv(tmpsv, ",CONTINUE");
395         if (pm->op_pmflags & PMf_RETAINT)
396             sv_catpv(tmpsv, ",RETAINT");
397         if (pm->op_pmflags & PMf_EVAL)
398             sv_catpv(tmpsv, ",EVAL");
399         dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
400         SvREFCNT_dec(tmpsv);
401     }
402
403     PL_dumplvl--;
404     dump("}\n");
405 #endif  /* DEBUGGING */
406 }
407
408
409 STATIC void
410 dump(char *pat,...)
411 {
412 #ifdef DEBUGGING
413     I32 i;
414     va_list args;
415
416     va_start(args, pat);
417     for (i = PL_dumplvl*4; i; i--)
418         (void)PerlIO_putc(Perl_debug_log,' ');
419     PerlIO_vprintf(Perl_debug_log,pat,args);
420     va_end(args);
421 #endif  /* DEBUGGING */
422 }