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;