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