lib/perl5db.pl

   1 package DB;
   2
   3 # Debugger for Perl 5.001m; perl5db.pl patch level:
   4
   5 $header = 'perl5db.pl patch level 0.93';
   6
   7 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
   8 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
   9
  10 # modified Perl debugger, to be run from Emacs in perldb-mode
  11 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  12 # Johan Vromans -- upgrade to 4.0 pl 10
  13 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  14
  15 #
  16 # This file is automatically included if you do perl -d.
  17 # It's probably not useful to include this yourself.
  18 #
  19 # Perl supplies the values for @line and %sub.  It effectively inserts
  20 # a &DB'DB(<linenum>); in front of every place that can have a
  21 # breakpoint. Instead of a subroutine call it calls &DB::sub with
  22 # $DB::sub being the called subroutine. It also inserts a BEGIN
  23 # {require 'perl5db.pl'} before the first line.
  24 #
  25 # Note that no subroutine call is possible until &DB::sub is defined
  26 # (for subroutines defined outside this file). In fact the same is
  27 # true if $deep is not defined.
  28 #
  29 # $Log: perldb.pl,v $
  30
  31 #
  32 # At start reads $rcfile that may set important options.  This file
  33 # may define a subroutine &afterinit that will be executed after the
  34 # debugger is initialized.
  35 #
  36 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
  37 # it as a rest of `O ...' line in debugger prompt.
  38 #
  39 # The options that can be specified only at startup:
  40 # [To set in $rcfile, call &parse_options("optionName=new_value").]
  41 #
  42 # TTY  - the TTY to use for debugging i/o.
  43 #
  44 # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  45 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  46 # Term::Rendezvous.  Current variant is to have the name of TTY in this
  47 # file.
  48 #
  49 # ReadLine - If false, dummy ReadLine is used, so you can debug
  50 # ReadLine applications.
  51 #
  52 # NonStop - if true, no i/o is performed until interrupt.
  53 #
  54 # LineInfo - file or pipe to print line number info to.  If it is a
  55 # pipe, a short "emacs like" message is used.
  56 #
  57 # Example $rcfile: (delete leading hashes!)
  58 #
  59 # &parse_options("NonStop=1 LineInfo=db.out");
  60 # sub afterinit { $trace = 1; }
  61 #
  62 # The script will run without human intervention, putting trace
  63 # information into db.out.  (If you interrupt it, you would better
  64 # reset LineInfo to something "interactive"!)
  65 #
  66
  67
  68 local($^W) = 0;
  69 warn (                  # Do not ;-)
  70       $dumpvar::hashDepth,
  71       $dumpvar::arrayDepth,
  72       $dumpvar::dumpDBFiles,
  73       $dumpvar::dumpPackages,
  74       $dumpvar::quoteHighBit,
  75       $dumpvar::printUndef,
  76       $dumpvar::globPrint,
  77       $readline::Tk_toloop,
  78       $dumpvar::usageOnly,
  79       @ARGS,
  80       $Carp::CarpLevel,
  81      ) if 0;
  82
  83 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
  84
  85 $trace = $signal = $single = 0; # Uninitialized warning suppression
  86                                 # (local $^W cannot help - other packages!).
  87 @stack = (0);
  88
  89 $option{PrintRet} = 1;
  90
  91 @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
  92                   compactDump veryCompact quote HighBit undefPrint
  93                   globPrint PrintRet UsageOnly frame
  94                   TTY noTTY ReadLine NonStop LineInfo
  95                   recallCommand ShellBang pager tkRunning
  96                   signalLevel warnLevel dieLevel);
  97
  98 %optionVars    = (
  99                  hashDepth      => \$dumpvar::hashDepth,
 100                  arrayDepth     => \$dumpvar::arrayDepth,
 101                  DumpDBFiles    => \$dumpvar::dumpDBFiles,
 102                  DumpPackages   => \$dumpvar::dumpPackages,
 103                  HighBit        => \$dumpvar::quoteHighBit,
 104                  undefPrint     => \$dumpvar::printUndef,
 105                  globPrint      => \$dumpvar::globPrint,
 106                  tkRunning      => \$readline::Tk_toloop,
 107                  UsageOnly      => \$dumpvar::usageOnly,
 108                   frame           => \$frame,
 109 );
 110
 111 %optionAction  = (
 112                   compactDump   => \&dumpvar::compactDump,
 113                   veryCompact   => \&dumpvar::veryCompact,
 114                   quote         => \&dumpvar::quote,
 115                   TTY           => \&TTY,
 116                   noTTY         => \&noTTY,
 117                   ReadLine      => \&ReadLine,
 118                   NonStop       => \&NonStop,
 119                   LineInfo      => \&LineInfo,
 120                   recallCommand => \&recallCommand,
 121                   ShellBang     => \&shellBang,
 122                   pager         => \&pager,
 123                   signalLevel   => \&signalLevel,
 124                   warnLevel     => \&warnLevel,
 125                   dieLevel      => \&dieLevel,
 126                  );
 127
 128 %optionRequire = (
 129                   compactDump   => 'dumpvar.pl',
 130                   veryCompact   => 'dumpvar.pl',
 131                   quote         => 'dumpvar.pl',
 132                  );
 133
 134 # These guys may be defined in $ENV{PERL5DB} :
 135 $rl = 1 unless defined $rl;
 136 warnLevel($warnLevel);
 137 dieLevel($dieLevel);
 138 signalLevel($signalLevel);
 139 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
 140 &recallCommand("!") unless defined $prc;
 141 &shellBang("!") unless defined $psh;
 142
 143 if (-e "/dev/tty") {
 144   $rcfile=".perldb";
 145 } else {
 146   $rcfile="perldb.ini";
 147 }
 148
 149 if (-f $rcfile) {
 150     do "./$rcfile";
 151 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
 152     do "$ENV{LOGDIR}/$rcfile";
 153 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
 154     do "$ENV{HOME}/$rcfile";
 155 }
 156
 157 if (defined $ENV{PERLDB_OPTS}) {
 158   parse_options($ENV{PERLDB_OPTS});
 159 }
 160
 161 if ($notty) {
 162   $runnonstop = 1;
 163 } else {
 164   # Is Perl being run from Emacs?
 165   $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
 166   $rl = 0, shift(@main::ARGV) if $emacs;
 167
 168   #require Term::ReadLine;
 169
 170   if (-e "/dev/tty") {
 171     $console = "/dev/tty";
 172   } elsif (-e "con") {
 173     $console = "con";
 174   } else {
 175     $console = "sys\$command";
 176   }
 177
 178   # Around a bug:
 179   if (defined $ENV{OS2_SHELL} and $emacs) { # In OS/2
 180     $console = undef;
 181   }
 182
 183   $console = $tty if defined $tty;
 184
 185   if (defined $console) {
 186     open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
 187     open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
 188       || open(OUT,">&STDOUT");  # so we don't dongle stdout
 189   } else {
 190     open(IN,"<&STDIN");
 191     open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
 192     $console = 'STDIN/OUT';
 193   }
 194   # so open("|more") can read from STDOUT and so we don't dingle stdin
 195   $IN = \*IN;
 196
 197   $OUT = \*OUT;
 198   select($OUT);
 199   $| = 1;                       # for DB::OUT
 200   select(STDOUT);
 201
 202   $LINEINFO = $OUT unless defined $LINEINFO;
 203   $lineinfo = $console unless defined $lineinfo;
 204
 205   $| = 1;                       # for real STDOUT
 206
 207   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
 208   unless ($runnonstop) {
 209     print $OUT "\nLoading DB routines from $header\n";
 210     print $OUT ("Emacs support ",
 211                 $emacs ? "enabled" : "available",
 212                 ".\n");
 213     print $OUT "\nEnter h or `h h' for help.\n\n";
 214   }
 215 }
 216
 217 @ARGS = @ARGV;
 218 for (@args) {
 219     s/\'/\\\'/g;
 220     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
 221 }
 222
 223 if (defined &afterinit) {       # May be defined in $rcfile
 224   &afterinit();
 225 }
 226
 227 ############################################################ Subroutines
 228
 229 # The following code may be executed now, but gives FPE later:
 230 # BEGIN {warn 5}
 231
 232 sub DB {
 233     if ($runnonstop) {          # Disable until signal
 234         for ($i=0; $i <= $#stack; ) {
 235             $stack[$i++] &= ~1;
 236         }
 237         $single = $runnonstop = 0; # Once only
 238         return;
 239     }
 240     &save;
 241     if ($doret) {
 242         $doret = 0;
 243         if ($option{PrintRet}) {
 244             print $OUT "$retctx context return from $lastsub:",
 245               ($retctx eq 'list') ? "\n" : " " ;
 246             dumpit( ($retctx eq 'list') ? \@ret : $ret );
 247         }
 248     }
 249     ($package, $filename, $line) = caller;
 250     $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
 251       "package $package;";      # this won't let them modify, alas
 252     local(*dbline) = "::_<$filename";
 253     $max = $#dbline;
 254     if (($stop,$action) = split(/\0/,$dbline{$line})) {
 255         if ($stop eq '1') {
 256             $signal |= 1;
 257         } else {
 258             $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
 259             $dbline{$line} =~ s/;9($|\0)/$1/;
 260         }
 261     }
 262     if ($single || $trace || $signal) {
 263         $term || &setterm;
 264         if ($emacs) {
 265             print $LINEINFO "\032\032$filename:$line:0\n";
 266         } else {
 267             $sub =~ s/\'/::/;
 268             $prefix = $sub =~ /::/ ? "" : "${'package'}::";
 269             $prefix .= "$sub($filename:";
 270             $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
 271             if (length($prefix) > 30) {
 272                 print $LINEINFO "$prefix$line):\n$line:\t", $dbline[$line], $after;
 273                 $prefix = "";
 274                 $infix = ":\t";
 275             } else {
 276                 $infix = "):\t";
 277                 print $LINEINFO "$prefix$line$infix",$dbline[$line], $after;
 278             }
 279             for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
 280                 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
 281                 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
 282                 print $LINEINFO "$prefix$i$infix", $dbline[$i], $after;
 283             }
 284         }
 285     }
 286     $evalarg = $action, &eval if $action;
 287     if ($single || $signal) {
 288         local $level = $level + 1;
 289         $evalarg = $pre, &eval if $pre;
 290         print $OUT $#stack . " levels deep in subroutine calls!\n"
 291           if $single & 4;
 292         $start = $line;
 293       CMD:
 294         while (($term || &setterm),
 295                defined ($cmd=$term->readline("  DB" . ('<' x $level) .
 296                                              ($#hist+1) . ('>' x $level) .
 297                                              " "))) {
 298             {                   # <-- Do we know what this brace is for?
 299                 $single = 0;
 300                 $signal = 0;
 301                 $cmd =~ s/\\$/\n/ && do {
 302                     $cmd .= $term->readline("  cont: ");
 303                     redo CMD;
 304                 };
 305                 $cmd =~ /^q$/ && exit 0;
 306                 $cmd =~ /^$/ && ($cmd = $laststep);
 307                 push(@hist,$cmd) if length($cmd) > 1;
 308               PIPE: {
 309                     ($i) = split(/\s+/,$cmd);
 310                     eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
 311                     $cmd =~ /^h$/ && do {
 312                         print $OUT $help;
 313                         next CMD; };
 314                     $cmd =~ /^h\s+h$/ && do {
 315                         print $OUT $summary;
 316                         next CMD; };
 317                     $cmd =~ /^h\s+(\S)$/ && do {
 318                         my $asked = "\Q$1";
 319                         if ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/m) {
 320                             print $OUT $1;
 321                         } else {
 322                             print $OUT "`$asked' is not a debugger command.\n";
 323                         }
 324                         next CMD; };
 325                     $cmd =~ /^t$/ && do {
 326                         $trace = !$trace;
 327                         print $OUT "Trace = ".($trace?"on":"off")."\n";
 328                         next CMD; };
 329                     $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
 330                         $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
 331                         foreach $subname (sort(keys %sub)) {
 332                             if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
 333                                 print $OUT $subname,"\n";
 334                             }
 335                         }
 336                         next CMD; };
 337                     $cmd =~ s/^X\b/V $package/;
 338                     $cmd =~ /^V$/ && do {
 339                         $cmd = "V $package"; };
 340                     $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
 341                         local ($savout) = select($OUT);
 342                         $packname = $1;
 343                         @vars = split(' ',$2);
 344                         do 'dumpvar.pl' unless defined &main::dumpvar;
 345                         if (defined &main::dumpvar) {
 346                             &main::dumpvar($packname,@vars);
 347                         } else {
 348                             print $OUT "dumpvar.pl not available.\n";
 349                         }
 350                         select ($savout);
 351                         next CMD; };
 352                     $cmd =~ s/^x\b/ / && do { # So that will be evaled
 353                         $onetimeDump = 1; };
 354                     $cmd =~ /^f\b\s*(.*)/ && do {
 355                         $file = $1;
 356                         if (!$file) {
 357                             print $OUT "The old f command is now the r command.\n";
 358                             print $OUT "The new f command switches filenames.\n";
 359                             next CMD;
 360                         }
 361                         if (!defined $main::{'_<' . $file}) {
 362                             if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
 363                                               $file = substr($try,2);
 364                                               print "\n$file:\n";
 365                                           }}
 366                         }
 367                         if (!defined $main::{'_<' . $file}) {
 368                             print $OUT "There's no code here matching $file.\n";
 369                             next CMD;
 370                         } elsif ($file ne $filename) {
 371                             *dbline = "::_<$file";
 372                             $max = $#dbline;
 373                             $filename = $file;
 374                             $start = 1;
 375                             $cmd = "l";
 376                         } };
 377                     $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
 378                         $subname = $1;
 379                         $subname =~ s/\'/::/;
 380                         $subname = "main::".$subname unless $subname =~ /::/;
 381                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 382                         @pieces = split(/:/,$sub{$subname});
 383                         $subrange = pop @pieces;
 384                         $file = join(':', @pieces);
 385                         if ($file ne $filename) {
 386                             *dbline = "::_<$file";
 387                             $max = $#dbline;
 388                             $filename = $file;
 389                         }
 390                         if ($subrange) {
 391                             if (eval($subrange) < -$window) {
 392                                 $subrange =~ s/-.*/+/;
 393                             }
 394                             $cmd = "l $subrange";
 395                         } else {
 396                             print $OUT "Subroutine $subname not found.\n";
 397                             next CMD;
 398                         } };
 399                     $cmd =~ /^w\b\s*(\d*)$/ && do {
 400                         $incr = $window - 1;
 401                         $start = $1 if $1;
 402                         $start -= $preview;
 403                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 404                     $cmd =~ /^-$/ && do {
 405                         $incr = $window - 1;
 406                         $cmd = 'l ' . ($start-$window*2) . '+'; };
 407                     $cmd =~ /^l$/ && do {
 408                         $incr = $window - 1;
 409                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 410                     $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
 411                         $start = $1 if $1;
 412                         $incr = $2;
 413                         $incr = $window - 1 unless $incr;
 414                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 415                     $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 416                         $end = (!$2) ? $max : ($4 ? $4 : $2);
 417                         $end = $max if $end > $max;
 418                         $i = $2;
 419                         $i = $line if $i eq '.';
 420                         $i = 1 if $i < 1;
 421                         if ($emacs) {
 422                             print $OUT "\032\032$filename:$i:0\n";
 423                             $i = $end;
 424                         } else {
 425                             for (; $i <= $end; $i++) {
 426                                 print $OUT "$i:\t", $dbline[$i];
 427                                 last if $signal;
 428                             }
 429                         }
 430                         $start = $i; # remember in case they want more
 431                         $start = $max if $start > $max;
 432                         next CMD; };
 433                     $cmd =~ /^D$/ && do {
 434                         print $OUT "Deleting all breakpoints...\n";
 435                         for ($i = 1; $i <= $max ; $i++) {
 436                             if (defined $dbline{$i}) {
 437                                 $dbline{$i} =~ s/^[^\0]+//;
 438                                 if ($dbline{$i} =~ s/^\0?$//) {
 439                                     delete $dbline{$i};
 440                                 }
 441                             }
 442                         }
 443                         next CMD; };
 444                     $cmd =~ /^L$/ && do {
 445                         for ($i = 1; $i <= $max; $i++) {
 446                             if (defined $dbline{$i}) {
 447                                 print $OUT "$i:\t", $dbline[$i];
 448                                 ($stop,$action) = split(/\0/, $dbline{$i});
 449                                 print $OUT "  break if (", $stop, ")\n"
 450                                   if $stop;
 451                                 print $OUT "  action:  ", $action, "\n"
 452                                   if $action;
 453                                 last if $signal;
 454                             }
 455                         }
 456                         next CMD; };
 457                     $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 458                         $subname = $1;
 459                         $cond = $2 || '1';
 460                         $subname =~ s/\'/::/;
 461                         $subname = "${'package'}::" . $subname
 462                           unless $subname =~ /::/;
 463                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 464                         # Filename below can contain ':'
 465                         ($file,$i) = ($sub{$subname} =~ /^(.*):(.*)$/);
 466                         $i += 0;
 467                         if ($i) {
 468                             $filename = $file;
 469                             *dbline = "::_<$filename";
 470                             $max = $#dbline;
 471                             ++$i while $dbline[$i] == 0 && $i < $max;
 472                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 473                         } else {
 474                             print $OUT "Subroutine $subname not found.\n";
 475                         }
 476                         next CMD; };
 477                     $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
 478                         $i = ($1?$1:$line);
 479                         $cond = $2 || '1';
 480                         if ($dbline[$i] == 0) {
 481                             print $OUT "Line $i not breakable.\n";
 482                         } else {
 483                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 484                         }
 485                         next CMD; };
 486                     $cmd =~ /^d\b\s*(\d+)?/ && do {
 487                         $i = ($1?$1:$line);
 488                         $dbline{$i} =~ s/^[^\0]*//;
 489                         delete $dbline{$i} if $dbline{$i} eq '';
 490                         next CMD; };
 491                     $cmd =~ /^A$/ && do {
 492                         for ($i = 1; $i <= $max ; $i++) {
 493                             if (defined $dbline{$i}) {
 494                                 $dbline{$i} =~ s/\0[^\0]*//;
 495                                 delete $dbline{$i} if $dbline{$i} eq '';
 496                             }
 497                         }
 498                         next CMD; };
 499                     $cmd =~ /^O\s*$/ && do {
 500                         for (@options) {
 501                             &dump_option($_);
 502                         }
 503                         next CMD; };
 504                     $cmd =~ /^O\s*(\S.*)/ && do {
 505                         parse_options($1);
 506                         next CMD; };
 507                     $cmd =~ /^<\s*(.*)/ && do {
 508                         $pre = action($1);
 509                         next CMD; };
 510                     $cmd =~ /^>\s*(.*)/ && do {
 511                         $post = action($1);
 512                         next CMD; };
 513                     $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
 514                         $i = $1; $j = $3;
 515                         if ($dbline[$i] == 0) {
 516                             print $OUT "Line $i may not have an action.\n";
 517                         } else {
 518                             $dbline{$i} =~ s/\0[^\0]*//;
 519                             $dbline{$i} .= "\0" . action($j);
 520                         }
 521                         next CMD; };
 522                     $cmd =~ /^n$/ && do {
 523                         $single = 2;
 524                         $laststep = $cmd;
 525                         last CMD; };
 526                     $cmd =~ /^s$/ && do {
 527                         $single = 1;
 528                         $laststep = $cmd;
 529                         last CMD; };
 530                     $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
 531                         $i = $1;
 532                         if ($i) {
 533                             if ($dbline[$i] == 0) {
 534                                 print $OUT "Line $i not breakable.\n";
 535                                 next CMD;
 536                             }
 537                             $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
 538                         }
 539                         for ($i=0; $i <= $#stack; ) {
 540                             $stack[$i++] &= ~1;
 541                         }
 542                         last CMD; };
 543                     $cmd =~ /^r$/ && do {
 544                         $stack[$#stack] |= 1;
 545                         $doret = 1;
 546                         last CMD; };
 547                     $cmd =~ /^T$/ && do {
 548                         local($p,$f,$l,$s,$h,$a,$e,$r,@a,@sub);
 549                         for ($i = 1;
 550                              ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i);
 551                              $i++) {
 552                             @a = ();
 553                             for $arg (@args) {
 554                                 $_ = "$arg";
 555                                 s/([\'\\])/\\$1/g;
 556                                 s/([^\0]*)/'$1'/
 557                                   unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
 558                                 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
 559                                 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
 560                                 push(@a, $_);
 561                             }
 562                             $w = $w ? '@ = ' : '$ = ';
 563                             $a = $h ? '(' . join(', ', @a) . ')' : '';
 564                             $e =~ s/\n\s*\;\s*\Z// if $e;
 565                             $e =~ s/[\\\']/\\$1/g if $e;
 566                             if ($r) {
 567                               $s = "require '$e'";
 568                             } elsif (defined $r) {
 569                               $s = "eval '$e'";
 570                             } elsif ($s eq '(eval)') {
 571                               $s = "eval {...}";
 572                             }
 573                             $f = "file `$f'" unless $f eq '-e';
 574                             push(@sub, "$w$s$a called from $f line $l\n");
 575                             last if $signal;
 576                         }
 577                         for ($i=0; $i <= $#sub; $i++) {
 578                             last if $signal;
 579                             print $OUT $sub[$i];
 580                         }
 581                         next CMD; };
 582                     $cmd =~ /^\/(.*)$/ && do {
 583                         $inpat = $1;
 584                         $inpat =~ s:([^\\])/$:$1:;
 585                         if ($inpat ne "") {
 586                             eval '$inpat =~ m'."\a$inpat\a";
 587                             if ($@ ne "") {
 588                                 print $OUT "$@";
 589                                 next CMD;
 590                             }
 591                             $pat = $inpat;
 592                         }
 593                         $end = $start;
 594                         eval '
 595                             for (;;) {
 596                                 ++$start;
 597                                 $start = 1 if ($start > $max);
 598                                 last if ($start == $end);
 599                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
 600                                     if ($emacs) {
 601                                         print $OUT "\032\032$filename:$start:0\n";
 602                                     } else {
 603                                         print $OUT "$start:\t", $dbline[$start], "\n";
 604                                     }
 605                                     last;
 606                                 }
 607                             } ';
 608                         print $OUT "/$pat/: not found\n" if ($start == $end);
 609                         next CMD; };
 610                     $cmd =~ /^\?(.*)$/ && do {
 611                         $inpat = $1;
 612                         $inpat =~ s:([^\\])\?$:$1:;
 613                         if ($inpat ne "") {
 614                             eval '$inpat =~ m'."\a$inpat\a";
 615                             if ($@ ne "") {
 616                                 print $OUT "$@";
 617                                 next CMD;
 618                             }
 619                             $pat = $inpat;
 620                         }
 621                         $end = $start;
 622                         eval '
 623                             for (;;) {
 624                                 --$start;
 625                                 $start = $max if ($start <= 0);
 626                                 last if ($start == $end);
 627                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
 628                                     if ($emacs) {
 629                                         print $OUT "\032\032$filename:$start:0\n";
 630                                     } else {
 631                                         print $OUT "$start:\t", $dbline[$start], "\n";
 632                                     }
 633                                     last;
 634                                 }
 635                             } ';
 636                         print $OUT "?$pat?: not found\n" if ($start == $end);
 637                         next CMD; };
 638                     $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
 639                         pop(@hist) if length($cmd) > 1;
 640                         $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
 641                         $cmd = $hist[$i] . "\n";
 642                         print $OUT $cmd;
 643                         redo CMD; };
 644                     $cmd =~ /^$sh$sh\s*/ && do {
 645                         &system($');
 646                         next CMD; };
 647                     $cmd =~ /^$rc([^$rc].*)$/ && do {
 648                         $pat = "^$1";
 649                         pop(@hist) if length($cmd) > 1;
 650                         for ($i = $#hist; $i; --$i) {
 651                             last if $hist[$i] =~ /$pat/;
 652                         }
 653                         if (!$i) {
 654                             print $OUT "No such command!\n\n";
 655                             next CMD;
 656                         }
 657                         $cmd = $hist[$i] . "\n";
 658                         print $OUT $cmd;
 659                         redo CMD; };
 660                     $cmd =~ /^$sh$/ && do {
 661                         &system($ENV{SHELL}||"/bin/sh");
 662                         next CMD; };
 663                     $cmd =~ /^$sh\s*/ && do {
 664                         &system($ENV{SHELL}||"/bin/sh","-c",$');
 665                         next CMD; };
 666                     $cmd =~ /^H\b\s*(-(\d+))?/ && do {
 667                         $end = $2?($#hist-$2):0;
 668                         $hist = 0 if $hist < 0;
 669                         for ($i=$#hist; $i>$end; $i--) {
 670                             print $OUT "$i: ",$hist[$i],"\n"
 671                               unless $hist[$i] =~ /^.?$/;
 672                         };
 673                         next CMD; };
 674                     $cmd =~ s/^p$/print \$DB::OUT \$_/;
 675                     $cmd =~ s/^p\b/print \$DB::OUT /;
 676                     $cmd =~ /^=/ && do {
 677                         if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
 678                             $alias{$k}="s~$k~$v~";
 679                             print $OUT "$k = $v\n";
 680                         } elsif ($cmd =~ /^=\s*$/) {
 681                             foreach $k (sort keys(%alias)) {
 682                                 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
 683                                     print $OUT "$k = $v\n";
 684                                 } else {
 685                                     print $OUT "$k\t$alias{$k}\n";
 686                                 };
 687                             };
 688                         };
 689                         next CMD; };
 690                     $cmd =~ /^\|\|?\s*[^|]/ && do {
 691                         if ($pager =~ /^\|/) {
 692                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
 693                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
 694                         } else {
 695                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
 696                         }
 697                         unless ($piped=open(OUT,$pager)) {
 698                             &warn("Can't pipe output to `$pager'");
 699                             if ($pager =~ /^\|/) {
 700                                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
 701                                 open(STDOUT,">&SAVEOUT")
 702                                   || &warn("Can't restore STDOUT");
 703                                 close(SAVEOUT);
 704                             } else {
 705                                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
 706                             }
 707                             next CMD;
 708                         }
 709                         $SIG{PIPE}= "DB::catch" if $pager =~ /^\|/
 710                           && "" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE};
 711                         $selected= select(OUT);
 712                         $|= 1;
 713                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
 714                         $cmd =~ s/^\|+\s*//;
 715                         redo PIPE; };
 716                     # XXX Local variants do not work!
 717                     $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
 718                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
 719                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
 720                 }               # PIPE:
 721             }                   # <-- Do we know what this brace is for?
 722             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
 723             if ($onetimeDump) {
 724                 $onetimeDump = undef;
 725             } else {
 726                 print $OUT "\n";
 727             }
 728         } continue {            # CMD:
 729             if ($piped) {
 730                 if ($pager =~ /^\|/) {
 731                     $?= 0;  close(OUT) || &warn("Can't close DB::OUT");
 732                     &warn( "Pager `$pager' failed: ",
 733                           ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
 734                           ( $? & 128 ) ? " (core dumped)" : "",
 735                           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
 736                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
 737                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
 738                     $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq "DB::catch";
 739                     # Will stop ignoring SIGPIPE if done like nohup(1)
 740                     # does SIGINT but Perl doesn't give us a choice.
 741                 } else {
 742                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
 743                 }
 744                 close(SAVEOUT);
 745                 select($selected), $selected= "" unless $selected eq "";
 746                 $piped= "";
 747             }
 748         }                       # CMD:
 749         if ($post) {
 750             $evalarg = $post; &eval;
 751         }
 752     }                           # if ($single || $signal)
 753     ($@, $!, $,, $/, $\, $^W) = @saved;
 754     ();
 755 }
 756
 757 # The following code may be executed now:
 758 # BEGIN {warn 4}
 759
 760 sub sub {
 761     print $LINEINFO ' ' x $#stack, "entering $sub\n" if $frame;
 762     push(@stack, $single);
 763     $single &= 1;
 764     $single |= 4 if $#stack == $deep;
 765     if (wantarray) {
 766         @ret = &$sub;
 767         $single |= pop(@stack);
 768         $retctx = "list";
 769         $lastsub = $sub;
 770 print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
 771         @ret;
 772     } else {
 773         $ret = &$sub;
 774         $single |= pop(@stack);
 775         $retctx = "scalar";
 776         $lastsub = $sub;
 777 print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
 778         $ret;
 779     }
 780 }
 781
 782 sub save {
 783     @saved = ($@, $!, $,, $/, $\, $^W);
 784     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
 785 }
 786
 787 # The following takes its argument via $evalarg to preserve current @_
 788
 789 sub eval {
 790     my @res;
 791     {
 792         local (@stack) = @stack; # guard against recursive debugging
 793         my $otrace = $trace;
 794         my $osingle = $single;
 795         my $od = $^D;
 796         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
 797         $trace = $otrace;
 798         $single = $osingle;
 799         $^D = $od;
 800     }
 801     my $at = $@;
 802     eval "&DB::save";
 803     if ($at) {
 804         print $OUT $at;
 805     } elsif ($onetimeDump) {
 806         dumpit(\@res);
 807     }
 808 }
 809
 810 sub dumpit {
 811     local ($savout) = select($OUT);
 812     do 'dumpvar.pl' unless defined &main::dumpValue;
 813     if (defined &main::dumpValue) {
 814         &main::dumpValue(shift);
 815     } else {
 816         print $OUT "dumpvar.pl not available.\n";
 817     }
 818     select ($savout);
 819 }
 820
 821 sub action {
 822     my $action = shift;
 823     while ($action =~ s/\\$//) {
 824         #print $OUT "+ ";
 825         #$action .= "\n";
 826         $action .= &gets;
 827     }
 828     $action;
 829 }
 830
 831 sub gets {
 832     local($.);
 833     #<IN>;
 834     &readline("cont: ");
 835 }
 836
 837 sub system {
 838     # We save, change, then restore STDIN and STDOUT to avoid fork() since
 839     # many non-Unix systems can do system() but have problems with fork().
 840     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
 841     open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
 842     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
 843     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
 844     system(@_);
 845     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
 846     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
 847     close(SAVEIN); close(SAVEOUT);
 848     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
 849           ( $? & 128 ) ? " (core dumped)" : "",
 850           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
 851     $?;
 852 }
 853
 854 sub setterm {
 855     eval "require Term::ReadLine;" or die $@;
 856     if ($notty) {
 857         if ($tty) {
 858             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
 859             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
 860             $IN = \*IN;
 861             $OUT = \*OUT;
 862             my $sel = select($OUT);
 863             $| = 1;
 864             select($sel);
 865         } else {
 866             eval "require Term::Rendezvous;" or die $@;
 867             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
 868             my $term_rv = new Term::Rendezvous $rv;
 869             $IN = $term_rv->IN;
 870             $OUT = $term_rv->OUT;
 871         }
 872     }
 873     if (!$rl) {
 874         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
 875     } else {
 876         $term = new Term::ReadLine 'perldb', $IN, $OUT;
 877
 878         $readline::rl_basic_word_break_characters .= "[:"
 879           if defined $readline::rl_basic_word_break_characters
 880             and index($readline::rl_basic_word_break_characters, ":") == -1;
 881     }
 882     $LINEINFO = $OUT unless defined $LINEINFO;
 883     $lineinfo = $console unless defined $lineinfo;
 884     $term->MinLine(2);
 885 }
 886
 887 sub readline {
 888   local $frame = 0;
 889   $term->readline(@_);
 890 }
 891
 892 sub dump_option {
 893     my ($opt, $val)= @_;
 894     if (defined $optionVars{$opt}
 895         and defined $ {$optionVars{$opt}}) {
 896         $val = $ {$optionVars{$opt}};
 897     } elsif (defined $optionAction{$opt}
 898         and defined &{$optionAction{$opt}}) {
 899         $val = &{$optionAction{$opt}}();
 900     } elsif (defined $optionAction{$opt}
 901              and not defined $option{$opt}
 902              or defined $optionVars{$opt}
 903              and not defined $ {$optionVars{$opt}}) {
 904         $val = 'N/A';
 905     } else {
 906         $val = $option{$opt};
 907     }
 908     $val =~ s/[\\\']/\\$&/g;
 909     printf $OUT "%20s = '%s'\n", $opt, $val;
 910 }
 911
 912 sub parse_options {
 913     local($_)= @_;
 914     while ($_ ne "") {
 915         s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
 916         my ($opt,$sep) = ($1,$2);
 917         my $val;
 918         if ("?" eq $sep) {
 919             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
 920               if /^\S/;
 921             #&dump_option($opt);
 922         } elsif ($sep !~ /\S/) {
 923             $val = "1";
 924         } elsif ($sep eq "=") {
 925             s/^(\S*)($|\s+)//;
 926             $val = $1;
 927         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
 928             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
 929             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
 930               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
 931             $val = $1;
 932             $val =~ s/\\([\\$end])/$1/g;
 933         }
 934         my ($option);
 935         my $matches =
 936           grep(  /^\Q$opt/ && ($option = $_),  @options  );
 937         $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
 938           unless $matches;
 939         print $OUT "Unknown option `$opt'\n" unless $matches;
 940         print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
 941         $option{$option} = $val if $matches == 1 and defined $val;
 942         eval "require '$optionRequire{$option}'"
 943           if $matches == 1 and defined $optionRequire{$option} and defined $val;
 944         $ {$optionVars{$option}} = $val
 945           if $matches == 1
 946             and defined $optionVars{$option} and defined $val;
 947         & {$optionAction{$option}} ($val)
 948           if $matches == 1
 949             and defined $optionAction{$option}
 950               and defined &{$optionAction{$option}} and defined $val;
 951         &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
 952         s/^\s+//;
 953     }
 954 }
 955
 956 sub catch {
 957     $signal = 1;
 958 }
 959
 960 sub warn {
 961     my($msg)= join("",@_);
 962     $msg .= ": $!\n" unless $msg =~ /\n$/;
 963     print $OUT $msg;
 964 }
 965
 966 sub TTY {
 967     if ($term) {
 968         &warn("Too late to set TTY!\n") if @_;
 969     } else {
 970         $tty = shift if @_;
 971     }
 972     $tty or $console;
 973 }
 974
 975 sub noTTY {
 976     if ($term) {
 977         &warn("Too late to set noTTY!\n") if @_;
 978     } else {
 979         $notty = shift if @_;
 980     }
 981     $notty;
 982 }
 983
 984 sub ReadLine {
 985     if ($term) {
 986         &warn("Too late to set ReadLine!\n") if @_;
 987     } else {
 988         $rl = shift if @_;
 989     }
 990     $rl;
 991 }
 992
 993 sub NonStop {
 994     if ($term) {
 995         &warn("Too late to set up NonStop mode!\n") if @_;
 996     } else {
 997         $runnonstop = shift if @_;
 998     }
 999     $runnonstop;
1000 }
1001
1002 sub pager {
1003     if (@_) {
1004         $pager = shift;
1005         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1006     }
1007     $pager;
1008 }
1009
1010 sub shellBang {
1011     if (@_) {
1012         $sh = quotemeta shift;
1013         $sh .= "\\b" if $sh =~ /\w$/;
1014     }
1015     $psh = $sh;
1016     $psh =~ s/\\b$//;
1017     $psh =~ s/\\(.)/$1/g;
1018     &sethelp;
1019     $psh;
1020 }
1021
1022 sub recallCommand {
1023     if (@_) {
1024         $rc = quotemeta shift;
1025         $rc .= "\\b" if $rc =~ /\w$/;
1026     }
1027     $prc = $rc;
1028     $prc =~ s/\\b$//;
1029     $prc =~ s/\\(.)/$1/g;
1030     &sethelp;
1031     $prc;
1032 }
1033
1034 sub LineInfo {
1035     return $lineinfo unless @_;
1036     $lineinfo = shift;
1037     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1038     $emacs = ($stream =~ /^\|/);
1039     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1040     $LINEINFO = \*LINEINFO;
1041     my $save = select($LINEINFO);
1042     $| = 1;
1043     select($save);
1044     $lineinfo;
1045 }
1046
1047 sub sethelp {
1048     $help = "
1049 T               Stack trace.
1050 s [expr]        Single step [in expr].
1051 n [expr]        Next, steps over subroutine calls [in expr].
1052 <CR>            Repeat last n or s command.
1053 r               Return from current subroutine.
1054 c [line]        Continue; optionally inserts a one-time-only breakpoint
1055                 at the specified line.
1056 l min+incr      List incr+1 lines starting at min.
1057 l min-max       List lines min through max.
1058 l line          List single line.
1059 l subname       List first window of lines from subroutine.
1060 l               List next window of lines.
1061 -               List previous window of lines.
1062 w [line]        List window around line.
1063 f filename      Switch to viewing filename.
1064 /pattern/       Search forwards for pattern; final / is optional.
1065 ?pattern?       Search backwards for pattern; final ? is optional.
1066 L               List all breakpoints and actions.
1067 S [[!]pattern]  List subroutine names [not] matching pattern.
1068 t               Toggle trace mode.
1069 t expr          Trace through execution of expr.
1070 b [line] [condition]
1071                 Set breakpoint; line defaults to the current execution line;
1072                 condition breaks if it evaluates to true, defaults to '1'.
1073 b subname [condition]
1074                 Set breakpoint at first line of subroutine.
1075 d [line]        Delete the breakpoint for line.
1076 D               Delete all breakpoints.
1077 a [line] command
1078                 Set an action to be done before the line is executed.
1079                 Sequence is: check for breakpoint, print line if necessary,
1080                 do action, prompt user if breakpoint or step, evaluate line.
1081 A               Delete all actions.
1082 V [pkg [vars]]  List some (default all) variables in package (default current).
1083                 Use ~pattern and !pattern for positive and negative regexps.
1084 X [vars]        Same as \"V currentpackage [vars]\".
1085 x expr          Evals expression in array context, dumps the result.
1086 O [opt[=val]] [opt\"val\"] [opt?]...
1087                 Set or query values of options.  val defaults to 1.  opt can
1088                 be abbreviated.  Several options can be listed.
1089     recallCommand, ShellBang:   chars used to recall command or spawn shell;
1090     pager:                      program for output of \"|cmd\";
1091   The following options affect what happens with V, X, and x commands:
1092     arrayDepth, hashDepth:      print only first N elements ('' for all);
1093     compactDump, veryCompact:   change style of array and hash dump;
1094     globPrint:                  whether to print contents of globs;
1095     DumpDBFiles:                dump arrays holding debugged files;
1096     DumpPackages:               dump symbol tables of packages;
1097     quote, HighBit, undefPrint: change style of string dump;
1098     tkRunning:                  run Tk while prompting (with ReadLine);
1099     signalLevel warnLevel dieLevel:     level of verbosity;
1100   Option PrintRet affects printing of return value after r command,
1101          frame    affects printing messages on entry and exit from subroutines.
1102                 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1103                 You can put additional initialization options TTY, noTTY,
1104                 ReadLine, and NonStop there.
1105 < command       Define command to run before each prompt.
1106 > command       Define command to run after each prompt.
1107 $prc number     Redo a previous command (default previous command).
1108 $prc -number    Redo number'th-to-last command.
1109 $prc pattern    Redo last command that started with pattern.
1110                 See 'O recallCommand' too.
1111 $psh$psh cmd    Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1112   . ( $rc eq $sh ? "" : "
1113 $psh [cmd]      Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1114                 See 'O shellBang' too.
1115 H -number       Display last number commands (default all).
1116 p expr          Same as \"print DB::OUT expr\" in current package.
1117 |dbcmd          Run debugger command, piping DB::OUT to current pager.
1118 ||dbcmd         Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1119 \= [alias value]        Define a command alias, or list current aliases.
1120 command         Execute as a perl statement in current package.
1121 h [db_command]  Get help [on a specific debugger command], enter |h to page.
1122 h h             Summary of debugger commands.
1123 q or ^D         Quit.
1124
1125 ";
1126     $summary = <<"END_SUM";
1127 List/search source lines:               Control script execution:
1128   l [ln|sub]  List source code            T           Stack trace
1129   -           List previous lines         s [expr]    Single step [in expr]
1130   w [line]    List around line            n [expr]    Next, steps over subs
1131   f filename  View source in file         <CR>        Repeat last n or s
1132   /pattern/   Search forward              r           Return from subroutine
1133   ?pattern?   Search backward             c [line]    Continue until line
1134 Debugger controls:                        L           List break pts & actions
1135   O [...]     Set debugger options        t [expr]    Toggle trace [trace expr]
1136   < command   Command for before prompt   b [ln] [c]  Set breakpoint
1137   > command   Command for after prompt    b sub [c]   Set breakpoint for sub
1138   $prc [N|pat]   Redo a previous command     d [line]    Delete a breakpoint
1139   H [-num]    Display last num commands   D           Delete all breakpoints
1140   = [a val]   Define/list an alias        a [ln] cmd  Do cmd before line
1141   h [db_cmd]  Get help on command         A           Delete all actions
1142   |[|]dbcmd   Send output to pager        $psh\[$psh\] syscmd Run cmd in a subprocess
1143   q or ^D     Quit
1144 Data Examination:             expr     Execute perl code, also see: s,n,t expr
1145   S [[!]pat]    List subroutine names [not] matching pattern
1146   V [Pk [Vars]] List Variables in Package.  Vars can be ~pattern or !pattern.
1147   X [Vars]      Same as \"V current_package [Vars]\".
1148   x expr        Evals expression in array context, dumps the result.
1149   p expr        Print expression (uses script's current package).
1150 END_SUM
1151                                 # '); # Fix balance of Emacs parsing
1152 }
1153
1154
1155 sub diesignal {
1156     $SIG{'ABRT'} = DEFAULT;
1157     kill 'ABRT', $$ if $panic++;
1158     print $DB::OUT "Got $_[0]!\n";      # in the case cannot continue
1159     local $SIG{__WARN__} = '';
1160     require Carp;
1161     local $Carp::CarpLevel = 2;         # mydie + confess
1162     &warn(Carp::longmess("Signal @_"));
1163     kill 'ABRT', $$;
1164 }
1165
1166 sub dbwarn {
1167   local $SIG{__WARN__} = '';
1168   require Carp;
1169   #&warn("Entering dbwarn\n");
1170   my ($mysingle,$mytrace) = ($single,$trace);
1171   $single = 0; $trace = 0;
1172   my $mess = Carp::longmess(@_);
1173   ($single,$trace) = ($mysingle,$mytrace);
1174   #&warn("Warning in dbwarn\n");
1175   &warn($mess);
1176   #&warn("Exiting dbwarn\n");
1177 }
1178
1179 sub dbdie {
1180   local $SIG{__DIE__} = '';
1181   local $SIG{__WARN__} = '';
1182   my $i = 0; my $ineval = 0; my $sub;
1183   #&warn("Entering dbdie\n");
1184   if ($dieLevel != 2) {
1185     while ((undef,undef,undef,$sub) = caller(++$i)) {
1186       $ineval = 1, last if $sub eq '(eval)';
1187     }
1188     {
1189       local $SIG{__WARN__} = \&dbwarn;
1190       &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1191     }
1192     #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1193     die @_ if $ineval and $dieLevel < 2;
1194   }
1195   require Carp;
1196   # We do not want to debug this chunk (automatic disabling works
1197   # inside DB::DB, but not in Carp).
1198   my ($mysingle,$mytrace) = ($single,$trace);
1199   $single = 0; $trace = 0;
1200   my $mess = Carp::longmess(@_);
1201   ($single,$trace) = ($mysingle,$mytrace);
1202   #&warn("dieing loudly in dbdie\n");
1203   die $mess;
1204 }
1205
1206 # sub diehard {                 # Always dump, useful if fatal is
1207 #                                 # deeply in evals.
1208 #   local $SIG{__DIE__} = '';
1209 #   require Carp;
1210 #   # We do not want to debug this (automatic disabling works inside DB::DB)
1211 #   my ($mysingle,$mytrace) = ($single,$trace);
1212 #   $single = 0; $trace = 0;
1213 #   my $mess = Carp::longmess(@_);
1214 #   ($single,$trace) = ($mysingle,$mytrace);
1215 #   die $mess;
1216 # }
1217
1218 sub warnLevel {
1219   if (@_) {
1220     $prevwarn = $SIG{__WARN__} unless $warnLevel;
1221     $warnLevel = shift;
1222     if ($warnLevel) {
1223       $SIG{__WARN__} = 'DB::dbwarn';
1224     } else {
1225       $SIG{__WARN__} = $prevwarn;
1226     }
1227   }
1228   $warnLevel;
1229 }
1230
1231 sub dieLevel {
1232   if (@_) {
1233     $prevdie = $SIG{__DIE__} unless $dieLevel;
1234     $dieLevel = shift;
1235     if ($dieLevel) {
1236       $SIG{__DIE__} = 'DB::dbdie'; # if $dieLevel < 2;
1237       #$SIG{__DIE__} = 'DB::diehard' if $dieLevel >= 2;
1238       print $OUT "Stack dump during die enabled",
1239         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1240       print $OUT "Dump printed too.\n" if $dieLevel > 2;
1241     } else {
1242       $SIG{__DIE__} = $prevdie;
1243       print $OUT "Default die handler restored.\n";
1244     }
1245   }
1246   $dieLevel;
1247 }
1248
1249 sub signalLevel {
1250   if (@_) {
1251     $prevsegv = $SIG{SEGV} unless $signalLevel;
1252     $prevbus = $SIG{BUS} unless $signalLevel;
1253     $signalLevel = shift;
1254     if ($signalLevel) {
1255       $SIG{SEGV} = 'DB::diesignal';
1256       $SIG{BUS} = 'DB::diesignal';
1257     } else {
1258       $SIG{SEGV} = $prevsegv;
1259       $SIG{BUS} = $prevbus;
1260     }
1261   }
1262   $signalLevel;
1263 }
1264
1265 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1266
1267 BEGIN {                 # This does not compile, alas.
1268   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
1269   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
1270   $sh = '!';
1271   $rc = ',';
1272   @hist = ('?');
1273   $deep = 100;                  # warning if stack gets this deep
1274   $window = 10;
1275   $preview = 3;
1276   $sub = '';
1277   #$SIG{__WARN__} = "DB::dbwarn";
1278   #$SIG{__DIE__} = 'DB::dbdie';
1279   #$SIG{SEGV} = "DB::diesignal";
1280   #$SIG{BUS} = "DB::diesignal";
1281   $SIG{INT} = "DB::catch";
1282   #$SIG{FPE} = "DB::catch";
1283   #warn "SIGFPE installed";
1284   $warnLevel = 1 unless defined $warnLevel;
1285   $dieLevel = 1 unless defined $dieLevel;
1286   $signalLevel = 1 unless defined $signalLevel;
1287
1288   $db_stop = 0;                 # Compiler warning
1289   $db_stop = 1 << 30;
1290   $level = 0;                   # Level of recursive debugging
1291 }
1292
1293 #use Carp;                      # This did break, left for debuggin
1294
1295 1;
1296 package DB;
1297
1298 # modified Perl debugger, to be run from Emacs in perldb-mode
1299 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
1300 # Johan Vromans -- upgrade to 4.0 pl 10
1301
1302 $header = '$RCSfile: perl5db.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:07 $';
1303 #
1304 # This file is automatically included if you do perl -d.
1305 # It's probably not useful to include this yourself.
1306 #
1307 # Perl supplies the values for @line and %sub.  It effectively inserts
1308 # a &DB'DB(<linenum>); in front of every place that can
1309 # have a breakpoint.  It also inserts a do 'perldb.pl' before the first line.
1310 #
1311 # $Log: perldb.pl,v $
1312
1313 # Is Perl being run from Emacs?
1314 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
1315 shift(@main::ARGV) if $emacs;
1316
1317 #require Term::ReadLine;
1318
1319 local($^W) = 0;
1320
1321 if (-e "/dev/tty") {
1322     $console = "/dev/tty";
1323     $rcfile=".perldb";
1324 }
1325 elsif (-e "con") {
1326     $console = "con";
1327     $rcfile="perldb.ini";
1328 }
1329 else {
1330     $console = "sys\$command";
1331     $rcfile="perldb.ini";
1332 }
1333
1334 # Around a bug:
1335 if (defined $ENV{'OS2_SHELL'}) { # In OS/2
1336   if ($DB::emacs) {
1337     $console = undef;
1338   } else {
1339     $console = "/dev/con";
1340   }
1341 }
1342
1343 open(IN, "<$console") || open(IN,  "<&STDIN");  # so we don't dingle stdin
1344 open(OUT,">$console") || open(OUT, ">&STDERR")
1345     || open(OUT, ">&STDOUT");   # so we don't dongle stdout
1346 select(OUT);
1347 $| = 1;                         # for DB::OUT
1348 select(STDOUT);
1349 $| = 1;                         # for real STDOUT
1350 $sub = '';
1351
1352 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
1353 print OUT "\nLoading DB routines from $header\n";
1354 print OUT ("Emacs support ",
1355            $emacs ? "enabled" : "available",
1356            ".\n");
1357 print OUT "\nEnter h for help.\n\n";
1358
1359 @ARGS;
1360
1361 sub DB {
1362     &save;
1363     ($pkg, $filename, $line) = caller;
1364     $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
1365         "package $pkg;";                # this won't let them modify, alas
1366     local(*dbline) = "::_<$filename";
1367     $max = $#dbline;
1368     if (($stop,$action) = split(/\0/,$dbline{$line})) {
1369         if ($stop eq '1') {
1370             $signal |= 1;
1371         }
1372         else {
1373             $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
1374             $dbline{$line} =~ s/;9($|\0)/$1/;
1375         }
1376     }
1377     if ($single || $trace || $signal) {
1378         if ($emacs) {
1379             print OUT "\032\032$filename:$line:0\n";
1380         } else {
1381             $prefix = $sub =~ /'|::/ ? "" : "${pkg}::";
1382             $prefix .= "$sub($filename:";
1383             if (length($prefix) > 30) {
1384                 print OUT "$prefix$line):\n$line:\t",$dbline[$line];
1385                 $prefix = "";
1386                 $infix = ":\t";
1387             }
1388             else {
1389                 $infix = "):\t";
1390                 print OUT "$prefix$line$infix",$dbline[$line];
1391             }
1392             for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
1393                 last if $dbline[$i] =~ /^\s*(}|#|\n)/;
1394                 print OUT "$prefix$i$infix",$dbline[$i];
1395             }
1396         }
1397     }
1398     $evalarg = $action, &eval if $action;
1399     if ($single || $signal) {
1400         $evalarg = $pre, &eval if $pre;
1401         print OUT $#stack . " levels deep in subroutine calls!\n"
1402             if $single & 4;
1403         $start = $line;
1404       CMD:
1405         while ((print OUT "  DB<", $#hist+1, "> "), $cmd=&gets) {
1406             {
1407                 $single = 0;
1408                 $signal = 0;
1409                 $cmd eq '' && exit 0;
1410                 chop($cmd);
1411                 $cmd =~ s/\\$// && do {
1412                     print OUT "  cont: ";
1413                     $cmd .= &gets;
1414                     redo CMD;
1415                 };
1416                 $cmd =~ /^q$/ && exit 0;
1417                 $cmd =~ /^$/ && ($cmd = $laststep);
1418                 push(@hist,$cmd) if length($cmd) > 1;
1419                 ($i) = split(/\s+/,$cmd);
1420                 eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
1421                 $cmd =~ /^h$/ && do {
1422                     print OUT "
1423 T               Stack trace.
1424 s               Single step.
1425 n               Next, steps over subroutine calls.
1426 r               Return from current subroutine.
1427 c [line]        Continue; optionally inserts a one-time-only breakpoint
1428                 at the specified line.
1429 <CR>            Repeat last n or s.
1430 l min+incr      List incr+1 lines starting at min.
1431 l min-max       List lines.
1432 l line          List line;
1433 l               List next window.
1434 -               List previous window.
1435 w line          List window around line.
1436 l subname       List subroutine.
1437 f filename      Switch to filename.
1438 /pattern/       Search forwards for pattern; final / is optional.
1439 ?pattern?       Search backwards for pattern.
1440 L               List breakpoints and actions.
1441 S               List subroutine names.
1442 t               Toggle trace mode.
1443 b [line] [condition]
1444                 Set breakpoint; line defaults to the current execution line;
1445                 condition breaks if it evaluates to true, defaults to \'1\'.
1446 b subname [condition]
1447                 Set breakpoint at first line of subroutine.
1448 d [line]        Delete breakpoint.
1449 D               Delete all breakpoints.
1450 a [line] command
1451                 Set an action to be done before the line is executed.
1452                 Sequence is: check for breakpoint, print line if necessary,
1453                 do action, prompt user if breakpoint or step, evaluate line.
1454 A               Delete all actions.
1455 V [pkg [vars]]  List some (default all) variables in package (default current).
1456 X [vars]        Same as \"V currentpackage [vars]\".
1457 < command       Define command before prompt.
1458 > command       Define command after prompt.
1459 ! number        Redo command (default previous command).
1460 ! -number       Redo number\'th to last command.
1461 H -number       Display last number commands (default all).
1462 q or ^D         Quit.
1463 p expr          Same as \"print DB::OUT expr\" in current package.
1464 = [alias value] Define a command alias, or list current aliases.
1465 command         Execute as a perl statement in current package.
1466
1467 ";
1468                     next CMD; };
1469                 $cmd =~ /^t$/ && do {
1470                     $trace = !$trace;
1471                     print OUT "Trace = ".($trace?"on":"off")."\n";
1472                     next CMD; };
1473                 $cmd =~ /^S$/ && do {
1474                     foreach $subname (sort(keys %sub)) {
1475                         print OUT $subname,"\n";
1476                     }
1477                     next CMD; };
1478                 $cmd =~ s/^X\b/V $pkg/;
1479                 $cmd =~ /^V$/ && do {
1480                     $cmd = "V $pkg"; };
1481                 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
1482                     local ($savout) = select(OUT);
1483                     $packname = $1;
1484                     @vars = split(' ',$2);
1485                     do 'dumpvar.pl' unless defined &main::dumpvar;
1486                     if (defined &main::dumpvar) {
1487                         &main::dumpvar($packname,@vars);
1488                     }
1489                     else {
1490                         print DB::OUT "dumpvar.pl not available.\n";
1491                     }
1492                     select ($savout);
1493                     next CMD; };
1494                 $cmd =~ /^f\b\s*(.*)/ && do {
1495                     $file = $1;
1496                     if (!$file) {
1497                         print OUT "The old f command is now the r command.\n";
1498                         print OUT "The new f command switches filenames.\n";
1499                         next CMD;
1500                     }
1501                     if (!defined $main::{'_<' . $file}) {
1502                         if (($try) = grep(m#^_<.*$file#, keys %main::)) {
1503                             $file = substr($try,2);
1504                             print "\n$file:\n";
1505                         }
1506                     }
1507                     if (!defined $main::{'_<' . $file}) {
1508                         print OUT "There's no code here anything matching $file.\n";
1509                         next CMD;
1510                     }
1511                     elsif ($file ne $filename) {
1512                         *dbline = "::_<$file";
1513                         $max = $#dbline;
1514                         $filename = $file;
1515                         $start = 1;
1516                         $cmd = "l";
1517                     } };
1518                 $cmd =~ /^l\b\s*([':A-Za-z_][':\w]*)/ && do {
1519                     $subname = $1;
1520                     $subname = "main::" . $subname unless $subname =~ /'|::/;
1521                     $subname = "main" . $subname if substr($subname,0,1)eq "'";
1522                     $subname = "main" . $subname if substr($subname,0,2)eq "::";
1523                     # VMS filespecs may (usually do) contain ':', so don't use split
1524                     ($file,$subrange) = $sub{$subname} =~ /(.*):(.*)/;
1525                     if ($file ne $filename) {
1526                         *dbline = "::_<$file";
1527                         $max = $#dbline;
1528                         $filename = $file;
1529                     }
1530                     if ($subrange) {
1531                         if (eval($subrange) < -$window) {
1532                             $subrange =~ s/-.*/+/;
1533                         }
1534                         $cmd = "l $subrange";
1535                     } else {
1536                         print OUT "Subroutine $1 not found.\n";
1537                         next CMD;
1538                     } };
1539                 $cmd =~ /^w\b\s*(\d*)$/ && do {
1540                     $incr = $window - 1;
1541                     $start = $1 if $1;
1542                     $start -= $preview;
1543                     $cmd = 'l ' . $start . '-' . ($start + $incr); };
1544                 $cmd =~ /^-$/ && do {
1545                     $incr = $window - 1;
1546                     $cmd = 'l ' . ($start-$window*2) . '+'; };
1547                 $cmd =~ /^l$/ && do {
1548                     $incr = $window - 1;
1549                     $cmd = 'l ' . $start . '-' . ($start + $incr); };
1550                 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
1551                     $start = $1 if $1;
1552                     $incr = $2;
1553                     $incr = $window - 1 unless $incr;
1554                     $cmd = 'l ' . $start . '-' . ($start + $incr); };
1555                 $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
1556                     $end = (!$2) ? $max : ($4 ? $4 : $2);
1557                     $end = $max if $end > $max;
1558                     $i = $2;
1559                     $i = $line if $i eq '.';
1560                     $i = 1 if $i < 1;
1561                     if ($emacs) {
1562                         print OUT "\032\032$filename:$i:0\n";
1563                         $i = $end;
1564                     } else {
1565                         for (; $i <= $end; $i++) {
1566                             print OUT "$i:\t", $dbline[$i];
1567                             last if $signal;
1568                         }
1569                     }
1570                     $start = $i;        # remember in case they want more
1571                     $start = $max if $start > $max;
1572                     next CMD; };
1573                 $cmd =~ /^D$/ && do {
1574                     print OUT "Deleting all breakpoints...\n";
1575                     for ($i = 1; $i <= $max ; $i++) {
1576                         if (defined $dbline{$i}) {
1577                             $dbline{$i} =~ s/^[^\0]+//;
1578                             if ($dbline{$i} =~ s/^\0?$//) {
1579                                 delete $dbline{$i};
1580                             }
1581                         }
1582                     }
1583                     next CMD; };
1584                 $cmd =~ /^L$/ && do {
1585                     for ($i = 1; $i <= $max; $i++) {
1586                         if (defined $dbline{$i}) {
1587                             print OUT "$i:\t", $dbline[$i];
1588                             ($stop,$action) = split(/\0/, $dbline{$i});
1589                             print OUT "  break if (", $stop, ")\n"
1590                                 if $stop;
1591                             print OUT "  action:  ", $action, "\n"
1592                                 if $action;
1593                             last if $signal;
1594                         }
1595                     }
1596                     next CMD; };
1597                 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
1598                     $subname = $1;
1599                     $cond = $2 || '1';
1600                     $subname = "${pkg}::" . $subname
1601                         unless $subname =~ /'|::/;
1602                     $subname = "main" . $subname if substr($subname,0,1) eq "'";
1603                     $subname = "main" . $subname if substr($subname,0,2) eq "::";
1604                     # VMS filespecs may (usually do) contain ':', so don't use split
1605                     ($filename,$i) = $sub{$subname} =~ /(.*):(.*)/;
1606                     $i += 0;
1607                     if ($i) {
1608                         *dbline = "::_<$filename";
1609                         ++$i while $dbline[$i] == 0 && $i < $#dbline;
1610                         $dbline{$i} =~ s/^[^\0]*/$cond/;
1611                     } else {
1612                         print OUT "Subroutine $subname not found.\n";
1613                     }
1614                     next CMD; };
1615                 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1616                     $i = ($1?$1:$line);
1617                     $cond = $2 || '1';
1618                     if ($dbline[$i] == 0) {
1619                         print OUT "Line $i not breakable.\n";
1620                     } else {
1621                         $dbline{$i} =~ s/^[^\0]*/$cond/;
1622                     }
1623                     next CMD; };
1624                 $cmd =~ /^d\b\s*(\d+)?/ && do {
1625                     $i = ($1?$1:$line);
1626                     $dbline{$i} =~ s/^[^\0]*//;
1627                     delete $dbline{$i} if $dbline{$i} eq '';
1628                     next CMD; };
1629                 $cmd =~ /^A$/ && do {
1630                     for ($i = 1; $i <= $max ; $i++) {
1631                         if (defined $dbline{$i}) {
1632                             $dbline{$i} =~ s/\0[^\0]*//;
1633                             delete $dbline{$i} if $dbline{$i} eq '';
1634                         }
1635                     }
1636                     next CMD; };
1637                 $cmd =~ /^<\s*(.*)/ && do {
1638                     $pre = action($1);
1639                     next CMD; };
1640                 $cmd =~ /^>\s*(.*)/ && do {
1641                     $post = action($1);
1642                     next CMD; };
1643                 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
1644                     $i = $1;
1645                     if ($dbline[$i] == 0) {
1646                         print OUT "Line $i may not have an action.\n";
1647                     } else {
1648                         $dbline{$i} =~ s/\0[^\0]*//;
1649                         $dbline{$i} .= "\0" . action($3);
1650                     }
1651                     next CMD; };
1652                 $cmd =~ /^n$/ && do {
1653                     $single = 2;
1654                     $laststep = $cmd;
1655                     last CMD; };
1656                 $cmd =~ /^s$/ && do {
1657                     $single = 1;
1658                     $laststep = $cmd;
1659                     last CMD; };
1660                 $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
1661                     $i = $1;
1662                     if ($i) {
1663                         if ($dbline[$i] == 0) {
1664                             print OUT "Line $i not breakable.\n";
1665                             next CMD;
1666                         }
1667                         $dbline{$i} =~ s/(\0|$)/;9$1/;  # add one-time-only b.p.
1668                     }
1669                     for ($i=0; $i <= $#stack; ) {
1670                         $stack[$i++] &= ~1;
1671                     }
1672                     last CMD; };
1673                 $cmd =~ /^r$/ && do {
1674                     $stack[$#stack] |= 2;
1675                     last CMD; };
1676                 $cmd =~ /^T$/ && do {
1677                     local($p,$f,$l,$s,$h,$a,@a,@sub);
1678                     for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
1679                         @a = ();
1680                         for $arg (@args) {
1681                             $_ = "$arg";
1682                             s/'/\\'/g;
1683                             s/([^\0]*)/'$1'/
1684                                 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1685                             s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1686                             s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1687                             push(@a, $_);
1688                         }
1689                         $w = $w ? '@ = ' : '$ = ';
1690                         $a = $h ? '(' . join(', ', @a) . ')' : '';
1691                         push(@sub, "$w$s$a from file $f line $l\n");
1692                         last if $signal;
1693                     }
1694                     for ($i=0; $i <= $#sub; $i++) {
1695                         last if $signal;
1696                         print OUT $sub[$i];
1697                     }
1698                     next CMD; };
1699                 $cmd =~ /^\/(.*)$/ && do {
1700                     $inpat = $1;
1701                     $inpat =~ s:([^\\])/$:$1:;
1702                     if ($inpat ne "") {
1703                         eval '$inpat =~ m'."\a$inpat\a";
1704                         if ($@ ne "") {
1705                             print OUT "$@";
1706                             next CMD;
1707                         }
1708                         $pat = $inpat;
1709                     }
1710                     $end = $start;
1711                     eval '
1712                     for (;;) {
1713                         ++$start;
1714                         $start = 1 if ($start > $max);
1715                         last if ($start == $end);
1716                         if ($dbline[$start] =~ m'."\a$pat\a".'i) {
1717                             if ($emacs) {
1718                                 print OUT "\032\032$filename:$start:0\n";
1719                             } else {
1720                                 print OUT "$start:\t", $dbline[$start], "\n";
1721                             }
1722                             last;
1723                         }
1724                     } ';
1725                     print OUT "/$pat/: not found\n" if ($start == $end);
1726                     next CMD; };
1727                 $cmd =~ /^\?(.*)$/ && do {
1728                     $inpat = $1;
1729                     $inpat =~ s:([^\\])\?$:$1:;
1730                     if ($inpat ne "") {
1731                         eval '$inpat =~ m'."\a$inpat\a";
1732                         if ($@ ne "") {
1733                             print OUT "$@";
1734                             next CMD;
1735                         }
1736                         $pat = $inpat;
1737                     }
1738                     $end = $start;
1739                     eval '
1740                     for (;;) {
1741                         --$start;
1742                         $start = $max if ($start <= 0);
1743                         last if ($start == $end);
1744                         if ($dbline[$start] =~ m'."\a$pat\a".'i) {
1745                             if ($emacs) {
1746                                 print OUT "\032\032$filename:$start:0\n";
1747                             } else {
1748                                 print OUT "$start:\t", $dbline[$start], "\n";
1749                             }
1750                             last;
1751                         }
1752                     } ';
1753                     print OUT "?$pat?: not found\n" if ($start == $end);
1754                     next CMD; };
1755                 $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
1756                     pop(@hist) if length($cmd) > 1;
1757                     $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
1758                     $cmd = $hist[$i] . "\n";
1759                     print OUT $cmd;
1760                     redo CMD; };
1761                 $cmd =~ /^!(.+)$/ && do {
1762                     $pat = "^$1";
1763                     pop(@hist) if length($cmd) > 1;
1764                     for ($i = $#hist; $i; --$i) {
1765                         last if $hist[$i] =~ $pat;
1766                     }
1767                     if (!$i) {
1768                         print OUT "No such command!\n\n";
1769                         next CMD;
1770                     }
1771                     $cmd = $hist[$i] . "\n";
1772                     print OUT $cmd;
1773                     redo CMD; };
1774                 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1775                     $end = $2?($#hist-$2):0;
1776                     $hist = 0 if $hist < 0;
1777                     for ($i=$#hist; $i>$end; $i--) {
1778                         print OUT "$i: ",$hist[$i],"\n"
1779                             unless $hist[$i] =~ /^.?$/;
1780                     };
1781                     next CMD; };
1782                 $cmd =~ s/^p( .*)?$/print DB::OUT$1/;
1783                 $cmd =~ /^=/ && do {
1784                     if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1785                         $alias{$k}="s~$k~$v~";
1786                         print OUT "$k = $v\n";
1787                     } elsif ($cmd =~ /^=\s*$/) {
1788                         foreach $k (sort keys(%alias)) {
1789                             if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1790                                 print OUT "$k = $v\n";
1791                             } else {
1792                                 print OUT "$k\t$alias{$k}\n";
1793                             };
1794                         };
1795                     };
1796                     next CMD; };
1797             }
1798             $evalarg = $cmd; &eval;
1799             print OUT "\n";
1800         }
1801         if ($post) {
1802             $evalarg = $post; &eval;
1803         }
1804     }
1805     ($@, $!, $,, $/, $\, $^W) = @saved;
1806     ();
1807 }
1808
1809 sub save {
1810     @saved = ($@, $!, $,, $/, $\, $^W);
1811     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1812 }
1813
1814 # The following takes its argument via $evalarg to preserve current @_
1815
1816 sub eval {
1817     eval "$usercontext $evalarg; &DB::save";
1818     print OUT $@;
1819 }
1820
1821 sub action {
1822     local($action) = @_;
1823     while ($action =~ s/\\$//) {
1824         print OUT "+ ";
1825         $action .= &gets;
1826     }
1827     $action;
1828 }
1829
1830 sub gets {
1831     local($.);
1832     <IN>;
1833 }
1834
1835 sub catch {
1836     $signal = 1;
1837 }
1838
1839 sub sub {
1840     push(@stack, $single);
1841     $single &= 1;
1842     $single |= 4 if $#stack == $deep;
1843     if (wantarray) {
1844         @i = &$sub;
1845         $single |= pop(@stack);
1846         @i;
1847     }
1848     else {
1849         $i = &$sub;
1850         $single |= pop(@stack);
1851         $i;
1852     }
1853 }
1854
1855 $trace = $signal = $single = 0; # uninitialized warning suppression
1856
1857 @hist = ('?');
1858 $SIG{'INT'} = "DB::catch";
1859 $deep = 100;            # warning if stack gets this deep
1860 $window = 10;
1861 $preview = 3;
1862
1863 @stack = (0);
1864 @ARGS = @ARGV;
1865 for (@args) {
1866     s/'/\\'/g;
1867     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
1868 }
1869
1870 if (-f $rcfile) {
1871     do "./$rcfile";
1872 }
1873 elsif (-f "$ENV{'LOGDIR'}/$rcfile") {
1874     do "$ENV{'LOGDIR'}/$rcfile";
1875 }
1876 elsif (-f "$ENV{'HOME'}/$rcfile") {
1877     do "$ENV{'HOME'}/$rcfile";
1878 }
1879
1880 1;