lib/perl5db.pl

   1 package DB;
   2
   3 # Debugger for Perl 5.00x; perl5db.pl patch level:
   4
   5 $VERSION = 1.06;
   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;
 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 =~ /^([lb])\b\s*(\$.*)/s && do {
 601                         $evalarg = $2;
 602                         my ($s) = &eval;
 603                         print($OUT "Error: $@\n"), next CMD if $@;
 604                         $s = CvGV_name($s);
 605                         print($OUT "Interpreted as: $1 $s\n");
 606                         $cmd = "$1 $s";
 607                     };
 608                     $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
 609                         $subname = $1;
 610                         $subname =~ s/\'/::/;
 611                         $subname = $package."::".$subname
 612                           unless $subname =~ /::/;
 613                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 614                         @pieces = split(/:/,find_sub($subname) || $sub{$subname});
 615                         $subrange = pop @pieces;
 616                         $file = join(':', @pieces);
 617                         if ($file ne $filename) {
 618                             print $OUT "Switching to file '$file'.\n"
 619                                 unless $emacs;
 620                             *dbline = $main::{'_<' . $file};
 621                             $max = $#dbline;
 622                             $filename = $file;
 623                         }
 624                         if ($subrange) {
 625                             if (eval($subrange) < -$window) {
 626                                 $subrange =~ s/-.*/+/;
 627                             }
 628                             $cmd = "l $subrange";
 629                         } else {
 630                             print $OUT "Subroutine $subname not found.\n";
 631                             next CMD;
 632                         } };
 633                     $cmd =~ /^\.$/ && do {
 634                         $incr = -1;             # for backward motion.
 635                         $start = $line;
 636                         $filename = $filename_ini;
 637                         *dbline = $main::{'_<' . $filename};
 638                         $max = $#dbline;
 639                         print $LINEINFO $position;
 640                         next CMD };
 641                     $cmd =~ /^w\b\s*(\d*)$/ && do {
 642                         $incr = $window - 1;
 643                         $start = $1 if $1;
 644                         $start -= $preview;
 645                         #print $OUT 'l ' . $start . '-' . ($start + $incr);
 646                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 647                     $cmd =~ /^-$/ && do {
 648                         $start -= $incr + $window + 1;
 649                         $start = 1 if $start <= 0;
 650                         $incr = $window - 1;
 651                         $cmd = 'l ' . ($start) . '+'; };
 652                     $cmd =~ /^l$/ && do {
 653                         $incr = $window - 1;
 654                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 655                     $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
 656                         $start = $1 if $1;
 657                         $incr = $2;
 658                         $incr = $window - 1 unless $incr;
 659                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 660                     $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 661                         $end = (!defined $2) ? $max : ($4 ? $4 : $2);
 662                         $end = $max if $end > $max;
 663                         $i = $2;
 664                         $i = $line if $i eq '.';
 665                         $i = 1 if $i < 1;
 666                         $incr = $end - $i;
 667                         if ($emacs) {
 668                             print $OUT "\032\032$filename:$i:0\n";
 669                             $i = $end;
 670                         } else {
 671                             for (; $i <= $end; $i++) {
 672                                 ($stop,$action) = split(/\0/, $dbline{$i});
 673                                 $arrow = ($i==$line
 674                                           and $filename eq $filename_ini)
 675                                   ?  '==>'
 676                                     : ($dbline[$i]+0 ? ':' : ' ') ;
 677                                 $arrow .= 'b' if $stop;
 678                                 $arrow .= 'a' if $action;
 679                                 print $OUT "$i$arrow\t", $dbline[$i];
 680                                 $i++, last if $signal;
 681                             }
 682                             print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
 683                         }
 684                         $start = $i; # remember in case they want more
 685                         $start = $max if $start > $max;
 686                         next CMD; };
 687                     $cmd =~ /^D$/ && do {
 688                       print $OUT "Deleting all breakpoints...\n";
 689                       my $file;
 690                       for $file (keys %had_breakpoints) {
 691                         local *dbline = $main::{'_<' . $file};
 692                         my $max = $#dbline;
 693                         my $was;
 694
 695                         for ($i = 1; $i <= $max ; $i++) {
 696                             if (defined $dbline{$i}) {
 697                                 $dbline{$i} =~ s/^[^\0]+//;
 698                                 if ($dbline{$i} =~ s/^\0?$//) {
 699                                     delete $dbline{$i};
 700                                 }
 701                             }
 702                         }
 703
 704                         if (not $had_breakpoints{$file} &= ~1) {
 705                             delete $had_breakpoints{$file};
 706                         }
 707                       }
 708                       undef %postponed;
 709                       undef %postponed_file;
 710                       undef %break_on_load;
 711                       next CMD; };
 712                     $cmd =~ /^L$/ && do {
 713                       my $file;
 714                       for $file (keys %had_breakpoints) {
 715                         local *dbline = $main::{'_<' . $file};
 716                         my $max = $#dbline;
 717                         my $was;
 718
 719                         for ($i = 1; $i <= $max; $i++) {
 720                             if (defined $dbline{$i}) {
 721                                 print $OUT "$file:\n" unless $was++;
 722                                 print $OUT " $i:\t", $dbline[$i];
 723                                 ($stop,$action) = split(/\0/, $dbline{$i});
 724                                 print $OUT "   break if (", $stop, ")\n"
 725                                   if $stop;
 726                                 print $OUT "   action:  ", $action, "\n"
 727                                   if $action;
 728                                 last if $signal;
 729                             }
 730                         }
 731                       }
 732                       if (%postponed) {
 733                         print $OUT "Postponed breakpoints in subroutines:\n";
 734                         my $subname;
 735                         for $subname (keys %postponed) {
 736                           print $OUT " $subname\t$postponed{$subname}\n";
 737                           last if $signal;
 738                         }
 739                       }
 740                       my @have = map { # Combined keys
 741                         keys %{$postponed_file{$_}}
 742                       } keys %postponed_file;
 743                       if (@have) {
 744                         print $OUT "Postponed breakpoints in files:\n";
 745                         my ($file, $line);
 746                         for $file (keys %postponed_file) {
 747                           my $db = $postponed_file{$file};
 748                           print $OUT " $file:\n";
 749                           for $line (sort {$a <=> $b} keys %$db) {
 750                                 print $OUT "  $line:\n";
 751                                 my ($stop,$action) = split(/\0/, $$db{$line});
 752                                 print $OUT "    break if (", $stop, ")\n"
 753                                   if $stop;
 754                                 print $OUT "    action:  ", $action, "\n"
 755                                   if $action;
 756                                 last if $signal;
 757                           }
 758                           last if $signal;
 759                         }
 760                       }
 761                       if (%break_on_load) {
 762                         print $OUT "Breakpoints on load:\n";
 763                         my $file;
 764                         for $file (keys %break_on_load) {
 765                           print $OUT " $file\n";
 766                           last if $signal;
 767                         }
 768                       }
 769                       if ($trace & 2) {
 770                         print $OUT "Watch-expressions:\n";
 771                         my $expr;
 772                         for $expr (@to_watch) {
 773                           print $OUT " $expr\n";
 774                           last if $signal;
 775                         }
 776                       }
 777                       next CMD; };
 778                     $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
 779                         my $file = $1; $file =~ s/\s+$//;
 780                         {
 781                           $break_on_load{$file} = 1;
 782                           $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
 783                           $file .= '.pm', redo unless $file =~ /\./;
 784                         }
 785                         $had_breakpoints{$file} |= 1;
 786                         print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
 787                         next CMD; };
 788                     $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 789                         my $cond = $3 || '1';
 790                         my ($subname, $break) = ($2, $1 eq 'postpone');
 791                         $subname =~ s/\'/::/;
 792                         $subname = "${'package'}::" . $subname
 793                           unless $subname =~ /::/;
 794                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 795                         $postponed{$subname} = $break
 796                           ? "break +0 if $cond" : "compile";
 797                         next CMD; };
 798                     $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
 799                         $subname = $1;
 800                         $cond = $2 || '1';
 801                         $subname =~ s/\'/::/;
 802                         $subname = "${'package'}::" . $subname
 803                           unless $subname =~ /::/;
 804                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 805                         # Filename below can contain ':'
 806                         ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
 807                         $i += 0;
 808                         if ($i) {
 809                             local $filename = $file;
 810                             local *dbline = $main::{'_<' . $filename};
 811                             $had_breakpoints{$filename} |= 1;
 812                             $max = $#dbline;
 813                             ++$i while $dbline[$i] == 0 && $i < $max;
 814                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 815                         } else {
 816                             print $OUT "Subroutine $subname not found.\n";
 817                         }
 818                         next CMD; };
 819                     $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
 820                         $i = $1 || $line;
 821                         $cond = $2 || '1';
 822                         if ($dbline[$i] == 0) {
 823                             print $OUT "Line $i not breakable.\n";
 824                         } else {
 825                             $had_breakpoints{$filename} |= 1;
 826                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 827                         }
 828                         next CMD; };
 829                     $cmd =~ /^d\b\s*(\d*)/ && do {
 830                         $i = $1 || $line;
 831                         $dbline{$i} =~ s/^[^\0]*//;
 832                         delete $dbline{$i} if $dbline{$i} eq '';
 833                         next CMD; };
 834                     $cmd =~ /^A$/ && do {
 835                       print $OUT "Deleting all actions...\n";
 836                       my $file;
 837                       for $file (keys %had_breakpoints) {
 838                         local *dbline = $main::{'_<' . $file};
 839                         my $max = $#dbline;
 840                         my $was;
 841
 842                         for ($i = 1; $i <= $max ; $i++) {
 843                             if (defined $dbline{$i}) {
 844                                 $dbline{$i} =~ s/\0[^\0]*//;
 845                                 delete $dbline{$i} if $dbline{$i} eq '';
 846                             }
 847                         }
 848
 849                         if (not $had_breakpoints{$file} &= ~2) {
 850                             delete $had_breakpoints{$file};
 851                         }
 852                       }
 853                       next CMD; };
 854                     $cmd =~ /^O\s*$/ && do {
 855                         for (@options) {
 856                             &dump_option($_);
 857                         }
 858                         next CMD; };
 859                     $cmd =~ /^O\s*(\S.*)/ && do {
 860                         parse_options($1);
 861                         next CMD; };
 862                     $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
 863                         push @$pre, action($1);
 864                         next CMD; };
 865                     $cmd =~ /^>>\s*(.*)/ && do {
 866                         push @$post, action($1);
 867                         next CMD; };
 868                     $cmd =~ /^<\s*(.*)/ && do {
 869                         $pre = [], next CMD unless $1;
 870                         $pre = [action($1)];
 871                         next CMD; };
 872                     $cmd =~ /^>\s*(.*)/ && do {
 873                         $post = [], next CMD unless $1;
 874                         $post = [action($1)];
 875                         next CMD; };
 876                     $cmd =~ /^\{\{\s*(.*)/ && do {
 877                         push @$pretype, $1;
 878                         next CMD; };
 879                     $cmd =~ /^\{\s*(.*)/ && do {
 880                         $pretype = [], next CMD unless $1;
 881                         $pretype = [$1];
 882                         next CMD; };
 883                     $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
 884                         $i = $1 || $line; $j = $2;
 885                         if (length $j) {
 886                             if ($dbline[$i] == 0) {
 887                                 print $OUT "Line $i may not have an action.\n";
 888                             } else {
 889                                 $had_breakpoints{$filename} |= 2;
 890                                 $dbline{$i} =~ s/\0[^\0]*//;
 891                                 $dbline{$i} .= "\0" . action($j);
 892                             }
 893                         } else {
 894                             $dbline{$i} =~ s/\0[^\0]*//;
 895                             delete $dbline{$i} if $dbline{$i} eq '';
 896                         }
 897                         next CMD; };
 898                     $cmd =~ /^n$/ && do {
 899                         end_report(), next CMD if $finished and $level <= 1;
 900                         $single = 2;
 901                         $laststep = $cmd;
 902                         last CMD; };
 903                     $cmd =~ /^s$/ && do {
 904                         end_report(), next CMD if $finished and $level <= 1;
 905                         $single = 1;
 906                         $laststep = $cmd;
 907                         last CMD; };
 908                     $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
 909                         end_report(), next CMD if $finished and $level <= 1;
 910                         $subname = $i = $1;
 911                         #  Probably not needed, since we finish an interactive
 912                         #  sub-session anyway...
 913                         # local $filename = $filename;
 914                         # local *dbline = *dbline;      # XXX Would this work?!
 915                         if ($i =~ /\D/) { # subroutine name
 916                             $subname = $package."::".$subname
 917                                 unless $subname =~ /::/;
 918                             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
 919                             $i += 0;
 920                             if ($i) {
 921                                 $filename = $file;
 922                                 *dbline = $main::{'_<' . $filename};
 923                                 $had_breakpoints{$filename} |= 1;
 924                                 $max = $#dbline;
 925                                 ++$i while $dbline[$i] == 0 && $i < $max;
 926                             } else {
 927                                 print $OUT "Subroutine $subname not found.\n";
 928                                 next CMD;
 929                             }
 930                         }
 931                         if ($i) {
 932                             if ($dbline[$i] == 0) {
 933                                 print $OUT "Line $i not breakable.\n";
 934                                 next CMD;
 935                             }
 936                             $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
 937                         }
 938                         for ($i=0; $i <= $stack_depth; ) {
 939                             $stack[$i++] &= ~1;
 940                         }
 941                         last CMD; };
 942                     $cmd =~ /^r$/ && do {
 943                         end_report(), next CMD if $finished and $level <= 1;
 944                         $stack[$stack_depth] |= 1;
 945                         $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
 946                         last CMD; };
 947                     $cmd =~ /^R$/ && do {
 948                         print $OUT "Warning: some settings and command-line options may be lost!\n";
 949                         my (@script, @flags, $cl);
 950                         push @flags, '-w' if $ini_warn;
 951                         # Put all the old includes at the start to get
 952                         # the same debugger.
 953                         for (@ini_INC) {
 954                           push @flags, '-I', $_;
 955                         }
 956                         # Arrange for setting the old INC:
 957                         set_list("PERLDB_INC", @ini_INC);
 958                         if ($0 eq '-e') {
 959                           for (1..$#{'::_<-e'}) { # The first line is PERL5DB
 960                             chomp ($cl =  $ {'::_<-e'}[$_]);
 961                             push @script, '-e', $cl;
 962                           }
 963                         } else {
 964                           @script = $0;
 965                         }
 966                         set_list("PERLDB_HIST",
 967                                  $term->Features->{getHistory}
 968                                  ? $term->GetHistory : @hist);
 969                         my @had_breakpoints = keys %had_breakpoints;
 970                         set_list("PERLDB_VISITED", @had_breakpoints);
 971                         set_list("PERLDB_OPT", %option);
 972                         set_list("PERLDB_ON_LOAD", %break_on_load);
 973                         my @hard;
 974                         for (0 .. $#had_breakpoints) {
 975                           my $file = $had_breakpoints[$_];
 976                           *dbline = $main::{'_<' . $file};
 977                           next unless %dbline or $postponed_file{$file};
 978                           (push @hard, $file), next
 979                             if $file =~ /^\(eval \d+\)$/;
 980                           my @add;
 981                           @add = %{$postponed_file{$file}}
 982                             if $postponed_file{$file};
 983                           set_list("PERLDB_FILE_$_", %dbline, @add);
 984                         }
 985                         for (@hard) { # Yes, really-really...
 986                           # Find the subroutines in this eval
 987                           *dbline = $main::{'_<' . $_};
 988                           my ($quoted, $sub, %subs, $line) = quotemeta $_;
 989                           for $sub (keys %sub) {
 990                             next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
 991                             $subs{$sub} = [$1, $2];
 992                           }
 993                           unless (%subs) {
 994                             print $OUT
 995                               "No subroutines in $_, ignoring breakpoints.\n";
 996                             next;
 997                           }
 998                         LINES: for $line (keys %dbline) {
 999                             # One breakpoint per sub only:
1000                             my ($offset, $sub, $found);
1001                           SUBS: for $sub (keys %subs) {
1002                               if ($subs{$sub}->[1] >= $line # Not after the subroutine
1003                                   and (not defined $offset # Not caught
1004                                        or $offset < 0 )) { # or badly caught
1005                                 $found = $sub;
1006                                 $offset = $line - $subs{$sub}->[0];
1007                                 $offset = "+$offset", last SUBS if $offset >= 0;
1008                               }
1009                             }
1010                             if (defined $offset) {
1011                               $postponed{$found} =
1012                                 "break $offset if $dbline{$line}";
1013                             } else {
1014                               print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1015                             }
1016                           }
1017                         }
1018                         set_list("PERLDB_POSTPONE", %postponed);
1019                         set_list("PERLDB_PRETYPE", @$pretype);
1020                         set_list("PERLDB_PRE", @$pre);
1021                         set_list("PERLDB_POST", @$post);
1022                         set_list("PERLDB_TYPEAHEAD", @typeahead);
1023                         $ENV{PERLDB_RESTART} = 1;
1024                         #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
1025                         exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
1026                         print $OUT "exec failed: $!\n";
1027                         last CMD; };
1028                     $cmd =~ /^T$/ && do {
1029                         print_trace($OUT, 1); # skip DB
1030                         next CMD; };
1031                     $cmd =~ /^W\s*$/ && do {
1032                         $trace &= ~2;
1033                         @to_watch = @old_watch = ();
1034                         next CMD; };
1035                     $cmd =~ /^W\b\s*(.*)/s && do {
1036                         push @to_watch, $1;
1037                         $evalarg = $1;
1038                         my ($val) = &eval;
1039                         $val = (defined $val) ? "'$val'" : 'undef' ;
1040                         push @old_watch, $val;
1041                         $trace |= 2;
1042                         next CMD; };
1043                     $cmd =~ /^\/(.*)$/ && do {
1044                         $inpat = $1;
1045                         $inpat =~ s:([^\\])/$:$1:;
1046                         if ($inpat ne "") {
1047                             eval '$inpat =~ m'."\a$inpat\a";
1048                             if ($@ ne "") {
1049                                 print $OUT "$@";
1050                                 next CMD;
1051                             }
1052                             $pat = $inpat;
1053                         }
1054                         $end = $start;
1055                         $incr = -1;
1056                         eval '
1057                             for (;;) {
1058                                 ++$start;
1059                                 $start = 1 if ($start > $max);
1060                                 last if ($start == $end);
1061                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1062                                     if ($emacs) {
1063                                         print $OUT "\032\032$filename:$start:0\n";
1064                                     } else {
1065                                         print $OUT "$start:\t", $dbline[$start], "\n";
1066                                     }
1067                                     last;
1068                                 }
1069                             } ';
1070                         print $OUT "/$pat/: not found\n" if ($start == $end);
1071                         next CMD; };
1072                     $cmd =~ /^\?(.*)$/ && do {
1073                         $inpat = $1;
1074                         $inpat =~ s:([^\\])\?$:$1:;
1075                         if ($inpat ne "") {
1076                             eval '$inpat =~ m'."\a$inpat\a";
1077                             if ($@ ne "") {
1078                                 print $OUT "$@";
1079                                 next CMD;
1080                             }
1081                             $pat = $inpat;
1082                         }
1083                         $end = $start;
1084                         $incr = -1;
1085                         eval '
1086                             for (;;) {
1087                                 --$start;
1088                                 $start = $max if ($start <= 0);
1089                                 last if ($start == $end);
1090                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1091                                     if ($emacs) {
1092                                         print $OUT "\032\032$filename:$start:0\n";
1093                                     } else {
1094                                         print $OUT "$start:\t", $dbline[$start], "\n";
1095                                     }
1096                                     last;
1097                                 }
1098                             } ';
1099                         print $OUT "?$pat?: not found\n" if ($start == $end);
1100                         next CMD; };
1101                     $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1102                         pop(@hist) if length($cmd) > 1;
1103                         $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1104                         $cmd = $hist[$i];
1105                         print $OUT $cmd, "\n";
1106                         redo CMD; };
1107                     $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1108                         &system($1);
1109                         next CMD; };
1110                     $cmd =~ /^$rc([^$rc].*)$/ && do {
1111                         $pat = "^$1";
1112                         pop(@hist) if length($cmd) > 1;
1113                         for ($i = $#hist; $i; --$i) {
1114                             last if $hist[$i] =~ /$pat/;
1115                         }
1116                         if (!$i) {
1117                             print $OUT "No such command!\n\n";
1118                             next CMD;
1119                         }
1120                         $cmd = $hist[$i];
1121                         print $OUT $cmd, "\n";
1122                         redo CMD; };
1123                     $cmd =~ /^$sh$/ && do {
1124                         &system($ENV{SHELL}||"/bin/sh");
1125                         next CMD; };
1126                     $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1127                         &system($ENV{SHELL}||"/bin/sh","-c",$1);
1128                         next CMD; };
1129                     $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1130                         $end = $2?($#hist-$2):0;
1131                         $hist = 0 if $hist < 0;
1132                         for ($i=$#hist; $i>$end; $i--) {
1133                             print $OUT "$i: ",$hist[$i],"\n"
1134                               unless $hist[$i] =~ /^.?$/;
1135                         };
1136                         next CMD; };
1137                     $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1138                     $cmd =~ s/^p\b/print {\$DB::OUT} /;
1139                     $cmd =~ /^=/ && do {
1140                         if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1141                             $alias{$k}="s~$k~$v~";
1142                             print $OUT "$k = $v\n";
1143                         } elsif ($cmd =~ /^=\s*$/) {
1144                             foreach $k (sort keys(%alias)) {
1145                                 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1146                                     print $OUT "$k = $v\n";
1147                                 } else {
1148                                     print $OUT "$k\t$alias{$k}\n";
1149                                 };
1150                             };
1151                         };
1152                         next CMD; };
1153                     $cmd =~ /^\|\|?\s*[^|]/ && do {
1154                         if ($pager =~ /^\|/) {
1155                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1156                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1157                         } else {
1158                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1159                         }
1160                         unless ($piped=open(OUT,$pager)) {
1161                             &warn("Can't pipe output to `$pager'");
1162                             if ($pager =~ /^\|/) {
1163                                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1164                                 open(STDOUT,">&SAVEOUT")
1165                                   || &warn("Can't restore STDOUT");
1166                                 close(SAVEOUT);
1167                             } else {
1168                                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1169                             }
1170                             next CMD;
1171                         }
1172                         $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1173                           && "" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE};
1174                         $selected= select(OUT);
1175                         $|= 1;
1176                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1177                         $cmd =~ s/^\|+\s*//;
1178                         redo PIPE; };
1179                     # XXX Local variants do not work!
1180                     $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1181                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1182                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1183                 }               # PIPE:
1184             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1185             if ($onetimeDump) {
1186                 $onetimeDump = undef;
1187             } elsif ($term_pid == $$) {
1188                 print $OUT "\n";
1189             }
1190         } continue {            # CMD:
1191             if ($piped) {
1192                 if ($pager =~ /^\|/) {
1193                     $?= 0;  close(OUT) || &warn("Can't close DB::OUT");
1194                     &warn( "Pager `$pager' failed: ",
1195                           ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1196                           ( $? & 128 ) ? " (core dumped)" : "",
1197                           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1198                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1199                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1200                     $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1201                     # Will stop ignoring SIGPIPE if done like nohup(1)
1202                     # does SIGINT but Perl doesn't give us a choice.
1203                 } else {
1204                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1205                 }
1206                 close(SAVEOUT);
1207                 select($selected), $selected= "" unless $selected eq "";
1208                 $piped= "";
1209             }
1210         }                       # CMD:
1211         $exiting = 1 unless defined $cmd;
1212         foreach $evalarg (@$post) {
1213           &eval;
1214         }
1215     }                           # if ($single || $signal)
1216     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1217     ();
1218 }
1219
1220 # The following code may be executed now:
1221 # BEGIN {warn 4}
1222
1223 sub sub {
1224     my ($al, $ret, @ret) = "";
1225     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1226         $al = " for $$sub";
1227     }
1228     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1229     $#stack = $stack_depth;
1230     $stack[-1] = $single;
1231     $single &= 1;
1232     $single |= 4 if $stack_depth == $deep;
1233     ($frame & 4
1234      ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in  "),
1235          # Why -1? But it works! :-(
1236          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1237      : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1238     if (wantarray) {
1239         @ret = &$sub;
1240         $single |= $stack[$stack_depth--];
1241         ($frame & 4
1242          ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1243              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1244          : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1245         if ($doret eq $stack_depth or $frame & 16) {
1246             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1247             print $fh ' ' x $stack_depth if $frame & 16;
1248             print $fh "list context return from $sub:\n";
1249             dumpit($fh, \@ret );
1250             $doret = -2;
1251         }
1252         @ret;
1253     } else {
1254         if (defined wantarray) {
1255             $ret = &$sub;
1256         } else {
1257             &$sub; undef $ret;
1258         };
1259         $single |= $stack[$stack_depth--];
1260         ($frame & 4
1261          ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1262               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1263          : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1264         if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1265             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1266             print $fh (' ' x $stack_depth) if $frame & 16;
1267             print $fh (defined wantarray
1268                          ? "scalar context return from $sub: "
1269                          : "void context return from $sub\n");
1270             dumpit( $fh, $ret ) if defined wantarray;
1271             $doret = -2;
1272         }
1273         $ret;
1274     }
1275 }
1276
1277 sub save {
1278     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1279     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1280 }
1281
1282 # The following takes its argument via $evalarg to preserve current @_
1283
1284 sub eval {
1285     local @res;                 # 'my' would make it visible from user code
1286     {
1287         local $otrace = $trace;
1288         local $osingle = $single;
1289         local $od = $^D;
1290         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1291         $trace = $otrace;
1292         $single = $osingle;
1293         $^D = $od;
1294     }
1295     my $at = $@;
1296     local $saved[0];            # Preserve the old value of $@
1297     eval { &DB::save };
1298     if ($at) {
1299         print $OUT $at;
1300     } elsif ($onetimeDump eq 'dump') {
1301         dumpit($OUT, \@res);
1302     } elsif ($onetimeDump eq 'methods') {
1303         methods($res[0]);
1304     }
1305     @res;
1306 }
1307
1308 sub postponed_sub {
1309   my $subname = shift;
1310   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1311     my $offset = $1 || 0;
1312     # Filename below can contain ':'
1313     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1314     if ($i) {
1315       $i += $offset;
1316       local *dbline = $main::{'_<' . $file};
1317       local $^W = 0;            # != 0 is magical below
1318       $had_breakpoints{$file} |= 1;
1319       my $max = $#dbline;
1320       ++$i until $dbline[$i] != 0 or $i >= $max;
1321       $dbline{$i} = delete $postponed{$subname};
1322     } else {
1323       print $OUT "Subroutine $subname not found.\n";
1324     }
1325     return;
1326   }
1327   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1328   #print $OUT "In postponed_sub for `$subname'.\n";
1329 }
1330
1331 sub postponed {
1332   if ($ImmediateStop) {
1333     $ImmediateStop = 0;
1334     $signal = 1;
1335   }
1336   return &postponed_sub
1337     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1338   # Cannot be done before the file is compiled
1339   local *dbline = shift;
1340   my $filename = $dbline;
1341   $filename =~ s/^_<//;
1342   $signal = 1, print $OUT "'$filename' loaded...\n"
1343     if $break_on_load{$filename};
1344   print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1345   return unless $postponed_file{$filename};
1346   $had_breakpoints{$filename} |= 1;
1347   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1348   my $key;
1349   for $key (keys %{$postponed_file{$filename}}) {
1350     $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1351   }
1352   delete $postponed_file{$filename};
1353 }
1354
1355 sub dumpit {
1356     local ($savout) = select(shift);
1357     my $osingle = $single;
1358     my $otrace = $trace;
1359     $single = $trace = 0;
1360     local $frame = 0;
1361     local $doret = -2;
1362     unless (defined &main::dumpValue) {
1363         do 'dumpvar.pl';
1364     }
1365     if (defined &main::dumpValue) {
1366         &main::dumpValue(shift);
1367     } else {
1368         print $OUT "dumpvar.pl not available.\n";
1369     }
1370     $single = $osingle;
1371     $trace = $otrace;
1372     select ($savout);
1373 }
1374
1375 # Tied method do not create a context, so may get wrong message:
1376
1377 sub print_trace {
1378   my $fh = shift;
1379   my @sub = dump_trace($_[0] + 1, $_[1]);
1380   my $short = $_[2];            # Print short report, next one for sub name
1381   my $s;
1382   for ($i=0; $i <= $#sub; $i++) {
1383     last if $signal;
1384     local $" = ', ';
1385     my $args = defined $sub[$i]{args}
1386     ? "(@{ $sub[$i]{args} })"
1387       : '' ;
1388     $args = (substr $args, 0, $maxtrace - 3) . '...'
1389       if length $args > $maxtrace;
1390     my $file = $sub[$i]{file};
1391     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1392     $s = $sub[$i]{sub};
1393     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1394     if ($short) {
1395       my $sub = @_ >= 4 ? $_[3] : $s;
1396       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1397     } else {
1398       print $fh "$sub[$i]{context} = $s$args" .
1399         " called from $file" .
1400           " line $sub[$i]{line}\n";
1401     }
1402   }
1403 }
1404
1405 sub dump_trace {
1406   my $skip = shift;
1407   my $count = shift || 1e9;
1408   $skip++;
1409   $count += $skip;
1410   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1411   my $nothard = not $frame & 8;
1412   local $frame = 0;             # Do not want to trace this.
1413   my $otrace = $trace;
1414   $trace = 0;
1415   for ($i = $skip;
1416        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1417        $i++) {
1418     @a = ();
1419     for $arg (@args) {
1420       my $type;
1421       if (not defined $arg) {
1422         push @a, "undef";
1423       } elsif ($nothard and tied $arg) {
1424         push @a, "tied";
1425       } elsif ($nothard and $type = ref $arg) {
1426         push @a, "ref($type)";
1427       } else {
1428         local $_ = "$arg";      # Safe to stringify now - should not call f().
1429         s/([\'\\])/\\$1/g;
1430         s/(.*)/'$1'/s
1431           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1432         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1433         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1434         push(@a, $_);
1435       }
1436     }
1437     $context = $context ? '@' : (defined $context ? "\$" : '.');
1438     $args = $h ? [@a] : undef;
1439     $e =~ s/\n\s*\;\s*\Z// if $e;
1440     $e =~ s/([\\\'])/\\$1/g if $e;
1441     if ($r) {
1442       $sub = "require '$e'";
1443     } elsif (defined $r) {
1444       $sub = "eval '$e'";
1445     } elsif ($sub eq '(eval)') {
1446       $sub = "eval {...}";
1447     }
1448     push(@sub, {context => $context, sub => $sub, args => $args,
1449                 file => $file, line => $line});
1450     last if $signal;
1451   }
1452   $trace = $otrace;
1453   @sub;
1454 }
1455
1456 sub action {
1457     my $action = shift;
1458     while ($action =~ s/\\$//) {
1459         #print $OUT "+ ";
1460         #$action .= "\n";
1461         $action .= &gets;
1462     }
1463     $action;
1464 }
1465
1466 sub gets {
1467     local($.);
1468     #<IN>;
1469     &readline("cont: ");
1470 }
1471
1472 sub system {
1473     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1474     # many non-Unix systems can do system() but have problems with fork().
1475     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1476     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1477     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1478     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1479     system(@_);
1480     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1481     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1482     close(SAVEIN); close(SAVEOUT);
1483     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1484           ( $? & 128 ) ? " (core dumped)" : "",
1485           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1486     $?;
1487 }
1488
1489 sub setterm {
1490     local $frame = 0;
1491     local $doret = -2;
1492     eval { require Term::ReadLine } or die $@;
1493     if ($notty) {
1494         if ($tty) {
1495             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1496             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1497             $IN = \*IN;
1498             $OUT = \*OUT;
1499             my $sel = select($OUT);
1500             $| = 1;
1501             select($sel);
1502         } else {
1503             eval "require Term::Rendezvous;" or die $@;
1504             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1505             my $term_rv = new Term::Rendezvous $rv;
1506             $IN = $term_rv->IN;
1507             $OUT = $term_rv->OUT;
1508         }
1509     }
1510     if (!$rl) {
1511         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1512     } else {
1513         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1514
1515         $rl_attribs = $term->Attribs;
1516         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1517           if defined $rl_attribs->{basic_word_break_characters}
1518             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1519         $rl_attribs->{special_prefixes} = '$@&%';
1520         $rl_attribs->{completer_word_break_characters} .= '$@&%';
1521         $rl_attribs->{completion_function} = \&db_complete;
1522     }
1523     $LINEINFO = $OUT unless defined $LINEINFO;
1524     $lineinfo = $console unless defined $lineinfo;
1525     $term->MinLine(2);
1526     if ($term->Features->{setHistory} and "@hist" ne "?") {
1527       $term->SetHistory(@hist);
1528     }
1529     ornaments($ornaments) if defined $ornaments;
1530     $term_pid = $$;
1531 }
1532
1533 sub resetterm {                 # We forked, so we need a different TTY
1534     $term_pid = $$;
1535     if (defined &get_fork_TTY) {
1536       &get_fork_TTY;
1537     } elsif (not defined $fork_TTY
1538              and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1539              and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1540         # Possibly _inside_ XTERM
1541         open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1542  sleep 10000000' |];
1543         $fork_TTY = <XT>;
1544         chomp $fork_TTY;
1545     }
1546     if (defined $fork_TTY) {
1547       TTY($fork_TTY);
1548       undef $fork_TTY;
1549     } else {
1550       print_help(<<EOP);
1551 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1552   Define B<\$DB::fork_TTY>
1553        - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1554   The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1555   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1556   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1557 EOP
1558     }
1559 }
1560
1561 sub readline {
1562   if (@typeahead) {
1563     my $left = @typeahead;
1564     my $got = shift @typeahead;
1565     print $OUT "auto(-$left)", shift, $got, "\n";
1566     $term->AddHistory($got)
1567       if length($got) > 1 and defined $term->Features->{addHistory};
1568     return $got;
1569   }
1570   local $frame = 0;
1571   local $doret = -2;
1572   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1573     print $OUT @_;
1574     my $stuff;
1575     $IN->recv( $stuff, 2048 );
1576     $stuff;
1577   }
1578   else {
1579     $term->readline(@_);
1580   }
1581 }
1582
1583 sub dump_option {
1584     my ($opt, $val)= @_;
1585     $val = option_val($opt,'N/A');
1586     $val =~ s/([\\\'])/\\$1/g;
1587     printf $OUT "%20s = '%s'\n", $opt, $val;
1588 }
1589
1590 sub option_val {
1591     my ($opt, $default)= @_;
1592     my $val;
1593     if (defined $optionVars{$opt}
1594         and defined $ {$optionVars{$opt}}) {
1595         $val = $ {$optionVars{$opt}};
1596     } elsif (defined $optionAction{$opt}
1597         and defined &{$optionAction{$opt}}) {
1598         $val = &{$optionAction{$opt}}();
1599     } elsif (defined $optionAction{$opt}
1600              and not defined $option{$opt}
1601              or defined $optionVars{$opt}
1602              and not defined $ {$optionVars{$opt}}) {
1603         $val = $default;
1604     } else {
1605         $val = $option{$opt};
1606     }
1607     $val
1608 }
1609
1610 sub parse_options {
1611     local($_)= @_;
1612     while ($_ ne "") {
1613         s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1614         my ($opt,$sep) = ($1,$2);
1615         my $val;
1616         if ("?" eq $sep) {
1617             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1618               if /^\S/;
1619             #&dump_option($opt);
1620         } elsif ($sep !~ /\S/) {
1621             $val = "1";
1622         } elsif ($sep eq "=") {
1623             s/^(\S*)($|\s+)//;
1624             $val = $1;
1625         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1626             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1627             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1628               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1629             $val = $1;
1630             $val =~ s/\\([\\$end])/$1/g;
1631         }
1632         my ($option);
1633         my $matches =
1634           grep(  /^\Q$opt/ && ($option = $_),  @options  );
1635         $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
1636           unless $matches;
1637         print $OUT "Unknown option `$opt'\n" unless $matches;
1638         print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1639         $option{$option} = $val if $matches == 1 and defined $val;
1640         eval "local \$frame = 0; local \$doret = -2;
1641               require '$optionRequire{$option}'"
1642           if $matches == 1 and defined $optionRequire{$option} and defined $val;
1643         $ {$optionVars{$option}} = $val
1644           if $matches == 1
1645             and defined $optionVars{$option} and defined $val;
1646         & {$optionAction{$option}} ($val)
1647           if $matches == 1
1648             and defined $optionAction{$option}
1649               and defined &{$optionAction{$option}} and defined $val;
1650         &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1651         s/^\s+//;
1652     }
1653 }
1654
1655 sub set_list {
1656   my ($stem,@list) = @_;
1657   my $val;
1658   $ENV{"$ {stem}_n"} = @list;
1659   for $i (0 .. $#list) {
1660     $val = $list[$i];
1661     $val =~ s/\\/\\\\/g;
1662     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1663     $ENV{"$ {stem}_$i"} = $val;
1664   }
1665 }
1666
1667 sub get_list {
1668   my $stem = shift;
1669   my @list;
1670   my $n = delete $ENV{"$ {stem}_n"};
1671   my $val;
1672   for $i (0 .. $n - 1) {
1673     $val = delete $ENV{"$ {stem}_$i"};
1674     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1675     push @list, $val;
1676   }
1677   @list;
1678 }
1679
1680 sub catch {
1681     $signal = 1;
1682     return;                     # Put nothing on the stack - malloc/free land!
1683 }
1684
1685 sub warn {
1686     my($msg)= join("",@_);
1687     $msg .= ": $!\n" unless $msg =~ /\n$/;
1688     print $OUT $msg;
1689 }
1690
1691 sub TTY {
1692     if (@_ and $term and $term->Features->{newTTY}) {
1693       my ($in, $out) = shift;
1694       if ($in =~ /,/) {
1695         ($in, $out) = split /,/, $in, 2;
1696       } else {
1697         $out = $in;
1698       }
1699       open IN, $in or die "cannot open `$in' for read: $!";
1700       open OUT, ">$out" or die "cannot open `$out' for write: $!";
1701       $term->newTTY(\*IN, \*OUT);
1702       $IN       = \*IN;
1703       $OUT      = \*OUT;
1704       return $tty = $in;
1705     } elsif ($term and @_) {
1706         &warn("Too late to set TTY, enabled on next `R'!\n");
1707     }
1708     $tty = shift if @_;
1709     $tty or $console;
1710 }
1711
1712 sub noTTY {
1713     if ($term) {
1714         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1715     }
1716     $notty = shift if @_;
1717     $notty;
1718 }
1719
1720 sub ReadLine {
1721     if ($term) {
1722         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1723     }
1724     $rl = shift if @_;
1725     $rl;
1726 }
1727
1728 sub RemotePort {
1729     if ($term) {
1730         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
1731     }
1732     $remoteport = shift if @_;
1733     $remoteport;
1734 }
1735
1736 sub tkRunning {
1737     if ($ {$term->Features}{tkRunning}) {
1738         return $term->tkRunning(@_);
1739     } else {
1740         print $OUT "tkRunning not supported by current ReadLine package.\n";
1741         0;
1742     }
1743 }
1744
1745 sub NonStop {
1746     if ($term) {
1747         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1748     }
1749     $runnonstop = shift if @_;
1750     $runnonstop;
1751 }
1752
1753 sub pager {
1754     if (@_) {
1755         $pager = shift;
1756         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1757     }
1758     $pager;
1759 }
1760
1761 sub shellBang {
1762     if (@_) {
1763         $sh = quotemeta shift;
1764         $sh .= "\\b" if $sh =~ /\w$/;
1765     }
1766     $psh = $sh;
1767     $psh =~ s/\\b$//;
1768     $psh =~ s/\\(.)/$1/g;
1769     &sethelp;
1770     $psh;
1771 }
1772
1773 sub ornaments {
1774   if (defined $term) {
1775     local ($warnLevel,$dieLevel) = (0, 1);
1776     return '' unless $term->Features->{ornaments};
1777     eval { $term->ornaments(@_) } || '';
1778   } else {
1779     $ornaments = shift;
1780   }
1781 }
1782
1783 sub recallCommand {
1784     if (@_) {
1785         $rc = quotemeta shift;
1786         $rc .= "\\b" if $rc =~ /\w$/;
1787     }
1788     $prc = $rc;
1789     $prc =~ s/\\b$//;
1790     $prc =~ s/\\(.)/$1/g;
1791     &sethelp;
1792     $prc;
1793 }
1794
1795 sub LineInfo {
1796     return $lineinfo unless @_;
1797     $lineinfo = shift;
1798     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1799     $emacs = ($stream =~ /^\|/);
1800     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1801     $LINEINFO = \*LINEINFO;
1802     my $save = select($LINEINFO);
1803     $| = 1;
1804     select($save);
1805     $lineinfo;
1806 }
1807
1808 sub list_versions {
1809   my %version;
1810   my $file;
1811   for (keys %INC) {
1812     $file = $_;
1813     s,\.p[lm]$,,i ;
1814     s,/,::,g ;
1815     s/^perl5db$/DB/;
1816     s/^Term::ReadLine::readline$/readline/;
1817     if (defined $ { $_ . '::VERSION' }) {
1818       $version{$file} = "$ { $_ . '::VERSION' } from ";
1819     }
1820     $version{$file} .= $INC{$file};
1821   }
1822   dumpit($OUT,\%version);
1823 }
1824
1825 sub sethelp {
1826     $help = "
1827 B<T>            Stack trace.
1828 B<s> [I<expr>]  Single step [in I<expr>].
1829 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
1830 <B<CR>>         Repeat last B<n> or B<s> command.
1831 B<r>            Return from current subroutine.
1832 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
1833                 at the specified position.
1834 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
1835 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
1836 B<l> I<line>            List single I<line>.
1837 B<l> I<subname> List first window of lines from subroutine.
1838 B<l> I<\$var>           List first window of lines from subroutine referenced by I<\$var>.
1839 B<l>            List next window of lines.
1840 B<->            List previous window of lines.
1841 B<w> [I<line>]  List window around I<line>.
1842 B<.>            Return to the executed line.
1843 B<f> I<filename>        Switch to viewing I<filename>. File must be already loaded.
1844                 I<filename> may be either the full name of the file, or a regular
1845                 expression matching the full file name:
1846                 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
1847                 Evals (with saved bodies) are considered to be filenames:
1848                 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
1849                 (in the order of execution).
1850 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
1851 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
1852 B<L>            List all breakpoints and actions.
1853 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1854 B<t>            Toggle trace mode.
1855 B<t> I<expr>            Trace through execution of I<expr>.
1856 B<b> [I<line>] [I<condition>]
1857                 Set breakpoint; I<line> defaults to the current execution line;
1858                 I<condition> breaks if it evaluates to true, defaults to '1'.
1859 B<b> I<subname> [I<condition>]
1860                 Set breakpoint at first line of subroutine.
1861 B<b> I<\$var>           Set breakpoint at first line of subroutine referenced by I<\$var>.
1862 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1863 B<b> B<postpone> I<subname> [I<condition>]
1864                 Set breakpoint at first line of subroutine after
1865                 it is compiled.
1866 B<b> B<compile> I<subname>
1867                 Stop after the subroutine is compiled.
1868 B<d> [I<line>]  Delete the breakpoint for I<line>.
1869 B<D>            Delete all breakpoints.
1870 B<a> [I<line>] I<command>
1871                 Set an action to be done before the I<line> is executed;
1872                 I<line> defaults to the current execution line.
1873                 Sequence is: check for breakpoint/watchpoint, print line
1874                 if necessary, do action, prompt user if necessary,
1875                 execute line.
1876 B<a> [I<line>]  Delete the action for I<line>.
1877 B<A>            Delete all actions.
1878 B<W> I<expr>            Add a global watch-expression.
1879 B<W>            Delete all watch-expressions.
1880 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1881                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1882 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
1883 B<x> I<expr>            Evals expression in array context, dumps the result.
1884 B<m> I<expr>            Evals expression in array context, prints methods callable
1885                 on the first element of the result.
1886 B<m> I<class>           Prints methods callable via the given class.
1887 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1888                 Set or query values of options.  I<val> defaults to 1.  I<opt> can
1889                 be abbreviated.  Several options can be listed.
1890     I<recallCommand>, I<ShellBang>:     chars used to recall command or spawn shell;
1891     I<pager>:                   program for output of \"|cmd\";
1892     I<tkRunning>:                       run Tk while prompting (with ReadLine);
1893     I<signalLevel> I<warnLevel> I<dieLevel>:    level of verbosity;
1894     I<inhibit_exit>             Allows stepping off the end of the script.
1895     I<ImmediateStop>            Debugger should stop as early as possible.
1896     I<RemotePort>:                      Remote hostname:port for remote debugging
1897   The following options affect what happens with B<V>, B<X>, and B<x> commands:
1898     I<arrayDepth>, I<hashDepth>:        print only first N elements ('' for all);
1899     I<compactDump>, I<veryCompact>:     change style of array and hash dump;
1900     I<globPrint>:                       whether to print contents of globs;
1901     I<DumpDBFiles>:             dump arrays holding debugged files;
1902     I<DumpPackages>:            dump symbol tables of packages;
1903     I<DumpReused>:                      dump contents of \"reused\" addresses;
1904     I<quote>, I<HighBit>, I<undefPrint>:        change style of string dump;
1905     I<bareStringify>:           Do not print the overload-stringified value;
1906   Option I<PrintRet> affects printing of return value after B<r> command,
1907          I<frame>    affects printing messages on entry and exit from subroutines.
1908          I<AutoTrace> affects printing messages on every possible breaking point.
1909          I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1910          I<ornaments> affects screen appearance of the command line.
1911                 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1912                 You can put additional initialization options I<TTY>, I<noTTY>,
1913                 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
1914                 `B<R>' after you set them).
1915 B<<> I<expr>            Define Perl command to run before each prompt.
1916 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
1917 B<>> I<expr>            Define Perl command to run after each prompt.
1918 B<>>B<>> I<expr>                Add to the list of Perl commands to run after each prompt.
1919 B<{> I<db_command>      Define debugger command to run before each prompt.
1920 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
1921 B<$prc> I<number>       Redo a previous command (default previous command).
1922 B<$prc> I<-number>      Redo number'th-to-last command.
1923 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
1924                 See 'B<O> I<recallCommand>' too.
1925 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1926   . ( $rc eq $sh ? "" : "
1927 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1928                 See 'B<O> I<shellBang>' too.
1929 B<H> I<-number> Display last number commands (default all).
1930 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
1931 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
1932 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1933 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
1934 I<command>              Execute as a perl statement in current package.
1935 B<v>            Show versions of loaded modules.
1936 B<R>            Pure-man-restart of debugger, some of debugger state
1937                 and command-line options may be lost.
1938                 Currently the following setting are preserved:
1939                 history, breakpoints and actions, debugger B<O>ptions
1940                 and the following command-line options: I<-w>, I<-I>, I<-e>.
1941 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
1942                 Complete description of debugger is available in B<perldebug>
1943                 section of Perl documention
1944 B<h h>          Summary of debugger commands.
1945 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
1946
1947 ";
1948     $summary = <<"END_SUM";
1949 I<List/search source lines:>               I<Control script execution:>
1950   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
1951   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
1952   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
1953   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
1954   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
1955   B<v>        Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
1956 I<Debugger controls:>                        B<L>           List break/watch/actions
1957   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
1958   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
1959   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
1960   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
1961   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
1962   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
1963   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1964   B<q> or B<^D>     Quit                          B<R>        Attempt a restart
1965 I<Data Examination:>          B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1966   B<x>|B<m> I<expr>     Evals expr in array context, dumps the result or lists methods.
1967   B<p> I<expr>  Print expression (uses script's current package).
1968   B<S> [[B<!>]I<pat>]   List subroutine names [not] matching pattern
1969   B<V> [I<Pk> [I<Vars>]]        List Variables in Package.  Vars can be ~pattern or !pattern.
1970   B<X> [I<Vars>]        Same as \"B<V> I<current_package> [I<Vars>]\".
1971 I<More help for> B<db_cmd>I<:>  Type B<h> I<cmd_letter>  Run B<perldoc perldebug> for more help.
1972 END_SUM
1973                                 # ')}}; # Fix balance of Emacs parsing
1974 }
1975
1976 sub print_help {
1977   my $message = shift;
1978   if (@Term::ReadLine::TermCap::rl_term_set) {
1979     $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1980     $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1981   }
1982   print $OUT $message;
1983 }
1984
1985 sub diesignal {
1986     local $frame = 0;
1987     local $doret = -2;
1988     $SIG{'ABRT'} = 'DEFAULT';
1989     kill 'ABRT', $$ if $panic++;
1990     if (defined &Carp::longmess) {
1991         local $SIG{__WARN__} = '';
1992         local $Carp::CarpLevel = 2;             # mydie + confess
1993         &warn(Carp::longmess("Signal @_"));
1994     }
1995     else {
1996         print $DB::OUT "Got signal @_\n";
1997     }
1998     kill 'ABRT', $$;
1999 }
2000
2001 sub dbwarn {
2002   local $frame = 0;
2003   local $doret = -2;
2004   local $SIG{__WARN__} = '';
2005   local $SIG{__DIE__} = '';
2006   eval { require Carp } if defined $^S; # If error/warning during compilation,
2007                                         # require may be broken.
2008   warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2009     return unless defined &Carp::longmess;
2010   my ($mysingle,$mytrace) = ($single,$trace);
2011   $single = 0; $trace = 0;
2012   my $mess = Carp::longmess(@_);
2013   ($single,$trace) = ($mysingle,$mytrace);
2014   &warn($mess);
2015 }
2016
2017 sub dbdie {
2018   local $frame = 0;
2019   local $doret = -2;
2020   local $SIG{__DIE__} = '';
2021   local $SIG{__WARN__} = '';
2022   my $i = 0; my $ineval = 0; my $sub;
2023   if ($dieLevel > 2) {
2024       local $SIG{__WARN__} = \&dbwarn;
2025       &warn(@_);                # Yell no matter what
2026       return;
2027   }
2028   if ($dieLevel < 2) {
2029     die @_ if $^S;              # in eval propagate
2030   }
2031   eval { require Carp } if defined $^S; # If error/warning during compilation,
2032                                         # require may be broken.
2033   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2034     unless defined &Carp::longmess;
2035   # We do not want to debug this chunk (automatic disabling works
2036   # inside DB::DB, but not in Carp).
2037   my ($mysingle,$mytrace) = ($single,$trace);
2038   $single = 0; $trace = 0;
2039   my $mess = Carp::longmess(@_);
2040   ($single,$trace) = ($mysingle,$mytrace);
2041   die $mess;
2042 }
2043
2044 sub warnLevel {
2045   if (@_) {
2046     $prevwarn = $SIG{__WARN__} unless $warnLevel;
2047     $warnLevel = shift;
2048     if ($warnLevel) {
2049       $SIG{__WARN__} = \&DB::dbwarn;
2050     } else {
2051       $SIG{__WARN__} = $prevwarn;
2052     }
2053   }
2054   $warnLevel;
2055 }
2056
2057 sub dieLevel {
2058   if (@_) {
2059     $prevdie = $SIG{__DIE__} unless $dieLevel;
2060     $dieLevel = shift;
2061     if ($dieLevel) {
2062       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2063       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2064       print $OUT "Stack dump during die enabled",
2065         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2066           if $I_m_init;
2067       print $OUT "Dump printed too.\n" if $dieLevel > 2;
2068     } else {
2069       $SIG{__DIE__} = $prevdie;
2070       print $OUT "Default die handler restored.\n";
2071     }
2072   }
2073   $dieLevel;
2074 }
2075
2076 sub signalLevel {
2077   if (@_) {
2078     $prevsegv = $SIG{SEGV} unless $signalLevel;
2079     $prevbus = $SIG{BUS} unless $signalLevel;
2080     $signalLevel = shift;
2081     if ($signalLevel) {
2082       $SIG{SEGV} = \&DB::diesignal;
2083       $SIG{BUS} = \&DB::diesignal;
2084     } else {
2085       $SIG{SEGV} = $prevsegv;
2086       $SIG{BUS} = $prevbus;
2087     }
2088   }
2089   $signalLevel;
2090 }
2091
2092 sub CvGV_name {
2093   my $in = shift;
2094   my $name = CvGV_name_or_bust($in);
2095   defined $name ? $name : $in;
2096 }
2097
2098 sub CvGV_name_or_bust {
2099   my $in = shift;
2100   return if $skipCvGV;          # Backdoor to avoid problems if XS broken...
2101   $in = \&$in;                  # Hard reference...
2102   eval {require Devel::Peek; 1} or return;
2103   my $gv = Devel::Peek::CvGV($in) or return;
2104   *$gv{PACKAGE} . '::' . *$gv{NAME};
2105 }
2106
2107 sub find_sub {
2108   my $subr = shift;
2109   $sub{$subr} or do {
2110     return unless defined &$subr;
2111     my $name = CvGV_name_or_bust($subr);
2112     my $data;
2113     $data = $sub{$name} if defined $name;
2114     return $data if defined $data;
2115
2116     # Old stupid way...
2117     $subr = \&$subr;            # Hard reference
2118     my $s;
2119     for (keys %sub) {
2120       $s = $_, last if $subr eq \&$_;
2121     }
2122     $sub{$s} if $s;
2123   }
2124 }
2125
2126 sub methods {
2127   my $class = shift;
2128   $class = ref $class if ref $class;
2129   local %seen;
2130   local %packs;
2131   methods_via($class, '', 1);
2132   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2133 }
2134
2135 sub methods_via {
2136   my $class = shift;
2137   return if $packs{$class}++;
2138   my $prefix = shift;
2139   my $prepend = $prefix ? "via $prefix: " : '';
2140   my $name;
2141   for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2142              sort keys %{"$ {class}::"}) {
2143     next if $seen{ $name }++;
2144     print $DB::OUT "$prepend$name\n";
2145   }
2146   return unless shift;          # Recurse?
2147   for $name (@{"$ {class}::ISA"}) {
2148     $prepend = $prefix ? $prefix . " -> $name" : $name;
2149     methods_via($name, $prepend, 1);
2150   }
2151 }
2152
2153 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2154
2155 BEGIN {                 # This does not compile, alas.
2156   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
2157   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
2158   $sh = '!';
2159   $rc = ',';
2160   @hist = ('?');
2161   $deep = 100;                  # warning if stack gets this deep
2162   $window = 10;
2163   $preview = 3;
2164   $sub = '';
2165   $SIG{INT} = \&DB::catch;
2166   # This may be enabled to debug debugger:
2167   #$warnLevel = 1 unless defined $warnLevel;
2168   #$dieLevel = 1 unless defined $dieLevel;
2169   #$signalLevel = 1 unless defined $signalLevel;
2170
2171   $db_stop = 0;                 # Compiler warning
2172   $db_stop = 1 << 30;
2173   $level = 0;                   # Level of recursive debugging
2174   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2175   # Triggers bug (?) in perl is we postpone this until runtime:
2176   @postponed = @stack = (0);
2177   $stack_depth = 0;             # Localized $#stack
2178   $doret = -2;
2179   $frame = 0;
2180 }
2181
2182 BEGIN {$^W = $ini_warn;}        # Switch warnings back
2183
2184 #use Carp;                      # This did break, left for debuggin
2185
2186 sub db_complete {
2187   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2188   my($text, $line, $start) = @_;
2189   my ($itext, $search, $prefix, $pack) =
2190     ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2191
2192   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2193                                (map { /$search/ ? ($1) : () } keys %sub)
2194     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2195   return sort grep /^\Q$text/, values %INC # files
2196     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2197   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2198     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2199       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2200   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2201     grep !/^main::/,
2202       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2203                                  # packages
2204         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2205           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
2206   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2207     # We may want to complete to (eval 9), so $text may be wrong
2208     $prefix = length($1) - length($text);
2209     $text = $1;
2210     return sort
2211         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2212   }
2213   if ((substr $text, 0, 1) eq '&') { # subroutines
2214     $text = substr $text, 1;
2215     $prefix = "&";
2216     return sort map "$prefix$_",
2217                grep /^\Q$text/,
2218                  (keys %sub),
2219                  (map { /$search/ ? ($1) : () }
2220                     keys %sub);
2221   }
2222   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2223     $pack = ($1 eq 'main' ? '' : $1) . '::';
2224     $prefix = (substr $text, 0, 1) . $1 . '::';
2225     $text = $2;
2226     my @out
2227       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2228     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2229       return db_complete($out[0], $line, $start);
2230     }
2231     return sort @out;
2232   }
2233   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2234     $pack = ($package eq 'main' ? '' : $package) . '::';
2235     $prefix = substr $text, 0, 1;
2236     $text = substr $text, 1;
2237     my @out = map "$prefix$_", grep /^\Q$text/,
2238        (grep /^_?[a-zA-Z]/, keys %$pack),
2239        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2240     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2241       return db_complete($out[0], $line, $start);
2242     }
2243     return sort @out;
2244   }
2245   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2246     my @out = grep /^\Q$text/, @options;
2247     my $val = option_val($out[0], undef);
2248     my $out = '? ';
2249     if (not defined $val or $val =~ /[\n\r]/) {
2250       # Can do nothing better
2251     } elsif ($val =~ /\s/) {
2252       my $found;
2253       foreach $l (split //, qq/\"\'\#\|/) {
2254         $out = "$l$val$l ", last if (index $val, $l) == -1;
2255       }
2256     } else {
2257       $out = "=$val ";
2258     }
2259     # Default to value if one completion, to question if many
2260     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2261     return sort @out;
2262   }
2263   return $term->filename_list($text); # filenames
2264 }
2265
2266 sub end_report {
2267   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
2268 }
2269
2270 END {
2271   $finished = $inhibit_exit;    # So that some keys may be disabled.
2272   # Do not stop in at_exit() and destructors on exit:
2273   $DB::single = !$exiting && !$runnonstop;
2274   DB::fake::at_exit() unless $exiting or $runnonstop;
2275 }
2276
2277 package DB::fake;
2278
2279 sub at_exit {
2280   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
2281 }
2282
2283 package DB;                     # Do not trace this 1; below!
2284
2285 1;