lib/perldb.pl

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