lib/perl5db.pl

   1 package DB;
   2
   3 # Debugger for Perl 5.00x; perl5db.pl patch level:
   4
   5 $VERSION = 1.04041;
   6 $header = "perl5db.pl version $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($main::{'_<'.$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 @{$main::{'_<'.$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 # RemotePort - host:port to connect to on remote host for remote debugging.
  80 #
  81 # Example $rcfile: (delete leading hashes!)
  82 #
  83 # &parse_options("NonStop=1 LineInfo=db.out");
  84 # sub afterinit { $trace = 1; }
  85 #
  86 # The script will run without human intervention, putting trace
  87 # information into db.out.  (If you interrupt it, you would better
  88 # reset LineInfo to something "interactive"!)
  89 #
  90 ##################################################################
  91 # Changelog:
  92
  93 # A lot of things changed after 0.94. First of all, core now informs
  94 # debugger about entry into XSUBs, overloaded operators, tied operations,
  95 # BEGIN and END. Handy with `O f=2'.
  96
  97 # This can make debugger a little bit too verbose, please be patient
  98 # and report your problems promptly.
  99
 100 # Now the option frame has 3 values: 0,1,2.
 101
 102 # Note that if DESTROY returns a reference to the object (or object),
 103 # the deletion of data may be postponed until the next function call,
 104 # due to the need to examine the return value.
 105
 106 # Changes: 0.95: `v' command shows versions.
 107 # Changes: 0.96: `v' command shows version of readline.
 108 #       primitive completion works (dynamic variables, subs for `b' and `l',
 109 #               options). Can `p %var'
 110 #       Better help (`h <' now works). New commands <<, >>, {, {{.
 111 #       {dump|print}_trace() coded (to be able to do it from <<cmd).
 112 #       `c sub' documented.
 113 #       At last enough magic combined to stop after the end of debuggee.
 114 #       !! should work now (thanks to Emacs bracket matching an extra
 115 #       `]' in a regexp is caught).
 116 #       `L', `D' and `A' span files now (as documented).
 117 #       Breakpoints in `require'd code are possible (used in `R').
 118 #       Some additional words on internal work of debugger.
 119 #       `b load filename' implemented.
 120 #       `b postpone subr' implemented.
 121 #       now only `q' exits debugger (overwriteable on $inhibit_exit).
 122 #       When restarting debugger breakpoints/actions persist.
 123 #     Buglet: When restarting debugger only one breakpoint/action per
 124 #               autoloaded function persists.
 125 # Changes: 0.97: NonStop will not stop in at_exit().
 126 #       Option AutoTrace implemented.
 127 #       Trace printed differently if frames are printed too.
 128 #       new `inhibitExit' option.
 129 #       printing of a very long statement interruptible.
 130 # Changes: 0.98: New command `m' for printing possible methods
 131 #       'l -' is a synonim for `-'.
 132 #       Cosmetic bugs in printing stack trace.
 133 #       `frame' & 8 to print "expanded args" in stack trace.
 134 #       Can list/break in imported subs.
 135 #       new `maxTraceLen' option.
 136 #       frame & 4 and frame & 8 granted.
 137 #       new command `m'
 138 #       nonstoppable lines do not have `:' near the line number.
 139 #       `b compile subname' implemented.
 140 #       Will not use $` any more.
 141 #       `-' behaves sane now.
 142 # Changes: 0.99: Completion for `f', `m'.
 143 #       `m' will remove duplicate names instead of duplicate functions.
 144 #       `b load' strips trailing whitespace.
 145 #       completion ignores leading `|'; takes into account current package
 146 #       when completing a subroutine name (same for `l').
 147
 148 ####################################################################
 149
 150 # Needed for the statement after exec():
 151
 152 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
 153 local($^W) = 0;                 # Switch run-time warnings off during init.
 154 warn (                  # Do not ;-)
 155       $dumpvar::hashDepth,
 156       $dumpvar::arrayDepth,
 157       $dumpvar::dumpDBFiles,
 158       $dumpvar::dumpPackages,
 159       $dumpvar::quoteHighBit,
 160       $dumpvar::printUndef,
 161       $dumpvar::globPrint,
 162       $dumpvar::usageOnly,
 163       @ARGS,
 164       $Carp::CarpLevel,
 165       $panic,
 166       $second_time,
 167      ) if 0;
 168
 169 # Command-line + PERLLIB:
 170 @ini_INC = @INC;
 171
 172 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
 173
 174 $trace = $signal = $single = 0; # Uninitialized warning suppression
 175                                 # (local $^W cannot help - other packages!).
 176 $inhibit_exit = $option{PrintRet} = 1;
 177
 178 @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
 179                   compactDump veryCompact quote HighBit undefPrint
 180                   globPrint PrintRet UsageOnly frame AutoTrace
 181                   TTY noTTY ReadLine NonStop LineInfo maxTraceLen
 182                   recallCommand ShellBang pager tkRunning ornaments
 183                   signalLevel warnLevel dieLevel inhibit_exit
 184                   ImmediateStop bareStringify
 185                   RemotePort);
 186
 187 %optionVars    = (
 188                  hashDepth      => \$dumpvar::hashDepth,
 189                  arrayDepth     => \$dumpvar::arrayDepth,
 190                  DumpDBFiles    => \$dumpvar::dumpDBFiles,
 191                  DumpPackages   => \$dumpvar::dumpPackages,
 192                  DumpReused     => \$dumpvar::dumpReused,
 193                  HighBit        => \$dumpvar::quoteHighBit,
 194                  undefPrint     => \$dumpvar::printUndef,
 195                  globPrint      => \$dumpvar::globPrint,
 196                  UsageOnly      => \$dumpvar::usageOnly,
 197                  bareStringify  => \$dumpvar::bareStringify,
 198                  frame          => \$frame,
 199                  AutoTrace      => \$trace,
 200                  inhibit_exit   => \$inhibit_exit,
 201                  maxTraceLen    => \$maxtrace,
 202                  ImmediateStop  => \$ImmediateStop,
 203                  RemotePort     => \$remoteport,
 204 );
 205
 206 %optionAction  = (
 207                   compactDump   => \&dumpvar::compactDump,
 208                   veryCompact   => \&dumpvar::veryCompact,
 209                   quote         => \&dumpvar::quote,
 210                   TTY           => \&TTY,
 211                   noTTY         => \&noTTY,
 212                   ReadLine      => \&ReadLine,
 213                   NonStop       => \&NonStop,
 214                   LineInfo      => \&LineInfo,
 215                   recallCommand => \&recallCommand,
 216                   ShellBang     => \&shellBang,
 217                   pager         => \&pager,
 218                   signalLevel   => \&signalLevel,
 219                   warnLevel     => \&warnLevel,
 220                   dieLevel      => \&dieLevel,
 221                   tkRunning     => \&tkRunning,
 222                   ornaments     => \&ornaments,
 223                   RemotePort    => \&RemotePort,
 224                  );
 225
 226 %optionRequire = (
 227                   compactDump   => 'dumpvar.pl',
 228                   veryCompact   => 'dumpvar.pl',
 229                   quote         => 'dumpvar.pl',
 230                  );
 231
 232 # These guys may be defined in $ENV{PERL5DB} :
 233 $rl = 1 unless defined $rl;
 234 $warnLevel = 1 unless defined $warnLevel;
 235 $dieLevel = 1 unless defined $dieLevel;
 236 $signalLevel = 1 unless defined $signalLevel;
 237 $pre = [] unless defined $pre;
 238 $post = [] unless defined $post;
 239 $pretype = [] unless defined $pretype;
 240 warnLevel($warnLevel);
 241 dieLevel($dieLevel);
 242 signalLevel($signalLevel);
 243 &pager((defined($ENV{PAGER})
 244         ? $ENV{PAGER}
 245         : ($^O eq 'os2'
 246            ? 'cmd /c more'
 247            : 'more'))) unless defined $pager;
 248 &recallCommand("!") unless defined $prc;
 249 &shellBang("!") unless defined $psh;
 250 $maxtrace = 400 unless defined $maxtrace;
 251
 252 if (-e "/dev/tty") {
 253   $rcfile=".perldb";
 254 } else {
 255   $rcfile="perldb.ini";
 256 }
 257
 258 if (-f $rcfile) {
 259     do "./$rcfile";
 260 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
 261     do "$ENV{LOGDIR}/$rcfile";
 262 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
 263     do "$ENV{HOME}/$rcfile";
 264 }
 265
 266 if (defined $ENV{PERLDB_OPTS}) {
 267   parse_options($ENV{PERLDB_OPTS});
 268 }
 269
 270 if (exists $ENV{PERLDB_RESTART}) {
 271   delete $ENV{PERLDB_RESTART};
 272   # $restart = 1;
 273   @hist = get_list('PERLDB_HIST');
 274   %break_on_load = get_list("PERLDB_ON_LOAD");
 275   %postponed = get_list("PERLDB_POSTPONE");
 276   my @had_breakpoints= get_list("PERLDB_VISITED");
 277   for (0 .. $#had_breakpoints) {
 278     my %pf = get_list("PERLDB_FILE_$_");
 279     $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
 280   }
 281   my %opt = get_list("PERLDB_OPT");
 282   my ($opt,$val);
 283   while (($opt,$val) = each %opt) {
 284     $val =~ s/[\\\']/\\$1/g;
 285     parse_options("$opt'$val'");
 286   }
 287   @INC = get_list("PERLDB_INC");
 288   @ini_INC = @INC;
 289   $pretype = [get_list("PERLDB_PRETYPE")];
 290   $pre = [get_list("PERLDB_PRE")];
 291   $post = [get_list("PERLDB_POST")];
 292   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
 293 }
 294
 295 if ($notty) {
 296   $runnonstop = 1;
 297 } else {
 298   # Is Perl being run from Emacs?
 299   $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
 300   $rl = 0, shift(@main::ARGV) if $emacs;
 301
 302   #require Term::ReadLine;
 303
 304   if ($^O eq 'cygwin') {
 305     # /dev/tty is binary. use stdin for textmode
 306     undef $console;
 307   } elsif (-e "/dev/tty") {
 308     $console = "/dev/tty";
 309   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
 310     $console = "con";
 311   } else {
 312     $console = "sys\$command";
 313   }
 314
 315   if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
 316     $console = undef;
 317   }
 318
 319   # Around a bug:
 320   if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
 321     $console = undef;
 322   }
 323
 324   if ($^O eq 'epoc') {
 325     $console = undef;
 326   }
 327
 328   $console = $tty if defined $tty;
 329
 330   if (defined $remoteport) {
 331     require IO::Socket;
 332     $OUT = new IO::Socket::INET( Timeout  => '10',
 333                                  PeerAddr => $remoteport,
 334                                  Proto    => 'tcp',
 335                                );
 336     if (!$OUT) { die "Could not create socket to connect to remote host."; }
 337     $IN = $OUT;
 338   }
 339   else {
 340     if (defined $console) {
 341       open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
 342       open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
 343         || open(OUT,">&STDOUT");        # so we don't dongle stdout
 344     } else {
 345       open(IN,"<&STDIN");
 346       open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
 347       $console = 'STDIN/OUT';
 348     }
 349     # so open("|more") can read from STDOUT and so we don't dingle stdin
 350     $IN = \*IN;
 351
 352     $OUT = \*OUT;
 353   }
 354   select($OUT);
 355   $| = 1;                       # for DB::OUT
 356   select(STDOUT);
 357
 358   $LINEINFO = $OUT unless defined $LINEINFO;
 359   $lineinfo = $console unless defined $lineinfo;
 360
 361   $| = 1;                       # for real STDOUT
 362
 363   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
 364   unless ($runnonstop) {
 365     print $OUT "\nLoading DB routines from $header\n";
 366     print $OUT ("Emacs support ",
 367                 $emacs ? "enabled" : "available",
 368                 ".\n");
 369     print $OUT "\nEnter h or `h h' for help, run `perldoc perldebug' for more help.\n\n";
 370   }
 371 }
 372
 373 @ARGS = @ARGV;
 374 for (@args) {
 375     s/\'/\\\'/g;
 376     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
 377 }
 378
 379 if (defined &afterinit) {       # May be defined in $rcfile
 380   &afterinit();
 381 }
 382
 383 $I_m_init = 1;
 384
 385 ############################################################ Subroutines
 386
 387 sub DB {
 388     # _After_ the perl program is compiled, $single is set to 1:
 389     if ($single and not $second_time++) {
 390       if ($runnonstop) {        # Disable until signal
 391         for ($i=0; $i <= $stack_depth; ) {
 392             $stack[$i++] &= ~1;
 393         }
 394         $single = 0;
 395         # return;                       # Would not print trace!
 396       } elsif ($ImmediateStop) {
 397         $ImmediateStop = 0;
 398         $signal = 1;
 399       }
 400     }
 401     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
 402     &save;
 403     ($package, $filename, $line) = caller;
 404     $filename_ini = $filename;
 405     $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
 406       "package $package;";      # this won't let them modify, alas
 407     local(*dbline) = $main::{'_<' . $filename};
 408     $max = $#dbline;
 409     if (($stop,$action) = split(/\0/,$dbline{$line})) {
 410         if ($stop eq '1') {
 411             $signal |= 1;
 412         } elsif ($stop) {
 413             $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
 414             $dbline{$line} =~ s/;9($|\0)/$1/;
 415         }
 416     }
 417     my $was_signal = $signal;
 418     if ($trace & 2) {
 419       for (my $n = 0; $n <= $#to_watch; $n++) {
 420         $evalarg = $to_watch[$n];
 421         local $onetimeDump;     # Do not output results
 422         my ($val) = &eval;      # Fix context (&eval is doing array)?
 423         $val = ( (defined $val) ? "'$val'" : 'undef' );
 424         if ($val ne $old_watch[$n]) {
 425           $signal = 1;
 426           print $OUT <<EOP;
 427 Watchpoint $n:\t$to_watch[$n] changed:
 428     old value:\t$old_watch[$n]
 429     new value:\t$val
 430 EOP
 431           $old_watch[$n] = $val;
 432         }
 433       }
 434     }
 435     if ($trace & 4) {           # User-installed watch
 436       return if watchfunction($package, $filename, $line)
 437         and not $single and not $was_signal and not ($trace & ~4);
 438     }
 439     $was_signal = $signal;
 440     $signal = 0;
 441     if ($single || ($trace & 1) || $was_signal) {
 442         if ($emacs) {
 443             $position = "\032\032$filename:$line:0\n";
 444             print $LINEINFO $position;
 445         } elsif ($package eq 'DB::fake') {
 446           $term || &setterm;
 447           print_help(<<EOP);
 448 Debugged program terminated.  Use B<q> to quit or B<R> to restart,
 449   use B<O> I<inhibit_exit> to avoid stopping after program termination,
 450   B<h q>, B<h R> or B<h O> to get additional info.
 451 EOP
 452           $package = 'main';
 453           $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
 454             "package $package;";        # this won't let them modify, alas
 455         } else {
 456             $sub =~ s/\'/::/;
 457             $prefix = $sub =~ /::/ ? "" : "${'package'}::";
 458             $prefix .= "$sub($filename:";
 459             $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
 460             if (length($prefix) > 30) {
 461                 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
 462                 $prefix = "";
 463                 $infix = ":\t";
 464             } else {
 465                 $infix = "):\t";
 466                 $position = "$prefix$line$infix$dbline[$line]$after";
 467             }
 468             if ($frame) {
 469                 print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
 470             } else {
 471                 print $LINEINFO $position;
 472             }
 473             for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
 474                 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
 475                 last if $signal;
 476                 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
 477                 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
 478                 $position .= $incr_pos;
 479                 if ($frame) {
 480                     print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
 481                 } else {
 482                     print $LINEINFO $incr_pos;
 483                 }
 484             }
 485         }
 486     }
 487     $evalarg = $action, &eval if $action;
 488     if ($single || $was_signal) {
 489         local $level = $level + 1;
 490         foreach $evalarg (@$pre) {
 491           &eval;
 492         }
 493         print $OUT $stack_depth . " levels deep in subroutine calls!\n"
 494           if $single & 4;
 495         $start = $line;
 496         $incr = -1;             # for backward motion.
 497         @typeahead = (@$pretype, @typeahead);
 498       CMD:
 499         while (($term || &setterm),
 500                ($term_pid == $$ or &resetterm),
 501                defined ($cmd=&readline("  DB" . ('<' x $level) .
 502                                        ($#hist+1) . ('>' x $level) .
 503                                        " "))) {
 504                 $single = 0;
 505                 $signal = 0;
 506                 $cmd =~ s/\\$/\n/ && do {
 507                     $cmd .= &readline("  cont: ");
 508                     redo CMD;
 509                 };
 510                 $cmd =~ /^$/ && ($cmd = $laststep);
 511                 push(@hist,$cmd) if length($cmd) > 1;
 512               PIPE: {
 513                     ($i) = split(/\s+/,$cmd);
 514                     eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
 515                     $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
 516                     $cmd =~ /^h$/ && do {
 517                         print_help($help);
 518                         next CMD; };
 519                     $cmd =~ /^h\s+h$/ && do {
 520                         print_help($summary);
 521                         next CMD; };
 522                     $cmd =~ /^h\s+(\S)$/ && do {
 523                         my $asked = "\Q$1";
 524                         if ($help =~ /^(?:[IB]<)$asked/m) {
 525                           while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
 526                             print_help($1);
 527                           }
 528                         } else {
 529                             print_help("B<$asked> is not a debugger command.\n");
 530                         }
 531                         next CMD; };
 532                     $cmd =~ /^t$/ && do {
 533                         ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
 534                         print $OUT "Trace = " .
 535                             (($trace & 1) ? "on" : "off" ) . "\n";
 536                         next CMD; };
 537                     $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
 538                         $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
 539                         foreach $subname (sort(keys %sub)) {
 540                             if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
 541                                 print $OUT $subname,"\n";
 542                             }
 543                         }
 544                         next CMD; };
 545                     $cmd =~ /^v$/ && do {
 546                         list_versions(); next CMD};
 547                     $cmd =~ s/^X\b/V $package/;
 548                     $cmd =~ /^V$/ && do {
 549                         $cmd = "V $package"; };
 550                     $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
 551                         local ($savout) = select($OUT);
 552                         $packname = $1;
 553                         @vars = split(' ',$2);
 554                         do 'dumpvar.pl' unless defined &main::dumpvar;
 555                         if (defined &main::dumpvar) {
 556                             local $frame = 0;
 557                             local $doret = -2;
 558                             &main::dumpvar($packname,@vars);
 559                         } else {
 560                             print $OUT "dumpvar.pl not available.\n";
 561                         }
 562                         select ($savout);
 563                         next CMD; };
 564                     $cmd =~ s/^x\b/ / && do { # So that will be evaled
 565                         $onetimeDump = 'dump'; };
 566                     $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
 567                         methods($1); next CMD};
 568                     $cmd =~ s/^m\b/ / && do { # So this will be evaled
 569                         $onetimeDump = 'methods'; };
 570                     $cmd =~ /^f\b\s*(.*)/ && do {
 571                         $file = $1;
 572                         $file =~ s/\s+$//;
 573                         if (!$file) {
 574                             print $OUT "The old f command is now the r command.\n";
 575                             print $OUT "The new f command switches filenames.\n";
 576                             next CMD;
 577                         }
 578                         if (!defined $main::{'_<' . $file}) {
 579                             if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
 580                                               $try = substr($try,2);
 581                                               print $OUT "Choosing $try matching `$file':\n";
 582                                               $file = $try;
 583                                           }}
 584                         }
 585                         if (!defined $main::{'_<' . $file}) {
 586                             print $OUT "No file matching `$file' is loaded.\n";
 587                             next CMD;
 588                         } elsif ($file ne $filename) {
 589                             *dbline = $main::{'_<' . $file};
 590                             $max = $#dbline;
 591                             $filename = $file;
 592                             $start = 1;
 593                             $cmd = "l";
 594                           } else {
 595                             print $OUT "Already in $file.\n";
 596                             next CMD;
 597                           }
 598                       };
 599                     $cmd =~ s/^l\s+-\s*$/-/;
 600                     $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
 601                         $subname = $1;
 602                         $subname =~ s/\'/::/;
 603                         $subname = $package."::".$subname
 604                           unless $subname =~ /::/;
 605                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 606                         @pieces = split(/:/,find_sub($subname));
 607                         $subrange = pop @pieces;
 608                         $file = join(':', @pieces);
 609                         if ($file ne $filename) {
 610                             print $OUT "Switching to file '$file'.\n"
 611                                 unless $emacs;
 612                             *dbline = $main::{'_<' . $file};
 613                             $max = $#dbline;
 614                             $filename = $file;
 615                         }
 616                         if ($subrange) {
 617                             if (eval($subrange) < -$window) {
 618                                 $subrange =~ s/-.*/+/;
 619                             }
 620                             $cmd = "l $subrange";
 621                         } else {
 622                             print $OUT "Subroutine $subname not found.\n";
 623                             next CMD;
 624                         } };
 625                     $cmd =~ /^\.$/ && do {
 626                         $incr = -1;             # for backward motion.
 627                         $start = $line;
 628                         $filename = $filename_ini;
 629                         *dbline = $main::{'_<' . $filename};
 630                         $max = $#dbline;
 631                         print $LINEINFO $position;
 632                         next CMD };
 633                     $cmd =~ /^w\b\s*(\d*)$/ && do {
 634                         $incr = $window - 1;
 635                         $start = $1 if $1;
 636                         $start -= $preview;
 637                         #print $OUT 'l ' . $start . '-' . ($start + $incr);
 638                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 639                     $cmd =~ /^-$/ && do {
 640                         $start -= $incr + $window + 1;
 641                         $start = 1 if $start <= 0;
 642                         $incr = $window - 1;
 643                         $cmd = 'l ' . ($start) . '+'; };
 644                     $cmd =~ /^l$/ && do {
 645                         $incr = $window - 1;
 646                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 647                     $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
 648                         $start = $1 if $1;
 649                         $incr = $2;
 650                         $incr = $window - 1 unless $incr;
 651                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 652                     $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 653                         $end = (!defined $2) ? $max : ($4 ? $4 : $2);
 654                         $end = $max if $end > $max;
 655                         $i = $2;
 656                         $i = $line if $i eq '.';
 657                         $i = 1 if $i < 1;
 658                         $incr = $end - $i;
 659                         if ($emacs) {
 660                             print $OUT "\032\032$filename:$i:0\n";
 661                             $i = $end;
 662                         } else {
 663                             for (; $i <= $end; $i++) {
 664                                 ($stop,$action) = split(/\0/, $dbline{$i});
 665                                 $arrow = ($i==$line
 666                                           and $filename eq $filename_ini)
 667                                   ?  '==>'
 668                                     : ($dbline[$i]+0 ? ':' : ' ') ;
 669                                 $arrow .= 'b' if $stop;
 670                                 $arrow .= 'a' if $action;
 671                                 print $OUT "$i$arrow\t", $dbline[$i];
 672                                 $i++, last if $signal;
 673                             }
 674                             print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
 675                         }
 676                         $start = $i; # remember in case they want more
 677                         $start = $max if $start > $max;
 678                         next CMD; };
 679                     $cmd =~ /^D$/ && do {
 680                       print $OUT "Deleting all breakpoints...\n";
 681                       my $file;
 682                       for $file (keys %had_breakpoints) {
 683                         local *dbline = $main::{'_<' . $file};
 684                         my $max = $#dbline;
 685                         my $was;
 686
 687                         for ($i = 1; $i <= $max ; $i++) {
 688                             if (defined $dbline{$i}) {
 689                                 $dbline{$i} =~ s/^[^\0]+//;
 690                                 if ($dbline{$i} =~ s/^\0?$//) {
 691                                     delete $dbline{$i};
 692                                 }
 693                             }
 694                         }
 695                       }
 696                       undef %postponed;
 697                       undef %postponed_file;
 698                       undef %break_on_load;
 699                       undef %had_breakpoints;
 700                       next CMD; };
 701                     $cmd =~ /^L$/ && do {
 702                       my $file;
 703                       for $file (keys %had_breakpoints) {
 704                         local *dbline = $main::{'_<' . $file};
 705                         my $max = $#dbline;
 706                         my $was;
 707
 708                         for ($i = 1; $i <= $max; $i++) {
 709                             if (defined $dbline{$i}) {
 710                                 print $OUT "$file:\n" unless $was++;
 711                                 print $OUT " $i:\t", $dbline[$i];
 712                                 ($stop,$action) = split(/\0/, $dbline{$i});
 713                                 print $OUT "   break if (", $stop, ")\n"
 714                                   if $stop;
 715                                 print $OUT "   action:  ", $action, "\n"
 716                                   if $action;
 717                                 last if $signal;
 718                             }
 719                         }
 720                       }
 721                       if (%postponed) {
 722                         print $OUT "Postponed breakpoints in subroutines:\n";
 723                         my $subname;
 724                         for $subname (keys %postponed) {
 725                           print $OUT " $subname\t$postponed{$subname}\n";
 726                           last if $signal;
 727                         }
 728                       }
 729                       my @have = map { # Combined keys
 730                         keys %{$postponed_file{$_}}
 731                       } keys %postponed_file;
 732                       if (@have) {
 733                         print $OUT "Postponed breakpoints in files:\n";
 734                         my ($file, $line);
 735                         for $file (keys %postponed_file) {
 736                           my $db = $postponed_file{$file};
 737                           print $OUT " $file:\n";
 738                           for $line (sort {$a <=> $b} keys %$db) {
 739                                 print $OUT "  $line:\n";
 740                                 my ($stop,$action) = split(/\0/, $$db{$line});
 741                                 print $OUT "    break if (", $stop, ")\n"
 742                                   if $stop;
 743                                 print $OUT "    action:  ", $action, "\n"
 744                                   if $action;
 745                                 last if $signal;
 746                           }
 747                           last if $signal;
 748                         }
 749                       }
 750                       if (%break_on_load) {
 751                         print $OUT "Breakpoints on load:\n";
 752                         my $file;
 753                         for $file (keys %break_on_load) {
 754                           print $OUT " $file\n";
 755                           last if $signal;
 756                         }
 757                       }
 758                       if ($trace & 2) {
 759                         print $OUT "Watch-expressions:\n";
 760                         my $expr;
 761                         for $expr (@to_watch) {
 762                           print $OUT " $expr\n";
 763                           last if $signal;
 764                         }
 765                       }
 766                       next CMD; };
 767                     $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
 768                         my $file = $1; $file =~ s/\s+$//;
 769                         {
 770                           $break_on_load{$file} = 1;
 771                           $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
 772                           $file .= '.pm', redo unless $file =~ /\./;
 773                         }
 774                         $had_breakpoints{$file} = 1;
 775                         print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
 776                         next CMD; };
 777                     $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 778                         my $cond = $3 || '1';
 779                         my ($subname, $break) = ($2, $1 eq 'postpone');
 780                         $subname =~ s/\'/::/;
 781                         $subname = "${'package'}::" . $subname
 782                           unless $subname =~ /::/;
 783                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 784                         $postponed{$subname} = $break
 785                           ? "break +0 if $cond" : "compile";
 786                         next CMD; };
 787                     $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 788                         $subname = $1;
 789                         $cond = $2 || '1';
 790                         $subname =~ s/\'/::/;
 791                         $subname = "${'package'}::" . $subname
 792                           unless $subname =~ /::/;
 793                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 794                         # Filename below can contain ':'
 795                         ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
 796                         $i += 0;
 797                         if ($i) {
 798                             local $filename = $file;
 799                             local *dbline = $main::{'_<' . $filename};
 800                             $had_breakpoints{$filename} = 1;
 801                             $max = $#dbline;
 802                             ++$i while $dbline[$i] == 0 && $i < $max;
 803                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 804                         } else {
 805                             print $OUT "Subroutine $subname not found.\n";
 806                         }
 807                         next CMD; };
 808                     $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
 809                         $i = ($1?$1:$line);
 810                         $cond = $2 || '1';
 811                         if ($dbline[$i] == 0) {
 812                             print $OUT "Line $i not breakable.\n";
 813                         } else {
 814                             $had_breakpoints{$filename} = 1;
 815                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 816                         }
 817                         next CMD; };
 818                     $cmd =~ /^d\b\s*(\d+)?/ && do {
 819                         $i = ($1?$1:$line);
 820                         $dbline{$i} =~ s/^[^\0]*//;
 821                         delete $dbline{$i} if $dbline{$i} eq '';
 822                         next CMD; };
 823                     $cmd =~ /^A$/ && do {
 824                       my $file;
 825                       for $file (keys %had_breakpoints) {
 826                         local *dbline = $main::{'_<' . $file};
 827                         my $max = $#dbline;
 828                         my $was;
 829
 830                         for ($i = 1; $i <= $max ; $i++) {
 831                             if (defined $dbline{$i}) {
 832                                 $dbline{$i} =~ s/\0[^\0]*//;
 833                                 delete $dbline{$i} if $dbline{$i} eq '';
 834                             }
 835                         }
 836                       }
 837                       next CMD; };
 838                     $cmd =~ /^O\s*$/ && do {
 839                         for (@options) {
 840                             &dump_option($_);
 841                         }
 842                         next CMD; };
 843                     $cmd =~ /^O\s*(\S.*)/ && do {
 844                         parse_options($1);
 845                         next CMD; };
 846                     $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
 847                         push @$pre, action($1);
 848                         next CMD; };
 849                     $cmd =~ /^>>\s*(.*)/ && do {
 850                         push @$post, action($1);
 851                         next CMD; };
 852                     $cmd =~ /^<\s*(.*)/ && do {
 853                         $pre = [], next CMD unless $1;
 854                         $pre = [action($1)];
 855                         next CMD; };
 856                     $cmd =~ /^>\s*(.*)/ && do {
 857                         $post = [], next CMD unless $1;
 858                         $post = [action($1)];
 859                         next CMD; };
 860                     $cmd =~ /^\{\{\s*(.*)/ && do {
 861                         push @$pretype, $1;
 862                         next CMD; };
 863                     $cmd =~ /^\{\s*(.*)/ && do {
 864                         $pretype = [], next CMD unless $1;
 865                         $pretype = [$1];
 866                         next CMD; };
 867                     $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
 868                         $i = $1; $j = $3;
 869                         if ($dbline[$i] == 0) {
 870                             print $OUT "Line $i may not have an action.\n";
 871                         } else {
 872                             $dbline{$i} =~ s/\0[^\0]*//;
 873                             $dbline{$i} .= "\0" . action($j);
 874                         }
 875                         next CMD; };
 876                     $cmd =~ /^n$/ && do {
 877                         end_report(), next CMD if $finished and $level <= 1;
 878                         $single = 2;
 879                         $laststep = $cmd;
 880                         last CMD; };
 881                     $cmd =~ /^s$/ && do {
 882                         end_report(), next CMD if $finished and $level <= 1;
 883                         $single = 1;
 884                         $laststep = $cmd;
 885                         last CMD; };
 886                     $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
 887                         end_report(), next CMD if $finished and $level <= 1;
 888                         $subname = $i = $1;
 889                         #  Probably not needed, since we finish an interactive
 890                         #  sub-session anyway...
 891                         # local $filename = $filename;
 892                         # local *dbline = *dbline;      # XXX Would this work?!
 893                         if ($i =~ /\D/) { # subroutine name
 894                             $subname = $package."::".$subname
 895                                 unless $subname =~ /::/;
 896                             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
 897                             $i += 0;
 898                             if ($i) {
 899                                 $filename = $file;
 900                                 *dbline = $main::{'_<' . $filename};
 901                                 $had_breakpoints{$filename}++;
 902                                 $max = $#dbline;
 903                                 ++$i while $dbline[$i] == 0 && $i < $max;
 904                             } else {
 905                                 print $OUT "Subroutine $subname not found.\n";
 906                                 next CMD;
 907                             }
 908                         }
 909                         if ($i) {
 910                             if ($dbline[$i] == 0) {
 911                                 print $OUT "Line $i not breakable.\n";
 912                                 next CMD;
 913                             }
 914                             $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
 915                         }
 916                         for ($i=0; $i <= $stack_depth; ) {
 917                             $stack[$i++] &= ~1;
 918                         }
 919                         last CMD; };
 920                     $cmd =~ /^r$/ && do {
 921                         end_report(), next CMD if $finished and $level <= 1;
 922                         $stack[$stack_depth] |= 1;
 923                         $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
 924                         last CMD; };
 925                     $cmd =~ /^R$/ && do {
 926                         print $OUT "Warning: some settings and command-line options may be lost!\n";
 927                         my (@script, @flags, $cl);
 928                         push @flags, '-w' if $ini_warn;
 929                         # Put all the old includes at the start to get
 930                         # the same debugger.
 931                         for (@ini_INC) {
 932                           push @flags, '-I', $_;
 933                         }
 934                         # Arrange for setting the old INC:
 935                         set_list("PERLDB_INC", @ini_INC);
 936                         if ($0 eq '-e') {
 937                           for (1..$#{'::_<-e'}) { # The first line is PERL5DB
 938                             chomp ($cl =  $ {'::_<-e'}[$_]);
 939                             push @script, '-e', $cl;
 940                           }
 941                         } else {
 942                           @script = $0;
 943                         }
 944                         set_list("PERLDB_HIST",
 945                                  $term->Features->{getHistory}
 946                                  ? $term->GetHistory : @hist);
 947                         my @had_breakpoints = keys %had_breakpoints;
 948                         set_list("PERLDB_VISITED", @had_breakpoints);
 949                         set_list("PERLDB_OPT", %option);
 950                         set_list("PERLDB_ON_LOAD", %break_on_load);
 951                         my @hard;
 952                         for (0 .. $#had_breakpoints) {
 953                           my $file = $had_breakpoints[$_];
 954                           *dbline = $main::{'_<' . $file};
 955                           next unless %dbline or $postponed_file{$file};
 956                           (push @hard, $file), next
 957                             if $file =~ /^\(eval \d+\)$/;
 958                           my @add;
 959                           @add = %{$postponed_file{$file}}
 960                             if $postponed_file{$file};
 961                           set_list("PERLDB_FILE_$_", %dbline, @add);
 962                         }
 963                         for (@hard) { # Yes, really-really...
 964                           # Find the subroutines in this eval
 965                           *dbline = $main::{'_<' . $_};
 966                           my ($quoted, $sub, %subs, $line) = quotemeta $_;
 967                           for $sub (keys %sub) {
 968                             next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
 969                             $subs{$sub} = [$1, $2];
 970                           }
 971                           unless (%subs) {
 972                             print $OUT
 973                               "No subroutines in $_, ignoring breakpoints.\n";
 974                             next;
 975                           }
 976                         LINES: for $line (keys %dbline) {
 977                             # One breakpoint per sub only:
 978                             my ($offset, $sub, $found);
 979                           SUBS: for $sub (keys %subs) {
 980                               if ($subs{$sub}->[1] >= $line # Not after the subroutine
 981                                   and (not defined $offset # Not caught
 982                                        or $offset < 0 )) { # or badly caught
 983                                 $found = $sub;
 984                                 $offset = $line - $subs{$sub}->[0];
 985                                 $offset = "+$offset", last SUBS if $offset >= 0;
 986                               }
 987                             }
 988                             if (defined $offset) {
 989                               $postponed{$found} =
 990                                 "break $offset if $dbline{$line}";
 991                             } else {
 992                               print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
 993                             }
 994                           }
 995                         }
 996                         set_list("PERLDB_POSTPONE", %postponed);
 997                         set_list("PERLDB_PRETYPE", @$pretype);
 998                         set_list("PERLDB_PRE", @$pre);
 999                         set_list("PERLDB_POST", @$post);
1000                         set_list("PERLDB_TYPEAHEAD", @typeahead);
1001                         $ENV{PERLDB_RESTART} = 1;
1002                         #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
1003                         exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
1004                         print $OUT "exec failed: $!\n";
1005                         last CMD; };
1006                     $cmd =~ /^T$/ && do {
1007                         print_trace($OUT, 1); # skip DB
1008                         next CMD; };
1009                     $cmd =~ /^W\s*$/ && do {
1010                         $trace &= ~2;
1011                         @to_watch = @old_watch = ();
1012                         next CMD; };
1013                     $cmd =~ /^W\b\s*(.*)/s && do {
1014                         push @to_watch, $1;
1015                         $evalarg = $1;
1016                         my ($val) = &eval;
1017                         $val = (defined $val) ? "'$val'" : 'undef' ;
1018                         push @old_watch, $val;
1019                         $trace |= 2;
1020                         next CMD; };
1021                     $cmd =~ /^\/(.*)$/ && do {
1022                         $inpat = $1;
1023                         $inpat =~ s:([^\\])/$:$1:;
1024                         if ($inpat ne "") {
1025                             eval '$inpat =~ m'."\a$inpat\a";
1026                             if ($@ ne "") {
1027                                 print $OUT "$@";
1028                                 next CMD;
1029                             }
1030                             $pat = $inpat;
1031                         }
1032                         $end = $start;
1033                         $incr = -1;
1034                         eval '
1035                             for (;;) {
1036                                 ++$start;
1037                                 $start = 1 if ($start > $max);
1038                                 last if ($start == $end);
1039                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1040                                     if ($emacs) {
1041                                         print $OUT "\032\032$filename:$start:0\n";
1042                                     } else {
1043                                         print $OUT "$start:\t", $dbline[$start], "\n";
1044                                     }
1045                                     last;
1046                                 }
1047                             } ';
1048                         print $OUT "/$pat/: not found\n" if ($start == $end);
1049                         next CMD; };
1050                     $cmd =~ /^\?(.*)$/ && do {
1051                         $inpat = $1;
1052                         $inpat =~ s:([^\\])\?$:$1:;
1053                         if ($inpat ne "") {
1054                             eval '$inpat =~ m'."\a$inpat\a";
1055                             if ($@ ne "") {
1056                                 print $OUT "$@";
1057                                 next CMD;
1058                             }
1059                             $pat = $inpat;
1060                         }
1061                         $end = $start;
1062                         $incr = -1;
1063                         eval '
1064                             for (;;) {
1065                                 --$start;
1066                                 $start = $max if ($start <= 0);
1067                                 last if ($start == $end);
1068                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1069                                     if ($emacs) {
1070                                         print $OUT "\032\032$filename:$start:0\n";
1071                                     } else {
1072                                         print $OUT "$start:\t", $dbline[$start], "\n";
1073                                     }
1074                                     last;
1075                                 }
1076                             } ';
1077                         print $OUT "?$pat?: not found\n" if ($start == $end);
1078                         next CMD; };
1079                     $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1080                         pop(@hist) if length($cmd) > 1;
1081                         $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1082                         $cmd = $hist[$i];
1083                         print $OUT $cmd, "\n";
1084                         redo CMD; };
1085                     $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1086                         &system($1);
1087                         next CMD; };
1088                     $cmd =~ /^$rc([^$rc].*)$/ && do {
1089                         $pat = "^$1";
1090                         pop(@hist) if length($cmd) > 1;
1091                         for ($i = $#hist; $i; --$i) {
1092                             last if $hist[$i] =~ /$pat/;
1093                         }
1094                         if (!$i) {
1095                             print $OUT "No such command!\n\n";
1096                             next CMD;
1097                         }
1098                         $cmd = $hist[$i];
1099                         print $OUT $cmd, "\n";
1100                         redo CMD; };
1101                     $cmd =~ /^$sh$/ && do {
1102                         &system($ENV{SHELL}||"/bin/sh");
1103                         next CMD; };
1104                     $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1105                         &system($ENV{SHELL}||"/bin/sh","-c",$1);
1106                         next CMD; };
1107                     $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1108                         $end = $2?($#hist-$2):0;
1109                         $hist = 0 if $hist < 0;
1110                         for ($i=$#hist; $i>$end; $i--) {
1111                             print $OUT "$i: ",$hist[$i],"\n"
1112                               unless $hist[$i] =~ /^.?$/;
1113                         };
1114                         next CMD; };
1115                     $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1116                     $cmd =~ s/^p\b/print {\$DB::OUT} /;
1117                     $cmd =~ /^=/ && do {
1118                         if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1119                             $alias{$k}="s~$k~$v~";
1120                             print $OUT "$k = $v\n";
1121                         } elsif ($cmd =~ /^=\s*$/) {
1122                             foreach $k (sort keys(%alias)) {
1123                                 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1124                                     print $OUT "$k = $v\n";
1125                                 } else {
1126                                     print $OUT "$k\t$alias{$k}\n";
1127                                 };
1128                             };
1129                         };
1130                         next CMD; };
1131                     $cmd =~ /^\|\|?\s*[^|]/ && do {
1132                         if ($pager =~ /^\|/) {
1133                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1134                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1135                         } else {
1136                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1137                         }
1138                         unless ($piped=open(OUT,$pager)) {
1139                             &warn("Can't pipe output to `$pager'");
1140                             if ($pager =~ /^\|/) {
1141                                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1142                                 open(STDOUT,">&SAVEOUT")
1143                                   || &warn("Can't restore STDOUT");
1144                                 close(SAVEOUT);
1145                             } else {
1146                                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1147                             }
1148                             next CMD;
1149                         }
1150                         $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1151                           && "" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE};
1152                         $selected= select(OUT);
1153                         $|= 1;
1154                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1155                         $cmd =~ s/^\|+\s*//;
1156                         redo PIPE; };
1157                     # XXX Local variants do not work!
1158                     $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1159                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1160                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1161                 }               # PIPE:
1162             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1163             if ($onetimeDump) {
1164                 $onetimeDump = undef;
1165             } elsif ($term_pid == $$) {
1166                 print $OUT "\n";
1167             }
1168         } continue {            # CMD:
1169             if ($piped) {
1170                 if ($pager =~ /^\|/) {
1171                     $?= 0;  close(OUT) || &warn("Can't close DB::OUT");
1172                     &warn( "Pager `$pager' failed: ",
1173                           ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1174                           ( $? & 128 ) ? " (core dumped)" : "",
1175                           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1176                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1177                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1178                     $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1179                     # Will stop ignoring SIGPIPE if done like nohup(1)
1180                     # does SIGINT but Perl doesn't give us a choice.
1181                 } else {
1182                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1183                 }
1184                 close(SAVEOUT);
1185                 select($selected), $selected= "" unless $selected eq "";
1186                 $piped= "";
1187             }
1188         }                       # CMD:
1189         $exiting = 1 unless defined $cmd;
1190         foreach $evalarg (@$post) {
1191           &eval;
1192         }
1193     }                           # if ($single || $signal)
1194     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1195     ();
1196 }
1197
1198 # The following code may be executed now:
1199 # BEGIN {warn 4}
1200
1201 sub sub {
1202     my ($al, $ret, @ret) = "";
1203     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1204         $al = " for $$sub";
1205     }
1206     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1207     $#stack = $stack_depth;
1208     $stack[-1] = $single;
1209     $single &= 1;
1210     $single |= 4 if $stack_depth == $deep;
1211     ($frame & 4
1212      ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in  "),
1213          # Why -1? But it works! :-(
1214          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1215      : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1216     if (wantarray) {
1217         @ret = &$sub;
1218         $single |= $stack[$stack_depth--];
1219         ($frame & 4
1220          ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1221              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1222          : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1223         if ($doret eq $stack_depth or $frame & 16) {
1224             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1225             print $fh ' ' x $stack_depth if $frame & 16;
1226             print $fh "list context return from $sub:\n";
1227             dumpit($fh, \@ret );
1228             $doret = -2;
1229         }
1230         @ret;
1231     } else {
1232         if (defined wantarray) {
1233             $ret = &$sub;
1234         } else {
1235             &$sub; undef $ret;
1236         };
1237         $single |= $stack[$stack_depth--];
1238         ($frame & 4
1239          ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1240               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1241          : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1242         if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1243             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1244             print $fh (' ' x $stack_depth) if $frame & 16;
1245             print $fh (defined wantarray
1246                          ? "scalar context return from $sub: "
1247                          : "void context return from $sub\n");
1248             dumpit( $fh, $ret ) if defined wantarray;
1249             $doret = -2;
1250         }
1251         $ret;
1252     }
1253 }
1254
1255 sub save {
1256     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1257     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1258 }
1259
1260 # The following takes its argument via $evalarg to preserve current @_
1261
1262 sub eval {
1263     local @res;                 # 'my' would make it visible from user code
1264     {
1265         local $otrace = $trace;
1266         local $osingle = $single;
1267         local $od = $^D;
1268         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1269         $trace = $otrace;
1270         $single = $osingle;
1271         $^D = $od;
1272     }
1273     my $at = $@;
1274     local $saved[0];            # Preserve the old value of $@
1275     eval { &DB::save };
1276     if ($at) {
1277         print $OUT $at;
1278     } elsif ($onetimeDump eq 'dump') {
1279         dumpit($OUT, \@res);
1280     } elsif ($onetimeDump eq 'methods') {
1281         methods($res[0]);
1282     }
1283     @res;
1284 }
1285
1286 sub postponed_sub {
1287   my $subname = shift;
1288   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1289     my $offset = $1 || 0;
1290     # Filename below can contain ':'
1291     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1292     if ($i) {
1293       $i += $offset;
1294       local *dbline = $main::{'_<' . $file};
1295       local $^W = 0;            # != 0 is magical below
1296       $had_breakpoints{$file}++;
1297       my $max = $#dbline;
1298       ++$i until $dbline[$i] != 0 or $i >= $max;
1299       $dbline{$i} = delete $postponed{$subname};
1300     } else {
1301       print $OUT "Subroutine $subname not found.\n";
1302     }
1303     return;
1304   }
1305   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1306   #print $OUT "In postponed_sub for `$subname'.\n";
1307 }
1308
1309 sub postponed {
1310   if ($ImmediateStop) {
1311     $ImmediateStop = 0;
1312     $signal = 1;
1313   }
1314   return &postponed_sub
1315     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1316   # Cannot be done before the file is compiled
1317   local *dbline = shift;
1318   my $filename = $dbline;
1319   $filename =~ s/^_<//;
1320   $signal = 1, print $OUT "'$filename' loaded...\n"
1321     if $break_on_load{$filename};
1322   print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1323   return unless $postponed_file{$filename};
1324   $had_breakpoints{$filename}++;
1325   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1326   my $key;
1327   for $key (keys %{$postponed_file{$filename}}) {
1328     $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1329   }
1330   delete $postponed_file{$filename};
1331 }
1332
1333 sub dumpit {
1334     local ($savout) = select(shift);
1335     my $osingle = $single;
1336     my $otrace = $trace;
1337     $single = $trace = 0;
1338     local $frame = 0;
1339     local $doret = -2;
1340     unless (defined &main::dumpValue) {
1341         do 'dumpvar.pl';
1342     }
1343     if (defined &main::dumpValue) {
1344         &main::dumpValue(shift);
1345     } else {
1346         print $OUT "dumpvar.pl not available.\n";
1347     }
1348     $single = $osingle;
1349     $trace = $otrace;
1350     select ($savout);
1351 }
1352
1353 # Tied method do not create a context, so may get wrong message:
1354
1355 sub print_trace {
1356   my $fh = shift;
1357   my @sub = dump_trace($_[0] + 1, $_[1]);
1358   my $short = $_[2];            # Print short report, next one for sub name
1359   my $s;
1360   for ($i=0; $i <= $#sub; $i++) {
1361     last if $signal;
1362     local $" = ', ';
1363     my $args = defined $sub[$i]{args}
1364     ? "(@{ $sub[$i]{args} })"
1365       : '' ;
1366     $args = (substr $args, 0, $maxtrace - 3) . '...'
1367       if length $args > $maxtrace;
1368     my $file = $sub[$i]{file};
1369     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1370     $s = $sub[$i]{sub};
1371     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1372     if ($short) {
1373       my $sub = @_ >= 4 ? $_[3] : $s;
1374       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1375     } else {
1376       print $fh "$sub[$i]{context} = $s$args" .
1377         " called from $file" .
1378           " line $sub[$i]{line}\n";
1379     }
1380   }
1381 }
1382
1383 sub dump_trace {
1384   my $skip = shift;
1385   my $count = shift || 1e9;
1386   $skip++;
1387   $count += $skip;
1388   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1389   my $nothard = not $frame & 8;
1390   local $frame = 0;             # Do not want to trace this.
1391   my $otrace = $trace;
1392   $trace = 0;
1393   for ($i = $skip;
1394        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1395        $i++) {
1396     @a = ();
1397     for $arg (@args) {
1398       my $type;
1399       if (not defined $arg) {
1400         push @a, "undef";
1401       } elsif ($nothard and tied $arg) {
1402         push @a, "tied";
1403       } elsif ($nothard and $type = ref $arg) {
1404         push @a, "ref($type)";
1405       } else {
1406         local $_ = "$arg";      # Safe to stringify now - should not call f().
1407         s/([\'\\])/\\$1/g;
1408         s/(.*)/'$1'/s
1409           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1410         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1411         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1412         push(@a, $_);
1413       }
1414     }
1415     $context = $context ? '@' : (defined $context ? "\$" : '.');
1416     $args = $h ? [@a] : undef;
1417     $e =~ s/\n\s*\;\s*\Z// if $e;
1418     $e =~ s/([\\\'])/\\$1/g if $e;
1419     if ($r) {
1420       $sub = "require '$e'";
1421     } elsif (defined $r) {
1422       $sub = "eval '$e'";
1423     } elsif ($sub eq '(eval)') {
1424       $sub = "eval {...}";
1425     }
1426     push(@sub, {context => $context, sub => $sub, args => $args,
1427                 file => $file, line => $line});
1428     last if $signal;
1429   }
1430   $trace = $otrace;
1431   @sub;
1432 }
1433
1434 sub action {
1435     my $action = shift;
1436     while ($action =~ s/\\$//) {
1437         #print $OUT "+ ";
1438         #$action .= "\n";
1439         $action .= &gets;
1440     }
1441     $action;
1442 }
1443
1444 sub gets {
1445     local($.);
1446     #<IN>;
1447     &readline("cont: ");
1448 }
1449
1450 sub system {
1451     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1452     # many non-Unix systems can do system() but have problems with fork().
1453     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1454     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1455     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1456     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1457     system(@_);
1458     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1459     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1460     close(SAVEIN); close(SAVEOUT);
1461     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1462           ( $? & 128 ) ? " (core dumped)" : "",
1463           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1464     $?;
1465 }
1466
1467 sub setterm {
1468     local $frame = 0;
1469     local $doret = -2;
1470     eval { require Term::ReadLine } or die $@;
1471     if ($notty) {
1472         if ($tty) {
1473             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1474             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1475             $IN = \*IN;
1476             $OUT = \*OUT;
1477             my $sel = select($OUT);
1478             $| = 1;
1479             select($sel);
1480         } else {
1481             eval "require Term::Rendezvous;" or die $@;
1482             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1483             my $term_rv = new Term::Rendezvous $rv;
1484             $IN = $term_rv->IN;
1485             $OUT = $term_rv->OUT;
1486         }
1487     }
1488     if (!$rl) {
1489         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1490     } else {
1491         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1492
1493         $rl_attribs = $term->Attribs;
1494         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1495           if defined $rl_attribs->{basic_word_break_characters}
1496             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1497         $rl_attribs->{special_prefixes} = '$@&%';
1498         $rl_attribs->{completer_word_break_characters} .= '$@&%';
1499         $rl_attribs->{completion_function} = \&db_complete;
1500     }
1501     $LINEINFO = $OUT unless defined $LINEINFO;
1502     $lineinfo = $console unless defined $lineinfo;
1503     $term->MinLine(2);
1504     if ($term->Features->{setHistory} and "@hist" ne "?") {
1505       $term->SetHistory(@hist);
1506     }
1507     ornaments($ornaments) if defined $ornaments;
1508     $term_pid = $$;
1509 }
1510
1511 sub resetterm {                 # We forked, so we need a different TTY
1512     $term_pid = $$;
1513     if (defined &get_fork_TTY) {
1514       &get_fork_TTY;
1515     } elsif (not defined $fork_TTY
1516              and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1517              and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1518         # Possibly _inside_ XTERM
1519         open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1520  sleep 10000000' |];
1521         $fork_TTY = <XT>;
1522         chomp $fork_TTY;
1523     }
1524     if (defined $fork_TTY) {
1525       TTY($fork_TTY);
1526       undef $fork_TTY;
1527     } else {
1528       print_help(<<EOP);
1529 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1530   Define B<\$DB::fork_TTY>
1531        - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1532   The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1533   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1534   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1535 EOP
1536     }
1537 }
1538
1539 sub readline {
1540   if (@typeahead) {
1541     my $left = @typeahead;
1542     my $got = shift @typeahead;
1543     print $OUT "auto(-$left)", shift, $got, "\n";
1544     $term->AddHistory($got)
1545       if length($got) > 1 and defined $term->Features->{addHistory};
1546     return $got;
1547   }
1548   local $frame = 0;
1549   local $doret = -2;
1550   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1551     print $OUT @_;
1552     my $stuff;
1553     $IN->recv( $stuff, 2048 );
1554     $stuff;
1555   }
1556   else {
1557     $term->readline(@_);
1558   }
1559 }
1560
1561 sub dump_option {
1562     my ($opt, $val)= @_;
1563     $val = option_val($opt,'N/A');
1564     $val =~ s/([\\\'])/\\$1/g;
1565     printf $OUT "%20s = '%s'\n", $opt, $val;
1566 }
1567
1568 sub option_val {
1569     my ($opt, $default)= @_;
1570     my $val;
1571     if (defined $optionVars{$opt}
1572         and defined $ {$optionVars{$opt}}) {
1573         $val = $ {$optionVars{$opt}};
1574     } elsif (defined $optionAction{$opt}
1575         and defined &{$optionAction{$opt}}) {
1576         $val = &{$optionAction{$opt}}();
1577     } elsif (defined $optionAction{$opt}
1578              and not defined $option{$opt}
1579              or defined $optionVars{$opt}
1580              and not defined $ {$optionVars{$opt}}) {
1581         $val = $default;
1582     } else {
1583         $val = $option{$opt};
1584     }
1585     $val
1586 }
1587
1588 sub parse_options {
1589     local($_)= @_;
1590     while ($_ ne "") {
1591         s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1592         my ($opt,$sep) = ($1,$2);
1593         my $val;
1594         if ("?" eq $sep) {
1595             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1596               if /^\S/;
1597             #&dump_option($opt);
1598         } elsif ($sep !~ /\S/) {
1599             $val = "1";
1600         } elsif ($sep eq "=") {
1601             s/^(\S*)($|\s+)//;
1602             $val = $1;
1603         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1604             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1605             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1606               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1607             $val = $1;
1608             $val =~ s/\\([\\$end])/$1/g;
1609         }
1610         my ($option);
1611         my $matches =
1612           grep(  /^\Q$opt/ && ($option = $_),  @options  );
1613         $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
1614           unless $matches;
1615         print $OUT "Unknown option `$opt'\n" unless $matches;
1616         print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1617         $option{$option} = $val if $matches == 1 and defined $val;
1618         eval "local \$frame = 0; local \$doret = -2;
1619               require '$optionRequire{$option}'"
1620           if $matches == 1 and defined $optionRequire{$option} and defined $val;
1621         $ {$optionVars{$option}} = $val
1622           if $matches == 1
1623             and defined $optionVars{$option} and defined $val;
1624         & {$optionAction{$option}} ($val)
1625           if $matches == 1
1626             and defined $optionAction{$option}
1627               and defined &{$optionAction{$option}} and defined $val;
1628         &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1629         s/^\s+//;
1630     }
1631 }
1632
1633 sub set_list {
1634   my ($stem,@list) = @_;
1635   my $val;
1636   $ENV{"$ {stem}_n"} = @list;
1637   for $i (0 .. $#list) {
1638     $val = $list[$i];
1639     $val =~ s/\\/\\\\/g;
1640     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1641     $ENV{"$ {stem}_$i"} = $val;
1642   }
1643 }
1644
1645 sub get_list {
1646   my $stem = shift;
1647   my @list;
1648   my $n = delete $ENV{"$ {stem}_n"};
1649   my $val;
1650   for $i (0 .. $n - 1) {
1651     $val = delete $ENV{"$ {stem}_$i"};
1652     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1653     push @list, $val;
1654   }
1655   @list;
1656 }
1657
1658 sub catch {
1659     $signal = 1;
1660     return;                     # Put nothing on the stack - malloc/free land!
1661 }
1662
1663 sub warn {
1664     my($msg)= join("",@_);
1665     $msg .= ": $!\n" unless $msg =~ /\n$/;
1666     print $OUT $msg;
1667 }
1668
1669 sub TTY {
1670     if (@_ and $term and $term->Features->{newTTY}) {
1671       my ($in, $out) = shift;
1672       if ($in =~ /,/) {
1673         ($in, $out) = split /,/, $in, 2;
1674       } else {
1675         $out = $in;
1676       }
1677       open IN, $in or die "cannot open `$in' for read: $!";
1678       open OUT, ">$out" or die "cannot open `$out' for write: $!";
1679       $term->newTTY(\*IN, \*OUT);
1680       $IN       = \*IN;
1681       $OUT      = \*OUT;
1682       return $tty = $in;
1683     } elsif ($term and @_) {
1684         &warn("Too late to set TTY, enabled on next `R'!\n");
1685     }
1686     $tty = shift if @_;
1687     $tty or $console;
1688 }
1689
1690 sub noTTY {
1691     if ($term) {
1692         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1693     }
1694     $notty = shift if @_;
1695     $notty;
1696 }
1697
1698 sub ReadLine {
1699     if ($term) {
1700         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1701     }
1702     $rl = shift if @_;
1703     $rl;
1704 }
1705
1706 sub RemotePort {
1707     if ($term) {
1708         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
1709     }
1710     $remoteport = shift if @_;
1711     $remoteport;
1712 }
1713
1714 sub tkRunning {
1715     if ($ {$term->Features}{tkRunning}) {
1716         return $term->tkRunning(@_);
1717     } else {
1718         print $OUT "tkRunning not supported by current ReadLine package.\n";
1719         0;
1720     }
1721 }
1722
1723 sub NonStop {
1724     if ($term) {
1725         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1726     }
1727     $runnonstop = shift if @_;
1728     $runnonstop;
1729 }
1730
1731 sub pager {
1732     if (@_) {
1733         $pager = shift;
1734         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1735     }
1736     $pager;
1737 }
1738
1739 sub shellBang {
1740     if (@_) {
1741         $sh = quotemeta shift;
1742         $sh .= "\\b" if $sh =~ /\w$/;
1743     }
1744     $psh = $sh;
1745     $psh =~ s/\\b$//;
1746     $psh =~ s/\\(.)/$1/g;
1747     &sethelp;
1748     $psh;
1749 }
1750
1751 sub ornaments {
1752   if (defined $term) {
1753     local ($warnLevel,$dieLevel) = (0, 1);
1754     return '' unless $term->Features->{ornaments};
1755     eval { $term->ornaments(@_) } || '';
1756   } else {
1757     $ornaments = shift;
1758   }
1759 }
1760
1761 sub recallCommand {
1762     if (@_) {
1763         $rc = quotemeta shift;
1764         $rc .= "\\b" if $rc =~ /\w$/;
1765     }
1766     $prc = $rc;
1767     $prc =~ s/\\b$//;
1768     $prc =~ s/\\(.)/$1/g;
1769     &sethelp;
1770     $prc;
1771 }
1772
1773 sub LineInfo {
1774     return $lineinfo unless @_;
1775     $lineinfo = shift;
1776     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1777     $emacs = ($stream =~ /^\|/);
1778     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1779     $LINEINFO = \*LINEINFO;
1780     my $save = select($LINEINFO);
1781     $| = 1;
1782     select($save);
1783     $lineinfo;
1784 }
1785
1786 sub list_versions {
1787   my %version;
1788   my $file;
1789   for (keys %INC) {
1790     $file = $_;
1791     s,\.p[lm]$,,i ;
1792     s,/,::,g ;
1793     s/^perl5db$/DB/;
1794     s/^Term::ReadLine::readline$/readline/;
1795     if (defined $ { $_ . '::VERSION' }) {
1796       $version{$file} = "$ { $_ . '::VERSION' } from ";
1797     }
1798     $version{$file} .= $INC{$file};
1799   }
1800   dumpit($OUT,\%version);
1801 }
1802
1803 sub sethelp {
1804     $help = "
1805 B<T>            Stack trace.
1806 B<s> [I<expr>]  Single step [in I<expr>].
1807 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
1808 <B<CR>>         Repeat last B<n> or B<s> command.
1809 B<r>            Return from current subroutine.
1810 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
1811                 at the specified position.
1812 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
1813 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
1814 B<l> I<line>            List single I<line>.
1815 B<l> I<subname> List first window of lines from subroutine.
1816 B<l>            List next window of lines.
1817 B<->            List previous window of lines.
1818 B<w> [I<line>]  List window around I<line>.
1819 B<.>            Return to the executed line.
1820 B<f> I<filename>        Switch to viewing I<filename>. File must be already loaded.
1821                 I<filename> may be either the full name of the file, or a regular
1822                 expression matching the full file name:
1823                 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
1824                 Evals (with saved bodies) are considered to be filenames:
1825                 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
1826                 (in the order of execution).
1827 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
1828 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
1829 B<L>            List all breakpoints and actions.
1830 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1831 B<t>            Toggle trace mode.
1832 B<t> I<expr>            Trace through execution of I<expr>.
1833 B<b> [I<line>] [I<condition>]
1834                 Set breakpoint; I<line> defaults to the current execution line;
1835                 I<condition> breaks if it evaluates to true, defaults to '1'.
1836 B<b> I<subname> [I<condition>]
1837                 Set breakpoint at first line of subroutine.
1838 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1839 B<b> B<postpone> I<subname> [I<condition>]
1840                 Set breakpoint at first line of subroutine after
1841                 it is compiled.
1842 B<b> B<compile> I<subname>
1843                 Stop after the subroutine is compiled.
1844 B<d> [I<line>]  Delete the breakpoint for I<line>.
1845 B<D>            Delete all breakpoints.
1846 B<a> [I<line>] I<command>
1847                 Set an action to be done before the I<line> is executed.
1848                 Sequence is: check for breakpoint/watchpoint, print line
1849                 if necessary, do action, prompt user if necessary,
1850                 execute expression.
1851 B<A>            Delete all actions.
1852 B<W> I<expr>            Add a global watch-expression.
1853 B<W>            Delete all watch-expressions.
1854 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1855                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1856 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
1857 B<x> I<expr>            Evals expression in array context, dumps the result.
1858 B<m> I<expr>            Evals expression in array context, prints methods callable
1859                 on the first element of the result.
1860 B<m> I<class>           Prints methods callable via the given class.
1861 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1862                 Set or query values of options.  I<val> defaults to 1.  I<opt> can
1863                 be abbreviated.  Several options can be listed.
1864     I<recallCommand>, I<ShellBang>:     chars used to recall command or spawn shell;
1865     I<pager>:                   program for output of \"|cmd\";
1866     I<tkRunning>:                       run Tk while prompting (with ReadLine);
1867     I<signalLevel> I<warnLevel> I<dieLevel>:    level of verbosity;
1868     I<inhibit_exit>             Allows stepping off the end of the script.
1869     I<ImmediateStop>            Debugger should stop as early as possible.
1870     I<RemotePort>:              Remote hostname:port for remote debugging
1871   The following options affect what happens with B<V>, B<X>, and B<x> commands:
1872     I<arrayDepth>, I<hashDepth>:        print only first N elements ('' for all);
1873     I<compactDump>, I<veryCompact>:     change style of array and hash dump;
1874     I<globPrint>:                       whether to print contents of globs;
1875     I<DumpDBFiles>:             dump arrays holding debugged files;
1876     I<DumpPackages>:            dump symbol tables of packages;
1877     I<DumpReused>:              dump contents of \"reused\" addresses;
1878     I<quote>, I<HighBit>, I<undefPrint>:        change style of string dump;
1879     I<bareStringify>:           Do not print the overload-stringified value;
1880   Option I<PrintRet> affects printing of return value after B<r> command,
1881          I<frame>    affects printing messages on entry and exit from subroutines.
1882          I<AutoTrace> affects printing messages on every possible breaking point.
1883          I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1884          I<ornaments> affects screen appearance of the command line.
1885                 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1886                 You can put additional initialization options I<TTY>, I<noTTY>,
1887                 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
1888                 `B<R>' after you set them).
1889 B<<> I<expr>            Define Perl command to run before each prompt.
1890 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
1891 B<>> I<expr>            Define Perl command to run after each prompt.
1892 B<>>B<>> I<expr>        Add to the list of Perl commands to run after each prompt.
1893 B<{> I<db_command>      Define debugger command to run before each prompt.
1894 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
1895 B<$prc> I<number>       Redo a previous command (default previous command).
1896 B<$prc> I<-number>      Redo number'th-to-last command.
1897 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
1898                 See 'B<O> I<recallCommand>' too.
1899 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1900   . ( $rc eq $sh ? "" : "
1901 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1902                 See 'B<O> I<shellBang>' too.
1903 B<H> I<-number> Display last number commands (default all).
1904 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
1905 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
1906 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1907 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
1908 I<command>              Execute as a perl statement in current package.
1909 B<v>            Show versions of loaded modules.
1910 B<R>            Pure-man-restart of debugger, some of debugger state
1911                 and command-line options may be lost.
1912                 Currently the following setting are preserved:
1913                 history, breakpoints and actions, debugger B<O>ptions
1914                 and the following command-line options: I<-w>, I<-I>, I<-e>.
1915 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
1916                 Complete description of debugger is available in B<perldebug>
1917                 section of Perl documention
1918 B<h h>          Summary of debugger commands.
1919 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
1920
1921 ";
1922     $summary = <<"END_SUM";
1923 I<List/search source lines:>               I<Control script execution:>
1924   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
1925   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
1926   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
1927   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
1928   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
1929   B<v>        Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
1930 I<Debugger controls:>                        B<L>           List break/watch/actions
1931   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
1932   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
1933   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
1934   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
1935   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
1936   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
1937   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1938   B<q> or B<^D>     Quit                          B<R>        Attempt a restart
1939 I<Data Examination:>          B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1940   B<x>|B<m> I<expr>     Evals expr in array context, dumps the result or lists methods.
1941   B<p> I<expr>  Print expression (uses script's current package).
1942   B<S> [[B<!>]I<pat>]   List subroutine names [not] matching pattern
1943   B<V> [I<Pk> [I<Vars>]]        List Variables in Package.  Vars can be ~pattern or !pattern.
1944   B<X> [I<Vars>]        Same as \"B<V> I<current_package> [I<Vars>]\".
1945 I<More help for> B<db_cmd>I<:>  Type B<h> I<cmd_letter>  Run B<perldoc perldebug> for more help.
1946 END_SUM
1947                                 # ')}}; # Fix balance of Emacs parsing
1948 }
1949
1950 sub print_help {
1951   my $message = shift;
1952   if (@Term::ReadLine::TermCap::rl_term_set) {
1953     $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1954     $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1955   }
1956   print $OUT $message;
1957 }
1958
1959 sub diesignal {
1960     local $frame = 0;
1961     local $doret = -2;
1962     $SIG{'ABRT'} = 'DEFAULT';
1963     kill 'ABRT', $$ if $panic++;
1964     if (defined &Carp::longmess) {
1965         local $SIG{__WARN__} = '';
1966         local $Carp::CarpLevel = 2;             # mydie + confess
1967         &warn(Carp::longmess("Signal @_"));
1968     }
1969     else {
1970         print $DB::OUT "Got signal @_\n";
1971     }
1972     kill 'ABRT', $$;
1973 }
1974
1975 sub dbwarn {
1976   local $frame = 0;
1977   local $doret = -2;
1978   local $SIG{__WARN__} = '';
1979   local $SIG{__DIE__} = '';
1980   eval { require Carp } if defined $^S; # If error/warning during compilation,
1981                                         # require may be broken.
1982   warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1983     return unless defined &Carp::longmess;
1984   my ($mysingle,$mytrace) = ($single,$trace);
1985   $single = 0; $trace = 0;
1986   my $mess = Carp::longmess(@_);
1987   ($single,$trace) = ($mysingle,$mytrace);
1988   &warn($mess);
1989 }
1990
1991 sub dbdie {
1992   local $frame = 0;
1993   local $doret = -2;
1994   local $SIG{__DIE__} = '';
1995   local $SIG{__WARN__} = '';
1996   my $i = 0; my $ineval = 0; my $sub;
1997   if ($dieLevel > 2) {
1998       local $SIG{__WARN__} = \&dbwarn;
1999       &warn(@_);                # Yell no matter what
2000       return;
2001   }
2002   if ($dieLevel < 2) {
2003     die @_ if $^S;              # in eval propagate
2004   }
2005   eval { require Carp } if defined $^S; # If error/warning during compilation,
2006                                         # require may be broken.
2007   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2008     unless defined &Carp::longmess;
2009   # We do not want to debug this chunk (automatic disabling works
2010   # inside DB::DB, but not in Carp).
2011   my ($mysingle,$mytrace) = ($single,$trace);
2012   $single = 0; $trace = 0;
2013   my $mess = Carp::longmess(@_);
2014   ($single,$trace) = ($mysingle,$mytrace);
2015   die $mess;
2016 }
2017
2018 sub warnLevel {
2019   if (@_) {
2020     $prevwarn = $SIG{__WARN__} unless $warnLevel;
2021     $warnLevel = shift;
2022     if ($warnLevel) {
2023       $SIG{__WARN__} = \&DB::dbwarn;
2024     } else {
2025       $SIG{__WARN__} = $prevwarn;
2026     }
2027   }
2028   $warnLevel;
2029 }
2030
2031 sub dieLevel {
2032   if (@_) {
2033     $prevdie = $SIG{__DIE__} unless $dieLevel;
2034     $dieLevel = shift;
2035     if ($dieLevel) {
2036       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2037       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2038       print $OUT "Stack dump during die enabled",
2039         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2040           if $I_m_init;
2041       print $OUT "Dump printed too.\n" if $dieLevel > 2;
2042     } else {
2043       $SIG{__DIE__} = $prevdie;
2044       print $OUT "Default die handler restored.\n";
2045     }
2046   }
2047   $dieLevel;
2048 }
2049
2050 sub signalLevel {
2051   if (@_) {
2052     $prevsegv = $SIG{SEGV} unless $signalLevel;
2053     $prevbus = $SIG{BUS} unless $signalLevel;
2054     $signalLevel = shift;
2055     if ($signalLevel) {
2056       $SIG{SEGV} = \&DB::diesignal;
2057       $SIG{BUS} = \&DB::diesignal;
2058     } else {
2059       $SIG{SEGV} = $prevsegv;
2060       $SIG{BUS} = $prevbus;
2061     }
2062   }
2063   $signalLevel;
2064 }
2065
2066 sub find_sub {
2067   my $subr = shift;
2068   return unless defined &$subr;
2069   $sub{$subr} or do {
2070     $subr = \&$subr;            # Hard reference
2071     my $s;
2072     for (keys %sub) {
2073       $s = $_, last if $subr eq \&$_;
2074     }
2075     $sub{$s} if $s;
2076   }
2077 }
2078
2079 sub methods {
2080   my $class = shift;
2081   $class = ref $class if ref $class;
2082   local %seen;
2083   local %packs;
2084   methods_via($class, '', 1);
2085   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2086 }
2087
2088 sub methods_via {
2089   my $class = shift;
2090   return if $packs{$class}++;
2091   my $prefix = shift;
2092   my $prepend = $prefix ? "via $prefix: " : '';
2093   my $name;
2094   for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2095              sort keys %{"$ {class}::"}) {
2096     next if $seen{ $name }++;
2097     print $DB::OUT "$prepend$name\n";
2098   }
2099   return unless shift;          # Recurse?
2100   for $name (@{"$ {class}::ISA"}) {
2101     $prepend = $prefix ? $prefix . " -> $name" : $name;
2102     methods_via($name, $prepend, 1);
2103   }
2104 }
2105
2106 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2107
2108 BEGIN {                 # This does not compile, alas.
2109   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
2110   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
2111   $sh = '!';
2112   $rc = ',';
2113   @hist = ('?');
2114   $deep = 100;                  # warning if stack gets this deep
2115   $window = 10;
2116   $preview = 3;
2117   $sub = '';
2118   $SIG{INT} = \&DB::catch;
2119   # This may be enabled to debug debugger:
2120   #$warnLevel = 1 unless defined $warnLevel;
2121   #$dieLevel = 1 unless defined $dieLevel;
2122   #$signalLevel = 1 unless defined $signalLevel;
2123
2124   $db_stop = 0;                 # Compiler warning
2125   $db_stop = 1 << 30;
2126   $level = 0;                   # Level of recursive debugging
2127   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2128   # Triggers bug (?) in perl is we postpone this until runtime:
2129   @postponed = @stack = (0);
2130   $stack_depth = 0;             # Localized $#stack
2131   $doret = -2;
2132   $frame = 0;
2133 }
2134
2135 BEGIN {$^W = $ini_warn;}        # Switch warnings back
2136
2137 #use Carp;                      # This did break, left for debuggin
2138
2139 sub db_complete {
2140   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2141   my($text, $line, $start) = @_;
2142   my ($itext, $search, $prefix, $pack) =
2143     ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2144
2145   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2146                                (map { /$search/ ? ($1) : () } keys %sub)
2147     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2148   return sort grep /^\Q$text/, values %INC # files
2149     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2150   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2151     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2152       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2153   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2154     grep !/^main::/,
2155       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2156                                  # packages
2157         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2158           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
2159   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2160     # We may want to complete to (eval 9), so $text may be wrong
2161     $prefix = length($1) - length($text);
2162     $text = $1;
2163     return sort
2164         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2165   }
2166   if ((substr $text, 0, 1) eq '&') { # subroutines
2167     $text = substr $text, 1;
2168     $prefix = "&";
2169     return sort map "$prefix$_",
2170                grep /^\Q$text/,
2171                  (keys %sub),
2172                  (map { /$search/ ? ($1) : () }
2173                     keys %sub);
2174   }
2175   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2176     $pack = ($1 eq 'main' ? '' : $1) . '::';
2177     $prefix = (substr $text, 0, 1) . $1 . '::';
2178     $text = $2;
2179     my @out
2180       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2181     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2182       return db_complete($out[0], $line, $start);
2183     }
2184     return sort @out;
2185   }
2186   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2187     $pack = ($package eq 'main' ? '' : $package) . '::';
2188     $prefix = substr $text, 0, 1;
2189     $text = substr $text, 1;
2190     my @out = map "$prefix$_", grep /^\Q$text/,
2191        (grep /^_?[a-zA-Z]/, keys %$pack),
2192        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2193     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2194       return db_complete($out[0], $line, $start);
2195     }
2196     return sort @out;
2197   }
2198   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2199     my @out = grep /^\Q$text/, @options;
2200     my $val = option_val($out[0], undef);
2201     my $out = '? ';
2202     if (not defined $val or $val =~ /[\n\r]/) {
2203       # Can do nothing better
2204     } elsif ($val =~ /\s/) {
2205       my $found;
2206       foreach $l (split //, qq/\"\'\#\|/) {
2207         $out = "$l$val$l ", last if (index $val, $l) == -1;
2208       }
2209     } else {
2210       $out = "=$val ";
2211     }
2212     # Default to value if one completion, to question if many
2213     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2214     return sort @out;
2215   }
2216   return $term->filename_list($text); # filenames
2217 }
2218
2219 sub end_report {
2220   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
2221 }
2222
2223 END {
2224   $finished = $inhibit_exit;    # So that some keys may be disabled.
2225   # Do not stop in at_exit() and destructors on exit:
2226   $DB::single = !$exiting && !$runnonstop;
2227   DB::fake::at_exit() unless $exiting or $runnonstop;
2228 }
2229
2230 package DB::fake;
2231
2232 sub at_exit {
2233   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
2234 }
2235
2236 package DB;                     # Do not trace this 1; below!
2237
2238 1;