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 "There's no code here matching $file.\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         map {$evalarg = $_; &eval} @$post;
1037     }                           # if ($single || $signal)
1038     ($@, $!, $,, $/, $\, $^W) = @saved;
1039     ();
1040 }
1041
1042 # The following code may be executed now:
1043 # BEGIN {warn 4}
1044
1045 sub sub {
1046     my ($al, $ret, @ret) = "";
1047     if ($sub =~ /::AUTOLOAD$/) {
1048       $al = " for $ {$` . '::AUTOLOAD'}";
1049     }
1050     ($frame & 4
1051      ? ( (print $LINEINFO ' ' x $#stack, "in  "),
1052          # Why -1? But it works! :-(
1053          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1054      : print $LINEINFO ' ' x $#stack, "entering $sub$al\n") if $frame;
1055     push(@stack, $single);
1056     $single &= 1;
1057     $single |= 4 if $#stack == $deep;
1058     if (wantarray) {
1059         @ret = &$sub;
1060         $single |= pop(@stack);
1061         print ($OUT "list context return from $sub:\n"), dumpit( \@ret ),
1062           $doret = -2 if $doret eq $#stack;
1063         ($frame & 4
1064          ? ( (print $LINEINFO ' ' x $#stack, "out "),
1065              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1066          : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1067         @ret;
1068     } else {
1069         $ret = &$sub;
1070         $single |= pop(@stack);
1071         print ($OUT "scalar context return from $sub: "), dumpit( $ret ),
1072           $doret = -2 if $doret eq $#stack;
1073         ($frame & 4
1074          ? ( (print $LINEINFO ' ' x $#stack, "out "),
1075               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1076          : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1077         $ret;
1078     }
1079 }
1080
1081 sub save {
1082     @saved = ($@, $!, $,, $/, $\, $^W);
1083     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1084 }
1085
1086 # The following takes its argument via $evalarg to preserve current @_
1087
1088 sub eval {
1089     my @res;
1090     {
1091         local (@stack) = @stack; # guard against recursive debugging
1092         my $otrace = $trace;
1093         my $osingle = $single;
1094         my $od = $^D;
1095         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1096         $trace = $otrace;
1097         $single = $osingle;
1098         $^D = $od;
1099     }
1100     my $at = $@;
1101     local $saved[0];            # Preserve the old value of $@
1102     eval "&DB::save";
1103     if ($at) {
1104         print $OUT $at;
1105     } elsif ($onetimeDump) {
1106         dumpit(\@res);
1107     }
1108 }
1109
1110 sub postponed_sub {
1111   my $subname = shift;
1112   if ($postponed{$subname} =~ s/break\s([+-]?\d+)\s+if\s//) {
1113     my $offset = $1 || 0;
1114     # Filename below can contain ':'
1115     my ($file,$i) = ($sub{$subname} =~ /^(.*):(\d+)-.*$/);
1116     $i += $offset;
1117     if ($i) {
1118       local *dbline = "::_<$file";
1119       local $^W = 0;            # != 0 is magical below
1120       $had_breakpoints{$file}++;
1121       my $max = $#dbline;
1122       ++$i until $dbline[$i] != 0 or $i >= $max;
1123       $dbline{$i} = delete $postponed{$subname};
1124     } else {
1125       print $OUT "Subroutine $subname not found.\n";
1126     }
1127     return;
1128   }
1129   #print $OUT "In postponed_sub for `$subname'.\n";
1130 }
1131
1132 sub postponed {
1133   return &postponed_sub
1134     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1135   # Cannot be done before the file is compiled
1136   local *dbline = shift;
1137   my $filename = $dbline;
1138   $filename =~ s/^_<//;
1139   $signal = 1, print $OUT "'$filename' loaded...\n"
1140     if $break_on_load{$filename};
1141   print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1142   return unless %{$postponed_file{$filename}};
1143   $had_breakpoints{$filename}++;
1144   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1145   my $key;
1146   for $key (keys %{$postponed_file{$filename}}) {
1147     $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1148   }
1149   undef %{$postponed_file{$filename}};
1150 }
1151
1152 sub dumpit {
1153     local ($savout) = select($OUT);
1154     my $osingle = $single;
1155     my $otrace = $trace;
1156     $single = $trace = 0;
1157     local $frame = 0;
1158     local $doret = -2;
1159     unless (defined &main::dumpValue) {
1160         do 'dumpvar.pl';
1161     }
1162     if (defined &main::dumpValue) {
1163         &main::dumpValue(shift);
1164     } else {
1165         print $OUT "dumpvar.pl not available.\n";
1166     }
1167     $single = $osingle;
1168     $trace = $otrace;
1169     select ($savout);
1170 }
1171
1172 # Tied method do not create a context, so may get wrong message:
1173
1174 sub print_trace {
1175   my $fh = shift;
1176   my @sub = dump_trace($_[0] + 1, $_[1]);
1177   my $short = $_[2];            # Print short report, next one for sub name
1178   for ($i=0; $i <= $#sub; $i++) {
1179     last if $signal;
1180     local $" = ', ';
1181     my $args = defined $sub[$i]{args}
1182     ? "(@{ $sub[$i]{args} })"
1183       : '' ;
1184     my $file = $sub[$i]{file};
1185     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1186     if ($short) {
1187       my $sub = @_ >= 4 ? $_[3] : $sub[$i]{sub};
1188       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1189     } else {
1190       print $fh "$sub[$i]{context} = $sub[$i]{sub}$args" .
1191         " called from $file" .
1192           " line $sub[$i]{line}\n";
1193     }
1194   }
1195 }
1196
1197 sub dump_trace {
1198   my $skip = shift;
1199   my $count = shift || 1e9;
1200   $skip++;
1201   $count += $skip;
1202   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1203   for ($i = $skip;
1204        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1205        $i++) {
1206     @a = ();
1207     for $arg (@args) {
1208       $_ = "$arg";
1209       s/([\'\\])/\\$1/g;
1210       s/([^\0]*)/'$1'/
1211         unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1212       s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1213       s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1214       push(@a, $_);
1215     }
1216     $context = $context ? '@' : '$';
1217     $args = $h ? [@a] : undef;
1218     $e =~ s/\n\s*\;\s*\Z// if $e;
1219     $e =~ s/[\\\']/\\$1/g if $e;
1220     if ($r) {
1221       $sub = "require '$e'";
1222     } elsif (defined $r) {
1223       $sub = "eval '$e'";
1224     } elsif ($sub eq '(eval)') {
1225       $sub = "eval {...}";
1226     }
1227     push(@sub, {context => $context, sub => $sub, args => $args,
1228                 file => $file, line => $line});
1229     last if $signal;
1230   }
1231   @sub;
1232 }
1233
1234 sub action {
1235     my $action = shift;
1236     while ($action =~ s/\\$//) {
1237         #print $OUT "+ ";
1238         #$action .= "\n";
1239         $action .= &gets;
1240     }
1241     $action;
1242 }
1243
1244 sub gets {
1245     local($.);
1246     #<IN>;
1247     &readline("cont: ");
1248 }
1249
1250 sub system {
1251     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1252     # many non-Unix systems can do system() but have problems with fork().
1253     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1254     open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1255     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1256     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1257     system(@_);
1258     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1259     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1260     close(SAVEIN); close(SAVEOUT);
1261     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1262           ( $? & 128 ) ? " (core dumped)" : "",
1263           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1264     $?;
1265 }
1266
1267 sub setterm {
1268     local $frame = 0;
1269     local $doret = -2;
1270     local @stack = @stack;              # Prevent growth by failing `use'.
1271     eval { require Term::ReadLine } or die $@;
1272     if ($notty) {
1273         if ($tty) {
1274             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1275             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1276             $IN = \*IN;
1277             $OUT = \*OUT;
1278             my $sel = select($OUT);
1279             $| = 1;
1280             select($sel);
1281         } else {
1282             eval "require Term::Rendezvous;" or die $@;
1283             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1284             my $term_rv = new Term::Rendezvous $rv;
1285             $IN = $term_rv->IN;
1286             $OUT = $term_rv->OUT;
1287         }
1288     }
1289     if (!$rl) {
1290         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1291     } else {
1292         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1293
1294         $readline::rl_basic_word_break_characters .= "[:"
1295           if defined $readline::rl_basic_word_break_characters
1296             and index($readline::rl_basic_word_break_characters, ":") == -1;
1297         $readline::rl_special_prefixes =
1298           $readline::rl_special_prefixes = '$@&%';
1299         $readline::rl_completer_word_break_characters =
1300           $readline::rl_completer_word_break_characters . '$@&%';
1301         $readline::rl_completion_function =
1302           $readline::rl_completion_function = \&db_complete;
1303     }
1304     $LINEINFO = $OUT unless defined $LINEINFO;
1305     $lineinfo = $console unless defined $lineinfo;
1306     $term->MinLine(2);
1307     if ($term->Features->{setHistory} and "@hist" ne "?") {
1308       $term->SetHistory(@hist);
1309     }
1310 }
1311
1312 sub readline {
1313   if (@typeahead) {
1314     my $left = @typeahead;
1315     my $got = shift @typeahead;
1316     print $OUT "auto(-$left)", shift, $got, "\n";
1317     $term->AddHistory($got)
1318       if length($got) > 1 and defined $term->Features->{addHistory};
1319     return $got;
1320   }
1321   local $frame = 0;
1322   local $doret = -2;
1323   $term->readline(@_);
1324 }
1325
1326 sub dump_option {
1327     my ($opt, $val)= @_;
1328     $val = option_val($opt,'N/A');
1329     $val =~ s/([\\\'])/\\$1/g;
1330     printf $OUT "%20s = '%s'\n", $opt, $val;
1331 }
1332
1333 sub option_val {
1334     my ($opt, $default)= @_;
1335     my $val;
1336     if (defined $optionVars{$opt}
1337         and defined $ {$optionVars{$opt}}) {
1338         $val = $ {$optionVars{$opt}};
1339     } elsif (defined $optionAction{$opt}
1340         and defined &{$optionAction{$opt}}) {
1341         $val = &{$optionAction{$opt}}();
1342     } elsif (defined $optionAction{$opt}
1343              and not defined $option{$opt}
1344              or defined $optionVars{$opt}
1345              and not defined $ {$optionVars{$opt}}) {
1346         $val = $default;
1347     } else {
1348         $val = $option{$opt};
1349     }
1350     $val
1351 }
1352
1353 sub parse_options {
1354     local($_)= @_;
1355     while ($_ ne "") {
1356         s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1357         my ($opt,$sep) = ($1,$2);
1358         my $val;
1359         if ("?" eq $sep) {
1360             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1361               if /^\S/;
1362             #&dump_option($opt);
1363         } elsif ($sep !~ /\S/) {
1364             $val = "1";
1365         } elsif ($sep eq "=") {
1366             s/^(\S*)($|\s+)//;
1367             $val = $1;
1368         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1369             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1370             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1371               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1372             $val = $1;
1373             $val =~ s/\\([\\$end])/$1/g;
1374         }
1375         my ($option);
1376         my $matches =
1377           grep(  /^\Q$opt/ && ($option = $_),  @options  );
1378         $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
1379           unless $matches;
1380         print $OUT "Unknown option `$opt'\n" unless $matches;
1381         print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1382         $option{$option} = $val if $matches == 1 and defined $val;
1383         eval "local \$frame = 0; local \$doret = -2;
1384               require '$optionRequire{$option}'"
1385           if $matches == 1 and defined $optionRequire{$option} and defined $val;
1386         $ {$optionVars{$option}} = $val
1387           if $matches == 1
1388             and defined $optionVars{$option} and defined $val;
1389         & {$optionAction{$option}} ($val)
1390           if $matches == 1
1391             and defined $optionAction{$option}
1392               and defined &{$optionAction{$option}} and defined $val;
1393         &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1394         s/^\s+//;
1395     }
1396 }
1397
1398 sub set_list {
1399   my ($stem,@list) = @_;
1400   my $val;
1401   $ENV{"$ {stem}_n"} = @list;
1402   for $i (0 .. $#list) {
1403     $val = $list[$i];
1404     $val =~ s/\\/\\\\/g;
1405     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1406     $ENV{"$ {stem}_$i"} = $val;
1407   }
1408 }
1409
1410 sub get_list {
1411   my $stem = shift;
1412   my @list;
1413   my $n = delete $ENV{"$ {stem}_n"};
1414   my $val;
1415   for $i (0 .. $n - 1) {
1416     $val = delete $ENV{"$ {stem}_$i"};
1417     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1418     push @list, $val;
1419   }
1420   @list;
1421 }
1422
1423 sub catch {
1424     $signal = 1;
1425     return;                     # Put nothing on the stack - malloc/free land!
1426 }
1427
1428 sub warn {
1429     my($msg)= join("",@_);
1430     $msg .= ": $!\n" unless $msg =~ /\n$/;
1431     print $OUT $msg;
1432 }
1433
1434 sub TTY {
1435     if ($term) {
1436         &warn("Too late to set TTY!\n") if @_;
1437     } else {
1438         $tty = shift if @_;
1439     }
1440     $tty or $console;
1441 }
1442
1443 sub noTTY {
1444     if ($term) {
1445         &warn("Too late to set noTTY!\n") if @_;
1446     } else {
1447         $notty = shift if @_;
1448     }
1449     $notty;
1450 }
1451
1452 sub ReadLine {
1453     if ($term) {
1454         &warn("Too late to set ReadLine!\n") if @_;
1455     } else {
1456         $rl = shift if @_;
1457     }
1458     $rl;
1459 }
1460
1461 sub NonStop {
1462     if ($term) {
1463         &warn("Too late to set up NonStop mode!\n") if @_;
1464     } else {
1465         $runnonstop = shift if @_;
1466     }
1467     $runnonstop;
1468 }
1469
1470 sub pager {
1471     if (@_) {
1472         $pager = shift;
1473         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1474     }
1475     $pager;
1476 }
1477
1478 sub shellBang {
1479     if (@_) {
1480         $sh = quotemeta shift;
1481         $sh .= "\\b" if $sh =~ /\w$/;
1482     }
1483     $psh = $sh;
1484     $psh =~ s/\\b$//;
1485     $psh =~ s/\\(.)/$1/g;
1486     &sethelp;
1487     $psh;
1488 }
1489
1490 sub recallCommand {
1491     if (@_) {
1492         $rc = quotemeta shift;
1493         $rc .= "\\b" if $rc =~ /\w$/;
1494     }
1495     $prc = $rc;
1496     $prc =~ s/\\b$//;
1497     $prc =~ s/\\(.)/$1/g;
1498     &sethelp;
1499     $prc;
1500 }
1501
1502 sub LineInfo {
1503     return $lineinfo unless @_;
1504     $lineinfo = shift;
1505     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1506     $emacs = ($stream =~ /^\|/);
1507     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1508     $LINEINFO = \*LINEINFO;
1509     my $save = select($LINEINFO);
1510     $| = 1;
1511     select($save);
1512     $lineinfo;
1513 }
1514
1515 sub list_versions {
1516   my %version;
1517   my $file;
1518   for (keys %INC) {
1519     $file = $_;
1520     s,\.p[lm]$,,i ;
1521     s,/,::,g ;
1522     s/^perl5db$/DB/;
1523     s/^Term::ReadLine::readline$/readline/;
1524     if (defined $ { $_ . '::VERSION' }) {
1525       $version{$file} = "$ { $_ . '::VERSION' } from ";
1526     }
1527     $version{$file} .= $INC{$file};
1528   }
1529   do 'dumpvar.pl' unless defined &main::dumpValue;
1530   if (defined &main::dumpValue) {
1531     local $frame = 0;
1532     &main::dumpValue(\%version);
1533   } else {
1534     print $OUT "dumpvar.pl not available.\n";
1535   }
1536 }
1537
1538 sub sethelp {
1539     $help = "
1540 T               Stack trace.
1541 s [expr]        Single step [in expr].
1542 n [expr]        Next, steps over subroutine calls [in expr].
1543 <CR>            Repeat last n or s command.
1544 r               Return from current subroutine.
1545 c [line|sub]    Continue; optionally inserts a one-time-only breakpoint
1546                 at the specified position.
1547 l min+incr      List incr+1 lines starting at min.
1548 l min-max       List lines min through max.
1549 l line          List single line.
1550 l subname       List first window of lines from subroutine.
1551 l               List next window of lines.
1552 -               List previous window of lines.
1553 w [line]        List window around line.
1554 .               Return to the executed line.
1555 f filename      Switch to viewing filename.
1556 /pattern/       Search forwards for pattern; final / is optional.
1557 ?pattern?       Search backwards for pattern; final ? is optional.
1558 L               List all breakpoints and actions.
1559 S [[!]pattern]  List subroutine names [not] matching pattern.
1560 t               Toggle trace mode.
1561 t expr          Trace through execution of expr.
1562 b [line] [condition]
1563                 Set breakpoint; line defaults to the current execution line;
1564                 condition breaks if it evaluates to true, defaults to '1'.
1565 b subname [condition]
1566                 Set breakpoint at first line of subroutine.
1567 b load filename Set breakpoint on `require'ing the given file.
1568 b postpone subname [condition]
1569                 Set breakpoint at first line of subroutine after
1570                 it is compiled.
1571 d [line]        Delete the breakpoint for line.
1572 D               Delete all breakpoints.
1573 a [line] command
1574                 Set an action to be done before the line is executed.
1575                 Sequence is: check for breakpoint, print line if necessary,
1576                 do action, prompt user if breakpoint or step, evaluate line.
1577 A               Delete all actions.
1578 V [pkg [vars]]  List some (default all) variables in package (default current).
1579                 Use ~pattern and !pattern for positive and negative regexps.
1580 X [vars]        Same as \"V currentpackage [vars]\".
1581 x expr          Evals expression in array context, dumps the result.
1582 O [opt[=val]] [opt\"val\"] [opt?]...
1583                 Set or query values of options.  val defaults to 1.  opt can
1584                 be abbreviated.  Several options can be listed.
1585     recallCommand, ShellBang:   chars used to recall command or spawn shell;
1586     pager:                      program for output of \"|cmd\";
1587     tkRunning:                  run Tk while prompting (with ReadLine);
1588     signalLevel warnLevel dieLevel:     level of verbosity;
1589     inhibit_exit                Allows stepping off the end of the script.
1590   The following options affect what happens with V, X, and x commands:
1591     arrayDepth, hashDepth:      print only first N elements ('' for all);
1592     compactDump, veryCompact:   change style of array and hash dump;
1593     globPrint:                  whether to print contents of globs;
1594     DumpDBFiles:                dump arrays holding debugged files;
1595     DumpPackages:               dump symbol tables of packages;
1596     quote, HighBit, undefPrint: change style of string dump;
1597   Option PrintRet affects printing of return value after r command,
1598          frame    affects printing messages on entry and exit from subroutines.
1599          AutoTrace affects printing messages on every possible breaking point.
1600                 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1601                 You can put additional initialization options TTY, noTTY,
1602                 ReadLine, and NonStop there.
1603 < command       Define Perl command to run before each prompt.
1604 << command      Add to the list of Perl commands to run before each prompt.
1605 > command       Define Perl command to run after each prompt.
1606 >> command      Add to the list of Perl commands to run after each prompt.
1607 \{ commandline  Define debugger command to run before each prompt.
1608 \{{ commandline Add to the list of debugger commands to run before each prompt.
1609 $prc number     Redo a previous command (default previous command).
1610 $prc -number    Redo number'th-to-last command.
1611 $prc pattern    Redo last command that started with pattern.
1612                 See 'O recallCommand' too.
1613 $psh$psh cmd    Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1614   . ( $rc eq $sh ? "" : "
1615 $psh [cmd]      Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1616                 See 'O shellBang' too.
1617 H -number       Display last number commands (default all).
1618 p expr          Same as \"print {DB::OUT} expr\" in current package.
1619 |dbcmd          Run debugger command, piping DB::OUT to current pager.
1620 ||dbcmd         Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1621 \= [alias value]        Define a command alias, or list current aliases.
1622 command         Execute as a perl statement in current package.
1623 v               Show versions of loaded modules.
1624 R               Pure-man-restart of debugger, some of debugger state
1625                 and command-line options may be lost.
1626                 Currently the following setting are preserved:
1627                 history, breakpoints and actions, debugger Options
1628                 and the following command-line options: -w, -I, -e.
1629 h [db_command]  Get help [on a specific debugger command], enter |h to page.
1630 h h             Summary of debugger commands.
1631 q or ^D         Quit. Set \$DB::finished to 0 to debug global destruction.
1632
1633 ";
1634     $summary = <<"END_SUM";
1635 List/search source lines:               Control script execution:
1636   l [ln|sub]  List source code            T           Stack trace
1637   - or .      List previous/current line  s [expr]    Single step [in expr]
1638   w [line]    List around line            n [expr]    Next, steps over subs
1639   f filename  View source in file         <CR>        Repeat last n or s
1640   /pattern/ ?patt?   Search forw/backw    r           Return from subroutine
1641   v           Show versions of modules    c [ln|sub]  Continue until position
1642 Debugger controls:                        L           List break pts & actions
1643   O [...]     Set debugger options        t [expr]    Toggle trace [trace expr]
1644   <[<] or {[{] [cmd]   Do before prompt   b [ln/event] [c]     Set breakpoint
1645   >[>] [cmd]  Do after prompt             b sub [c]   Set breakpoint for sub
1646   $prc [N|pat]   Redo a previous command     d [line]    Delete a breakpoint
1647   H [-num]    Display last num commands   D           Delete all breakpoints
1648   = [a val]   Define/list an alias        a [ln] cmd  Do cmd before line
1649   h [db_cmd]  Get help on command         A           Delete all actions
1650   |[|]dbcmd   Send output to pager        $psh\[$psh\] syscmd Run cmd in a subprocess
1651   q or ^D     Quit                        R           Attempt a restart
1652 Data Examination:             expr     Execute perl code, also see: s,n,t expr
1653   x expr        Evals expression in array context, dumps the result.
1654   p expr        Print expression (uses script's current package).
1655   S [[!]pat]    List subroutine names [not] matching pattern
1656   V [Pk [Vars]] List Variables in Package.  Vars can be ~pattern or !pattern.
1657   X [Vars]      Same as \"V current_package [Vars]\".
1658 END_SUM
1659                                 # ')}}; # Fix balance of Emacs parsing
1660 }
1661
1662 sub diesignal {
1663     local $frame = 0;
1664     local $doret = -2;
1665     $SIG{'ABRT'} = 'DEFAULT';
1666     kill 'ABRT', $$ if $panic++;
1667     print $DB::OUT "Got $_[0]!\n";      # in the case cannot continue
1668     local $SIG{__WARN__} = '';
1669     require Carp;
1670     local $Carp::CarpLevel = 2;         # mydie + confess
1671     &warn(Carp::longmess("Signal @_"));
1672     kill 'ABRT', $$;
1673 }
1674
1675 sub dbwarn {
1676   local $frame = 0;
1677   local $doret = -2;
1678   local $SIG{__WARN__} = '';
1679   local $SIG{__DIE__} = '';
1680   eval { require Carp };        # If error/warning during compilation,
1681                                 # require may be broken.
1682   warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1683     unless defined &Carp::longmess;
1684   #&warn("Entering dbwarn\n");
1685   my ($mysingle,$mytrace) = ($single,$trace);
1686   $single = 0; $trace = 0;
1687   my $mess = Carp::longmess(@_);
1688   ($single,$trace) = ($mysingle,$mytrace);
1689   #&warn("Warning in dbwarn\n");
1690   &warn($mess);
1691   #&warn("Exiting dbwarn\n");
1692 }
1693
1694 sub dbdie {
1695   local $frame = 0;
1696   local $doret = -2;
1697   local $SIG{__DIE__} = '';
1698   local $SIG{__WARN__} = '';
1699   my $i = 0; my $ineval = 0; my $sub;
1700   #&warn("Entering dbdie\n");
1701   if ($dieLevel != 2) {
1702     while ((undef,undef,undef,$sub) = caller(++$i)) {
1703       $ineval = 1, last if $sub eq '(eval)';
1704     }
1705     {
1706       local $SIG{__WARN__} = \&dbwarn;
1707       &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1708     }
1709     #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1710     die @_ if $ineval and $dieLevel < 2;
1711   }
1712   eval { require Carp };        # If error/warning during compilation,
1713                                 # require may be broken.
1714   die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1715   # We do not want to debug this chunk (automatic disabling works
1716   # inside DB::DB, but not in Carp).
1717   my ($mysingle,$mytrace) = ($single,$trace);
1718   $single = 0; $trace = 0;
1719   my $mess = Carp::longmess(@_);
1720   ($single,$trace) = ($mysingle,$mytrace);
1721   #&warn("dieing loudly in dbdie\n");
1722   die $mess;
1723 }
1724
1725 sub warnLevel {
1726   if (@_) {
1727     $prevwarn = $SIG{__WARN__} unless $warnLevel;
1728     $warnLevel = shift;
1729     if ($warnLevel) {
1730       $SIG{__WARN__} = \&DB::dbwarn;
1731     } else {
1732       $SIG{__WARN__} = $prevwarn;
1733     }
1734   }
1735   $warnLevel;
1736 }
1737
1738 sub dieLevel {
1739   if (@_) {
1740     $prevdie = $SIG{__DIE__} unless $dieLevel;
1741     $dieLevel = shift;
1742     if ($dieLevel) {
1743       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1744       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1745       print $OUT "Stack dump during die enabled",
1746         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1747       print $OUT "Dump printed too.\n" if $dieLevel > 2;
1748     } else {
1749       $SIG{__DIE__} = $prevdie;
1750       print $OUT "Default die handler restored.\n";
1751     }
1752   }
1753   $dieLevel;
1754 }
1755
1756 sub signalLevel {
1757   if (@_) {
1758     $prevsegv = $SIG{SEGV} unless $signalLevel;
1759     $prevbus = $SIG{BUS} unless $signalLevel;
1760     $signalLevel = shift;
1761     if ($signalLevel) {
1762       $SIG{SEGV} = \&DB::diesignal;
1763       $SIG{BUS} = \&DB::diesignal;
1764     } else {
1765       $SIG{SEGV} = $prevsegv;
1766       $SIG{BUS} = $prevbus;
1767     }
1768   }
1769   $signalLevel;
1770 }
1771
1772 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1773
1774 BEGIN {                 # This does not compile, alas.
1775   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
1776   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
1777   $sh = '!';
1778   $rc = ',';
1779   @hist = ('?');
1780   $deep = 100;                  # warning if stack gets this deep
1781   $window = 10;
1782   $preview = 3;
1783   $sub = '';
1784   $SIG{INT} = \&DB::catch;
1785   # This may be enabled to debug debugger:
1786   #$warnLevel = 1 unless defined $warnLevel;
1787   #$dieLevel = 1 unless defined $dieLevel;
1788   #$signalLevel = 1 unless defined $signalLevel;
1789
1790   $db_stop = 0;                 # Compiler warning
1791   $db_stop = 1 << 30;
1792   $level = 0;                   # Level of recursive debugging
1793   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1794   # Triggers bug (?) in perl is we postpone this until runtime:
1795   @postponed = @stack = (0);
1796   $doret = -2;
1797   $frame = 0;
1798 }
1799
1800 BEGIN {$^W = $ini_warn;}        # Switch warnings back
1801
1802 #use Carp;                      # This did break, left for debuggin
1803
1804 sub db_complete {
1805   my($text, $line, $start) = @_;
1806   my ($itext, $prefix, $pack) = $text;
1807
1808   if ((substr $text, 0, 1) eq '&') { # subroutines
1809     $text = substr $text, 1;
1810     $prefix = "&";
1811     return map "$prefix$_", grep /^\Q$text/, keys %sub;
1812   }
1813   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
1814     $pack = ($1 eq 'main' ? '' : $1) . '::';
1815     $prefix = (substr $text, 0, 1) . $1 . '::';
1816     $text = $2;
1817     my @out
1818       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
1819     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1820       return db_complete($out[0], $line, $start);
1821     }
1822     return @out;
1823   }
1824   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
1825     $pack = ($package eq 'main' ? '' : $package) . '::';
1826     $prefix = substr $text, 0, 1;
1827     $text = substr $text, 1;
1828     my @out = map "$prefix$_", grep /^\Q$text/,
1829        (grep /^_?[a-zA-Z]/, keys %$pack),
1830        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
1831     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1832       return db_complete($out[0], $line, $start);
1833     }
1834     return @out;
1835   }
1836   return grep /^\Q$text/, (keys %sub), qw(postpone load) # subroutines
1837     if (substr $line, 0, $start) =~ /^[bl]\s+(postpone\s+)?$/;
1838   return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages
1839     if (substr $line, 0, $start) =~ /^V\s+$/;
1840   if ((substr $line, 0, $start) =~ /^O\b.*\s$/) { # Options after a space
1841     my @out = grep /^\Q$text/, @options;
1842     my $val = option_val($out[0], undef);
1843     my $out = '? ';
1844     if (not defined $val or $val =~ /[\n\r]/) {
1845       # Can do nothing better
1846     } elsif ($val =~ /\s/) {
1847       my $found;
1848       foreach $l (split //, qq/\"\'\#\|/) {
1849         $out = "$l$val$l ", last if (index $val, $l) == -1;
1850       }
1851     } else {
1852       $out = "=$val ";
1853     }
1854     # Default to value if one completion, to question if many
1855     $readline::rl_completer_terminator_character
1856       = $readline::rl_completer_terminator_character
1857         = (@out == 1 ? $out : '? ');
1858     return @out;
1859   }
1860   return &readline::rl_filename_list($text); # filenames
1861 }
1862
1863 sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
1864
1865 END {
1866   $finished = $inhibit_exit;    # So that some keys may be disabled.
1867   # Do not stop in at_exit() and destructors on exit:
1868   $DB::single = !$exiting && !$runnonstop;
1869   DB::fake::at_exit() unless $exiting or $runnonstop;
1870 }
1871
1872 package DB::fake;
1873
1874 sub at_exit {
1875   "Debuggee terminated. Use `q' to quit and `R' to restart.";
1876 }
1877
1878 package DB;                     # Do not trace this 1; below!
1879
1880 1;