lib/perl5db.pl

   1 package DB;
   2
   3 # Debugger for Perl 5.00x; perl5db.pl patch level:
   4
   5 $VERSION = 1.07;
   6 $header = "perl5db.pl version $VERSION";
   7
   8 #
   9 # This file is automatically included if you do perl -d.
  10 # It's probably not useful to include this yourself.
  11 #
  12 # Perl supplies the values for %sub.  It effectively inserts
  13 # a &DB'DB(); in front of every place that can have a
  14 # breakpoint. Instead of a subroutine call it calls &DB::sub with
  15 # $DB::sub being the called subroutine. It also inserts a BEGIN
  16 # {require 'perl5db.pl'} before the first line.
  17 #
  18 # After each `require'd file is compiled, but before it is executed, a
  19 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
  20 # $filename is the expanded name of the `require'd file (as found as
  21 # value of %INC).
  22 #
  23 # Additional services from Perl interpreter:
  24 #
  25 # if caller() is called from the package DB, it provides some
  26 # additional data.
  27 #
  28 # The array @{$main::{'_<'.$filename}} is the line-by-line contents of
  29 # $filename.
  30 #
  31 # The hash %{'_<'.$filename} contains breakpoints and action (it is
  32 # keyed by line number), and individual entries are settable (as
  33 # opposed to the whole hash). Only true/false is important to the
  34 # interpreter, though the values used by perl5db.pl have the form
  35 # "$break_condition\0$action". Values are magical in numeric context.
  36 #
  37 # The scalar ${'_<'.$filename} contains $filename.
  38 #
  39 # Note that no subroutine call is possible until &DB::sub is defined
  40 # (for subroutines defined outside of the package DB). In fact the same is
  41 # true if $deep is not defined.
  42 #
  43 # $Log: perldb.pl,v $
  44
  45 #
  46 # At start reads $rcfile that may set important options.  This file
  47 # may define a subroutine &afterinit that will be executed after the
  48 # debugger is initialized.
  49 #
  50 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
  51 # it as a rest of `O ...' line in debugger prompt.
  52 #
  53 # The options that can be specified only at startup:
  54 # [To set in $rcfile, call &parse_options("optionName=new_value").]
  55 #
  56 # TTY  - the TTY to use for debugging i/o.
  57 #
  58 # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  59 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  60 # Term::Rendezvous.  Current variant is to have the name of TTY in this
  61 # file.
  62 #
  63 # ReadLine - If false, dummy ReadLine is used, so you can debug
  64 # ReadLine applications.
  65 #
  66 # NonStop - if true, no i/o is performed until interrupt.
  67 #
  68 # LineInfo - file or pipe to print line number info to.  If it is a
  69 # pipe, a short "emacs like" message is used.
  70 #
  71 # RemotePort - host:port to connect to on remote host for remote debugging.
  72 #
  73 # Example $rcfile: (delete leading hashes!)
  74 #
  75 # &parse_options("NonStop=1 LineInfo=db.out");
  76 # sub afterinit { $trace = 1; }
  77 #
  78 # The script will run without human intervention, putting trace
  79 # information into db.out.  (If you interrupt it, you would better
  80 # reset LineInfo to something "interactive"!)
  81 #
  82 ##################################################################
  83
  84 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
  85 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
  86
  87 # modified Perl debugger, to be run from Emacs in perldb-mode
  88 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  89 # Johan Vromans -- upgrade to 4.0 pl 10
  90 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  91
  92 # Changelog:
  93
  94 # A lot of things changed after 0.94. First of all, core now informs
  95 # debugger about entry into XSUBs, overloaded operators, tied operations,
  96 # BEGIN and END. Handy with `O f=2'.
  97
  98 # This can make debugger a little bit too verbose, please be patient
  99 # and report your problems promptly.
 100
 101 # Now the option frame has 3 values: 0,1,2.
 102
 103 # Note that if DESTROY returns a reference to the object (or object),
 104 # the deletion of data may be postponed until the next function call,
 105 # due to the need to examine the return value.
 106
 107 # Changes: 0.95: `v' command shows versions.
 108 # Changes: 0.96: `v' command shows version of readline.
 109 #       primitive completion works (dynamic variables, subs for `b' and `l',
 110 #               options). Can `p %var'
 111 #       Better help (`h <' now works). New commands <<, >>, {, {{.
 112 #       {dump|print}_trace() coded (to be able to do it from <<cmd).
 113 #       `c sub' documented.
 114 #       At last enough magic combined to stop after the end of debuggee.
 115 #       !! should work now (thanks to Emacs bracket matching an extra
 116 #       `]' in a regexp is caught).
 117 #       `L', `D' and `A' span files now (as documented).
 118 #       Breakpoints in `require'd code are possible (used in `R').
 119 #       Some additional words on internal work of debugger.
 120 #       `b load filename' implemented.
 121 #       `b postpone subr' implemented.
 122 #       now only `q' exits debugger (overwriteable on $inhibit_exit).
 123 #       When restarting debugger breakpoints/actions persist.
 124 #     Buglet: When restarting debugger only one breakpoint/action per
 125 #               autoloaded function persists.
 126 # Changes: 0.97: NonStop will not stop in at_exit().
 127 #       Option AutoTrace implemented.
 128 #       Trace printed differently if frames are printed too.
 129 #       new `inhibitExit' option.
 130 #       printing of a very long statement interruptible.
 131 # Changes: 0.98: New command `m' for printing possible methods
 132 #       'l -' is a synonim for `-'.
 133 #       Cosmetic bugs in printing stack trace.
 134 #       `frame' & 8 to print "expanded args" in stack trace.
 135 #       Can list/break in imported subs.
 136 #       new `maxTraceLen' option.
 137 #       frame & 4 and frame & 8 granted.
 138 #       new command `m'
 139 #       nonstoppable lines do not have `:' near the line number.
 140 #       `b compile subname' implemented.
 141 #       Will not use $` any more.
 142 #       `-' behaves sane now.
 143 # Changes: 0.99: Completion for `f', `m'.
 144 #       `m' will remove duplicate names instead of duplicate functions.
 145 #       `b load' strips trailing whitespace.
 146 #       completion ignores leading `|'; takes into account current package
 147 #       when completing a subroutine name (same for `l').
 148 # Changes: 1.07: Many fixed by tchrist 13-March-2000
 149 #   BUG FIXES:
 150 #   + Added bare mimimal security checks on perldb rc files, plus
 151 #     comments on what else is needed.
 152 #   + Fixed the ornaments that made "|h" completely unusable.
 153 #     They are not used in print_help if they will hurt.  Strip pod
 154 #     if we're paging to less.
 155 #   + Fixed mis-formatting of help messages caused by ornaments
 156 #     to restore Larry's original formatting.
 157 #   + Fixed many other formatting errors.  The code is still suboptimal,
 158 #     and needs a lot of work at restructuing. It's also misindented
 159 #     in many places.
 160 #   + Fixed bug where trying to look at an option like your pager
 161 #     shows "1".
 162 #   + Fixed some $? processing.  Note: if you use csh or tcsh, you will
 163 #     lose.  You should consider shell escapes not using their shell,
 164 #     or else not caring about detailed status.  This should really be
 165 #     unified into one place, too.
 166 #   + Fixed bug where invisible trailing whitespace on commands hoses you,
 167 #     tricking Perl into thinking you wern't calling a debugger command!
 168 #   + Fixed bug where leading whitespace on commands hoses you.  (One
 169 #     suggests a leading semicolon or any other irrelevant non-whitespace
 170 #     to indicate literal Perl code.)
 171 #   + Fixed bugs that ate warnings due to wrong selected handle.
 172 #   + Fixed a precedence bug on signal stuff.
 173 #   + Fixed some unseemly wording.
 174 #   + Fixed bug in help command trying to call perl method code.
 175 #   + Fixed to call dumpvar from exception handler.  SIGPIPE killed us.
 176 #   ENHANCEMENTS:
 177 #   + Added some comments.  This code is still nasty spaghetti.
 178 #   + Added message if you clear your pre/post command stacks which was
 179 #     very easy to do if you just typed a bare >, <, or {.  (A command
 180 #     without an argument should *never* be a destructive action; this
 181 #     API is fundamentally screwed up; likewise option setting, which
 182 #     is equally buggered.)
 183 #   + Added command stack dump on argument of "?" for >, <, or {.
 184 #   + Added a semi-built-in doc viewer command that calls man with the
 185 #     proper %Config::Config path (and thus gets caching, man -k, etc),
 186 #     or else perldoc on obstreperous platforms.
 187 #   + Added to and rearranged the help information.
 188 #   + Detected apparent misuse of { ... } to declare a block; this used
 189 #     to work but now is a command, and mysteriously gave no complaint.
 190
 191 ####################################################################
 192
 193 # Needed for the statement after exec():
 194
 195 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
 196 local($^W) = 0;                 # Switch run-time warnings off during init.
 197 warn (                  # Do not ;-)
 198       $dumpvar::hashDepth,
 199       $dumpvar::arrayDepth,
 200       $dumpvar::dumpDBFiles,
 201       $dumpvar::dumpPackages,
 202       $dumpvar::quoteHighBit,
 203       $dumpvar::printUndef,
 204       $dumpvar::globPrint,
 205       $dumpvar::usageOnly,
 206       @ARGS,
 207       $Carp::CarpLevel,
 208       $panic,
 209       $second_time,
 210      ) if 0;
 211
 212 # Command-line + PERLLIB:
 213 @ini_INC = @INC;
 214
 215 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
 216
 217 $trace = $signal = $single = 0; # Uninitialized warning suppression
 218                                 # (local $^W cannot help - other packages!).
 219 $inhibit_exit = $option{PrintRet} = 1;
 220
 221 @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
 222                   compactDump veryCompact quote HighBit undefPrint
 223                   globPrint PrintRet UsageOnly frame AutoTrace
 224                   TTY noTTY ReadLine NonStop LineInfo maxTraceLen
 225                   recallCommand ShellBang pager tkRunning ornaments
 226                   signalLevel warnLevel dieLevel inhibit_exit
 227                   ImmediateStop bareStringify CreateTTY
 228                   RemotePort);
 229
 230 %optionVars    = (
 231                  hashDepth      => \$dumpvar::hashDepth,
 232                  arrayDepth     => \$dumpvar::arrayDepth,
 233                  DumpDBFiles    => \$dumpvar::dumpDBFiles,
 234                  DumpPackages   => \$dumpvar::dumpPackages,
 235                  DumpReused     => \$dumpvar::dumpReused,
 236                  HighBit        => \$dumpvar::quoteHighBit,
 237                  undefPrint     => \$dumpvar::printUndef,
 238                  globPrint      => \$dumpvar::globPrint,
 239                  UsageOnly      => \$dumpvar::usageOnly,
 240                  CreateTTY      => \$CreateTTY,
 241                  bareStringify  => \$dumpvar::bareStringify,
 242                  frame          => \$frame,
 243                  AutoTrace      => \$trace,
 244                  inhibit_exit   => \$inhibit_exit,
 245                  maxTraceLen    => \$maxtrace,
 246                  ImmediateStop  => \$ImmediateStop,
 247                  RemotePort     => \$remoteport,
 248 );
 249
 250 %optionAction  = (
 251                   compactDump   => \&dumpvar::compactDump,
 252                   veryCompact   => \&dumpvar::veryCompact,
 253                   quote         => \&dumpvar::quote,
 254                   TTY           => \&TTY,
 255                   noTTY         => \&noTTY,
 256                   ReadLine      => \&ReadLine,
 257                   NonStop       => \&NonStop,
 258                   LineInfo      => \&LineInfo,
 259                   recallCommand => \&recallCommand,
 260                   ShellBang     => \&shellBang,
 261                   pager         => \&pager,
 262                   signalLevel   => \&signalLevel,
 263                   warnLevel     => \&warnLevel,
 264                   dieLevel      => \&dieLevel,
 265                   tkRunning     => \&tkRunning,
 266                   ornaments     => \&ornaments,
 267                   RemotePort    => \&RemotePort,
 268                  );
 269
 270 %optionRequire = (
 271                   compactDump   => 'dumpvar.pl',
 272                   veryCompact   => 'dumpvar.pl',
 273                   quote         => 'dumpvar.pl',
 274                  );
 275
 276 # These guys may be defined in $ENV{PERL5DB} :
 277 $rl             = 1     unless defined $rl;
 278 $warnLevel      = 0     unless defined $warnLevel;
 279 $dieLevel       = 0     unless defined $dieLevel;
 280 $signalLevel    = 1     unless defined $signalLevel;
 281 $pre            = []    unless defined $pre;
 282 $post           = []    unless defined $post;
 283 $pretype        = []    unless defined $pretype;
 284 $CreateTTY      = 3     unless defined $CreateTTY;
 285
 286 warnLevel($warnLevel);
 287 dieLevel($dieLevel);
 288 signalLevel($signalLevel);
 289
 290 &pager(
 291     (defined($ENV{PAGER})
 292         ? $ENV{PAGER}
 293         : ($^O eq 'os2'
 294            ? 'cmd /c more'
 295            : 'more'))) unless defined $pager;
 296 setman();
 297 &recallCommand("!") unless defined $prc;
 298 &shellBang("!") unless defined $psh;
 299 $maxtrace = 400 unless defined $maxtrace;
 300 $ini_pids = $ENV{PERLDB_PIDS};
 301 if (defined $ENV{PERLDB_PIDS}) {
 302   $pids = "[$ENV{PERLDB_PIDS}]";
 303   $ENV{PERLDB_PIDS} .= "->$$";
 304   $term_pid = -1;
 305 } else {
 306   $ENV{PERLDB_PIDS} = "$$";
 307   $pids = '';
 308   $term_pid = $$;
 309 }
 310 $pidprompt = '';
 311 *emacs = $slave_editor;         # May be used in afterinit()...
 312
 313 if (-e "/dev/tty") {  # this is the wrong metric!
 314   $rcfile=".perldb";
 315 } else {
 316   $rcfile="perldb.ini";
 317 }
 318
 319 # This isn't really safe, because there's a race
 320 # between checking and opening.  The solution is to
 321 # open and fstat the handle, but then you have to read and
 322 # eval the contents.  But then the silly thing gets
 323 # your lexical scope, which is unfortunately at best.
 324 sub safe_do {
 325     my $file = shift;
 326
 327     # Just exactly what part of the word "CORE::" don't you understand?
 328     local $SIG{__WARN__};
 329     local $SIG{__DIE__};
 330
 331     unless (is_safe_file($file)) {
 332         CORE::warn <<EO_GRIPE;
 333 perldb: Must not source insecure rcfile $file.
 334         You or the superuser must be the owner, and it must not
 335         be writable by anyone but its owner.
 336 EO_GRIPE
 337         return;
 338     }
 339
 340     do $file;
 341     CORE::warn("perldb: couldn't parse $file: $@") if $@;
 342 }
 343
 344
 345 # Verifies that owner is either real user or superuser and that no
 346 # one but owner may write to it.  This function is of limited use
 347 # when called on a path instead of upon a handle, because there are
 348 # no guarantees that filename (by dirent) whose file (by ino) is
 349 # eventually accessed is the same as the one tested.
 350 # Assumes that the file's existence is not in doubt.
 351 sub is_safe_file {
 352     my $path = shift;
 353     stat($path) || return;      # mysteriously vaporized
 354     my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
 355
 356     return 0 if $uid != 0 && $uid != $<;
 357     return 0 if $mode & 022;
 358     return 1;
 359 }
 360
 361 if (-f $rcfile) {
 362     safe_do("./$rcfile");
 363 }
 364 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
 365     safe_do("$ENV{HOME}/$rcfile");
 366 }
 367 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
 368     safe_do("$ENV{LOGDIR}/$rcfile");
 369 }
 370
 371 if (defined $ENV{PERLDB_OPTS}) {
 372   parse_options($ENV{PERLDB_OPTS});
 373 }
 374
 375 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
 376      and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
 377     *get_fork_TTY = \&xterm_get_fork_TTY;
 378 } elsif ($^O eq 'os2') {
 379     *get_fork_TTY = \&os2_get_fork_TTY;
 380 }
 381
 382 # Here begin the unreadable code.  It needs fixing.
 383
 384 if (exists $ENV{PERLDB_RESTART}) {
 385   delete $ENV{PERLDB_RESTART};
 386   # $restart = 1;
 387   @hist = get_list('PERLDB_HIST');
 388   %break_on_load = get_list("PERLDB_ON_LOAD");
 389   %postponed = get_list("PERLDB_POSTPONE");
 390   my @had_breakpoints= get_list("PERLDB_VISITED");
 391   for (0 .. $#had_breakpoints) {
 392     my %pf = get_list("PERLDB_FILE_$_");
 393     $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
 394   }
 395   my %opt = get_list("PERLDB_OPT");
 396   my ($opt,$val);
 397   while (($opt,$val) = each %opt) {
 398     $val =~ s/[\\\']/\\$1/g;
 399     parse_options("$opt'$val'");
 400   }
 401   @INC = get_list("PERLDB_INC");
 402   @ini_INC = @INC;
 403   $pretype = [get_list("PERLDB_PRETYPE")];
 404   $pre = [get_list("PERLDB_PRE")];
 405   $post = [get_list("PERLDB_POST")];
 406   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
 407 }
 408
 409 if ($notty) {
 410   $runnonstop = 1;
 411 } else {
 412   # Is Perl being run from a slave editor or graphical debugger?
 413   $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
 414   $rl = 0, shift(@main::ARGV) if $slave_editor;
 415
 416   #require Term::ReadLine;
 417
 418   if ($^O eq 'cygwin') {
 419     # /dev/tty is binary. use stdin for textmode
 420     undef $console;
 421   } elsif (-e "/dev/tty") {
 422     $console = "/dev/tty";
 423   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
 424     $console = "con";
 425   } elsif ($^O eq 'MacOS') {
 426     if ($MacPerl::Version !~ /MPW/) {
 427       $console = "Dev:Console:Perl Debug"; # Separate window for application
 428     } else {
 429       $console = "Dev:Console";
 430     }
 431   } else {
 432     $console = "sys\$command";
 433   }
 434
 435   if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
 436     $console = undef;
 437   }
 438
 439   # Around a bug:
 440   if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
 441     $console = undef;
 442   }
 443
 444   if ($^O eq 'epoc') {
 445     $console = undef;
 446   }
 447
 448   $console = $tty if defined $tty;
 449
 450   if (defined $remoteport) {
 451     require IO::Socket;
 452     $OUT = new IO::Socket::INET( Timeout  => '10',
 453                                  PeerAddr => $remoteport,
 454                                  Proto    => 'tcp',
 455                                );
 456     if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
 457     $IN = $OUT;
 458   } elsif ($CreateTTY & 4) {
 459     create_IN_OUT(4);
 460   } else {
 461     if (defined $console) {
 462       my ($i, $o) = split $console, /,/;
 463       $o = $i unless defined $o;
 464       open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
 465       open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
 466         || open(OUT,">&STDOUT");        # so we don't dongle stdout
 467     } else {
 468       open(IN,"<&STDIN");
 469       open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
 470       $console = 'STDIN/OUT';
 471     }
 472     # so open("|more") can read from STDOUT and so we don't dingle stdin
 473     $IN = \*IN;
 474
 475     $OUT = \*OUT;
 476   }
 477   select($OUT);
 478   $| = 1;                       # for DB::OUT
 479   select(STDOUT);
 480
 481   $LINEINFO = $OUT unless defined $LINEINFO;
 482   $lineinfo = $console unless defined $lineinfo;
 483
 484   $| = 1;                       # for real STDOUT
 485
 486   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
 487   unless ($runnonstop) {
 488     if ($term_pid eq '-1') {
 489       print $OUT "\nDaughter DB session started...\n";
 490     } else {
 491       print $OUT "\nLoading DB routines from $header\n";
 492       print $OUT ("Editor support ",
 493                   $slave_editor ? "enabled" : "available",
 494                   ".\n");
 495       print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
 496     }
 497   }
 498 }
 499
 500 @ARGS = @ARGV;
 501 for (@args) {
 502     s/\'/\\\'/g;
 503     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
 504 }
 505
 506 if (defined &afterinit) {       # May be defined in $rcfile
 507   &afterinit();
 508 }
 509
 510 $I_m_init = 1;
 511
 512 ############################################################ Subroutines
 513
 514 sub DB {
 515     # _After_ the perl program is compiled, $single is set to 1:
 516     if ($single and not $second_time++) {
 517       if ($runnonstop) {        # Disable until signal
 518         for ($i=0; $i <= $stack_depth; ) {
 519             $stack[$i++] &= ~1;
 520         }
 521         $single = 0;
 522         # return;                       # Would not print trace!
 523       } elsif ($ImmediateStop) {
 524         $ImmediateStop = 0;
 525         $signal = 1;
 526       }
 527     }
 528     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
 529     &save;
 530     ($package, $filename, $line) = caller;
 531     $filename_ini = $filename;
 532     $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
 533       "package $package;";      # this won't let them modify, alas
 534     local(*dbline) = $main::{'_<' . $filename};
 535     $max = $#dbline;
 536     if (($stop,$action) = split(/\0/,$dbline{$line})) {
 537         if ($stop eq '1') {
 538             $signal |= 1;
 539         } elsif ($stop) {
 540             $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
 541             $dbline{$line} =~ s/;9($|\0)/$1/;
 542         }
 543     }
 544     my $was_signal = $signal;
 545     if ($trace & 2) {
 546       for (my $n = 0; $n <= $#to_watch; $n++) {
 547         $evalarg = $to_watch[$n];
 548         local $onetimeDump;     # Do not output results
 549         my ($val) = &eval;      # Fix context (&eval is doing array)?
 550         $val = ( (defined $val) ? "'$val'" : 'undef' );
 551         if ($val ne $old_watch[$n]) {
 552           $signal = 1;
 553           print $OUT <<EOP;
 554 Watchpoint $n:\t$to_watch[$n] changed:
 555     old value:\t$old_watch[$n]
 556     new value:\t$val
 557 EOP
 558           $old_watch[$n] = $val;
 559         }
 560       }
 561     }
 562     if ($trace & 4) {           # User-installed watch
 563       return if watchfunction($package, $filename, $line)
 564         and not $single and not $was_signal and not ($trace & ~4);
 565     }
 566     $was_signal = $signal;
 567     $signal = 0;
 568     if ($single || ($trace & 1) || $was_signal) {
 569         if ($slave_editor) {
 570             $position = "\032\032$filename:$line:0\n";
 571             print_lineinfo($position);
 572         } elsif ($package eq 'DB::fake') {
 573           $term || &setterm;
 574           print_help(<<EOP);
 575 Debugged program terminated.  Use B<q> to quit or B<R> to restart,
 576   use B<O> I<inhibit_exit> to avoid stopping after program termination,
 577   B<h q>, B<h R> or B<h O> to get additional info.
 578 EOP
 579           $package = 'main';
 580           $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
 581             "package $package;";        # this won't let them modify, alas
 582         } else {
 583             $sub =~ s/\'/::/;
 584             $prefix = $sub =~ /::/ ? "" : "${'package'}::";
 585             $prefix .= "$sub($filename:";
 586             $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
 587             if (length($prefix) > 30) {
 588                 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
 589                 $prefix = "";
 590                 $infix = ":\t";
 591             } else {
 592                 $infix = "):\t";
 593                 $position = "$prefix$line$infix$dbline[$line]$after";
 594             }
 595             if ($frame) {
 596                 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
 597             } else {
 598                 print_lineinfo($position);
 599             }
 600             for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
 601                 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
 602                 last if $signal;
 603                 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
 604                 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
 605                 $position .= $incr_pos;
 606                 if ($frame) {
 607                     print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
 608                 } else {
 609                     print_lineinfo($incr_pos);
 610                 }
 611             }
 612         }
 613     }
 614     $evalarg = $action, &eval if $action;
 615     if ($single || $was_signal) {
 616         local $level = $level + 1;
 617         foreach $evalarg (@$pre) {
 618           &eval;
 619         }
 620         print $OUT $stack_depth . " levels deep in subroutine calls!\n"
 621           if $single & 4;
 622         $start = $line;
 623         $incr = -1;             # for backward motion.
 624         @typeahead = (@$pretype, @typeahead);
 625       CMD:
 626         while (($term || &setterm),
 627                ($term_pid == $$ or resetterm(1)),
 628                defined ($cmd=&readline("$pidprompt  DB" . ('<' x $level) .
 629                                        ($#hist+1) . ('>' x $level) .
 630                                        " ")))
 631         {
 632                 $single = 0;
 633                 $signal = 0;
 634                 $cmd =~ s/\\$/\n/ && do {
 635                     $cmd .= &readline("  cont: ");
 636                     redo CMD;
 637                 };
 638                 $cmd =~ /^$/ && ($cmd = $laststep);
 639                 push(@hist,$cmd) if length($cmd) > 1;
 640               PIPE: {
 641                     $cmd =~ s/^\s+//s;   # trim annoying leading whitespace
 642                     $cmd =~ s/\s+$//s;   # trim annoying trailing whitespace
 643                     ($i) = split(/\s+/,$cmd);
 644                     if ($alias{$i}) {
 645                         # squelch the sigmangler
 646                         local $SIG{__DIE__};
 647                         local $SIG{__WARN__};
 648                         eval "\$cmd =~ $alias{$i}";
 649                         if ($@) {
 650                             print $OUT "Couldn't evaluate `$i' alias: $@";
 651                             next CMD;
 652                         }
 653                     }
 654                    $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
 655                     $cmd =~ /^h$/ && do {
 656                         print_help($help);
 657                         next CMD; };
 658                     $cmd =~ /^h\s+h$/ && do {
 659                         print_help($summary);
 660                         next CMD; };
 661                     # support long commands; otherwise bogus errors
 662                     # happen when you ask for h on <CR> for example
 663                     $cmd =~ /^h\s+(\S.*)$/ && do {
 664                         my $asked = $1;                 # for proper errmsg
 665                         my $qasked = quotemeta($asked); # for searching
 666                         # XXX: finds CR but not <CR>
 667                         if ($help =~ /^<?(?:[IB]<)$qasked/m) {
 668                           while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
 669                             print_help($1);
 670                           }
 671                         } else {
 672                             print_help("B<$asked> is not a debugger command.\n");
 673                         }
 674                         next CMD; };
 675                     $cmd =~ /^t$/ && do {
 676                         $trace ^= 1;
 677                         print $OUT "Trace = " .
 678                             (($trace & 1) ? "on" : "off" ) . "\n";
 679                         next CMD; };
 680                     $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
 681                         $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
 682                         foreach $subname (sort(keys %sub)) {
 683                             if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
 684                                 print $OUT $subname,"\n";
 685                             }
 686                         }
 687                         next CMD; };
 688                     $cmd =~ /^v$/ && do {
 689                         list_versions(); next CMD};
 690                     $cmd =~ s/^X\b/V $package/;
 691                     $cmd =~ /^V$/ && do {
 692                         $cmd = "V $package"; };
 693                     $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
 694                         local ($savout) = select($OUT);
 695                         $packname = $1;
 696                         @vars = split(' ',$2);
 697                         do 'dumpvar.pl' unless defined &main::dumpvar;
 698                         if (defined &main::dumpvar) {
 699                             local $frame = 0;
 700                             local $doret = -2;
 701                             # must detect sigpipe failures
 702                             eval { &main::dumpvar($packname,@vars) };
 703                             if ($@) {
 704                                 die unless $@ =~ /dumpvar print failed/;
 705                             }
 706                         } else {
 707                             print $OUT "dumpvar.pl not available.\n";
 708                         }
 709                         select ($savout);
 710                         next CMD; };
 711                     $cmd =~ s/^x\b/ / && do { # So that will be evaled
 712                         $onetimeDump = 'dump'; };
 713                     $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
 714                         methods($1); next CMD};
 715                     $cmd =~ s/^m\b/ / && do { # So this will be evaled
 716                         $onetimeDump = 'methods'; };
 717                     $cmd =~ /^f\b\s*(.*)/ && do {
 718                         $file = $1;
 719                         $file =~ s/\s+$//;
 720                         if (!$file) {
 721                             print $OUT "The old f command is now the r command.\n";
 722                             print $OUT "The new f command switches filenames.\n";
 723                             next CMD;
 724                         }
 725                         if (!defined $main::{'_<' . $file}) {
 726                             if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
 727                                               $try = substr($try,2);
 728                                               print $OUT "Choosing $try matching `$file':\n";
 729                                               $file = $try;
 730                                           }}
 731                         }
 732                         if (!defined $main::{'_<' . $file}) {
 733                             print $OUT "No file matching `$file' is loaded.\n";
 734                             next CMD;
 735                         } elsif ($file ne $filename) {
 736                             *dbline = $main::{'_<' . $file};
 737                             $max = $#dbline;
 738                             $filename = $file;
 739                             $start = 1;
 740                             $cmd = "l";
 741                           } else {
 742                             print $OUT "Already in $file.\n";
 743                             next CMD;
 744                           }
 745                       };
 746                     $cmd =~ s/^l\s+-\s*$/-/;
 747                     $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
 748                         $evalarg = $2;
 749                         my ($s) = &eval;
 750                         print($OUT "Error: $@\n"), next CMD if $@;
 751                         $s = CvGV_name($s);
 752                         print($OUT "Interpreted as: $1 $s\n");
 753                         $cmd = "$1 $s";
 754                     };
 755                     $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
 756                         my $s = $subname = $1;
 757                         $subname =~ s/\'/::/;
 758                         $subname = $package."::".$subname
 759                           unless $subname =~ /::/;
 760                         $subname = "CORE::GLOBAL::$s"
 761                           if not defined &$subname and $s !~ /::/
 762                              and defined &{"CORE::GLOBAL::$s"};
 763                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 764                         @pieces = split(/:/,find_sub($subname) || $sub{$subname});
 765                         $subrange = pop @pieces;
 766                         $file = join(':', @pieces);
 767                         if ($file ne $filename) {
 768                             print $OUT "Switching to file '$file'.\n"
 769                                 unless $slave_editor;
 770                             *dbline = $main::{'_<' . $file};
 771                             $max = $#dbline;
 772                             $filename = $file;
 773                         }
 774                         if ($subrange) {
 775                             if (eval($subrange) < -$window) {
 776                                 $subrange =~ s/-.*/+/;
 777                             }
 778                             $cmd = "l $subrange";
 779                         } else {
 780                             print $OUT "Subroutine $subname not found.\n";
 781                             next CMD;
 782                         } };
 783                     $cmd =~ /^\.$/ && do {
 784                         $incr = -1;             # for backward motion.
 785                         $start = $line;
 786                         $filename = $filename_ini;
 787                         *dbline = $main::{'_<' . $filename};
 788                         $max = $#dbline;
 789                         print_lineinfo($position);
 790                         next CMD };
 791                     $cmd =~ /^w\b\s*(\d*)$/ && do {
 792                         $incr = $window - 1;
 793                         $start = $1 if $1;
 794                         $start -= $preview;
 795                         #print $OUT 'l ' . $start . '-' . ($start + $incr);
 796                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 797                     $cmd =~ /^-$/ && do {
 798                         $start -= $incr + $window + 1;
 799                         $start = 1 if $start <= 0;
 800                         $incr = $window - 1;
 801                         $cmd = 'l ' . ($start) . '+'; };
 802                     $cmd =~ /^l$/ && do {
 803                         $incr = $window - 1;
 804                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 805                     $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
 806                         $start = $1 if $1;
 807                         $incr = $2;
 808                         $incr = $window - 1 unless $incr;
 809                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 810                     $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 811                         $end = (!defined $2) ? $max : ($4 ? $4 : $2);
 812                         $end = $max if $end > $max;
 813                         $i = $2;
 814                         $i = $line if $i eq '.';
 815                         $i = 1 if $i < 1;
 816                         $incr = $end - $i;
 817                         if ($slave_editor) {
 818                             print $OUT "\032\032$filename:$i:0\n";
 819                             $i = $end;
 820                         } else {
 821                             for (; $i <= $end; $i++) {
 822                                 ($stop,$action) = split(/\0/, $dbline{$i});
 823                                 $arrow = ($i==$line
 824                                           and $filename eq $filename_ini)
 825                                   ?  '==>'
 826                                     : ($dbline[$i]+0 ? ':' : ' ') ;
 827                                 $arrow .= 'b' if $stop;
 828                                 $arrow .= 'a' if $action;
 829                                 print $OUT "$i$arrow\t", $dbline[$i];
 830                                 $i++, last if $signal;
 831                             }
 832                             print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
 833                         }
 834                         $start = $i; # remember in case they want more
 835                         $start = $max if $start > $max;
 836                         next CMD; };
 837                     $cmd =~ /^D$/ && do {
 838                       print $OUT "Deleting all breakpoints...\n";
 839                       my $file;
 840                       for $file (keys %had_breakpoints) {
 841                         local *dbline = $main::{'_<' . $file};
 842                         my $max = $#dbline;
 843                         my $was;
 844
 845                         for ($i = 1; $i <= $max ; $i++) {
 846                             if (defined $dbline{$i}) {
 847                                 $dbline{$i} =~ s/^[^\0]+//;
 848                                 if ($dbline{$i} =~ s/^\0?$//) {
 849                                     delete $dbline{$i};
 850                                 }
 851                             }
 852                         }
 853
 854                         if (not $had_breakpoints{$file} &= ~1) {
 855                             delete $had_breakpoints{$file};
 856                         }
 857                       }
 858                       undef %postponed;
 859                       undef %postponed_file;
 860                       undef %break_on_load;
 861                       next CMD; };
 862                     $cmd =~ /^L$/ && do {
 863                       my $file;
 864                       for $file (keys %had_breakpoints) {
 865                         local *dbline = $main::{'_<' . $file};
 866                         my $max = $#dbline;
 867                         my $was;
 868
 869                         for ($i = 1; $i <= $max; $i++) {
 870                             if (defined $dbline{$i}) {
 871                                 print $OUT "$file:\n" unless $was++;
 872                                 print $OUT " $i:\t", $dbline[$i];
 873                                 ($stop,$action) = split(/\0/, $dbline{$i});
 874                                 print $OUT "   break if (", $stop, ")\n"
 875                                   if $stop;
 876                                 print $OUT "   action:  ", $action, "\n"
 877                                   if $action;
 878                                 last if $signal;
 879                             }
 880                         }
 881                       }
 882                       if (%postponed) {
 883                         print $OUT "Postponed breakpoints in subroutines:\n";
 884                         my $subname;
 885                         for $subname (keys %postponed) {
 886                           print $OUT " $subname\t$postponed{$subname}\n";
 887                           last if $signal;
 888                         }
 889                       }
 890                       my @have = map { # Combined keys
 891                         keys %{$postponed_file{$_}}
 892                       } keys %postponed_file;
 893                       if (@have) {
 894                         print $OUT "Postponed breakpoints in files:\n";
 895                         my ($file, $line);
 896                         for $file (keys %postponed_file) {
 897                           my $db = $postponed_file{$file};
 898                           print $OUT " $file:\n";
 899                           for $line (sort {$a <=> $b} keys %$db) {
 900                                 print $OUT "  $line:\n";
 901                                 my ($stop,$action) = split(/\0/, $$db{$line});
 902                                 print $OUT "    break if (", $stop, ")\n"
 903                                   if $stop;
 904                                 print $OUT "    action:  ", $action, "\n"
 905                                   if $action;
 906                                 last if $signal;
 907                           }
 908                           last if $signal;
 909                         }
 910                       }
 911                       if (%break_on_load) {
 912                         print $OUT "Breakpoints on load:\n";
 913                         my $file;
 914                         for $file (keys %break_on_load) {
 915                           print $OUT " $file\n";
 916                           last if $signal;
 917                         }
 918                       }
 919                       if ($trace & 2) {
 920                         print $OUT "Watch-expressions:\n";
 921                         my $expr;
 922                         for $expr (@to_watch) {
 923                           print $OUT " $expr\n";
 924                           last if $signal;
 925                         }
 926                       }
 927                       next CMD; };
 928                     $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
 929                         my $file = $1; $file =~ s/\s+$//;
 930                         cmd_b_load($file);
 931                         next CMD; };
 932                     $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 933                         my $cond = length $3 ? $3 : '1';
 934                         my ($subname, $break) = ($2, $1 eq 'postpone');
 935                         $subname =~ s/\'/::/g;
 936                         $subname = "${'package'}::" . $subname
 937                           unless $subname =~ /::/;
 938                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 939                         $postponed{$subname} = $break
 940                           ? "break +0 if $cond" : "compile";
 941                         next CMD; };
 942                     $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
 943                         $subname = $1;
 944                         $cond = length $2 ? $2 : '1';
 945                         cmd_b_sub($subname, $cond);
 946                         next CMD; };
 947                     $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
 948                         $i = $1 || $line;
 949                         $cond = length $2 ? $2 : '1';
 950                         cmd_b_line($i, $cond);
 951                         next CMD; };
 952                     $cmd =~ /^d\b\s*(\d*)/ && do {
 953                         cmd_d($1 || $line);
 954                         next CMD; };
 955                     $cmd =~ /^A$/ && do {
 956                       print $OUT "Deleting all actions...\n";
 957                       my $file;
 958                       for $file (keys %had_breakpoints) {
 959                         local *dbline = $main::{'_<' . $file};
 960                         my $max = $#dbline;
 961                         my $was;
 962
 963                         for ($i = 1; $i <= $max ; $i++) {
 964                             if (defined $dbline{$i}) {
 965                                 $dbline{$i} =~ s/\0[^\0]*//;
 966                                 delete $dbline{$i} if $dbline{$i} eq '';
 967                             }
 968                         }
 969
 970                         unless ($had_breakpoints{$file} &= ~2) {
 971                             delete $had_breakpoints{$file};
 972                         }
 973                       }
 974                       next CMD; };
 975                     $cmd =~ /^O\s*$/ && do {
 976                         for (@options) {
 977                             &dump_option($_);
 978                         }
 979                         next CMD; };
 980                     $cmd =~ /^O\s*(\S.*)/ && do {
 981                         parse_options($1);
 982                         next CMD; };
 983                     $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
 984                         push @$pre, action($1);
 985                         next CMD; };
 986                     $cmd =~ /^>>\s*(.*)/ && do {
 987                         push @$post, action($1);
 988                         next CMD; };
 989                     $cmd =~ /^<\s*(.*)/ && do {
 990                         unless ($1) {
 991                             print $OUT "All < actions cleared.\n";
 992                             $pre = [];
 993                             next CMD;
 994                         }
 995                         if ($1 eq '?') {
 996                             unless (@$pre) {
 997                                 print $OUT "No pre-prompt Perl actions.\n";
 998                                 next CMD;
 999                             }
1000                             print $OUT "Perl commands run before each prompt:\n";
1001                             for my $action ( @$pre ) {
1002                                 print $OUT "\t< -- $action\n";
1003                             }
1004                             next CMD;
1005                         }
1006                         $pre = [action($1)];
1007                         next CMD; };
1008                     $cmd =~ /^>\s*(.*)/ && do {
1009                         unless ($1) {
1010                             print $OUT "All > actions cleared.\n";
1011                             $post = [];
1012                             next CMD;
1013                         }
1014                         if ($1 eq '?') {
1015                             unless (@$post) {
1016                                 print $OUT "No post-prompt Perl actions.\n";
1017                                 next CMD;
1018                             }
1019                             print $OUT "Perl commands run after each prompt:\n";
1020                             for my $action ( @$post ) {
1021                                 print $OUT "\t> -- $action\n";
1022                             }
1023                             next CMD;
1024                         }
1025                         $post = [action($1)];
1026                         next CMD; };
1027                     $cmd =~ /^\{\{\s*(.*)/ && do {
1028                         if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1029                             print $OUT "{{ is now a debugger command\n",
1030                                 "use `;{{' if you mean Perl code\n";
1031                             $cmd = "h {{";
1032                             redo CMD;
1033                         }
1034                         push @$pretype, $1;
1035                         next CMD; };
1036                     $cmd =~ /^\{\s*(.*)/ && do {
1037                         unless ($1) {
1038                             print $OUT "All { actions cleared.\n";
1039                             $pretype = [];
1040                             next CMD;
1041                         }
1042                         if ($1 eq '?') {
1043                             unless (@$pretype) {
1044                                 print $OUT "No pre-prompt debugger actions.\n";
1045                                 next CMD;
1046                             }
1047                             print $OUT "Debugger commands run before each prompt:\n";
1048                             for my $action ( @$pretype ) {
1049                                 print $OUT "\t{ -- $action\n";
1050                             }
1051                             next CMD;
1052                         }
1053                         if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1054                             print $OUT "{ is now a debugger command\n",
1055                                 "use `;{' if you mean Perl code\n";
1056                             $cmd = "h {";
1057                             redo CMD;
1058                         }
1059                         $pretype = [$1];
1060                         next CMD; };
1061                     $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1062                         $i = $1 || $line; $j = $2;
1063                         if (length $j) {
1064                             if ($dbline[$i] == 0) {
1065                                 print $OUT "Line $i may not have an action.\n";
1066                             } else {
1067                                 $had_breakpoints{$filename} |= 2;
1068                                 $dbline{$i} =~ s/\0[^\0]*//;
1069                                 $dbline{$i} .= "\0" . action($j);
1070                             }
1071                         } else {
1072                             $dbline{$i} =~ s/\0[^\0]*//;
1073                             delete $dbline{$i} if $dbline{$i} eq '';
1074                         }
1075                         next CMD; };
1076                     $cmd =~ /^n$/ && do {
1077                         end_report(), next CMD if $finished and $level <= 1;
1078                         $single = 2;
1079                         $laststep = $cmd;
1080                         last CMD; };
1081                     $cmd =~ /^s$/ && do {
1082                         end_report(), next CMD if $finished and $level <= 1;
1083                         $single = 1;
1084                         $laststep = $cmd;
1085                         last CMD; };
1086                     $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1087                         end_report(), next CMD if $finished and $level <= 1;
1088                         $subname = $i = $1;
1089                         #  Probably not needed, since we finish an interactive
1090                         #  sub-session anyway...
1091                         # local $filename = $filename;
1092                         # local *dbline = *dbline;      # XXX Would this work?!
1093                         if ($i =~ /\D/) { # subroutine name
1094                             $subname = $package."::".$subname
1095                                 unless $subname =~ /::/;
1096                             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1097                             $i += 0;
1098                             if ($i) {
1099                                 $filename = $file;
1100                                 *dbline = $main::{'_<' . $filename};
1101                                 $had_breakpoints{$filename} |= 1;
1102                                 $max = $#dbline;
1103                                 ++$i while $dbline[$i] == 0 && $i < $max;
1104                             } else {
1105                                 print $OUT "Subroutine $subname not found.\n";
1106                                 next CMD;
1107                             }
1108                         }
1109                         if ($i) {
1110                             if ($dbline[$i] == 0) {
1111                                 print $OUT "Line $i not breakable.\n";
1112                                 next CMD;
1113                             }
1114                             $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1115                         }
1116                         for ($i=0; $i <= $stack_depth; ) {
1117                             $stack[$i++] &= ~1;
1118                         }
1119                         last CMD; };
1120                     $cmd =~ /^r$/ && do {
1121                         end_report(), next CMD if $finished and $level <= 1;
1122                         $stack[$stack_depth] |= 1;
1123                         $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1124                         last CMD; };
1125                     $cmd =~ /^R$/ && do {
1126                         print $OUT "Warning: some settings and command-line options may be lost!\n";
1127                         my (@script, @flags, $cl);
1128                         push @flags, '-w' if $ini_warn;
1129                         # Put all the old includes at the start to get
1130                         # the same debugger.
1131                         for (@ini_INC) {
1132                           push @flags, '-I', $_;
1133                         }
1134                         # Arrange for setting the old INC:
1135                         set_list("PERLDB_INC", @ini_INC);
1136                         if ($0 eq '-e') {
1137                           for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1138                                 chomp ($cl =  ${'::_<-e'}[$_]);
1139                             push @script, '-e', $cl;
1140                           }
1141                         } else {
1142                           @script = $0;
1143                         }
1144                         set_list("PERLDB_HIST",
1145                                  $term->Features->{getHistory}
1146                                  ? $term->GetHistory : @hist);
1147                         my @had_breakpoints = keys %had_breakpoints;
1148                         set_list("PERLDB_VISITED", @had_breakpoints);
1149                         set_list("PERLDB_OPT", %option);
1150                         set_list("PERLDB_ON_LOAD", %break_on_load);
1151                         my @hard;
1152                         for (0 .. $#had_breakpoints) {
1153                           my $file = $had_breakpoints[$_];
1154                           *dbline = $main::{'_<' . $file};
1155                           next unless %dbline or $postponed_file{$file};
1156                           (push @hard, $file), next
1157                             if $file =~ /^\(eval \d+\)$/;
1158                           my @add;
1159                           @add = %{$postponed_file{$file}}
1160                             if $postponed_file{$file};
1161                           set_list("PERLDB_FILE_$_", %dbline, @add);
1162                         }
1163                         for (@hard) { # Yes, really-really...
1164                           # Find the subroutines in this eval
1165                           *dbline = $main::{'_<' . $_};
1166                           my ($quoted, $sub, %subs, $line) = quotemeta $_;
1167                           for $sub (keys %sub) {
1168                             next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1169                             $subs{$sub} = [$1, $2];
1170                           }
1171                           unless (%subs) {
1172                             print $OUT
1173                               "No subroutines in $_, ignoring breakpoints.\n";
1174                             next;
1175                           }
1176                         LINES: for $line (keys %dbline) {
1177                             # One breakpoint per sub only:
1178                             my ($offset, $sub, $found);
1179                           SUBS: for $sub (keys %subs) {
1180                               if ($subs{$sub}->[1] >= $line # Not after the subroutine
1181                                   and (not defined $offset # Not caught
1182                                        or $offset < 0 )) { # or badly caught
1183                                 $found = $sub;
1184                                 $offset = $line - $subs{$sub}->[0];
1185                                 $offset = "+$offset", last SUBS if $offset >= 0;
1186                               }
1187                             }
1188                             if (defined $offset) {
1189                               $postponed{$found} =
1190                                 "break $offset if $dbline{$line}";
1191                             } else {
1192                               print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1193                             }
1194                           }
1195                         }
1196                         set_list("PERLDB_POSTPONE", %postponed);
1197                         set_list("PERLDB_PRETYPE", @$pretype);
1198                         set_list("PERLDB_PRE", @$pre);
1199                         set_list("PERLDB_POST", @$post);
1200                         set_list("PERLDB_TYPEAHEAD", @typeahead);
1201                         $ENV{PERLDB_RESTART} = 1;
1202                         delete $ENV{PERLDB_PIDS}; # Restore ini state
1203                         $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1204                         #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1205                         exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS;
1206                         print $OUT "exec failed: $!\n";
1207                         last CMD; };
1208                     $cmd =~ /^T$/ && do {
1209                         print_trace($OUT, 1); # skip DB
1210                         next CMD; };
1211                     $cmd =~ /^W\s*$/ && do {
1212                         $trace &= ~2;
1213                         @to_watch = @old_watch = ();
1214                         next CMD; };
1215                     $cmd =~ /^W\b\s*(.*)/s && do {
1216                         push @to_watch, $1;
1217                         $evalarg = $1;
1218                         my ($val) = &eval;
1219                         $val = (defined $val) ? "'$val'" : 'undef' ;
1220                         push @old_watch, $val;
1221                         $trace |= 2;
1222                         next CMD; };
1223                     $cmd =~ /^\/(.*)$/ && do {
1224                         $inpat = $1;
1225                         $inpat =~ s:([^\\])/$:$1:;
1226                         if ($inpat ne "") {
1227                             # squelch the sigmangler
1228                             local $SIG{__DIE__};
1229                             local $SIG{__WARN__};
1230                             eval '$inpat =~ m'."\a$inpat\a";
1231                             if ($@ ne "") {
1232                                 print $OUT "$@";
1233                                 next CMD;
1234                             }
1235                             $pat = $inpat;
1236                         }
1237                         $end = $start;
1238                         $incr = -1;
1239                         eval '
1240                             for (;;) {
1241                                 ++$start;
1242                                 $start = 1 if ($start > $max);
1243                                 last if ($start == $end);
1244                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1245                                     if ($slave_editor) {
1246                                         print $OUT "\032\032$filename:$start:0\n";
1247                                     } else {
1248                                         print $OUT "$start:\t", $dbline[$start], "\n";
1249                                     }
1250                                     last;
1251                                 }
1252                             } ';
1253                         print $OUT "/$pat/: not found\n" if ($start == $end);
1254                         next CMD; };
1255                     $cmd =~ /^\?(.*)$/ && do {
1256                         $inpat = $1;
1257                         $inpat =~ s:([^\\])\?$:$1:;
1258                         if ($inpat ne "") {
1259                             # squelch the sigmangler
1260                             local $SIG{__DIE__};
1261                             local $SIG{__WARN__};
1262                             eval '$inpat =~ m'."\a$inpat\a";
1263                             if ($@ ne "") {
1264                                 print $OUT $@;
1265                                 next CMD;
1266                             }
1267                             $pat = $inpat;
1268                         }
1269                         $end = $start;
1270                         $incr = -1;
1271                         eval '
1272                             for (;;) {
1273                                 --$start;
1274                                 $start = $max if ($start <= 0);
1275                                 last if ($start == $end);
1276                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1277                                     if ($slave_editor) {
1278                                         print $OUT "\032\032$filename:$start:0\n";
1279                                     } else {
1280                                         print $OUT "$start:\t", $dbline[$start], "\n";
1281                                     }
1282                                     last;
1283                                 }
1284                             } ';
1285                         print $OUT "?$pat?: not found\n" if ($start == $end);
1286                         next CMD; };
1287                     $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1288                         pop(@hist) if length($cmd) > 1;
1289                         $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1290                         $cmd = $hist[$i];
1291                         print $OUT $cmd, "\n";
1292                         redo CMD; };
1293                     $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1294                         &system($1);
1295                         next CMD; };
1296                     $cmd =~ /^$rc([^$rc].*)$/ && do {
1297                         $pat = "^$1";
1298                         pop(@hist) if length($cmd) > 1;
1299                         for ($i = $#hist; $i; --$i) {
1300                             last if $hist[$i] =~ /$pat/;
1301                         }
1302                         if (!$i) {
1303                             print $OUT "No such command!\n\n";
1304                             next CMD;
1305                         }
1306                         $cmd = $hist[$i];
1307                         print $OUT $cmd, "\n";
1308                         redo CMD; };
1309                     $cmd =~ /^$sh$/ && do {
1310                         &system($ENV{SHELL}||"/bin/sh");
1311                         next CMD; };
1312                     $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1313                         # XXX: using csh or tcsh destroys sigint retvals!
1314                         #&system($1);  # use this instead
1315                         &system($ENV{SHELL}||"/bin/sh","-c",$1);
1316                         next CMD; };
1317                     $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1318                         $end = $2 ? ($#hist-$2) : 0;
1319                         $hist = 0 if $hist < 0;
1320                         for ($i=$#hist; $i>$end; $i--) {
1321                             print $OUT "$i: ",$hist[$i],"\n"
1322                               unless $hist[$i] =~ /^.?$/;
1323                         };
1324                         next CMD; };
1325                     $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1326                         runman($1);
1327                         next CMD; };
1328                     $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1329                     $cmd =~ s/^p\b/print {\$DB::OUT} /;
1330                     $cmd =~ s/^=\s*// && do {
1331                         my @keys;
1332                         if (length $cmd == 0) {
1333                             @keys = sort keys %alias;
1334                         }
1335                         elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1336                             # can't use $_ or kill //g state
1337                             for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1338                             $alias{$k} = "s\a$k\a$v\a";
1339                             # squelch the sigmangler
1340                             local $SIG{__DIE__};
1341                             local $SIG{__WARN__};
1342                             unless (eval "sub { s\a$k\a$v\a }; 1") {
1343                                 print $OUT "Can't alias $k to $v: $@\n";
1344                                 delete $alias{$k};
1345                                 next CMD;
1346                             }
1347                             @keys = ($k);
1348                         }
1349                         else {
1350                             @keys = ($cmd);
1351                         }
1352                         for my $k (@keys) {
1353                             if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
1354                                 print $OUT "$k\t= $1\n";
1355                             }
1356                             elsif (defined $alias{$k}) {
1357                                     print $OUT "$k\t$alias{$k}\n";
1358                             }
1359                             else {
1360                                 print "No alias for $k\n";
1361                             }
1362                         }
1363                         next CMD; };
1364                     $cmd =~ /^\|\|?\s*[^|]/ && do {
1365                         if ($pager =~ /^\|/) {
1366                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1367                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1368                         } else {
1369                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1370                         }
1371                         fix_less();
1372                         unless ($piped=open(OUT,$pager)) {
1373                             &warn("Can't pipe output to `$pager'");
1374                             if ($pager =~ /^\|/) {
1375                                 open(OUT,">&STDOUT") # XXX: lost message
1376                                     || &warn("Can't restore DB::OUT");
1377                                 open(STDOUT,">&SAVEOUT")
1378                                   || &warn("Can't restore STDOUT");
1379                                 close(SAVEOUT);
1380                             } else {
1381                                 open(OUT,">&STDOUT") # XXX: lost message
1382                                     || &warn("Can't restore DB::OUT");
1383                             }
1384                             next CMD;
1385                         }
1386                         $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1387                             && ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
1388                         $selected= select(OUT);
1389                         $|= 1;
1390                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1391                         $cmd =~ s/^\|+\s*//;
1392                         redo PIPE;
1393                     };
1394                     # XXX Local variants do not work!
1395                     $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1396                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1397                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1398                 }               # PIPE:
1399             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1400             if ($onetimeDump) {
1401                 $onetimeDump = undef;
1402             } elsif ($term_pid == $$) {
1403                 print $OUT "\n";
1404             }
1405         } continue {            # CMD:
1406             if ($piped) {
1407                 if ($pager =~ /^\|/) {
1408                     $? = 0;
1409                     # we cannot warn here: the handle is missing --tchrist
1410                     close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1411
1412                     # most of the $? crud was coping with broken cshisms
1413                     if ($?) {
1414                         print SAVEOUT "Pager `$pager' failed: ";
1415                         if ($? == -1) {
1416                             print SAVEOUT "shell returned -1\n";
1417                         } elsif ($? >> 8) {
1418                             print SAVEOUT
1419                               ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1420                               ( $? & 128 ) ? " -- core dumped" : "", "\n";
1421                         } else {
1422                             print SAVEOUT "status ", ($? >> 8), "\n";
1423                         }
1424                     }
1425
1426                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1427                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1428                     $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1429                     # Will stop ignoring SIGPIPE if done like nohup(1)
1430                     # does SIGINT but Perl doesn't give us a choice.
1431                 } else {
1432                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1433                 }
1434                 close(SAVEOUT);
1435                 select($selected), $selected= "" unless $selected eq "";
1436                 $piped= "";
1437             }
1438         }                       # CMD:
1439        $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1440         foreach $evalarg (@$post) {
1441           &eval;
1442         }
1443     }                           # if ($single || $signal)
1444     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1445     ();
1446 }
1447
1448 # The following code may be executed now:
1449 # BEGIN {warn 4}
1450
1451 sub sub {
1452     my ($al, $ret, @ret) = "";
1453     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1454         $al = " for $$sub";
1455     }
1456     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1457     $#stack = $stack_depth;
1458     $stack[-1] = $single;
1459     $single &= 1;
1460     $single |= 4 if $stack_depth == $deep;
1461     ($frame & 4
1462      ? ( print_lineinfo(' ' x ($stack_depth - 1), "in  "),
1463          # Why -1? But it works! :-(
1464          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1465      : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1466     if (wantarray) {
1467         @ret = &$sub;
1468         $single |= $stack[$stack_depth--];
1469         ($frame & 4
1470          ? ( print_lineinfo(' ' x $stack_depth, "out "),
1471              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1472          : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1473         if ($doret eq $stack_depth or $frame & 16) {
1474             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1475             print $fh ' ' x $stack_depth if $frame & 16;
1476             print $fh "list context return from $sub:\n";
1477             dumpit($fh, \@ret );
1478             $doret = -2;
1479         }
1480         @ret;
1481     } else {
1482         if (defined wantarray) {
1483             $ret = &$sub;
1484         } else {
1485             &$sub; undef $ret;
1486         };
1487         $single |= $stack[$stack_depth--];
1488         ($frame & 4
1489          ? (  print_lineinfo(' ' x $stack_depth, "out "),
1490               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1491          : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1492         if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1493             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1494             print $fh (' ' x $stack_depth) if $frame & 16;
1495             print $fh (defined wantarray
1496                          ? "scalar context return from $sub: "
1497                          : "void context return from $sub\n");
1498             dumpit( $fh, $ret ) if defined wantarray;
1499             $doret = -2;
1500         }
1501         $ret;
1502     }
1503 }
1504
1505 ### The API section
1506
1507 ### Functions with multiple modes of failure die on error, the rest
1508 ### returns FALSE on error.
1509 ### User-interface functions cmd_* output error message.
1510
1511 sub break_on_load {
1512   my $file = shift;
1513   $break_on_load{$file} = 1;
1514   $had_breakpoints{$file} |= 1;
1515 }
1516
1517 sub report_break_on_load {
1518   sort keys %break_on_load;
1519 }
1520
1521 sub cmd_b_load {
1522   my $file = shift;
1523   my @files;
1524   {
1525     push @files, $file;
1526     push @files, $::INC{$file} if $::INC{$file};
1527     $file .= '.pm', redo unless $file =~ /\./;
1528   }
1529   break_on_load($_) for @files;
1530   my @files = report_break_on_load;
1531   print $OUT "Will stop on load of `@files'.\n";
1532 }
1533
1534 $filename_error = '';
1535
1536 sub breakable_line {
1537   my ($from, $to) = @_;
1538   my $i = $from;
1539   if (@_ >= 2) {
1540     my $delta = $from < $to ? +1 : -1;
1541     my $limit = $delta > 0 ? $#dbline : 1;
1542     $limit = $to if ($limit - $to) * $delta > 0;
1543     $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1544   }
1545   return $i unless $dbline[$i] == 0;
1546   my ($pl, $upto) = ('', '');
1547   ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1548   die "Line$pl $from$upto$filename_error not breakable\n";
1549 }
1550
1551 sub breakable_line_in_filename {
1552   my ($f) = shift;
1553   local *dbline = $main::{'_<' . $f};
1554   local $filename_error = " of `$f'";
1555   breakable_line(@_);
1556 }
1557
1558 sub break_on_line {
1559   my ($i, $cond) = @_;
1560   $cond = 1 unless @_ >= 2;
1561   my $inii = $i;
1562   my $after = '';
1563   my $pl = '';
1564   die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1565   $had_breakpoints{$filename} |= 1;
1566   $dbline{$i} =~ s/^[^\0]*/$cond/;
1567 }
1568
1569 sub cmd_b_line {
1570   eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1571 }
1572
1573 sub break_on_filename_line {
1574   my ($f, $i, $cond) = @_;
1575   $cond = 1 unless @_ >= 3;
1576   local *dbline = $main::{'_<' . $f};
1577   local $filename_error = " of `$f'";
1578   local $filename = $f;
1579   break_on_line($i, $cond);
1580 }
1581
1582 sub break_on_filename_line_range {
1583   my ($f, $from, $to, $cond) = @_;
1584   my $i = breakable_line_in_filename($f, $from, $to);
1585   $cond = 1 unless @_ >= 3;
1586   break_on_filename_line($f,$i,$cond);
1587 }
1588
1589 sub subroutine_filename_lines {
1590   my ($subname,$cond) = @_;
1591   # Filename below can contain ':'
1592   find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1593 }
1594
1595 sub break_subroutine {
1596   my $subname = shift;
1597   my ($file,$s,$e) = subroutine_filename_lines($subname) or
1598     die "Subroutine $subname not found.\n";
1599   $cond = 1 unless @_ >= 2;
1600   break_on_filename_line_range($file,$s,$e,@_);
1601 }
1602
1603 sub cmd_b_sub {
1604   my ($subname,$cond) = @_;
1605   $cond = 1 unless @_ >= 2;
1606   unless (ref $subname eq 'CODE') {
1607     $subname =~ s/\'/::/g;
1608     my $s = $subname;
1609     $subname = "${'package'}::" . $subname
1610       unless $subname =~ /::/;
1611     $subname = "CORE::GLOBAL::$s"
1612       if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1613     $subname = "main".$subname if substr($subname,0,2) eq "::";
1614   }
1615   eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1616 }
1617
1618 sub cmd_stop {                  # As on ^C, but not signal-safy.
1619   $signal = 1;
1620 }
1621
1622 sub delete_breakpoint {
1623   my $i = shift;
1624   die "Line $i not breakable.\n" if $dbline[$i] == 0;
1625   $dbline{$i} =~ s/^[^\0]*//;
1626   delete $dbline{$i} if $dbline{$i} eq '';
1627 }
1628
1629 sub cmd_d {
1630   my $i = shift;
1631   eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1632 }
1633
1634 ### END of the API section
1635
1636 sub save {
1637     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1638     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1639 }
1640
1641 sub print_lineinfo {
1642   resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1643   print $LINEINFO @_;
1644 }
1645
1646 # The following takes its argument via $evalarg to preserve current @_
1647
1648 sub eval {
1649     # 'my' would make it visible from user code
1650     #    but so does local! --tchrist  [... into @DB::res, not @res. IZ]
1651     local @res;
1652     {
1653         local $otrace = $trace;
1654         local $osingle = $single;
1655         local $od = $^D;
1656         { ($evalarg) = $evalarg =~ /(.*)/s; }
1657         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1658         $trace = $otrace;
1659         $single = $osingle;
1660         $^D = $od;
1661     }
1662     my $at = $@;
1663     local $saved[0];            # Preserve the old value of $@
1664     eval { &DB::save };
1665     if ($at) {
1666         print $OUT $at;
1667     } elsif ($onetimeDump eq 'dump') {
1668         dumpit($OUT, \@res);
1669     } elsif ($onetimeDump eq 'methods') {
1670         methods($res[0]);
1671     }
1672     @res;
1673 }
1674
1675 sub postponed_sub {
1676   my $subname = shift;
1677   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1678     my $offset = $1 || 0;
1679     # Filename below can contain ':'
1680     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1681     if ($i) {
1682       $i += $offset;
1683       local *dbline = $main::{'_<' . $file};
1684       local $^W = 0;            # != 0 is magical below
1685       $had_breakpoints{$file} |= 1;
1686       my $max = $#dbline;
1687       ++$i until $dbline[$i] != 0 or $i >= $max;
1688       $dbline{$i} = delete $postponed{$subname};
1689     } else {
1690       print $OUT "Subroutine $subname not found.\n";
1691     }
1692     return;
1693   }
1694   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1695   #print $OUT "In postponed_sub for `$subname'.\n";
1696 }
1697
1698 sub postponed {
1699   if ($ImmediateStop) {
1700     $ImmediateStop = 0;
1701     $signal = 1;
1702   }
1703   return &postponed_sub
1704     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1705   # Cannot be done before the file is compiled
1706   local *dbline = shift;
1707   my $filename = $dbline;
1708   $filename =~ s/^_<//;
1709   $signal = 1, print $OUT "'$filename' loaded...\n"
1710     if $break_on_load{$filename};
1711   print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1712   return unless $postponed_file{$filename};
1713   $had_breakpoints{$filename} |= 1;
1714   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1715   my $key;
1716   for $key (keys %{$postponed_file{$filename}}) {
1717     $dbline{$key} = ${$postponed_file{$filename}}{$key};
1718   }
1719   delete $postponed_file{$filename};
1720 }
1721
1722 sub dumpit {
1723     local ($savout) = select(shift);
1724     my $osingle = $single;
1725     my $otrace = $trace;
1726     $single = $trace = 0;
1727     local $frame = 0;
1728     local $doret = -2;
1729     unless (defined &main::dumpValue) {
1730         do 'dumpvar.pl';
1731     }
1732     if (defined &main::dumpValue) {
1733         &main::dumpValue(shift);
1734     } else {
1735         print $OUT "dumpvar.pl not available.\n";
1736     }
1737     $single = $osingle;
1738     $trace = $otrace;
1739     select ($savout);
1740 }
1741
1742 # Tied method do not create a context, so may get wrong message:
1743
1744 sub print_trace {
1745   my $fh = shift;
1746   resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1747   my @sub = dump_trace($_[0] + 1, $_[1]);
1748   my $short = $_[2];            # Print short report, next one for sub name
1749   my $s;
1750   for ($i=0; $i <= $#sub; $i++) {
1751     last if $signal;
1752     local $" = ', ';
1753     my $args = defined $sub[$i]{args}
1754     ? "(@{ $sub[$i]{args} })"
1755       : '' ;
1756     $args = (substr $args, 0, $maxtrace - 3) . '...'
1757       if length $args > $maxtrace;
1758     my $file = $sub[$i]{file};
1759     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1760     $s = $sub[$i]{sub};
1761     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1762     if ($short) {
1763       my $sub = @_ >= 4 ? $_[3] : $s;
1764       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1765     } else {
1766       print $fh "$sub[$i]{context} = $s$args" .
1767         " called from $file" .
1768           " line $sub[$i]{line}\n";
1769     }
1770   }
1771 }
1772
1773 sub dump_trace {
1774   my $skip = shift;
1775   my $count = shift || 1e9;
1776   $skip++;
1777   $count += $skip;
1778   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1779   my $nothard = not $frame & 8;
1780   local $frame = 0;             # Do not want to trace this.
1781   my $otrace = $trace;
1782   $trace = 0;
1783   for ($i = $skip;
1784        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1785        $i++) {
1786     @a = ();
1787     for $arg (@args) {
1788       my $type;
1789       if (not defined $arg) {
1790         push @a, "undef";
1791       } elsif ($nothard and tied $arg) {
1792         push @a, "tied";
1793       } elsif ($nothard and $type = ref $arg) {
1794         push @a, "ref($type)";
1795       } else {
1796         local $_ = "$arg";      # Safe to stringify now - should not call f().
1797         s/([\'\\])/\\$1/g;
1798         s/(.*)/'$1'/s
1799           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1800         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1801         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1802         push(@a, $_);
1803       }
1804     }
1805     $context = $context ? '@' : (defined $context ? "\$" : '.');
1806     $args = $h ? [@a] : undef;
1807     $e =~ s/\n\s*\;\s*\Z// if $e;
1808     $e =~ s/([\\\'])/\\$1/g if $e;
1809     if ($r) {
1810       $sub = "require '$e'";
1811     } elsif (defined $r) {
1812       $sub = "eval '$e'";
1813     } elsif ($sub eq '(eval)') {
1814       $sub = "eval {...}";
1815     }
1816     push(@sub, {context => $context, sub => $sub, args => $args,
1817                 file => $file, line => $line});
1818     last if $signal;
1819   }
1820   $trace = $otrace;
1821   @sub;
1822 }
1823
1824 sub action {
1825     my $action = shift;
1826     while ($action =~ s/\\$//) {
1827         #print $OUT "+ ";
1828         #$action .= "\n";
1829         $action .= &gets;
1830     }
1831     $action;
1832 }
1833
1834 sub unbalanced {
1835     # i hate using globals!
1836     $balanced_brace_re ||= qr{
1837         ^ \{
1838               (?:
1839                  (?> [^{}] + )              # Non-parens without backtracking
1840                |
1841                  (??{ $balanced_brace_re }) # Group with matching parens
1842               ) *
1843           \} $
1844    }x;
1845    return $_[0] !~ m/$balanced_brace_re/;
1846 }
1847
1848 sub gets {
1849     &readline("cont: ");
1850 }
1851
1852 sub system {
1853     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1854     # some non-Unix systems can do system() but have problems with fork().
1855     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1856     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1857     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1858     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1859
1860     # XXX: using csh or tcsh destroys sigint retvals!
1861     system(@_);
1862     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1863     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1864     close(SAVEIN);
1865     close(SAVEOUT);
1866
1867
1868     # most of the $? crud was coping with broken cshisms
1869     if ($? >> 8) {
1870         &warn("(Command exited ", ($? >> 8), ")\n");
1871     } elsif ($?) {
1872         &warn( "(Command died of SIG#",  ($? & 127),
1873             (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1874     }
1875
1876     return $?;
1877
1878 }
1879
1880 sub setterm {
1881     local $frame = 0;
1882     local $doret = -2;
1883     eval { require Term::ReadLine } or die $@;
1884     if ($notty) {
1885         if ($tty) {
1886             my ($i, $o) = split $tty, /,/;
1887             $o = $i unless defined $o;
1888             open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1889             open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1890             $IN = \*IN;
1891             $OUT = \*OUT;
1892             my $sel = select($OUT);
1893             $| = 1;
1894             select($sel);
1895         } else {
1896             eval "require Term::Rendezvous;" or die;
1897             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1898             my $term_rv = new Term::Rendezvous $rv;
1899             $IN = $term_rv->IN;
1900             $OUT = $term_rv->OUT;
1901         }
1902     }
1903     if ($term_pid eq '-1') {            # In a TTY with another debugger
1904         resetterm(2);
1905     }
1906     if (!$rl) {
1907         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1908     } else {
1909         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1910
1911         $rl_attribs = $term->Attribs;
1912         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1913           if defined $rl_attribs->{basic_word_break_characters}
1914             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1915         $rl_attribs->{special_prefixes} = '$@&%';
1916         $rl_attribs->{completer_word_break_characters} .= '$@&%';
1917         $rl_attribs->{completion_function} = \&db_complete;
1918     }
1919     $LINEINFO = $OUT unless defined $LINEINFO;
1920     $lineinfo = $console unless defined $lineinfo;
1921     $term->MinLine(2);
1922     if ($term->Features->{setHistory} and "@hist" ne "?") {
1923       $term->SetHistory(@hist);
1924     }
1925     ornaments($ornaments) if defined $ornaments;
1926     $term_pid = $$;
1927 }
1928
1929 # Example get_fork_TTY functions
1930 sub xterm_get_fork_TTY {
1931   (my $name = $0) =~ s,^.*[/\\],,s;
1932   open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
1933  sleep 10000000' |];
1934   my $tty = <XT>;
1935   chomp $tty;
1936   $pidprompt = '';              # Shown anyway in titlebar
1937   return $tty;
1938 }
1939
1940 # This one resets $IN, $OUT itself
1941 sub os2_get_fork_TTY {
1942   $^F = 40;             # XXXX Fixme!
1943   my ($in1, $out1, $in2, $out2);
1944   # Having -d in PERL5OPT would lead to a disaster...
1945   local $ENV{PERL5OPT} = $ENV{PERL5OPT}    if $ENV{PERL5OPT};
1946   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b//  if $ENV{PERL5OPT};
1947   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
1948   print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
1949   (my $name = $0) =~ s,^.*[/\\],,s;
1950   if ( pipe $in1, $out1 and pipe $in2, $out2 and
1951        # system P_SESSION will fail if there is another process
1952        # in the same session with a "dependent" asyncroneous child session.
1953        (($kpid = system 4, $^X, '-we', <<'ES', fileno $in1, fileno $out2, "Daughter Perl debugger $pids $name") >= 0 or warn "system P_SESSION: $!, $^E" and 0) # P_SESSION
1954 use Term::ReadKey;
1955 use OS2::Process;
1956
1957 my $in = shift;         # Read from here and pass through
1958 set_title pop;
1959 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
1960   open IN, '<&=$in' or die "open <&=$in: \$!";
1961   \$| = 1; print while sysread IN, \$_, 1<<16;
1962 EOS
1963
1964 my $out = shift;
1965 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
1966 select OUT;    $| = 1;
1967 ReadMode 4;             # Nodelay on kbd.  Pipe is automatically nodelay...
1968 print while sysread STDIN, $_, 1<<16;
1969 ES
1970         and close $in1 and close $out2 ) {
1971       $pidprompt = '';          # Shown anyway in titlebar
1972       reset_IN_OUT($in2, $out1);
1973       $tty = '*reset*';
1974       return '';                        # Indicate that reset_IN_OUT is called
1975    }
1976    return;
1977 }
1978
1979 sub create_IN_OUT {     # Create a window with IN/OUT handles redirected there
1980     my $in = &get_fork_TTY if defined &get_fork_TTY;
1981     $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
1982     if (not defined $in) {
1983       my $why = shift;
1984       print_help(<<EOP) if $why == 1;
1985 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
1986 EOP
1987       print_help(<<EOP) if $why == 2;
1988 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
1989   This may be an asyncroneous session, so the parent debugger may be active.
1990 EOP
1991       print_help(<<EOP) if $why != 4;
1992   Since two debuggers fight for the same TTY, input is severely entangled.
1993
1994 EOP
1995       print_help(<<EOP);
1996   I know how to switch the output to a different window in xterms
1997   and OS/2 consoles only.  For a manual switch, put the name of the created I<TTY>
1998   in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
1999
2000   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2001   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2002
2003 EOP
2004     } elsif ($in ne '') {
2005       TTY($in);
2006     }
2007     undef $fork_TTY;
2008 }
2009
2010 sub resetterm {                 # We forked, so we need a different TTY
2011     my $in = shift;
2012     my $systemed = $in > 1 ? '-' : '';
2013     if ($pids) {
2014       $pids =~ s/\]/$systemed->$$]/;
2015     } else {
2016       $pids = "[$term_pid->$$]";
2017     }
2018     $pidprompt = $pids;
2019     $term_pid = $$;
2020     return unless $CreateTTY & $in;
2021     create_IN_OUT($in);
2022 }
2023
2024 sub readline {
2025   local $.;
2026   if (@typeahead) {
2027     my $left = @typeahead;
2028     my $got = shift @typeahead;
2029     print $OUT "auto(-$left)", shift, $got, "\n";
2030     $term->AddHistory($got)
2031       if length($got) > 1 and defined $term->Features->{addHistory};
2032     return $got;
2033   }
2034   local $frame = 0;
2035   local $doret = -2;
2036   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2037     $OUT->write(join('', @_));
2038     my $stuff;
2039     $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
2040     $stuff;
2041   }
2042   else {
2043     $term->readline(@_);
2044   }
2045 }
2046
2047 sub dump_option {
2048     my ($opt, $val)= @_;
2049     $val = option_val($opt,'N/A');
2050     $val =~ s/([\\\'])/\\$1/g;
2051     printf $OUT "%20s = '%s'\n", $opt, $val;
2052 }
2053
2054 sub option_val {
2055     my ($opt, $default)= @_;
2056     my $val;
2057     if (defined $optionVars{$opt}
2058         and defined ${$optionVars{$opt}}) {
2059         $val = ${$optionVars{$opt}};
2060     } elsif (defined $optionAction{$opt}
2061         and defined &{$optionAction{$opt}}) {
2062         $val = &{$optionAction{$opt}}();
2063     } elsif (defined $optionAction{$opt}
2064              and not defined $option{$opt}
2065              or defined $optionVars{$opt}
2066              and not defined ${$optionVars{$opt}}) {
2067         $val = $default;
2068     } else {
2069         $val = $option{$opt};
2070     }
2071     $val
2072 }
2073
2074 sub parse_options {
2075     local($_)= @_;
2076     # too dangerous to let intuitive usage overwrite important things
2077     # defaultion should never be the default
2078     my %opt_needs_val = map { ( $_ => 1 ) } qw{
2079         arrayDepth hashDepth LineInfo maxTraceLen ornaments
2080         pager quote ReadLine recallCommand RemotePort ShellBang TTY
2081     };
2082     while (length) {
2083         my $val_defaulted;
2084         s/^\s+// && next;
2085         s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2086         my ($opt,$sep) = ($1,$2);
2087         my $val;
2088         if ("?" eq $sep) {
2089             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2090               if /^\S/;
2091             #&dump_option($opt);
2092         } elsif ($sep !~ /\S/) {
2093             $val_defaulted = 1;
2094             $val = "1";  #  this is an evil default; make 'em set it!
2095         } elsif ($sep eq "=") {
2096
2097             if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2098                 my $quote = $1;
2099                 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2100             } else {
2101                 s/^(\S*)//;
2102             $val = $1;
2103                 print OUT qq(Option better cleared using $opt=""\n)
2104                     unless length $val;
2105             }
2106
2107         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2108             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2109             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2110               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2111             ($val = $1) =~ s/\\([\\$end])/$1/g;
2112         }
2113
2114         my $option;
2115         my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
2116                    || grep( /^\Q$opt/i && ($option = $_),  @options  );
2117
2118         print($OUT "Unknown option `$opt'\n"), next     unless $matches;
2119         print($OUT "Ambiguous option `$opt'\n"), next   if $matches > 1;
2120
2121        if ($opt_needs_val{$option} && $val_defaulted) {
2122             print $OUT "Option `$opt' is non-boolean.  Use `O $option=VAL' to set, `O $option?' to query\n";
2123             next;
2124         }
2125
2126         $option{$option} = $val if defined $val;
2127
2128         eval qq{
2129                 local \$frame = 0;
2130                 local \$doret = -2;
2131                 require '$optionRequire{$option}';
2132                 1;
2133          } || die  # XXX: shouldn't happen
2134             if  defined $optionRequire{$option}     &&
2135                 defined $val;
2136
2137         ${$optionVars{$option}} = $val
2138             if  defined $optionVars{$option}        &&
2139                 defined $val;
2140
2141         &{$optionAction{$option}} ($val)
2142             if defined $optionAction{$option}       &&
2143                defined &{$optionAction{$option}}    &&
2144                defined $val;
2145
2146         # Not $rcfile
2147         dump_option($option)    unless $OUT eq \*STDERR;
2148     }
2149 }
2150
2151 sub set_list {
2152   my ($stem,@list) = @_;
2153   my $val;
2154   $ENV{"${stem}_n"} = @list;
2155   for $i (0 .. $#list) {
2156     $val = $list[$i];
2157     $val =~ s/\\/\\\\/g;
2158     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2159     $ENV{"${stem}_$i"} = $val;
2160   }
2161 }
2162
2163 sub get_list {
2164   my $stem = shift;
2165   my @list;
2166   my $n = delete $ENV{"${stem}_n"};
2167   my $val;
2168   for $i (0 .. $n - 1) {
2169     $val = delete $ENV{"${stem}_$i"};
2170     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2171     push @list, $val;
2172   }
2173   @list;
2174 }
2175
2176 sub catch {
2177     $signal = 1;
2178     return;                     # Put nothing on the stack - malloc/free land!
2179 }
2180
2181 sub warn {
2182     my($msg)= join("",@_);
2183     $msg .= ": $!\n" unless $msg =~ /\n$/;
2184     print $OUT $msg;
2185 }
2186
2187 sub reset_IN_OUT {
2188     my $switch_li = $LINEINFO eq $OUT;
2189     if ($term and $term->Features->{newTTY}) {
2190       ($IN, $OUT) = (shift, shift);
2191       $term->newTTY($IN, $OUT);
2192     } elsif ($term) {
2193         &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2194     } else {
2195       ($IN, $OUT) = (shift, shift);
2196     }
2197     my $o = select $OUT;
2198     $| = 1;
2199     select $o;
2200     $LINEINFO = $OUT if $switch_li;
2201 }
2202
2203 sub TTY {
2204     if (@_ and $term and $term->Features->{newTTY}) {
2205       my ($in, $out) = shift;
2206       if ($in =~ /,/) {
2207         ($in, $out) = split /,/, $in, 2;
2208       } else {
2209         $out = $in;
2210       }
2211       open IN, $in or die "cannot open `$in' for read: $!";
2212       open OUT, ">$out" or die "cannot open `$out' for write: $!";
2213       reset_IN_OUT(\*IN,\*OUT);
2214       return $tty = $in;
2215     }
2216     &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2217     # Useful if done through PERLDB_OPTS:
2218     $tty = shift if @_;
2219     $tty or $console;
2220 }
2221
2222 sub noTTY {
2223     if ($term) {
2224         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2225     }
2226     $notty = shift if @_;
2227     $notty;
2228 }
2229
2230 sub ReadLine {
2231     if ($term) {
2232         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2233     }
2234     $rl = shift if @_;
2235     $rl;
2236 }
2237
2238 sub RemotePort {
2239     if ($term) {
2240         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2241     }
2242     $remoteport = shift if @_;
2243     $remoteport;
2244 }
2245
2246 sub tkRunning {
2247     if (${$term->Features}{tkRunning}) {
2248         return $term->tkRunning(@_);
2249     } else {
2250         print $OUT "tkRunning not supported by current ReadLine package.\n";
2251         0;
2252     }
2253 }
2254
2255 sub NonStop {
2256     if ($term) {
2257         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2258     }
2259     $runnonstop = shift if @_;
2260     $runnonstop;
2261 }
2262
2263 sub pager {
2264     if (@_) {
2265         $pager = shift;
2266         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2267     }
2268     $pager;
2269 }
2270
2271 sub shellBang {
2272     if (@_) {
2273         $sh = quotemeta shift;
2274         $sh .= "\\b" if $sh =~ /\w$/;
2275     }
2276     $psh = $sh;
2277     $psh =~ s/\\b$//;
2278     $psh =~ s/\\(.)/$1/g;
2279     &sethelp;
2280     $psh;
2281 }
2282
2283 sub ornaments {
2284   if (defined $term) {
2285     local ($warnLevel,$dieLevel) = (0, 1);
2286     return '' unless $term->Features->{ornaments};
2287     eval { $term->ornaments(@_) } || '';
2288   } else {
2289     $ornaments = shift;
2290   }
2291 }
2292
2293 sub recallCommand {
2294     if (@_) {
2295         $rc = quotemeta shift;
2296         $rc .= "\\b" if $rc =~ /\w$/;
2297     }
2298     $prc = $rc;
2299     $prc =~ s/\\b$//;
2300     $prc =~ s/\\(.)/$1/g;
2301     &sethelp;
2302     $prc;
2303 }
2304
2305 sub LineInfo {
2306     return $lineinfo unless @_;
2307     $lineinfo = shift;
2308     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2309     $slave_editor = ($stream =~ /^\|/);
2310     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2311     $LINEINFO = \*LINEINFO;
2312     my $save = select($LINEINFO);
2313     $| = 1;
2314     select($save);
2315     $lineinfo;
2316 }
2317
2318 sub list_versions {
2319   my %version;
2320   my $file;
2321   for (keys %INC) {
2322     $file = $_;
2323     s,\.p[lm]$,,i ;
2324     s,/,::,g ;
2325     s/^perl5db$/DB/;
2326     s/^Term::ReadLine::readline$/readline/;
2327     if (defined ${ $_ . '::VERSION' }) {
2328       $version{$file} = "${ $_ . '::VERSION' } from ";
2329     }
2330     $version{$file} .= $INC{$file};
2331   }
2332   dumpit($OUT,\%version);
2333 }
2334
2335 sub sethelp {
2336     # XXX: make sure these are tabs between the command and explantion,
2337     #      or print_help will screw up your formatting if you have
2338     #      eeevil ornaments enabled.  This is an insane mess.
2339
2340     $help = "
2341 B<T>            Stack trace.
2342 B<s> [I<expr>]  Single step [in I<expr>].
2343 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
2344 <B<CR>>         Repeat last B<n> or B<s> command.
2345 B<r>            Return from current subroutine.
2346 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
2347                 at the specified position.
2348 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
2349 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
2350 B<l> I<line>            List single I<line>.
2351 B<l> I<subname> List first window of lines from subroutine.
2352 B<l> I<\$var>           List first window of lines from subroutine referenced by I<\$var>.
2353 B<l>            List next window of lines.
2354 B<->            List previous window of lines.
2355 B<w> [I<line>]  List window around I<line>.
2356 B<.>            Return to the executed line.
2357 B<f> I<filename>        Switch to viewing I<filename>. File must be already loaded.
2358                 I<filename> may be either the full name of the file, or a regular
2359                 expression matching the full file name:
2360                 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2361                 Evals (with saved bodies) are considered to be filenames:
2362                 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2363                 (in the order of execution).
2364 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
2365 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
2366 B<L>            List all breakpoints and actions.
2367 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2368 B<t>            Toggle trace mode.
2369 B<t> I<expr>            Trace through execution of I<expr>.
2370 B<b> [I<line>] [I<condition>]
2371                 Set breakpoint; I<line> defaults to the current execution line;
2372                 I<condition> breaks if it evaluates to true, defaults to '1'.
2373 B<b> I<subname> [I<condition>]
2374                 Set breakpoint at first line of subroutine.
2375 B<b> I<\$var>           Set breakpoint at first line of subroutine referenced by I<\$var>.
2376 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2377 B<b> B<postpone> I<subname> [I<condition>]
2378                 Set breakpoint at first line of subroutine after
2379                 it is compiled.
2380 B<b> B<compile> I<subname>
2381                 Stop after the subroutine is compiled.
2382 B<d> [I<line>]  Delete the breakpoint for I<line>.
2383 B<D>            Delete all breakpoints.
2384 B<a> [I<line>] I<command>
2385                 Set an action to be done before the I<line> is executed;
2386                 I<line> defaults to the current execution line.
2387                 Sequence is: check for breakpoint/watchpoint, print line
2388                 if necessary, do action, prompt user if necessary,
2389                 execute line.
2390 B<a> [I<line>]  Delete the action for I<line>.
2391 B<A>            Delete all actions.
2392 B<W> I<expr>            Add a global watch-expression.
2393 B<W>            Delete all watch-expressions.
2394 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2395                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2396 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
2397 B<x> I<expr>            Evals expression in list context, dumps the result.
2398 B<m> I<expr>            Evals expression in list context, prints methods callable
2399                 on the first element of the result.
2400 B<m> I<class>           Prints methods callable via the given class.
2401
2402 B<<> ?                  List Perl commands to run before each prompt.
2403 B<<> I<expr>            Define Perl command to run before each prompt.
2404 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
2405 B<>> ?                  List Perl commands to run after each prompt.
2406 B<>> I<expr>            Define Perl command to run after each prompt.
2407 B<>>B<>> I<expr>                Add to the list of Perl commands to run after each prompt.
2408 B<{> I<db_command>      Define debugger command to run before each prompt.
2409 B<{> ?                  List debugger commands to run before each prompt.
2410 B<<> I<expr>            Define Perl command to run before each prompt.
2411 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
2412 B<$prc> I<number>       Redo a previous command (default previous command).
2413 B<$prc> I<-number>      Redo number'th-to-last command.
2414 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
2415                 See 'B<O> I<recallCommand>' too.
2416 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2417   . ( $rc eq $sh ? "" : "
2418 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2419                 See 'B<O> I<shellBang>' too.
2420 B<H> I<-number> Display last number commands (default all).
2421 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
2422 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
2423 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2424 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
2425 I<command>              Execute as a perl statement in current package.
2426 B<v>            Show versions of loaded modules.
2427 B<R>            Pure-man-restart of debugger, some of debugger state
2428                 and command-line options may be lost.
2429                 Currently the following setting are preserved:
2430                 history, breakpoints and actions, debugger B<O>ptions
2431                 and the following command-line options: I<-w>, I<-I>, I<-e>.
2432
2433 B<O> [I<opt>] ...       Set boolean option to true
2434 B<O> [I<opt>B<?>]       Query options
2435 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2436                 Set options.  Use quotes in spaces in value.
2437     I<recallCommand>, I<ShellBang>      chars used to recall command or spawn shell;
2438     I<pager>                    program for output of \"|cmd\";
2439     I<tkRunning>                        run Tk while prompting (with ReadLine);
2440     I<signalLevel> I<warnLevel> I<dieLevel>     level of verbosity;
2441     I<inhibit_exit>             Allows stepping off the end of the script.
2442     I<ImmediateStop>            Debugger should stop as early as possible.
2443     I<RemotePort>                       Remote hostname:port for remote debugging
2444   The following options affect what happens with B<V>, B<X>, and B<x> commands:
2445     I<arrayDepth>, I<hashDepth>         print only first N elements ('' for all);
2446     I<compactDump>, I<veryCompact>      change style of array and hash dump;
2447     I<globPrint>                        whether to print contents of globs;
2448     I<DumpDBFiles>              dump arrays holding debugged files;
2449     I<DumpPackages>             dump symbol tables of packages;
2450     I<DumpReused>                       dump contents of \"reused\" addresses;
2451     I<quote>, I<HighBit>, I<undefPrint>         change style of string dump;
2452     I<bareStringify>            Do not print the overload-stringified value;
2453   Other options include:
2454     I<PrintRet>         affects printing of return value after B<r> command,
2455     I<frame>            affects printing messages on entry and exit from subroutines.
2456     I<AutoTrace>        affects printing messages on every possible breaking point.
2457     I<maxTraceLen>      gives maximal length of evals/args listed in stack trace.
2458     I<ornaments>        affects screen appearance of the command line.
2459     I<CreateTTY>        bits control attempts to create a new TTY on events:
2460                         1: on fork()    2: debugger is started inside debugger
2461                         4: on startup
2462         During startup options are initialized from \$ENV{PERLDB_OPTS}.
2463         You can put additional initialization options I<TTY>, I<noTTY>,
2464         I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2465         `B<R>' after you set them).
2466
2467 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
2468 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
2469 B<h h>          Summary of debugger commands.
2470 B<$doccmd> I<manpage>   Runs the external doc viewer B<$doccmd> command on the
2471                 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2472                 Set B<\$DB::doccmd> to change viewer.
2473
2474 Type `|h' for a paged display if this was too hard to read.
2475
2476 "; # Fix balance of vi % matching: } }}
2477
2478     #  note: tabs in the following section are not-so-helpful
2479     $summary = <<"END_SUM";
2480 I<List/search source lines:>               I<Control script execution:>
2481   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
2482   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
2483   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
2484   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
2485   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
2486   B<v>           Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
2487 I<Debugger controls:>                        B<L>           List break/watch/actions
2488   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
2489   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2490   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
2491   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
2492   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
2493   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
2494   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2495   B<q> or B<^D>     Quit                        B<R>           Attempt a restart
2496 I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2497   B<x>|B<m> I<expr>       Evals expr in list context, dumps the result or lists methods.
2498   B<p> I<expr>         Print expression (uses script's current package).
2499   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
2500   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
2501   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
2502 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2503 END_SUM
2504                                 # ')}}; # Fix balance of vi % matching
2505 }
2506
2507 sub print_help {
2508     local $_ = shift;
2509
2510     # Restore proper alignment destroyed by eeevil I<> and B<>
2511     # ornaments: A pox on both their houses!
2512     #
2513     # A help command will have everything up to and including
2514     # the first tab sequence paddeed into a field 16 (or if indented 20)
2515     # wide.  If it's wide than that, an extra space will be added.
2516     s{
2517         ^                       # only matters at start of line
2518           ( \040{4} | \t )*     # some subcommands are indented
2519           ( < ?                 # so <CR> works
2520             [BI] < [^\t\n] + )  # find an eeevil ornament
2521           ( \t+ )               # original separation, discarded
2522           ( .* )                # this will now start (no earlier) than
2523                                 # column 16
2524     } {
2525         my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2526         my $clean = $command;
2527         $clean =~ s/[BI]<([^>]*)>/$1/g;
2528     # replace with this whole string:
2529         (length($leadwhite) ? " " x 4 : "")
2530       . $command
2531       . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ")
2532       . $text;
2533
2534     }mgex;
2535
2536     s{                          # handle bold ornaments
2537         B < ( [^>] + | > ) >
2538     } {
2539           $Term::ReadLine::TermCap::rl_term_set[2]
2540         . $1
2541         . $Term::ReadLine::TermCap::rl_term_set[3]
2542     }gex;
2543
2544     s{                          # handle italic ornaments
2545         I < ( [^>] + | > ) >
2546     } {
2547           $Term::ReadLine::TermCap::rl_term_set[0]
2548         . $1
2549         . $Term::ReadLine::TermCap::rl_term_set[1]
2550     }gex;
2551
2552     print $OUT $_;
2553 }
2554
2555 sub fix_less {
2556     return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2557     my $is_less = $pager =~ /\bless\b/;
2558     if ($pager =~ /\bmore\b/) {
2559         my @st_more = stat('/usr/bin/more');
2560         my @st_less = stat('/usr/bin/less');
2561         $is_less = @st_more    && @st_less
2562                 && $st_more[0] == $st_less[0]
2563                 && $st_more[1] == $st_less[1];
2564     }
2565     # changes environment!
2566     $ENV{LESS} .= 'r'   if $is_less;
2567 }
2568
2569 sub diesignal {
2570     local $frame = 0;
2571     local $doret = -2;
2572     $SIG{'ABRT'} = 'DEFAULT';
2573     kill 'ABRT', $$ if $panic++;
2574     if (defined &Carp::longmess) {
2575         local $SIG{__WARN__} = '';
2576         local $Carp::CarpLevel = 2;             # mydie + confess
2577         &warn(Carp::longmess("Signal @_"));
2578     }
2579     else {
2580         print $DB::OUT "Got signal @_\n";
2581     }
2582     kill 'ABRT', $$;
2583 }
2584
2585 sub dbwarn {
2586   local $frame = 0;
2587   local $doret = -2;
2588   local $SIG{__WARN__} = '';
2589   local $SIG{__DIE__} = '';
2590   eval { require Carp } if defined $^S; # If error/warning during compilation,
2591                                         # require may be broken.
2592   warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2593     return unless defined &Carp::longmess;
2594   my ($mysingle,$mytrace) = ($single,$trace);
2595   $single = 0; $trace = 0;
2596   my $mess = Carp::longmess(@_);
2597   ($single,$trace) = ($mysingle,$mytrace);
2598   &warn($mess);
2599 }
2600
2601 sub dbdie {
2602   local $frame = 0;
2603   local $doret = -2;
2604   local $SIG{__DIE__} = '';
2605   local $SIG{__WARN__} = '';
2606   my $i = 0; my $ineval = 0; my $sub;
2607   if ($dieLevel > 2) {
2608       local $SIG{__WARN__} = \&dbwarn;
2609       &warn(@_);                # Yell no matter what
2610       return;
2611   }
2612   if ($dieLevel < 2) {
2613     die @_ if $^S;              # in eval propagate
2614   }
2615   eval { require Carp } if defined $^S; # If error/warning during compilation,
2616                                         # require may be broken.
2617
2618   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2619     unless defined &Carp::longmess;
2620
2621   # We do not want to debug this chunk (automatic disabling works
2622   # inside DB::DB, but not in Carp).
2623   my ($mysingle,$mytrace) = ($single,$trace);
2624   $single = 0; $trace = 0;
2625   my $mess = Carp::longmess(@_);
2626   ($single,$trace) = ($mysingle,$mytrace);
2627   die $mess;
2628 }
2629
2630 sub warnLevel {
2631   if (@_) {
2632     $prevwarn = $SIG{__WARN__} unless $warnLevel;
2633     $warnLevel = shift;
2634     if ($warnLevel) {
2635       $SIG{__WARN__} = \&DB::dbwarn;
2636     } else {
2637       $SIG{__WARN__} = $prevwarn;
2638     }
2639   }
2640   $warnLevel;
2641 }
2642
2643 sub dieLevel {
2644   if (@_) {
2645     $prevdie = $SIG{__DIE__} unless $dieLevel;
2646     $dieLevel = shift;
2647     if ($dieLevel) {
2648       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2649       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2650       print $OUT "Stack dump during die enabled",
2651         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2652           if $I_m_init;
2653       print $OUT "Dump printed too.\n" if $dieLevel > 2;
2654     } else {
2655       $SIG{__DIE__} = $prevdie;
2656       print $OUT "Default die handler restored.\n";
2657     }
2658   }
2659   $dieLevel;
2660 }
2661
2662 sub signalLevel {
2663   if (@_) {
2664     $prevsegv = $SIG{SEGV} unless $signalLevel;
2665     $prevbus = $SIG{BUS} unless $signalLevel;
2666     $signalLevel = shift;
2667     if ($signalLevel) {
2668       $SIG{SEGV} = \&DB::diesignal;
2669       $SIG{BUS} = \&DB::diesignal;
2670     } else {
2671       $SIG{SEGV} = $prevsegv;
2672       $SIG{BUS} = $prevbus;
2673     }
2674   }
2675   $signalLevel;
2676 }
2677
2678 sub CvGV_name {
2679   my $in = shift;
2680   my $name = CvGV_name_or_bust($in);
2681   defined $name ? $name : $in;
2682 }
2683
2684 sub CvGV_name_or_bust {
2685   my $in = shift;
2686   return if $skipCvGV;          # Backdoor to avoid problems if XS broken...
2687   $in = \&$in;                  # Hard reference...
2688   eval {require Devel::Peek; 1} or return;
2689   my $gv = Devel::Peek::CvGV($in) or return;
2690   *$gv{PACKAGE} . '::' . *$gv{NAME};
2691 }
2692
2693 sub find_sub {
2694   my $subr = shift;
2695   $sub{$subr} or do {
2696     return unless defined &$subr;
2697     my $name = CvGV_name_or_bust($subr);
2698     my $data;
2699     $data = $sub{$name} if defined $name;
2700     return $data if defined $data;
2701
2702     # Old stupid way...
2703     $subr = \&$subr;            # Hard reference
2704     my $s;
2705     for (keys %sub) {
2706       $s = $_, last if $subr eq \&$_;
2707     }
2708     $sub{$s} if $s;
2709   }
2710 }
2711
2712 sub methods {
2713   my $class = shift;
2714   $class = ref $class if ref $class;
2715   local %seen;
2716   local %packs;
2717   methods_via($class, '', 1);
2718   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2719 }
2720
2721 sub methods_via {
2722   my $class = shift;
2723   return if $packs{$class}++;
2724   my $prefix = shift;
2725   my $prepend = $prefix ? "via $prefix: " : '';
2726   my $name;
2727   for $name (grep {defined &{${"${class}::"}{$_}}}
2728              sort keys %{"${class}::"}) {
2729     next if $seen{ $name }++;
2730     print $DB::OUT "$prepend$name\n";
2731   }
2732   return unless shift;          # Recurse?
2733   for $name (@{"${class}::ISA"}) {
2734     $prepend = $prefix ? $prefix . " -> $name" : $name;
2735     methods_via($name, $prepend, 1);
2736   }
2737 }
2738
2739 sub setman {
2740     $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
2741                 ? "man"             # O Happy Day!
2742                 : "perldoc";        # Alas, poor unfortunates
2743 }
2744
2745 sub runman {
2746     my $page = shift;
2747     unless ($page) {
2748         &system("$doccmd $doccmd");
2749         return;
2750     }
2751     # this way user can override, like with $doccmd="man -Mwhatever"
2752     # or even just "man " to disable the path check.
2753     unless ($doccmd eq 'man') {
2754         &system("$doccmd $page");
2755         return;
2756     }
2757
2758     $page = 'perl' if lc($page) eq 'help';
2759
2760     require Config;
2761     my $man1dir = $Config::Config{'man1dir'};
2762     my $man3dir = $Config::Config{'man3dir'};
2763     for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2764     my $manpath = '';
2765     $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2766     $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2767     chop $manpath if $manpath;
2768     # harmless if missing, I figure
2769     my $oldpath = $ENV{MANPATH};
2770     $ENV{MANPATH} = $manpath if $manpath;
2771     my $nopathopt = $^O =~ /dunno what goes here/;
2772     if (system($doccmd,
2773                 # I just *know* there are men without -M
2774                 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2775             split ' ', $page) )
2776     {
2777         unless ($page =~ /^perl\w/) {
2778             if (grep { $page eq $_ } qw{
2779                 5004delta 5005delta amiga api apio book boot bot call compile
2780                 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2781                 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2782                 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2783                 modinstall modlib number obj op opentut os2 os390 pod port
2784                 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2785                 trap unicode var vms win32 xs xstut
2786               })
2787             {
2788                 $page =~ s/^/perl/;
2789                 system($doccmd,
2790                         (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2791                         $page);
2792             }
2793         }
2794     }
2795     if (defined $oldpath) {
2796         $ENV{MANPATH} = $manpath;
2797     } else {
2798         delete $ENV{MANPATH};
2799     }
2800 }
2801
2802 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2803
2804 BEGIN {                 # This does not compile, alas.
2805   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
2806   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
2807   $sh = '!';
2808   $rc = ',';
2809   @hist = ('?');
2810   $deep = 100;                  # warning if stack gets this deep
2811   $window = 10;
2812   $preview = 3;
2813   $sub = '';
2814   $SIG{INT} = \&DB::catch;
2815   # This may be enabled to debug debugger:
2816   #$warnLevel = 1 unless defined $warnLevel;
2817   #$dieLevel = 1 unless defined $dieLevel;
2818   #$signalLevel = 1 unless defined $signalLevel;
2819
2820   $db_stop = 0;                 # Compiler warning
2821   $db_stop = 1 << 30;
2822   $level = 0;                   # Level of recursive debugging
2823   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2824   # Triggers bug (?) in perl is we postpone this until runtime:
2825   @postponed = @stack = (0);
2826   $stack_depth = 0;             # Localized $#stack
2827   $doret = -2;
2828   $frame = 0;
2829 }
2830
2831 BEGIN {$^W = $ini_warn;}        # Switch warnings back
2832
2833 #use Carp;                      # This did break, left for debuggin
2834
2835 sub db_complete {
2836   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2837   my($text, $line, $start) = @_;
2838   my ($itext, $search, $prefix, $pack) =
2839     ($text, "^\Q${'package'}::\E([^:]+)\$");
2840
2841   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2842                                (map { /$search/ ? ($1) : () } keys %sub)
2843     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2844   return sort grep /^\Q$text/, values %INC # files
2845     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2846   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2847     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2848       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2849   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2850     grep !/^main::/,
2851       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2852                                  # packages
2853         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2854           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
2855   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2856     # We may want to complete to (eval 9), so $text may be wrong
2857     $prefix = length($1) - length($text);
2858     $text = $1;
2859     return sort
2860         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2861   }
2862   if ((substr $text, 0, 1) eq '&') { # subroutines
2863     $text = substr $text, 1;
2864     $prefix = "&";
2865     return sort map "$prefix$_",
2866                grep /^\Q$text/,
2867                  (keys %sub),
2868                  (map { /$search/ ? ($1) : () }
2869                     keys %sub);
2870   }
2871   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2872     $pack = ($1 eq 'main' ? '' : $1) . '::';
2873     $prefix = (substr $text, 0, 1) . $1 . '::';
2874     $text = $2;
2875     my @out
2876       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2877     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2878       return db_complete($out[0], $line, $start);
2879     }
2880     return sort @out;
2881   }
2882   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2883     $pack = ($package eq 'main' ? '' : $package) . '::';
2884     $prefix = substr $text, 0, 1;
2885     $text = substr $text, 1;
2886     my @out = map "$prefix$_", grep /^\Q$text/,
2887        (grep /^_?[a-zA-Z]/, keys %$pack),
2888        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2889     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2890       return db_complete($out[0], $line, $start);
2891     }
2892     return sort @out;
2893   }
2894   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2895     my @out = grep /^\Q$text/, @options;
2896     my $val = option_val($out[0], undef);
2897     my $out = '? ';
2898     if (not defined $val or $val =~ /[\n\r]/) {
2899       # Can do nothing better
2900     } elsif ($val =~ /\s/) {
2901       my $found;
2902       foreach $l (split //, qq/\"\'\#\|/) {
2903         $out = "$l$val$l ", last if (index $val, $l) == -1;
2904       }
2905     } else {
2906       $out = "=$val ";
2907     }
2908     # Default to value if one completion, to question if many
2909     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2910     return sort @out;
2911   }
2912   return $term->filename_list($text); # filenames
2913 }
2914
2915 sub end_report {
2916   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
2917 }
2918
2919 END {
2920   $finished = 1 if $inhibit_exit;      # So that some keys may be disabled.
2921   $fall_off_end = 1 unless $inhibit_exit;
2922   # Do not stop in at_exit() and destructors on exit:
2923   $DB::single = !$fall_off_end && !$runnonstop;
2924   DB::fake::at_exit() unless $fall_off_end or $runnonstop;
2925 }
2926
2927 package DB::fake;
2928
2929 sub at_exit {
2930   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
2931 }
2932
2933 package DB;                     # Do not trace this 1; below!
2934
2935 1;