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, "<&STDERR")
  76     || open(OUT, ">&STDOUT");   # so we don't dongle stdout
  77 select(OUT);
  78 $| = 1;                         # for DB::OUT
  79 select(STDOUT);
  80 $| = 1;                         # for real STDOUT
  81 $sub = '';
  82
  83 # Is Perl being run from Emacs?
  84 $emacs = $main::ARGV[$[] eq '-emacs';
  85 shift(@main::ARGV) if $emacs;
  86
  87 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  88 print OUT "\nLoading DB routines from $header\n";
  89 print OUT ("Emacs support ",
  90            $emacs ? "enabled" : "available",
  91            ".\n");
  92 print OUT "\nEnter h for help.\n\n";
  93
  94 sub DB {
  95     &save;
  96     ($package, $filename, $line) = caller;
  97     $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
  98         "package $package;";            # this won't let them modify, alas
  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                     $subname = "main" . $subname if substr($subname,0,2)eq "::";
 247                     ($file,$subrange) = split(/:/,$sub{$subname});
 248                     if ($file ne $filename) {
 249                         *dbline = "::_<$file";
 250                         $max = $#dbline;
 251                         $filename = $file;
 252                     }
 253                     if ($subrange) {
 254                         if (eval($subrange) < -$window) {
 255                             $subrange =~ s/-.*/+/;
 256                         }
 257                         $cmd = "l $subrange";
 258                     } else {
 259                         print OUT "Subroutine $1 not found.\n";
 260                         next CMD;
 261                     } };
 262                 $cmd =~ /^w\b\s*(\d*)$/ && do {
 263                     $incr = $window - 1;
 264                     $start = $1 if $1;
 265                     $start -= $preview;
 266                     $cmd = 'l ' . $start . '-' . ($start + $incr); };
 267                 $cmd =~ /^-$/ && do {
 268                     $incr = $window - 1;
 269                     $cmd = 'l ' . ($start-$window*2) . '+'; };
 270                 $cmd =~ /^l$/ && do {
 271                     $incr = $window - 1;
 272                     $cmd = 'l ' . $start . '-' . ($start + $incr); };
 273                 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
 274                     $start = $1 if $1;
 275                     $incr = $2;
 276                     $incr = $window - 1 unless $incr;
 277                     $cmd = 'l ' . $start . '-' . ($start + $incr); };
 278                 $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 279                     $end = (!$2) ? $max : ($4 ? $4 : $2);
 280                     $end = $max if $end > $max;
 281                     $i = $2;
 282                     $i = $line if $i eq '.';
 283                     $i = 1 if $i < 1;
 284                     if ($emacs) {
 285                         print OUT "\032\032$filename:$i:0\n";
 286                         $i = $end;
 287                     } else {
 288                         for (; $i <= $end; $i++) {
 289                             print OUT "$i:\t", $dbline[$i];
 290                             last if $signal;
 291                         }
 292                     }
 293                     $start = $i;        # remember in case they want more
 294                     $start = $max if $start > $max;
 295                     next CMD; };
 296                 $cmd =~ /^D$/ && do {
 297                     print OUT "Deleting all breakpoints...\n";
 298                     for ($i = 1; $i <= $max ; $i++) {
 299                         if (defined $dbline{$i}) {
 300                             $dbline{$i} =~ s/^[^\0]+//;
 301                             if ($dbline{$i} =~ s/^\0?$//) {
 302                                 delete $dbline{$i};
 303                             }
 304                         }
 305                     }
 306                     next CMD; };
 307                 $cmd =~ /^L$/ && do {
 308                     for ($i = 1; $i <= $max; $i++) {
 309                         if (defined $dbline{$i}) {
 310                             print OUT "$i:\t", $dbline[$i];
 311                             ($stop,$action) = split(/\0/, $dbline{$i});
 312                             print OUT "  break if (", $stop, ")\n"
 313                                 if $stop;
 314                             print OUT "  action:  ", $action, "\n"
 315                                 if $action;
 316                             last if $signal;
 317                         }
 318                     }
 319                     next CMD; };
 320                 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 321                     $subname = $1;
 322                     $cond = $2 || '1';
 323                     $subname = "$package::" . $subname unless $subname =~ /'|::/;
 324                     $subname = "main" . $subname if substr($subname,0,1) eq "'";
 325                     $subname = "main" . $subname if substr($subname,0,2) eq "::";
 326                     ($filename,$i) = split(/:/, $sub{$subname});
 327                     $i += 0;
 328                     if ($i) {
 329                         *dbline = "::_<$filename";
 330                         ++$i while $dbline[$i] == 0 && $i < $#dbline;
 331                         $dbline{$i} =~ s/^[^\0]*/$cond/;
 332                     } else {
 333                         print OUT "Subroutine $subname not found.\n";
 334                     }
 335                     next CMD; };
 336                 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
 337                     $i = ($1?$1:$line);
 338                     $cond = $2 || '1';
 339                     if ($dbline[$i] == 0) {
 340                         print OUT "Line $i not breakable.\n";
 341                     } else {
 342                         $dbline{$i} =~ s/^[^\0]*/$cond/;
 343                     }
 344                     next CMD; };
 345                 $cmd =~ /^d\b\s*(\d+)?/ && do {
 346                     $i = ($1?$1:$line);
 347                     $dbline{$i} =~ s/^[^\0]*//;
 348                     delete $dbline{$i} if $dbline{$i} eq '';
 349                     next CMD; };
 350                 $cmd =~ /^A$/ && do {
 351                     for ($i = 1; $i <= $max ; $i++) {
 352                         if (defined $dbline{$i}) {
 353                             $dbline{$i} =~ s/\0[^\0]*//;
 354                             delete $dbline{$i} if $dbline{$i} eq '';
 355                         }
 356                     }
 357                     next CMD; };
 358                 $cmd =~ /^<\s*(.*)/ && do {
 359                     $pre = do action($1);
 360                     next CMD; };
 361                 $cmd =~ /^>\s*(.*)/ && do {
 362                     $post = do action($1);
 363                     next CMD; };
 364                 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
 365                     $i = $1;
 366                     if ($dbline[$i] == 0) {
 367                         print OUT "Line $i may not have an action.\n";
 368                     } else {
 369                         $dbline{$i} =~ s/\0[^\0]*//;
 370                         $dbline{$i} .= "\0" . do action($3);
 371                     }
 372                     next CMD; };
 373                 $cmd =~ /^n$/ && do {
 374                     $single = 2;
 375                     $laststep = $cmd;
 376                     last CMD; };
 377                 $cmd =~ /^s$/ && do {
 378                     $single = 1;
 379                     $laststep = $cmd;
 380                     last CMD; };
 381                 $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
 382                     $i = $1;
 383                     if ($i) {
 384                         if ($dbline[$i] == 0) {
 385                             print OUT "Line $i not breakable.\n";
 386                             next CMD;
 387                         }
 388                         $dbline{$i} =~ s/(\0|$)/;9$1/;  # add one-time-only b.p.
 389                     }
 390                     for ($i=0; $i <= $#stack; ) {
 391                         $stack[$i++] &= ~1;
 392                     }
 393                     last CMD; };
 394                 $cmd =~ /^r$/ && do {
 395                     $stack[$#stack] |= 2;
 396                     last CMD; };
 397                 $cmd =~ /^T$/ && do {
 398                     local($p,$f,$l,$s,$h,$a,@a,@sub);
 399                     for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
 400                         @a = @args;
 401                         for (@a) {
 402                             s/'/\\'/g;
 403                             s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
 404                             s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
 405                             s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
 406                         }
 407                         $w = $w ? '@ = ' : '$ = ';
 408                         $a = $h ? '(' . join(', ', @a) . ')' : '';
 409                         push(@sub, "$w&$s$a from file $f line $l\n");
 410                         last if $signal;
 411                     }
 412                     for ($i=0; $i <= $#sub; $i++) {
 413                         last if $signal;
 414                         print OUT $sub[$i];
 415                     }
 416                     next CMD; };
 417                 $cmd =~ /^\/(.*)$/ && do {
 418                     $inpat = $1;
 419                     $inpat =~ s:([^\\])/$:$1:;
 420                     if ($inpat ne "") {
 421                         eval '$inpat =~ m'."\n$inpat\n";
 422                         if ($@ ne "") {
 423                             print OUT "$@";
 424                             next CMD;
 425                         }
 426                         $pat = $inpat;
 427                     }
 428                     $end = $start;
 429                     eval '
 430                     for (;;) {
 431                         ++$start;
 432                         $start = 1 if ($start > $max);
 433                         last if ($start == $end);
 434                         if ($dbline[$start] =~ m'."\n$pat\n".'i) {
 435                             if ($emacs) {
 436                                 print OUT "\032\032$filename:$start:0\n";
 437                             } else {
 438                                 print OUT "$start:\t", $dbline[$start], "\n";
 439                             }
 440                             last;
 441                         }
 442                     } ';
 443                     print OUT "/$pat/: not found\n" if ($start == $end);
 444                     next CMD; };
 445                 $cmd =~ /^\?(.*)$/ && do {
 446                     $inpat = $1;
 447                     $inpat =~ s:([^\\])\?$:$1:;
 448                     if ($inpat ne "") {
 449                         eval '$inpat =~ m'."\n$inpat\n";
 450                         if ($@ ne "") {
 451                             print OUT "$@";
 452                             next CMD;
 453                         }
 454                         $pat = $inpat;
 455                     }
 456                     $end = $start;
 457                     eval '
 458                     for (;;) {
 459                         --$start;
 460                         $start = $max if ($start <= 0);
 461                         last if ($start == $end);
 462                         if ($dbline[$start] =~ m'."\n$pat\n".'i) {
 463                             if ($emacs) {
 464                                 print OUT "\032\032$filename:$start:0\n";
 465                             } else {
 466                                 print OUT "$start:\t", $dbline[$start], "\n";
 467                             }
 468                             last;
 469                         }
 470                     } ';
 471                     print OUT "?$pat?: not found\n" if ($start == $end);
 472                     next CMD; };
 473                 $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
 474                     pop(@hist) if length($cmd) > 1;
 475                     $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
 476                     $cmd = $hist[$i] . "\n";
 477                     print OUT $cmd;
 478                     redo CMD; };
 479                 $cmd =~ /^!(.+)$/ && do {
 480                     $pat = "^$1";
 481                     pop(@hist) if length($cmd) > 1;
 482                     for ($i = $#hist; $i; --$i) {
 483                         last if $hist[$i] =~ $pat;
 484                     }
 485                     if (!$i) {
 486                         print OUT "No such command!\n\n";
 487                         next CMD;
 488                     }
 489                     $cmd = $hist[$i] . "\n";
 490                     print OUT $cmd;
 491                     redo CMD; };
 492                 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
 493                     $end = $2?($#hist-$2):0;
 494                     $hist = 0 if $hist < 0;
 495                     for ($i=$#hist; $i>$end; $i--) {
 496                         print OUT "$i: ",$hist[$i],"\n"
 497                             unless $hist[$i] =~ /^.?$/;
 498                     };
 499                     next CMD; };
 500                 $cmd =~ s/^p( .*)?$/print DB::OUT$1/;
 501                 $cmd =~ /^=/ && do {
 502                     if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
 503                         $alias{$k}="s~$k~$v~";
 504                         print OUT "$k = $v\n";
 505                     } elsif ($cmd =~ /^=\s*$/) {
 506                         foreach $k (sort keys(%alias)) {
 507                             if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
 508                                 print OUT "$k = $v\n";
 509                             } else {
 510                                 print OUT "$k\t$alias{$k}\n";
 511                             };
 512                         };
 513                     };
 514                     next CMD; };
 515             }
 516             $evalarg = $cmd; &eval;
 517             print OUT "\n";
 518         }
 519         if ($post) {
 520             $evalarg = $post; &eval;
 521         }
 522     }
 523     ($@, $!, $[, $,, $/, $\) = @saved;
 524 }
 525
 526 sub save {
 527     @saved = ($@, $!, $[, $,, $/, $\);
 528     $[ = 0; $, = ""; $/ = "\n"; $\ = "";
 529 }
 530
 531 # The following takes its argument via $evalarg to preserve current @_
 532
 533 sub eval {
 534     eval "$usercontext $evalarg; &DB::save";
 535     print OUT $@;
 536 }
 537
 538 sub action {
 539     local($action) = @_;
 540     while ($action =~ s/\\$//) {
 541         print OUT "+ ";
 542         $action .= &gets;
 543     }
 544     $action;
 545 }
 546
 547 sub gets {
 548     local($.);
 549     <IN>;
 550 }
 551
 552 sub catch {
 553     $signal = 1;
 554 }
 555
 556 sub sub {
 557     push(@stack, $single);
 558     $single &= 1;
 559     $single |= 4 if $#stack == $deep;
 560     if (wantarray) {
 561         @i = &$sub;
 562         $single |= pop(@stack);
 563         @i;
 564     }
 565     else {
 566         $i = &$sub;
 567         $single |= pop(@stack);
 568         $i;
 569     }
 570 }
 571
 572 $single = 1;                    # so it stops on first executable statement
 573 @hist = ('?');
 574 $SIG{'INT'} = "DB::catch";
 575 $deep = 100;            # warning if stack gets this deep
 576 $window = 10;
 577 $preview = 3;
 578
 579 @stack = (0);
 580 @ARGS = @ARGV;
 581 for (@args) {
 582     s/'/\\'/g;
 583     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
 584 }
 585
 586 if (-f $rcfile) {
 587     do "./$rcfile";
 588 }
 589 elsif (-f "$ENV{'LOGDIR'}/$rcfile") {
 590     do "$ENV{'LOGDIR'}/$rcfile";
 591 }
 592 elsif (-f "$ENV{'HOME'}/$rcfile") {
 593     do "$ENV{'HOME'}/$rcfile";
 594 }
 595
 596 1;