lib/perl5db.pl

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