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