Commit | Line | Data |
a687059c |
1 | package DB; |
2 | |
79a0689e |
3 | $header = '$Header: perldb.pl,v 3.0.1.2 90/03/12 16:39:39 lwall Locked $'; |
a687059c |
4 | # |
5 | # This file is automatically included if you do perl -d. |
6 | # It's probably not useful to include this yourself. |
7 | # |
8 | # Perl supplies the values for @line and %sub. It effectively inserts |
9 | # a do DB'DB(<linenum>); in front of every place that can |
10 | # have a breakpoint. It also inserts a do 'perldb.pl' before the first line. |
11 | # |
12 | # $Log: perldb.pl,v $ |
79a0689e |
13 | # Revision 3.0.1.2 90/03/12 16:39:39 lwall |
14 | # patch13: perl -d didn't format stack traces of *foo right |
15 | # patch13: perl -d wiped out scalar return values of subroutines |
16 | # |
03a14243 |
17 | # Revision 3.0.1.1 89/10/26 23:14:02 lwall |
18 | # patch1: RCS expanded an unintended $Header in lib/perldb.pl |
19 | # |
a687059c |
20 | # Revision 3.0 89/10/18 15:19:46 lwall |
21 | # 3.0 baseline |
22 | # |
23 | # Revision 2.0 88/06/05 00:09:45 root |
24 | # Baseline version 2.0. |
25 | # |
26 | # |
27 | |
28 | open(IN,"/dev/tty"); # so we don't dingle stdin |
29 | open(OUT,">/dev/tty"); # so we don't dongle stdout |
30 | select(OUT); |
31 | $| = 1; # for DB'OUT |
32 | select(STDOUT); |
33 | $| = 1; # for real STDOUT |
34 | |
03a14243 |
35 | $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; |
a687059c |
36 | print OUT "\nLoading DB from $header\n\n"; |
37 | |
38 | sub DB { |
39 | local($. ,$@, $!, $[, $,, $/, $\); |
40 | $[ = 0; $, = ""; $/ = "\n"; $\ = ""; |
41 | ($line) = @_; |
42 | if ($stop[$line]) { |
43 | if ($stop eq '1') { |
44 | $signal |= 1; |
45 | } |
46 | else { |
47 | package main; |
48 | $DB'signal |= eval $DB'stop[$DB'line]; print DB'OUT $@; |
49 | $DB'stop[$DB'line] =~ s/;9$//; |
50 | } |
51 | } |
52 | if ($single || $trace || $signal) { |
53 | print OUT "$sub($line):\t",$line[$line]; |
54 | for ($i = $line + 1; $i <= $max && $line[$i] == 0; ++$i) { |
55 | last if $line[$i] =~ /^\s*(}|#|\n)/; |
56 | print OUT "$sub($i):\t",$line[$i]; |
57 | } |
58 | } |
59 | if ($action[$line]) { |
60 | package main; |
61 | eval $DB'action[$DB'line]; print DB'OUT $@; |
62 | } |
63 | if ($single || $signal) { |
64 | if ($pre) { |
65 | package main; |
66 | eval $DB'pre; print DB'OUT $@; |
67 | } |
68 | print OUT $#stack . " levels deep in subroutine calls!\n" |
69 | if $single & 4; |
70 | $start = $line; |
71 | while ((print OUT " DB<", $#hist+1, "> "), $cmd=<IN>) { |
72 | $single = 0; |
73 | $signal = 0; |
74 | $cmd eq '' && exit 0; |
75 | chop($cmd); |
76 | $cmd =~ /^q$/ && exit 0; |
77 | $cmd =~ /^$/ && ($cmd = $laststep); |
78 | push(@hist,$cmd) if length($cmd) > 1; |
79 | ($i) = split(/\s+/,$cmd); |
80 | eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i}; |
81 | $cmd =~ /^h$/ && do { |
82 | print OUT " |
83 | T Stack trace. |
84 | s Single step. |
85 | n Next, steps over subroutine calls. |
86 | f Finish current subroutine. |
87 | c [line] Continue; optionally inserts a one-time-only breakpoint |
88 | at the specified line. |
89 | <CR> Repeat last n or s. |
90 | l min+incr List incr+1 lines starting at min. |
91 | l min-max List lines. |
92 | l line List line; |
93 | l List next window. |
94 | - List previous window. |
95 | w line List window around line. |
96 | l subname List subroutine. |
97 | /pattern/ Search forwards for pattern; final / is optional. |
98 | ?pattern? Search backwards for pattern. |
99 | L List breakpoints and actions. |
100 | S List subroutine names. |
101 | t Toggle trace mode. |
102 | b [line] [condition] |
103 | Set breakpoint; line defaults to the current execution line; |
104 | condition breaks if it evaluates to true, defaults to \'1\'. |
105 | b subname [condition] |
106 | Set breakpoint at first line of subroutine. |
107 | d [line] Delete breakpoint. |
108 | D Delete all breakpoints. |
109 | a [line] command |
110 | Set an action to be done before the line is executed. |
111 | Sequence is: check for breakpoint, print line if necessary, |
112 | do action, prompt user if breakpoint or step, evaluate line. |
113 | A Delete all actions. |
114 | V package List all variables and values in package (default main). |
115 | < command Define command before prompt. |
116 | > command Define command after prompt. |
117 | ! number Redo command (default previous command). |
118 | ! -number Redo number\'th to last command. |
119 | H -number Display last number commands (default all). |
120 | q or ^D Quit. |
121 | p expr Same as \"package main; print DB'OUT expr\". |
122 | command Execute as a perl statement. |
123 | |
124 | "; |
125 | next; }; |
126 | $cmd =~ /^t$/ && do { |
127 | $trace = !$trace; |
128 | print OUT "Trace = ".($trace?"on":"off")."\n"; |
129 | next; }; |
130 | $cmd =~ /^S$/ && do { |
131 | foreach $subname (sort(keys %sub)) { |
132 | if ($subname =~ /^main'(.*)/) { |
133 | print OUT $1,"\n"; |
134 | } |
135 | else { |
136 | print OUT $subname,"\n"; |
137 | } |
138 | } |
139 | next; }; |
140 | $cmd =~ /^V$/ && do { |
141 | $cmd = 'V main'; }; |
142 | $cmd =~ /^V\s*(['A-Za-z_]['\w]*)$/ && do { |
143 | $packname = $1; |
144 | do 'dumpvar.pl' unless defined &main'dumpvar; |
145 | if (defined &main'dumpvar) { |
146 | &main'dumpvar($packname); |
147 | } |
148 | else { |
149 | print DB'OUT "dumpvar.pl not available.\n"; |
150 | } |
151 | next; }; |
152 | $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do { |
153 | $subname = $1; |
154 | $subname = "main'" . $subname unless $subname =~ /'/; |
155 | $subrange = $sub{$subname}; |
156 | if ($subrange) { |
157 | if (eval($subrange) < -$window) { |
158 | $subrange =~ s/-.*/+/; |
159 | } |
160 | $cmd = "l $subrange"; |
161 | } else { |
162 | print OUT "Subroutine $1 not found.\n"; |
163 | next; |
164 | } }; |
165 | $cmd =~ /^w\s*(\d*)$/ && do { |
166 | $incr = $window - 1; |
167 | $start = $1 if $1; |
168 | $start -= $preview; |
169 | $cmd = 'l ' . $start . '-' . ($start + $incr); }; |
170 | $cmd =~ /^-$/ && do { |
171 | $incr = $window - 1; |
172 | $cmd = 'l ' . ($start-$window*2) . '+'; }; |
173 | $cmd =~ /^l$/ && do { |
174 | $incr = $window - 1; |
175 | $cmd = 'l ' . $start . '-' . ($start + $incr); }; |
176 | $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do { |
177 | $start = $1 if $1; |
178 | $incr = $2; |
179 | $incr = $window - 1 unless $incr; |
180 | $cmd = 'l ' . $start . '-' . ($start + $incr); }; |
181 | $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { |
182 | $end = (!$2) ? $max : ($4 ? $4 : $2); |
183 | $end = $max if $end > $max; |
184 | $i = $2; |
185 | $i = $line if $i eq '.'; |
186 | $i = 1 if $i < 1; |
187 | for (; $i <= $end; $i++) { |
188 | print OUT "$i:\t", $line[$i]; |
189 | last if $signal; |
190 | } |
191 | $start = $i; # remember in case they want more |
192 | $start = $max if $start > $max; |
193 | next; }; |
194 | $cmd =~ /^D$/ && do { |
195 | print OUT "Deleting all breakpoints...\n"; |
196 | for ($i = 1; $i <= $max ; $i++) { |
197 | $stop[$i] = 0; |
198 | } |
199 | next; }; |
200 | $cmd =~ /^L$/ && do { |
201 | for ($i = 1; $i <= $max; $i++) { |
202 | if ($stop[$i] || $action[$i]) { |
203 | print OUT "$i:\t", $line[$i]; |
204 | print OUT " break if (", $stop[$i], ")\n" |
205 | if $stop[$i]; |
206 | print OUT " action: ", $action[$i], "\n" |
207 | if $action[$i]; |
208 | last if $signal; |
209 | } |
210 | } |
211 | next; }; |
212 | $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do { |
213 | $subname = $1; |
214 | $subname = "main'" . $subname unless $subname =~ /'/; |
215 | ($i) = split(/-/, $sub{$subname}); |
216 | if ($i) { |
217 | ++$i while $line[$i] == 0 && $i < $#line; |
218 | $stop[$i] = $2 ? $2 : 1; |
219 | } else { |
220 | print OUT "Subroutine $1 not found.\n"; |
221 | } |
222 | next; }; |
223 | $cmd =~ /^b\s*(\d*)\s*(.*)/ && do { |
224 | $i = ($1?$1:$line); |
225 | if ($line[$i] == 0) { |
226 | print OUT "Line $i not breakable.\n"; |
227 | } else { |
228 | $stop[$i] = $2 ? $2 : 1; |
229 | } |
230 | next; }; |
231 | $cmd =~ /^d\s*(\d+)?/ && do { |
232 | $i = ($1?$1:$line); |
233 | $stop[$i] = ''; |
234 | next; }; |
235 | $cmd =~ /^A$/ && do { |
236 | for ($i = 1; $i <= $max ; $i++) { |
237 | $action[$i] = ''; |
238 | } |
239 | next; }; |
240 | $cmd =~ /^<\s*(.*)/ && do { |
241 | $pre = do action($1); |
242 | next; }; |
243 | $cmd =~ /^>\s*(.*)/ && do { |
244 | $post = do action($1); |
245 | next; }; |
246 | $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do { |
247 | $i = $1; |
248 | if ($line[$i] == 0) { |
249 | print OUT "Line $i may not have an action.\n"; |
250 | } else { |
251 | $action[$i] = do action($3); |
252 | } |
253 | next; }; |
254 | $cmd =~ /^n$/ && do { |
255 | $single = 2; |
256 | $laststep = $cmd; |
257 | last; }; |
258 | $cmd =~ /^s$/ && do { |
259 | $single = 1; |
260 | $laststep = $cmd; |
261 | last; }; |
262 | $cmd =~ /^c\s*(\d*)\s*$/ && do { |
263 | $i = $1; |
264 | if ($i) { |
265 | if ($line[$i] == 0) { |
266 | print OUT "Line $i not breakable.\n"; |
267 | next; |
268 | } |
269 | $stop[$i] .= ";9"; # add one-time-only b.p. |
270 | } |
271 | for ($i=0; $i <= $#stack; ) { |
272 | $stack[$i++] &= ~1; |
273 | } |
274 | last; }; |
275 | $cmd =~ /^f$/ && do { |
276 | $stack[$#stack] |= 2; |
277 | last; }; |
278 | $cmd =~ /^T$/ && do { |
279 | for ($i=0; $i <= $#sub; ) { |
280 | print OUT $sub[$i++], "\n"; |
281 | last if $signal; |
282 | } |
283 | next; }; |
284 | $cmd =~ /^\/(.*)$/ && do { |
285 | $inpat = $1; |
286 | $inpat =~ s:([^\\])/$:$1:; |
287 | if ($inpat ne "") { |
288 | eval '$inpat =~ m'."\n$inpat\n"; |
289 | if ($@ ne "") { |
290 | print OUT "$@"; |
291 | next; |
292 | } |
293 | $pat = $inpat; |
294 | } |
295 | $end = $start; |
296 | eval ' |
297 | for (;;) { |
298 | ++$start; |
299 | $start = 1 if ($start > $max); |
300 | last if ($start == $end); |
301 | if ($line[$start] =~ m'."\n$pat\n".'i) { |
302 | print OUT "$start:\t", $line[$start], "\n"; |
303 | last; |
304 | } |
305 | } '; |
306 | print OUT "/$pat/: not found\n" if ($start == $end); |
307 | next; }; |
308 | $cmd =~ /^\?(.*)$/ && do { |
309 | $inpat = $1; |
310 | $inpat =~ s:([^\\])\?$:$1:; |
311 | if ($inpat ne "") { |
312 | eval '$inpat =~ m'."\n$inpat\n"; |
313 | if ($@ ne "") { |
314 | print OUT "$@"; |
315 | next; |
316 | } |
317 | $pat = $inpat; |
318 | } |
319 | $end = $start; |
320 | eval ' |
321 | for (;;) { |
322 | --$start; |
323 | $start = $max if ($start <= 0); |
324 | last if ($start == $end); |
325 | if ($line[$start] =~ m'."\n$pat\n".'i) { |
326 | print OUT "$start:\t", $line[$start], "\n"; |
327 | last; |
328 | } |
329 | } '; |
330 | print OUT "?$pat?: not found\n" if ($start == $end); |
331 | next; }; |
332 | $cmd =~ /^!+\s*(-)?(\d+)?$/ && do { |
333 | pop(@hist) if length($cmd) > 1; |
334 | $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist)); |
335 | $cmd = $hist[$i] . "\n"; |
336 | print OUT $cmd; |
337 | redo; }; |
338 | $cmd =~ /^!(.+)$/ && do { |
339 | $pat = "^$1"; |
340 | pop(@hist) if length($cmd) > 1; |
341 | for ($i = $#hist; $i; --$i) { |
342 | last if $hist[$i] =~ $pat; |
343 | } |
344 | if (!$i) { |
345 | print OUT "No such command!\n\n"; |
346 | next; |
347 | } |
348 | $cmd = $hist[$i] . "\n"; |
349 | print OUT $cmd; |
350 | redo; }; |
351 | $cmd =~ /^H\s*(-(\d+))?/ && do { |
352 | $end = $2?($#hist-$2):0; |
353 | $hist = 0 if $hist < 0; |
354 | for ($i=$#hist; $i>$end; $i--) { |
355 | print OUT "$i: ",$hist[$i],"\n" |
356 | unless $hist[$i] =~ /^.?$/; |
357 | }; |
358 | next; }; |
359 | $cmd =~ s/^p( .*)?$/print DB'OUT$1/; |
360 | { |
361 | package main; |
362 | eval $DB'cmd; |
363 | } |
364 | print OUT $@,"\n"; |
365 | } |
366 | if ($post) { |
367 | package main; |
368 | eval $DB'post; print DB'OUT $@; |
369 | } |
370 | } |
371 | } |
372 | |
373 | sub action { |
374 | local($action) = @_; |
375 | while ($action =~ s/\\$//) { |
376 | print OUT "+ "; |
377 | $action .= <IN>; |
378 | } |
379 | $action; |
380 | } |
381 | |
382 | sub catch { |
383 | $signal = 1; |
384 | } |
385 | |
386 | sub sub { |
387 | push(@stack, $single); |
388 | $single &= 1; |
389 | $single |= 4 if $#stack == $deep; |
390 | local(@args) = @_; |
391 | for (@args) { |
79a0689e |
392 | if (/^StB\000/ && length($_) == length($_main{'_main'})) { |
a687059c |
393 | $_ = sprintf("%s",$_); |
a687059c |
394 | } |
395 | else { |
396 | s/'/\\'/g; |
397 | s/(.*)/'$1'/ unless /^-?[\d.]+$/; |
398 | } |
399 | } |
400 | push(@sub, $sub . '(' . join(', ', @args) . ') from ' . $line); |
401 | if (wantarray) { |
402 | @i = &$sub; |
79a0689e |
403 | --$#sub; |
404 | $single |= pop(@stack); |
405 | @i; |
a687059c |
406 | } |
407 | else { |
408 | $i = &$sub; |
79a0689e |
409 | --$#sub; |
410 | $single |= pop(@stack); |
411 | $i; |
a687059c |
412 | } |
a687059c |
413 | } |
414 | |
415 | $single = 1; # so it stops on first executable statement |
416 | $max = $#line; |
417 | @hist = ('?'); |
418 | $SIG{'INT'} = "DB'catch"; |
419 | $deep = 100; # warning if stack gets this deep |
420 | $window = 10; |
421 | $preview = 3; |
422 | |
423 | @stack = (0); |
424 | @args = @ARGV; |
425 | for (@args) { |
426 | s/'/\\'/g; |
427 | s/(.*)/'$1'/ unless /^-?[\d.]+$/; |
428 | } |
429 | push(@sub, 'main(' . join(', ', @args) . ")" ); |
430 | $sub = 'main'; |
431 | |
432 | if (-f '.perldb') { |
433 | do './.perldb'; |
434 | } |
435 | elsif (-f "$ENV{'LOGDIR'}/.perldb") { |
436 | do "$ENV{'LOGDIR'}/.perldb"; |
437 | } |
438 | elsif (-f "$ENV{'HOME'}/.perldb") { |
439 | do "$ENV{'HOME'}/.perldb"; |
440 | } |
441 | |
442 | 1; |