lib/perl5db.pl

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