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