lib/perl5db.pl

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