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