emacs/perldb.pl

   1 package DB;
   2
   3 # modified Perl debugger, to be run from Emacs in perldb-mode
   4 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
   5
   6 $header = '$Header: perldb.pl,v 4.0 91/03/20 01:18:58 lwall Locked $';
   7 #
   8 # This file is automatically included if you do perl -d.
   9 # It's probably not useful to include this yourself.
  10 #
  11 # Perl supplies the values for @line and %sub.  It effectively inserts
  12 # a do DB'DB(<linenum>); in front of every place that can
  13 # have a breakpoint.  It also inserts a do 'perldb.pl' before the first line.
  14 #
  15 # $Log: perldb.pl,v $
  16 # Revision 4.0  91/03/20  01:18:58  lwall
  17 # 4.0 baseline.
  18 #
  19 # Revision 3.0.1.6  91/01/11  18:08:58  lwall
  20 # patch42: @_ couldn't be accessed from debugger
  21 #
  22 # Revision 3.0.1.5  90/11/10  01:40:26  lwall
  23 # patch38: the debugger wouldn't stop correctly or do action routines
  24 #
  25 # Revision 3.0.1.4  90/10/15  17:40:38  lwall
  26 # patch29: added caller
  27 # patch29: the debugger now understands packages and evals
  28 # patch29: scripts now run at almost full speed under the debugger
  29 # patch29: more variables are settable from debugger
  30 #
  31 # Revision 3.0.1.3  90/08/09  04:00:58  lwall
  32 # patch19: debugger now allows continuation lines
  33 # patch19: debugger can now dump lists of variables
  34 # patch19: debugger can now add aliases easily from prompt
  35 #
  36 # Revision 3.0.1.2  90/03/12  16:39:39  lwall
  37 # patch13: perl -d didn't format stack traces of *foo right
  38 # patch13: perl -d wiped out scalar return values of subroutines
  39 #
  40 # Revision 3.0.1.1  89/10/26  23:14:02  lwall
  41 # patch1: RCS expanded an unintended $Header in lib/perldb.pl
  42 #
  43 # Revision 3.0  89/10/18  15:19:46  lwall
  44 # 3.0 baseline
  45 #
  46 # Revision 2.0  88/06/05  00:09:45  root
  47 # Baseline version 2.0.
  48 #
  49 #
  50
  51 open(IN, "</dev/tty") || open(IN,  "<&STDIN");  # so we don't dingle stdin
  52 open(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
  53 select(OUT);
  54 $| = 1;                         # for DB'OUT
  55 select(STDOUT);
  56 $| = 1;                         # for real STDOUT
  57 $sub = '';
  58
  59 # Is Perl being run from Emacs?
  60 $emacs = $main'ARGV[$[] eq '-emacs';
  61 shift(@main'ARGV) if $emacs;
  62
  63 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  64 print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
  65
  66 sub DB {
  67     &save;
  68     ($package, $filename, $line) = caller;
  69     $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
  70         "package $package;";            # this won't let them modify, alas
  71     local(*dbline) = "_<$filename";
  72     $max = $#dbline;
  73     if (($stop,$action) = split(/\0/,$dbline{$line})) {
  74         if ($stop eq '1') {
  75             $signal |= 1;
  76         }
  77         else {
  78             $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
  79             $dbline{$line} =~ s/;9($|\0)/$1/;
  80         }
  81     }
  82     if ($single || $trace || $signal) {
  83         if ($emacs) {
  84             print OUT "\032\032$filename:$line:0\n";
  85         } else {
  86             print OUT "$package'" unless $sub =~ /'/;
  87             print OUT "$sub($filename:$line):\t",$dbline[$line];
  88             for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
  89                 last if $dbline[$i] =~ /^\s*(}|#|\n)/;
  90                 print OUT "$sub($filename:$i):\t",$dbline[$i];
  91             }
  92         }
  93     }
  94     $evalarg = $action, &eval if $action;
  95     if ($single || $signal) {
  96         $evalarg = $pre, &eval if $pre;
  97         print OUT $#stack . " levels deep in subroutine calls!\n"
  98             if $single & 4;
  99         $start = $line;
 100         while ((print OUT "  DB<", $#hist+1, "> "), $cmd=&gets) {
 101             $single = 0;
 102             $signal = 0;
 103             $cmd eq '' && exit 0;
 104             chop($cmd);
 105             $cmd =~ s/\\$// && do {
 106                 print OUT "  cont: ";
 107                 $cmd .= &gets;
 108                 redo;
 109             };
 110             $cmd =~ /^q$/ && exit 0;
 111             $cmd =~ /^$/ && ($cmd = $laststep);
 112             push(@hist,$cmd) if length($cmd) > 1;
 113             ($i) = split(/\s+/,$cmd);
 114             eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
 115             $cmd =~ /^h$/ && do {
 116                 print OUT "
 117 T               Stack trace.
 118 s               Single step.
 119 n               Next, steps over subroutine calls.
 120 r               Return from current subroutine.
 121 c [line]        Continue; optionally inserts a one-time-only breakpoint
 122                 at the specified line.
 123 <CR>            Repeat last n or s.
 124 l min+incr      List incr+1 lines starting at min.
 125 l min-max       List lines.
 126 l line          List line;
 127 l               List next window.
 128 -               List previous window.
 129 w line          List window around line.
 130 l subname       List subroutine.
 131 f filename      Switch to filename.
 132 /pattern/       Search forwards for pattern; final / is optional.
 133 ?pattern?       Search backwards for pattern.
 134 L               List breakpoints and actions.
 135 S               List subroutine names.
 136 t               Toggle trace mode.
 137 b [line] [condition]
 138                 Set breakpoint; line defaults to the current execution line;
 139                 condition breaks if it evaluates to true, defaults to \'1\'.
 140 b subname [condition]
 141                 Set breakpoint at first line of subroutine.
 142 d [line]        Delete breakpoint.
 143 D               Delete all breakpoints.
 144 a [line] command
 145                 Set an action to be done before the line is executed.
 146                 Sequence is: check for breakpoint, print line if necessary,
 147                 do action, prompt user if breakpoint or step, evaluate line.
 148 A               Delete all actions.
 149 V [pkg [vars]]  List some (default all) variables in package (default current).
 150 X [vars]        Same as \"V currentpackage [vars]\".
 151 < command       Define command before prompt.
 152 | command       Define command after prompt.
 153 ! number        Redo command (default previous command).
 154 ! -number       Redo number\'th to last command.
 155 H -number       Display last number commands (default all).
 156 q or ^D         Quit.
 157 p expr          Same as \"print DB'OUT expr\" in current package.
 158 = [alias value] Define a command alias, or list current aliases.
 159 command         Execute as a perl statement in current package.
 160
 161 ";
 162                 next; };
 163             $cmd =~ /^t$/ && do {
 164                 $trace = !$trace;
 165                 print OUT "Trace = ".($trace?"on":"off")."\n";
 166                 next; };
 167             $cmd =~ /^S$/ && do {
 168                 foreach $subname (sort(keys %sub)) {
 169                     print OUT $subname,"\n";
 170                 }
 171                 next; };
 172             $cmd =~ s/^X\b/V $package/;
 173             $cmd =~ /^V$/ && do {
 174                 $cmd = 'V $package'; };
 175             $cmd =~ /^V\s*(\S+)\s*(.*)/ && do {
 176                 $packname = $1;
 177                 @vars = split(' ',$2);
 178                 do 'dumpvar.pl' unless defined &main'dumpvar;
 179                 if (defined &main'dumpvar) {
 180                     &main'dumpvar($packname,@vars);
 181                 }
 182                 else {
 183                     print DB'OUT "dumpvar.pl not available.\n";
 184                 }
 185                 next; };
 186             $cmd =~ /^f\s*(.*)/ && do {
 187                 $file = $1;
 188                 if (!$file) {
 189                     print OUT "The old f command is now the r command.\n";
 190                     print OUT "The new f command switches filenames.\n";
 191                     next;
 192                 }
 193                 if (!defined $_main{'_<' . $file}) {
 194                     if (($try) = grep(m#^_<.*$file#, keys %_main)) {
 195                         $file = substr($try,2);
 196                         print "\n$file:\n";
 197                     }
 198                 }
 199                 if (!defined $_main{'_<' . $file}) {
 200                     print OUT "There's no code here anything matching $file.\n";
 201                     next;
 202                 }
 203                 elsif ($file ne $filename) {
 204                     *dbline = "_<$file";
 205                     $max = $#dbline;
 206                     $filename = $file;
 207                     $start = 1;
 208                     $cmd = "l";
 209                 } };
 210             $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
 211                 $subname = $1;
 212                 $subname = "main'" . $subname unless $subname =~ /'/;
 213                 $subname = "main" . $subname if substr($subname,0,1) eq "'";
 214                 ($file,$subrange) = split(/:/,$sub{$subname});
 215                 if ($file ne $filename) {
 216                     *dbline = "_<$file";
 217                     $max = $#dbline;
 218                     $filename = $file;
 219                 }
 220                 if ($subrange) {
 221                     if (eval($subrange) < -$window) {
 222                         $subrange =~ s/-.*/+/;
 223                     }
 224                     $cmd = "l $subrange";
 225                 } else {
 226                     print OUT "Subroutine $1 not found.\n";
 227                     next;
 228                 } };
 229             $cmd =~ /^w\s*(\d*)$/ && do {
 230                 $incr = $window - 1;
 231                 $start = $1 if $1;
 232                 $start -= $preview;
 233                 $cmd = 'l ' . $start . '-' . ($start + $incr); };
 234             $cmd =~ /^-$/ && do {
 235                 $incr = $window - 1;
 236                 $cmd = 'l ' . ($start-$window*2) . '+'; };
 237             $cmd =~ /^l$/ && do {
 238                 $incr = $window - 1;
 239                 $cmd = 'l ' . $start . '-' . ($start + $incr); };
 240             $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do {
 241                 $start = $1 if $1;
 242                 $incr = $2;
 243                 $incr = $window - 1 unless $incr;
 244                 $cmd = 'l ' . $start . '-' . ($start + $incr); };
 245             $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 246                 $end = (!$2) ? $max : ($4 ? $4 : $2);
 247                 $end = $max if $end > $max;
 248                 $i = $2;
 249                 $i = $line if $i eq '.';
 250                 $i = 1 if $i < 1;
 251                 if ($emacs) {
 252                     print OUT "\032\032$filename:$i:0\n";
 253                     $i = $end;
 254                 } else {
 255                     for (; $i <= $end; $i++) {
 256                         print OUT "$i:\t", $dbline[$i];
 257                         last if $signal;
 258                     }
 259                 }
 260                 $start = $i;    # remember in case they want more
 261                 $start = $max if $start > $max;
 262                 next; };
 263             $cmd =~ /^D$/ && do {
 264                 print OUT "Deleting all breakpoints...\n";
 265                 for ($i = 1; $i <= $max ; $i++) {
 266                     if (defined $dbline{$i}) {
 267                         $dbline{$i} =~ s/^[^\0]+//;
 268                         if ($dbline{$i} =~ s/^\0?$//) {
 269                             delete $dbline{$i};
 270                         }
 271                     }
 272                 }
 273                 next; };
 274             $cmd =~ /^L$/ && do {
 275                 for ($i = 1; $i <= $max; $i++) {
 276                     if (defined $dbline{$i}) {
 277                         print OUT "$i:\t", $dbline[$i];
 278                         ($stop,$action) = split(/\0/, $dbline{$i});
 279                         print OUT "  break if (", $stop, ")\n"
 280                             if $stop;
 281                         print OUT "  action:  ", $action, "\n"
 282                             if $action;
 283                         last if $signal;
 284                     }
 285                 }
 286                 next; };
 287             $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
 288                 $subname = $1;
 289                 $cond = $2 || '1';
 290                 $subname = "$package'" . $subname unless $subname =~ /'/;
 291                 $subname = "main" . $subname if substr($subname,0,1) eq "'";
 292                 ($filename,$i) = split(/[:-]/, $sub{$subname});
 293                 if ($i) {
 294                     *dbline = "_<$filename";
 295                     ++$i while $dbline[$i] == 0 && $i < $#dbline;
 296                     $dbline{$i} =~ s/^[^\0]*/$cond/;
 297                 } else {
 298                     print OUT "Subroutine $subname not found.\n";
 299                 }
 300                 next; };
 301             $cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
 302                 $i = ($1?$1:$line);
 303                 $cond = $2 || '1';
 304                 if ($dbline[$i] == 0) {
 305                     print OUT "Line $i not breakable.\n";
 306                 } else {
 307                     $dbline{$i} =~ s/^[^\0]*/$cond/;
 308                 }
 309                 next; };
 310             $cmd =~ /^d\s*(\d+)?/ && do {
 311                 $i = ($1?$1:$line);
 312                 $dbline{$i} =~ s/^[^\0]*//;
 313                 delete $dbline{$i} if $dbline{$i} eq '';
 314                 next; };
 315             $cmd =~ /^A$/ && do {
 316                 for ($i = 1; $i <= $max ; $i++) {
 317                     if (defined $dbline{$i}) {
 318                         $dbline{$i} =~ s/\0[^\0]*//;
 319                         delete $dbline{$i} if $dbline{$i} eq '';
 320                     }
 321                 }
 322                 next; };
 323             $cmd =~ /^<\s*(.*)/ && do {
 324                 $pre = do action($1);
 325                 next; };
 326             $cmd =~ /^>\s*(.*)/ && do {
 327                 $post = do action($1);
 328                 next; };
 329             $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do {
 330                 $i = $1;
 331                 if ($dbline[$i] == 0) {
 332                     print OUT "Line $i may not have an action.\n";
 333                 } else {
 334                     $dbline{$i} =~ s/\0[^\0]*//;
 335                     $dbline{$i} .= "\0" . do action($3);
 336                 }
 337                 next; };
 338             $cmd =~ /^n$/ && do {
 339                 $single = 2;
 340                 $laststep = $cmd;
 341                 last; };
 342             $cmd =~ /^s$/ && do {
 343                 $single = 1;
 344                 $laststep = $cmd;
 345                 last; };
 346             $cmd =~ /^c\s*(\d*)\s*$/ && do {
 347                 $i = $1;
 348                 if ($i) {
 349                     if ($dbline[$i] == 0) {
 350                         print OUT "Line $i not breakable.\n";
 351                         next;
 352                     }
 353                     $dbline{$i} =~ s/(\0|$)/;9$1/;      # add one-time-only b.p.
 354                 }
 355                 for ($i=0; $i <= $#stack; ) {
 356                     $stack[$i++] &= ~1;
 357                 }
 358                 last; };
 359             $cmd =~ /^r$/ && do {
 360                 $stack[$#stack] |= 2;
 361                 last; };
 362             $cmd =~ /^T$/ && do {
 363                 local($p,$f,$l,$s,$h,$a,@a,@sub);
 364                 for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
 365                     @a = @args;
 366                     for (@a) {
 367                         if (/^StB\000/ && length($_) == length($_main{'_main'})) {
 368                             $_ = sprintf("%s",$_);
 369                         }
 370                         else {
 371                             s/'/\\'/g;
 372                             s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
 373                             s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
 374                             s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
 375                         }
 376                     }
 377                     $w = $w ? '@ = ' : '$ = ';
 378                     $a = $h ? '(' . join(', ', @a) . ')' : '';
 379                     push(@sub, "$w&$s$a from file $f line $l\n");
 380                     last if $signal;
 381                 }
 382                 for ($i=0; $i <= $#sub; $i++) {
 383                     last if $signal;
 384                     print OUT $sub[$i];
 385                 }
 386                 next; };
 387             $cmd =~ /^\/(.*)$/ && do {
 388                 $inpat = $1;
 389                 $inpat =~ s:([^\\])/$:$1:;
 390                 if ($inpat ne "") {
 391                     eval '$inpat =~ m'."\n$inpat\n";
 392                     if ($@ ne "") {
 393                         print OUT "$@";
 394                         next;
 395                     }
 396                     $pat = $inpat;
 397                 }
 398                 $end = $start;
 399                 eval '
 400                 for (;;) {
 401                     ++$start;
 402                     $start = 1 if ($start > $max);
 403                     last if ($start == $end);
 404                     if ($dbline[$start] =~ m'."\n$pat\n".'i) {
 405                         if ($emacs) {
 406                             print OUT "\032\032$filename:$start:0\n";
 407                         } else {
 408                             print OUT "$start:\t", $dbline[$start], "\n";
 409                         }
 410                         last;
 411                     }
 412                 } ';
 413                 print OUT "/$pat/: not found\n" if ($start == $end);
 414                 next; };
 415             $cmd =~ /^\?(.*)$/ && do {
 416                 $inpat = $1;
 417                 $inpat =~ s:([^\\])\?$:$1:;
 418                 if ($inpat ne "") {
 419                     eval '$inpat =~ m'."\n$inpat\n";
 420                     if ($@ ne "") {
 421                         print OUT "$@";
 422                         next;
 423                     }
 424                     $pat = $inpat;
 425                 }
 426                 $end = $start;
 427                 eval '
 428                 for (;;) {
 429                     --$start;
 430                     $start = $max if ($start <= 0);
 431                     last if ($start == $end);
 432                     if ($dbline[$start] =~ m'."\n$pat\n".'i) {
 433                         if ($emacs) {
 434                             print OUT "\032\032$filename:$start:0\n";
 435                         } else {
 436                             print OUT "$start:\t", $dbline[$start], "\n";
 437                         }
 438                         last;
 439                     }
 440                 } ';
 441                 print OUT "?$pat?: not found\n" if ($start == $end);
 442                 next; };
 443             $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
 444                 pop(@hist) if length($cmd) > 1;
 445                 $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
 446                 $cmd = $hist[$i] . "\n";
 447                 print OUT $cmd;
 448                 redo; };
 449             $cmd =~ /^!(.+)$/ && do {
 450                 $pat = "^$1";
 451                 pop(@hist) if length($cmd) > 1;
 452                 for ($i = $#hist; $i; --$i) {
 453                     last if $hist[$i] =~ $pat;
 454                 }
 455                 if (!$i) {
 456                     print OUT "No such command!\n\n";
 457                     next;
 458                 }
 459                 $cmd = $hist[$i] . "\n";
 460                 print OUT $cmd;
 461                 redo; };
 462             $cmd =~ /^H\s*(-(\d+))?/ && do {
 463                 $end = $2?($#hist-$2):0;
 464                 $hist = 0 if $hist < 0;
 465                 for ($i=$#hist; $i>$end; $i--) {
 466                     print OUT "$i: ",$hist[$i],"\n"
 467                         unless $hist[$i] =~ /^.?$/;
 468                 };
 469                 next; };
 470             $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
 471             $cmd =~ /^=/ && do {
 472                 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
 473                     $alias{$k}="s~$k~$v~";
 474                     print OUT "$k = $v\n";
 475                 } elsif ($cmd =~ /^=\s*$/) {
 476                     foreach $k (sort keys(%alias)) {
 477                         if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
 478                             print OUT "$k = $v\n";
 479                         } else {
 480                             print OUT "$k\t$alias{$k}\n";
 481                         };
 482                     };
 483                 };
 484                 next; };
 485             $evalarg = $cmd; &eval;
 486             print OUT "\n";
 487         }
 488         if ($post) {
 489             $evalarg = $post; &eval;
 490         }
 491     }
 492     ($@, $!, $[, $,, $/, $\) = @saved;
 493 }
 494
 495 sub save {
 496     @saved = ($@, $!, $[, $,, $/, $\);
 497     $[ = 0; $, = ""; $/ = "\n"; $\ = "";
 498 }
 499
 500 # The following takes its argument via $evalarg to preserve current @_
 501
 502 sub eval {
 503     eval "$usercontext $evalarg; &DB'save";
 504     print OUT $@;
 505 }
 506
 507 sub action {
 508     local($action) = @_;
 509     while ($action =~ s/\\$//) {
 510         print OUT "+ ";
 511         $action .= &gets;
 512     }
 513     $action;
 514 }
 515
 516 sub gets {
 517     local($.);
 518     <IN>;
 519 }
 520
 521 sub catch {
 522     $signal = 1;
 523 }
 524
 525 sub sub {
 526     push(@stack, $single);
 527     $single &= 1;
 528     $single |= 4 if $#stack == $deep;
 529     if (wantarray) {
 530         @i = &$sub;
 531         $single |= pop(@stack);
 532         @i;
 533     }
 534     else {
 535         $i = &$sub;
 536         $single |= pop(@stack);
 537         $i;
 538     }
 539 }
 540
 541 $single = 1;                    # so it stops on first executable statement
 542 @hist = ('?');
 543 $SIG{'INT'} = "DB'catch";
 544 $deep = 100;            # warning if stack gets this deep
 545 $window = 10;
 546 $preview = 3;
 547
 548 @stack = (0);
 549 @ARGS = @ARGV;
 550 for (@args) {
 551     s/'/\\'/g;
 552     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
 553 }
 554
 555 if (-f '.perldb') {
 556     do './.perldb';
 557 }
 558 elsif (-f "$ENV{'LOGDIR'}/.perldb") {
 559     do "$ENV{'LOGDIR'}/.perldb";
 560 }
 561 elsif (-f "$ENV{'HOME'}/.perldb") {
 562     do "$ENV{'HOME'}/.perldb";
 563 }
 564
 565 1;