lib/perl5db.pl

   1 package DB;
   2
   3 # Debugger for Perl 5.00x; perl5db.pl patch level:
   4
   5 $VERSION = 1.13;
   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) && 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*[^|]/ && do {
1437                         if ($pager =~ /^\|/) {
1438                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1439                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1440                         } else {
1441                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1442                         }
1443                         fix_less();
1444                         unless ($piped=open(OUT,$pager)) {
1445                             &warn("Can't pipe output to `$pager'");
1446                             if ($pager =~ /^\|/) {
1447                                 open(OUT,">&STDOUT") # XXX: lost message
1448                                     || &warn("Can't restore DB::OUT");
1449                                 open(STDOUT,">&SAVEOUT")
1450                                   || &warn("Can't restore STDOUT");
1451                                 close(SAVEOUT);
1452                             } else {
1453                                 open(OUT,">&STDOUT") # XXX: lost message
1454                                     || &warn("Can't restore DB::OUT");
1455                             }
1456                             next CMD;
1457                         }
1458                         $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1459                             && ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
1460                         $selected= select(OUT);
1461                         $|= 1;
1462                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1463                         $cmd =~ s/^\|+\s*//;
1464                         redo PIPE;
1465                     };
1466                     # XXX Local variants do not work!
1467                     $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1468                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1469                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1470                 }               # PIPE:
1471             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1472             if ($onetimeDump) {
1473                 $onetimeDump = undef;
1474             } elsif ($term_pid == $$) {
1475                 print $OUT "\n";
1476             }
1477         } continue {            # CMD:
1478             if ($piped) {
1479                 if ($pager =~ /^\|/) {
1480                     $? = 0;
1481                     # we cannot warn here: the handle is missing --tchrist
1482                     close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1483
1484                     # most of the $? crud was coping with broken cshisms
1485                     if ($?) {
1486                         print SAVEOUT "Pager `$pager' failed: ";
1487                         if ($? == -1) {
1488                             print SAVEOUT "shell returned -1\n";
1489                         } elsif ($? >> 8) {
1490                             print SAVEOUT
1491                               ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1492                               ( $? & 128 ) ? " -- core dumped" : "", "\n";
1493                         } else {
1494                             print SAVEOUT "status ", ($? >> 8), "\n";
1495                         }
1496                     }
1497
1498                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1499                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1500                     $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1501                     # Will stop ignoring SIGPIPE if done like nohup(1)
1502                     # does SIGINT but Perl doesn't give us a choice.
1503                 } else {
1504                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1505                 }
1506                 close(SAVEOUT);
1507                 select($selected), $selected= "" unless $selected eq "";
1508                 $piped= "";
1509             }
1510         }                       # CMD:
1511        $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1512         foreach $evalarg (@$post) {
1513           &eval;
1514         }
1515     }                           # if ($single || $signal)
1516     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1517     ();
1518 }
1519
1520 # The following code may be executed now:
1521 # BEGIN {warn 4}
1522
1523 sub sub {
1524     my ($al, $ret, @ret) = "";
1525     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1526         $al = " for $$sub";
1527     }
1528     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1529     $#stack = $stack_depth;
1530     $stack[-1] = $single;
1531     $single &= 1;
1532     $single |= 4 if $stack_depth == $deep;
1533     ($frame & 4
1534      ? ( print_lineinfo(' ' x ($stack_depth - 1), "in  "),
1535          # Why -1? But it works! :-(
1536          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1537      : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1538     if (wantarray) {
1539         @ret = &$sub;
1540         $single |= $stack[$stack_depth--];
1541         ($frame & 4
1542          ? ( print_lineinfo(' ' x $stack_depth, "out "),
1543              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1544          : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1545         if ($doret eq $stack_depth or $frame & 16) {
1546             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1547             print $fh ' ' x $stack_depth if $frame & 16;
1548             print $fh "list context return from $sub:\n";
1549             dumpit($fh, \@ret );
1550             $doret = -2;
1551         }
1552         @ret;
1553     } else {
1554         if (defined wantarray) {
1555             $ret = &$sub;
1556         } else {
1557             &$sub; undef $ret;
1558         };
1559         $single |= $stack[$stack_depth--];
1560         ($frame & 4
1561          ? (  print_lineinfo(' ' x $stack_depth, "out "),
1562               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1563          : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1564         if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1565             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1566             print $fh (' ' x $stack_depth) if $frame & 16;
1567             print $fh (defined wantarray
1568                          ? "scalar context return from $sub: "
1569                          : "void context return from $sub\n");
1570             dumpit( $fh, $ret ) if defined wantarray;
1571             $doret = -2;
1572         }
1573         $ret;
1574     }
1575 }
1576
1577 ### The API section
1578
1579 ### Functions with multiple modes of failure die on error, the rest
1580 ### returns FALSE on error.
1581 ### User-interface functions cmd_* output error message.
1582
1583 sub break_on_load {
1584   my $file = shift;
1585   $break_on_load{$file} = 1;
1586   $had_breakpoints{$file} |= 1;
1587 }
1588
1589 sub report_break_on_load {
1590   sort keys %break_on_load;
1591 }
1592
1593 sub cmd_b_load {
1594   my $file = shift;
1595   my @files;
1596   {
1597     push @files, $file;
1598     push @files, $::INC{$file} if $::INC{$file};
1599     $file .= '.pm', redo unless $file =~ /\./;
1600   }
1601   break_on_load($_) for @files;
1602   @files = report_break_on_load;
1603   print $OUT "Will stop on load of `@files'.\n";
1604 }
1605
1606 $filename_error = '';
1607
1608 sub breakable_line {
1609   my ($from, $to) = @_;
1610   my $i = $from;
1611   if (@_ >= 2) {
1612     my $delta = $from < $to ? +1 : -1;
1613     my $limit = $delta > 0 ? $#dbline : 1;
1614     $limit = $to if ($limit - $to) * $delta > 0;
1615     $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1616   }
1617   return $i unless $dbline[$i] == 0;
1618   my ($pl, $upto) = ('', '');
1619   ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1620   die "Line$pl $from$upto$filename_error not breakable\n";
1621 }
1622
1623 sub breakable_line_in_filename {
1624   my ($f) = shift;
1625   local *dbline = $main::{'_<' . $f};
1626   local $filename_error = " of `$f'";
1627   breakable_line(@_);
1628 }
1629
1630 sub break_on_line {
1631   my ($i, $cond) = @_;
1632   $cond = 1 unless @_ >= 2;
1633   my $inii = $i;
1634   my $after = '';
1635   my $pl = '';
1636   die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1637   $had_breakpoints{$filename} |= 1;
1638   if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1639   else { $dbline{$i} = $cond; }
1640 }
1641
1642 sub cmd_b_line {
1643   eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1644 }
1645
1646 sub break_on_filename_line {
1647   my ($f, $i, $cond) = @_;
1648   $cond = 1 unless @_ >= 3;
1649   local *dbline = $main::{'_<' . $f};
1650   local $filename_error = " of `$f'";
1651   local $filename = $f;
1652   break_on_line($i, $cond);
1653 }
1654
1655 sub break_on_filename_line_range {
1656   my ($f, $from, $to, $cond) = @_;
1657   my $i = breakable_line_in_filename($f, $from, $to);
1658   $cond = 1 unless @_ >= 3;
1659   break_on_filename_line($f,$i,$cond);
1660 }
1661
1662 sub subroutine_filename_lines {
1663   my ($subname,$cond) = @_;
1664   # Filename below can contain ':'
1665   find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1666 }
1667
1668 sub break_subroutine {
1669   my $subname = shift;
1670   my ($file,$s,$e) = subroutine_filename_lines($subname) or
1671     die "Subroutine $subname not found.\n";
1672   $cond = 1 unless @_ >= 2;
1673   break_on_filename_line_range($file,$s,$e,@_);
1674 }
1675
1676 sub cmd_b_sub {
1677   my ($subname,$cond) = @_;
1678   $cond = 1 unless @_ >= 2;
1679   unless (ref $subname eq 'CODE') {
1680     $subname =~ s/\'/::/g;
1681     my $s = $subname;
1682     $subname = "${'package'}::" . $subname
1683       unless $subname =~ /::/;
1684     $subname = "CORE::GLOBAL::$s"
1685       if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1686     $subname = "main".$subname if substr($subname,0,2) eq "::";
1687   }
1688   eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1689 }
1690
1691 sub cmd_stop {                  # As on ^C, but not signal-safy.
1692   $signal = 1;
1693 }
1694
1695 sub delete_breakpoint {
1696   my $i = shift;
1697   die "Line $i not breakable.\n" if $dbline[$i] == 0;
1698   $dbline{$i} =~ s/^[^\0]*//;
1699   delete $dbline{$i} if $dbline{$i} eq '';
1700 }
1701
1702 sub cmd_d {
1703   my $i = shift;
1704   eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1705 }
1706
1707 ### END of the API section
1708
1709 sub save {
1710     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1711     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1712 }
1713
1714 sub print_lineinfo {
1715   resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1716   print $LINEINFO @_;
1717 }
1718
1719 # The following takes its argument via $evalarg to preserve current @_
1720
1721 sub eval {
1722     # 'my' would make it visible from user code
1723     #    but so does local! --tchrist  [... into @DB::res, not @res. IZ]
1724     local @res;
1725     {
1726         local $otrace = $trace;
1727         local $osingle = $single;
1728         local $od = $^D;
1729         { ($evalarg) = $evalarg =~ /(.*)/s; }
1730         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1731         $trace = $otrace;
1732         $single = $osingle;
1733         $^D = $od;
1734     }
1735     my $at = $@;
1736     local $saved[0];            # Preserve the old value of $@
1737     eval { &DB::save };
1738     if ($at) {
1739         print $OUT $at;
1740     } elsif ($onetimeDump) {
1741         dumpit($OUT, \@res) if $onetimeDump eq 'dump';
1742         methods($res[0])    if $onetimeDump eq 'methods';
1743     }
1744     @res;
1745 }
1746
1747 sub postponed_sub {
1748   my $subname = shift;
1749   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1750     my $offset = $1 || 0;
1751     # Filename below can contain ':'
1752     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1753     if ($i) {
1754       $i += $offset;
1755       local *dbline = $main::{'_<' . $file};
1756       local $^W = 0;            # != 0 is magical below
1757       $had_breakpoints{$file} |= 1;
1758       my $max = $#dbline;
1759       ++$i until $dbline[$i] != 0 or $i >= $max;
1760       $dbline{$i} = delete $postponed{$subname};
1761     } else {
1762       print $OUT "Subroutine $subname not found.\n";
1763     }
1764     return;
1765   }
1766   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1767   #print $OUT "In postponed_sub for `$subname'.\n";
1768 }
1769
1770 sub postponed {
1771   if ($ImmediateStop) {
1772     $ImmediateStop = 0;
1773     $signal = 1;
1774   }
1775   return &postponed_sub
1776     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1777   # Cannot be done before the file is compiled
1778   local *dbline = shift;
1779   my $filename = $dbline;
1780   $filename =~ s/^_<//;
1781   $signal = 1, print $OUT "'$filename' loaded...\n"
1782     if $break_on_load{$filename};
1783   print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1784   return unless $postponed_file{$filename};
1785   $had_breakpoints{$filename} |= 1;
1786   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1787   my $key;
1788   for $key (keys %{$postponed_file{$filename}}) {
1789     $dbline{$key} = ${$postponed_file{$filename}}{$key};
1790   }
1791   delete $postponed_file{$filename};
1792 }
1793
1794 sub dumpit {
1795     local ($savout) = select(shift);
1796     my $osingle = $single;
1797     my $otrace = $trace;
1798     $single = $trace = 0;
1799     local $frame = 0;
1800     local $doret = -2;
1801     unless (defined &main::dumpValue) {
1802         do 'dumpvar.pl';
1803     }
1804     if (defined &main::dumpValue) {
1805         &main::dumpValue(shift);
1806     } else {
1807         print $OUT "dumpvar.pl not available.\n";
1808     }
1809     $single = $osingle;
1810     $trace = $otrace;
1811     select ($savout);
1812 }
1813
1814 # Tied method do not create a context, so may get wrong message:
1815
1816 sub print_trace {
1817   my $fh = shift;
1818   resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1819   my @sub = dump_trace($_[0] + 1, $_[1]);
1820   my $short = $_[2];            # Print short report, next one for sub name
1821   my $s;
1822   for ($i=0; $i <= $#sub; $i++) {
1823     last if $signal;
1824     local $" = ', ';
1825     my $args = defined $sub[$i]{args}
1826     ? "(@{ $sub[$i]{args} })"
1827       : '' ;
1828     $args = (substr $args, 0, $maxtrace - 3) . '...'
1829       if length $args > $maxtrace;
1830     my $file = $sub[$i]{file};
1831     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1832     $s = $sub[$i]{sub};
1833     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1834     if ($short) {
1835       my $sub = @_ >= 4 ? $_[3] : $s;
1836       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1837     } else {
1838       print $fh "$sub[$i]{context} = $s$args" .
1839         " called from $file" .
1840           " line $sub[$i]{line}\n";
1841     }
1842   }
1843 }
1844
1845 sub dump_trace {
1846   my $skip = shift;
1847   my $count = shift || 1e9;
1848   $skip++;
1849   $count += $skip;
1850   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1851   my $nothard = not $frame & 8;
1852   local $frame = 0;             # Do not want to trace this.
1853   my $otrace = $trace;
1854   $trace = 0;
1855   for ($i = $skip;
1856        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1857        $i++) {
1858     @a = ();
1859     for $arg (@args) {
1860       my $type;
1861       if (not defined $arg) {
1862         push @a, "undef";
1863       } elsif ($nothard and tied $arg) {
1864         push @a, "tied";
1865       } elsif ($nothard and $type = ref $arg) {
1866         push @a, "ref($type)";
1867       } else {
1868         local $_ = "$arg";      # Safe to stringify now - should not call f().
1869         s/([\'\\])/\\$1/g;
1870         s/(.*)/'$1'/s
1871           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1872         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1873         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1874         push(@a, $_);
1875       }
1876     }
1877     $context = $context ? '@' : (defined $context ? "\$" : '.');
1878     $args = $h ? [@a] : undef;
1879     $e =~ s/\n\s*\;\s*\Z// if $e;
1880     $e =~ s/([\\\'])/\\$1/g if $e;
1881     if ($r) {
1882       $sub = "require '$e'";
1883     } elsif (defined $r) {
1884       $sub = "eval '$e'";
1885     } elsif ($sub eq '(eval)') {
1886       $sub = "eval {...}";
1887     }
1888     push(@sub, {context => $context, sub => $sub, args => $args,
1889                 file => $file, line => $line});
1890     last if $signal;
1891   }
1892   $trace = $otrace;
1893   @sub;
1894 }
1895
1896 sub action {
1897     my $action = shift;
1898     while ($action =~ s/\\$//) {
1899         #print $OUT "+ ";
1900         #$action .= "\n";
1901         $action .= &gets;
1902     }
1903     $action;
1904 }
1905
1906 sub unbalanced {
1907     # i hate using globals!
1908     $balanced_brace_re ||= qr{
1909         ^ \{
1910               (?:
1911                  (?> [^{}] + )              # Non-parens without backtracking
1912                |
1913                  (??{ $balanced_brace_re }) # Group with matching parens
1914               ) *
1915           \} $
1916    }x;
1917    return $_[0] !~ m/$balanced_brace_re/;
1918 }
1919
1920 sub gets {
1921     &readline("cont: ");
1922 }
1923
1924 sub system {
1925     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1926     # some non-Unix systems can do system() but have problems with fork().
1927     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1928     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1929     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1930     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1931
1932     # XXX: using csh or tcsh destroys sigint retvals!
1933     system(@_);
1934     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1935     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1936     close(SAVEIN);
1937     close(SAVEOUT);
1938
1939
1940     # most of the $? crud was coping with broken cshisms
1941     if ($? >> 8) {
1942         &warn("(Command exited ", ($? >> 8), ")\n");
1943     } elsif ($?) {
1944         &warn( "(Command died of SIG#",  ($? & 127),
1945             (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1946     }
1947
1948     return $?;
1949
1950 }
1951
1952 sub setterm {
1953     local $frame = 0;
1954     local $doret = -2;
1955     eval { require Term::ReadLine } or die $@;
1956     if ($notty) {
1957         if ($tty) {
1958             my ($i, $o) = split $tty, /,/;
1959             $o = $i unless defined $o;
1960             open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1961             open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1962             $IN = \*IN;
1963             $OUT = \*OUT;
1964             my $sel = select($OUT);
1965             $| = 1;
1966             select($sel);
1967         } else {
1968             eval "require Term::Rendezvous;" or die;
1969             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1970             my $term_rv = new Term::Rendezvous $rv;
1971             $IN = $term_rv->IN;
1972             $OUT = $term_rv->OUT;
1973         }
1974     }
1975     if ($term_pid eq '-1') {            # In a TTY with another debugger
1976         resetterm(2);
1977     }
1978     if (!$rl) {
1979         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1980     } else {
1981         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1982
1983         $rl_attribs = $term->Attribs;
1984         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1985           if defined $rl_attribs->{basic_word_break_characters}
1986             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1987         $rl_attribs->{special_prefixes} = '$@&%';
1988         $rl_attribs->{completer_word_break_characters} .= '$@&%';
1989         $rl_attribs->{completion_function} = \&db_complete;
1990     }
1991     $LINEINFO = $OUT unless defined $LINEINFO;
1992     $lineinfo = $console unless defined $lineinfo;
1993     $term->MinLine(2);
1994     if ($term->Features->{setHistory} and "@hist" ne "?") {
1995       $term->SetHistory(@hist);
1996     }
1997     ornaments($ornaments) if defined $ornaments;
1998     $term_pid = $$;
1999 }
2000
2001 # Example get_fork_TTY functions
2002 sub xterm_get_fork_TTY {
2003   (my $name = $0) =~ s,^.*[/\\],,s;
2004   open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2005  sleep 10000000' |];
2006   my $tty = <XT>;
2007   chomp $tty;
2008   $pidprompt = '';              # Shown anyway in titlebar
2009   return $tty;
2010 }
2011
2012 # This one resets $IN, $OUT itself
2013 sub os2_get_fork_TTY {
2014   $^F = 40;             # XXXX Fixme!
2015   my ($in1, $out1, $in2, $out2);
2016   # Having -d in PERL5OPT would lead to a disaster...
2017   local $ENV{PERL5OPT} = $ENV{PERL5OPT}    if $ENV{PERL5OPT};
2018   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b//  if $ENV{PERL5OPT};
2019   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2020   print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2021   (my $name = $0) =~ s,^.*[/\\],,s;
2022   if ( pipe $in1, $out1 and pipe $in2, $out2 and
2023        # system P_SESSION will fail if there is another process
2024        # in the same session with a "dependent" asynchronous child session.
2025        (($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
2026 use Term::ReadKey;
2027 use OS2::Process;
2028
2029 my $in = shift;         # Read from here and pass through
2030 set_title pop;
2031 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2032   open IN, '<&=$in' or die "open <&=$in: \$!";
2033   \$| = 1; print while sysread IN, \$_, 1<<16;
2034 EOS
2035
2036 my $out = shift;
2037 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2038 select OUT;    $| = 1;
2039 ReadMode 4;             # Nodelay on kbd.  Pipe is automatically nodelay...
2040 print while sysread STDIN, $_, 1<<16;
2041 ES
2042         and close $in1 and close $out2 ) {
2043       $pidprompt = '';          # Shown anyway in titlebar
2044       reset_IN_OUT($in2, $out1);
2045       $tty = '*reset*';
2046       return '';                        # Indicate that reset_IN_OUT is called
2047    }
2048    return;
2049 }
2050
2051 sub create_IN_OUT {     # Create a window with IN/OUT handles redirected there
2052     my $in = &get_fork_TTY if defined &get_fork_TTY;
2053     $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2054     if (not defined $in) {
2055       my $why = shift;
2056       print_help(<<EOP) if $why == 1;
2057 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2058 EOP
2059       print_help(<<EOP) if $why == 2;
2060 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2061   This may be an asynchronous session, so the parent debugger may be active.
2062 EOP
2063       print_help(<<EOP) if $why != 4;
2064   Since two debuggers fight for the same TTY, input is severely entangled.
2065
2066 EOP
2067       print_help(<<EOP);
2068   I know how to switch the output to a different window in xterms
2069   and OS/2 consoles only.  For a manual switch, put the name of the created I<TTY>
2070   in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2071
2072   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2073   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2074
2075 EOP
2076     } elsif ($in ne '') {
2077       TTY($in);
2078     }
2079     undef $fork_TTY;
2080 }
2081
2082 sub resetterm {                 # We forked, so we need a different TTY
2083     my $in = shift;
2084     my $systemed = $in > 1 ? '-' : '';
2085     if ($pids) {
2086       $pids =~ s/\]/$systemed->$$]/;
2087     } else {
2088       $pids = "[$term_pid->$$]";
2089     }
2090     $pidprompt = $pids;
2091     $term_pid = $$;
2092     return unless $CreateTTY & $in;
2093     create_IN_OUT($in);
2094 }
2095
2096 sub readline {
2097   local $.;
2098   if (@typeahead) {
2099     my $left = @typeahead;
2100     my $got = shift @typeahead;
2101     print $OUT "auto(-$left)", shift, $got, "\n";
2102     $term->AddHistory($got)
2103       if length($got) > 1 and defined $term->Features->{addHistory};
2104     return $got;
2105   }
2106   local $frame = 0;
2107   local $doret = -2;
2108   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2109     $OUT->write(join('', @_));
2110     my $stuff;
2111     $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
2112     $stuff;
2113   }
2114   else {
2115     $term->readline(@_);
2116   }
2117 }
2118
2119 sub dump_option {
2120     my ($opt, $val)= @_;
2121     $val = option_val($opt,'N/A');
2122     $val =~ s/([\\\'])/\\$1/g;
2123     printf $OUT "%20s = '%s'\n", $opt, $val;
2124 }
2125
2126 sub option_val {
2127     my ($opt, $default)= @_;
2128     my $val;
2129     if (defined $optionVars{$opt}
2130         and defined ${$optionVars{$opt}}) {
2131         $val = ${$optionVars{$opt}};
2132     } elsif (defined $optionAction{$opt}
2133         and defined &{$optionAction{$opt}}) {
2134         $val = &{$optionAction{$opt}}();
2135     } elsif (defined $optionAction{$opt}
2136              and not defined $option{$opt}
2137              or defined $optionVars{$opt}
2138              and not defined ${$optionVars{$opt}}) {
2139         $val = $default;
2140     } else {
2141         $val = $option{$opt};
2142     }
2143     $val = $default unless defined $val;
2144     $val
2145 }
2146
2147 sub parse_options {
2148     local($_)= @_;
2149     # too dangerous to let intuitive usage overwrite important things
2150     # defaultion should never be the default
2151     my %opt_needs_val = map { ( $_ => 1 ) } qw{
2152         arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2153         pager quote ReadLine recallCommand RemotePort ShellBang TTY
2154     };
2155     while (length) {
2156         my $val_defaulted;
2157         s/^\s+// && next;
2158         s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2159         my ($opt,$sep) = ($1,$2);
2160         my $val;
2161         if ("?" eq $sep) {
2162             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2163               if /^\S/;
2164             #&dump_option($opt);
2165         } elsif ($sep !~ /\S/) {
2166             $val_defaulted = 1;
2167             $val = "1";  #  this is an evil default; make 'em set it!
2168         } elsif ($sep eq "=") {
2169
2170             if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2171                 my $quote = $1;
2172                 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2173             } else {
2174                 s/^(\S*)//;
2175             $val = $1;
2176                 print OUT qq(Option better cleared using $opt=""\n)
2177                     unless length $val;
2178             }
2179
2180         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2181             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2182             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2183               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2184             ($val = $1) =~ s/\\([\\$end])/$1/g;
2185         }
2186
2187         my $option;
2188         my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
2189                    || grep( /^\Q$opt/i && ($option = $_),  @options  );
2190
2191         print($OUT "Unknown option `$opt'\n"), next     unless $matches;
2192         print($OUT "Ambiguous option `$opt'\n"), next   if $matches > 1;
2193
2194        if ($opt_needs_val{$option} && $val_defaulted) {
2195             print $OUT "Option `$opt' is non-boolean.  Use `O $option=VAL' to set, `O $option?' to query\n";
2196             next;
2197         }
2198
2199         $option{$option} = $val if defined $val;
2200
2201         eval qq{
2202                 local \$frame = 0;
2203                 local \$doret = -2;
2204                 require '$optionRequire{$option}';
2205                 1;
2206          } || die  # XXX: shouldn't happen
2207             if  defined $optionRequire{$option}     &&
2208                 defined $val;
2209
2210         ${$optionVars{$option}} = $val
2211             if  defined $optionVars{$option}        &&
2212                 defined $val;
2213
2214         &{$optionAction{$option}} ($val)
2215             if defined $optionAction{$option}       &&
2216                defined &{$optionAction{$option}}    &&
2217                defined $val;
2218
2219         # Not $rcfile
2220         dump_option($option)    unless $OUT eq \*STDERR;
2221     }
2222 }
2223
2224 sub set_list {
2225   my ($stem,@list) = @_;
2226   my $val;
2227   $ENV{"${stem}_n"} = @list;
2228   for $i (0 .. $#list) {
2229     $val = $list[$i];
2230     $val =~ s/\\/\\\\/g;
2231     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2232     $ENV{"${stem}_$i"} = $val;
2233   }
2234 }
2235
2236 sub get_list {
2237   my $stem = shift;
2238   my @list;
2239   my $n = delete $ENV{"${stem}_n"};
2240   my $val;
2241   for $i (0 .. $n - 1) {
2242     $val = delete $ENV{"${stem}_$i"};
2243     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2244     push @list, $val;
2245   }
2246   @list;
2247 }
2248
2249 sub catch {
2250     $signal = 1;
2251     return;                     # Put nothing on the stack - malloc/free land!
2252 }
2253
2254 sub warn {
2255     my($msg)= join("",@_);
2256     $msg .= ": $!\n" unless $msg =~ /\n$/;
2257     print $OUT $msg;
2258 }
2259
2260 sub reset_IN_OUT {
2261     my $switch_li = $LINEINFO eq $OUT;
2262     if ($term and $term->Features->{newTTY}) {
2263       ($IN, $OUT) = (shift, shift);
2264       $term->newTTY($IN, $OUT);
2265     } elsif ($term) {
2266         &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2267     } else {
2268       ($IN, $OUT) = (shift, shift);
2269     }
2270     my $o = select $OUT;
2271     $| = 1;
2272     select $o;
2273     $LINEINFO = $OUT if $switch_li;
2274 }
2275
2276 sub TTY {
2277     if (@_ and $term and $term->Features->{newTTY}) {
2278       my ($in, $out) = shift;
2279       if ($in =~ /,/) {
2280         ($in, $out) = split /,/, $in, 2;
2281       } else {
2282         $out = $in;
2283       }
2284       open IN, $in or die "cannot open `$in' for read: $!";
2285       open OUT, ">$out" or die "cannot open `$out' for write: $!";
2286       reset_IN_OUT(\*IN,\*OUT);
2287       return $tty = $in;
2288     }
2289     &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2290     # Useful if done through PERLDB_OPTS:
2291     $tty = shift if @_;
2292     $tty or $console;
2293 }
2294
2295 sub noTTY {
2296     if ($term) {
2297         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2298     }
2299     $notty = shift if @_;
2300     $notty;
2301 }
2302
2303 sub ReadLine {
2304     if ($term) {
2305         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2306     }
2307     $rl = shift if @_;
2308     $rl;
2309 }
2310
2311 sub RemotePort {
2312     if ($term) {
2313         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2314     }
2315     $remoteport = shift if @_;
2316     $remoteport;
2317 }
2318
2319 sub tkRunning {
2320     if (${$term->Features}{tkRunning}) {
2321         return $term->tkRunning(@_);
2322     } else {
2323         print $OUT "tkRunning not supported by current ReadLine package.\n";
2324         0;
2325     }
2326 }
2327
2328 sub NonStop {
2329     if ($term) {
2330         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2331     }
2332     $runnonstop = shift if @_;
2333     $runnonstop;
2334 }
2335
2336 sub pager {
2337     if (@_) {
2338         $pager = shift;
2339         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2340     }
2341     $pager;
2342 }
2343
2344 sub shellBang {
2345     if (@_) {
2346         $sh = quotemeta shift;
2347         $sh .= "\\b" if $sh =~ /\w$/;
2348     }
2349     $psh = $sh;
2350     $psh =~ s/\\b$//;
2351     $psh =~ s/\\(.)/$1/g;
2352     $psh;
2353 }
2354
2355 sub ornaments {
2356   if (defined $term) {
2357     local ($warnLevel,$dieLevel) = (0, 1);
2358     return '' unless $term->Features->{ornaments};
2359     eval { $term->ornaments(@_) } || '';
2360   } else {
2361     $ornaments = shift;
2362   }
2363 }
2364
2365 sub recallCommand {
2366     if (@_) {
2367         $rc = quotemeta shift;
2368         $rc .= "\\b" if $rc =~ /\w$/;
2369     }
2370     $prc = $rc;
2371     $prc =~ s/\\b$//;
2372     $prc =~ s/\\(.)/$1/g;
2373     $prc;
2374 }
2375
2376 sub LineInfo {
2377     return $lineinfo unless @_;
2378     $lineinfo = shift;
2379     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2380     $slave_editor = ($stream =~ /^\|/);
2381     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2382     $LINEINFO = \*LINEINFO;
2383     my $save = select($LINEINFO);
2384     $| = 1;
2385     select($save);
2386     $lineinfo;
2387 }
2388
2389 sub list_versions {
2390   my %version;
2391   my $file;
2392   for (keys %INC) {
2393     $file = $_;
2394     s,\.p[lm]$,,i ;
2395     s,/,::,g ;
2396     s/^perl5db$/DB/;
2397     s/^Term::ReadLine::readline$/readline/;
2398     if (defined ${ $_ . '::VERSION' }) {
2399       $version{$file} = "${ $_ . '::VERSION' } from ";
2400     }
2401     $version{$file} .= $INC{$file};
2402   }
2403   dumpit($OUT,\%version);
2404 }
2405
2406 sub sethelp {
2407     # XXX: make sure there are tabs between the command and explanation,
2408     #      or print_help will screw up your formatting if you have
2409     #      eeevil ornaments enabled.  This is an insane mess.
2410
2411     $help = "
2412 B<T>            Stack trace.
2413 B<s> [I<expr>]  Single step [in I<expr>].
2414 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
2415 <B<CR>>         Repeat last B<n> or B<s> command.
2416 B<r>            Return from current subroutine.
2417 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
2418                 at the specified position.
2419 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
2420 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
2421 B<l> I<line>            List single I<line>.
2422 B<l> I<subname> List first window of lines from subroutine.
2423 B<l> I<\$var>           List first window of lines from subroutine referenced by I<\$var>.
2424 B<l>            List next window of lines.
2425 B<->            List previous window of lines.
2426 B<w> [I<line>]  List window around I<line>.
2427 B<.>            Return to the executed line.
2428 B<f> I<filename>        Switch to viewing I<filename>. File must be already loaded.
2429                 I<filename> may be either the full name of the file, or a regular
2430                 expression matching the full file name:
2431                 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2432                 Evals (with saved bodies) are considered to be filenames:
2433                 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2434                 (in the order of execution).
2435 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
2436 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
2437 B<L>            List all breakpoints and actions.
2438 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2439 B<t>            Toggle trace mode.
2440 B<t> I<expr>            Trace through execution of I<expr>.
2441 B<b> [I<line>] [I<condition>]
2442                 Set breakpoint; I<line> defaults to the current execution line;
2443                 I<condition> breaks if it evaluates to true, defaults to '1'.
2444 B<b> I<subname> [I<condition>]
2445                 Set breakpoint at first line of subroutine.
2446 B<b> I<\$var>           Set breakpoint at first line of subroutine referenced by I<\$var>.
2447 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2448 B<b> B<postpone> I<subname> [I<condition>]
2449                 Set breakpoint at first line of subroutine after
2450                 it is compiled.
2451 B<b> B<compile> I<subname>
2452                 Stop after the subroutine is compiled.
2453 B<d> [I<line>]  Delete the breakpoint for I<line>.
2454 B<D>            Delete all breakpoints.
2455 B<a> [I<line>] I<command>
2456                 Set an action to be done before the I<line> is executed;
2457                 I<line> defaults to the current execution line.
2458                 Sequence is: check for breakpoint/watchpoint, print line
2459                 if necessary, do action, prompt user if necessary,
2460                 execute line.
2461 B<a> [I<line>]  Delete the action for I<line>.
2462 B<A>            Delete all actions.
2463 B<W> I<expr>            Add a global watch-expression.
2464 B<W>            Delete all watch-expressions.
2465 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2466                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2467 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
2468 B<x> I<expr>            Evals expression in list context, dumps the result.
2469 B<m> I<expr>            Evals expression in list context, prints methods callable
2470                 on the first element of the result.
2471 B<m> I<class>           Prints methods callable via the given class.
2472
2473 B<<> ?                  List Perl commands to run before each prompt.
2474 B<<> I<expr>            Define Perl command to run before each prompt.
2475 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
2476 B<>> ?                  List Perl commands to run after each prompt.
2477 B<>> I<expr>            Define Perl command to run after each prompt.
2478 B<>>B<>> I<expr>                Add to the list of Perl commands to run after each prompt.
2479 B<{> I<db_command>      Define debugger command to run before each prompt.
2480 B<{> ?                  List debugger commands to run before each prompt.
2481 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
2482 B<$prc> I<number>       Redo a previous command (default previous command).
2483 B<$prc> I<-number>      Redo number'th-to-last command.
2484 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
2485                 See 'B<O> I<recallCommand>' too.
2486 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2487   . ( $rc eq $sh ? "" : "
2488 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2489                 See 'B<O> I<shellBang>' too.
2490 B<H> I<-number> Display last number commands (default all).
2491 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
2492 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
2493 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2494 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
2495 I<command>              Execute as a perl statement in current package.
2496 B<v>            Show versions of loaded modules.
2497 B<R>            Pure-man-restart of debugger, some of debugger state
2498                 and command-line options may be lost.
2499                 Currently the following settings are preserved:
2500                 history, breakpoints and actions, debugger B<O>ptions
2501                 and the following command-line options: I<-w>, I<-I>, I<-e>.
2502
2503 B<O> [I<opt>] ...       Set boolean option to true
2504 B<O> [I<opt>B<?>]       Query options
2505 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2506                 Set options.  Use quotes in spaces in value.
2507     I<recallCommand>, I<ShellBang>      chars used to recall command or spawn shell;
2508     I<pager>                    program for output of \"|cmd\";
2509     I<tkRunning>                        run Tk while prompting (with ReadLine);
2510     I<signalLevel> I<warnLevel> I<dieLevel>     level of verbosity;
2511     I<inhibit_exit>             Allows stepping off the end of the script.
2512     I<ImmediateStop>            Debugger should stop as early as possible.
2513     I<RemotePort>                       Remote hostname:port for remote debugging
2514   The following options affect what happens with B<V>, B<X>, and B<x> commands:
2515     I<arrayDepth>, I<hashDepth>         print only first N elements ('' for all);
2516     I<compactDump>, I<veryCompact>      change style of array and hash dump;
2517     I<globPrint>                        whether to print contents of globs;
2518     I<DumpDBFiles>              dump arrays holding debugged files;
2519     I<DumpPackages>             dump symbol tables of packages;
2520     I<DumpReused>                       dump contents of \"reused\" addresses;
2521     I<quote>, I<HighBit>, I<undefPrint>         change style of string dump;
2522     I<bareStringify>            Do not print the overload-stringified value;
2523   Other options include:
2524     I<PrintRet>         affects printing of return value after B<r> command,
2525     I<frame>            affects printing messages on subroutine entry/exit.
2526     I<AutoTrace>        affects printing messages on possible breaking points.
2527     I<maxTraceLen>      gives max length of evals/args listed in stack trace.
2528     I<ornaments>        affects screen appearance of the command line.
2529     I<CreateTTY>        bits control attempts to create a new TTY on events:
2530                         1: on fork()    2: debugger is started inside debugger
2531                         4: on startup
2532         During startup options are initialized from \$ENV{PERLDB_OPTS}.
2533         You can put additional initialization options I<TTY>, I<noTTY>,
2534         I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2535         `B<R>' after you set them).
2536
2537 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
2538 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
2539 B<h h>          Summary of debugger commands.
2540 B<$doccmd> I<manpage>   Runs the external doc viewer B<$doccmd> command on the
2541                 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2542                 Set B<\$DB::doccmd> to change viewer.
2543
2544 Type `|h' for a paged display if this was too hard to read.
2545
2546 "; # Fix balance of vi % matching: }}}}
2547
2548     #  note: tabs in the following section are not-so-helpful
2549     $summary = <<"END_SUM";
2550 I<List/search source lines:>               I<Control script execution:>
2551   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
2552   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
2553   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
2554   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
2555   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
2556   B<v>           Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
2557 I<Debugger controls:>                        B<L>           List break/watch/actions
2558   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
2559   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2560   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
2561   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
2562   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
2563   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
2564   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2565   B<q> or B<^D>     Quit                        B<R>           Attempt a restart
2566 I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2567   B<x>|B<m> I<expr>       Evals expr in list context, dumps the result or lists methods.
2568   B<p> I<expr>         Print expression (uses script's current package).
2569   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
2570   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
2571   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
2572 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2573 END_SUM
2574                                 # ')}}; # Fix balance of vi % matching
2575 }
2576
2577 sub print_help {
2578     local $_ = shift;
2579
2580     # Restore proper alignment destroyed by eeevil I<> and B<>
2581     # ornaments: A pox on both their houses!
2582     #
2583     # A help command will have everything up to and including
2584     # the first tab sequence padded into a field 16 (or if indented 20)
2585     # wide.  If it's wider than that, an extra space will be added.
2586     s{
2587         ^                       # only matters at start of line
2588           ( \040{4} | \t )*     # some subcommands are indented
2589           ( < ?                 # so <CR> works
2590             [BI] < [^\t\n] + )  # find an eeevil ornament
2591           ( \t+ )               # original separation, discarded
2592           ( .* )                # this will now start (no earlier) than
2593                                 # column 16
2594     } {
2595         my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2596         my $clean = $command;
2597         $clean =~ s/[BI]<([^>]*)>/$1/g;
2598     # replace with this whole string:
2599         ($leadwhite ? " " x 4 : "")
2600       . $command
2601       . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2602       . $text;
2603
2604     }mgex;
2605
2606     s{                          # handle bold ornaments
2607         B < ( [^>] + | > ) >
2608     } {
2609           $Term::ReadLine::TermCap::rl_term_set[2]
2610         . $1
2611         . $Term::ReadLine::TermCap::rl_term_set[3]
2612     }gex;
2613
2614     s{                          # handle italic ornaments
2615         I < ( [^>] + | > ) >
2616     } {
2617           $Term::ReadLine::TermCap::rl_term_set[0]
2618         . $1
2619         . $Term::ReadLine::TermCap::rl_term_set[1]
2620     }gex;
2621
2622     print $OUT $_;
2623 }
2624
2625 sub fix_less {
2626     return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2627     my $is_less = $pager =~ /\bless\b/;
2628     if ($pager =~ /\bmore\b/) {
2629         my @st_more = stat('/usr/bin/more');
2630         my @st_less = stat('/usr/bin/less');
2631         $is_less = @st_more    && @st_less
2632                 && $st_more[0] == $st_less[0]
2633                 && $st_more[1] == $st_less[1];
2634     }
2635     # changes environment!
2636     $ENV{LESS} .= 'r'   if $is_less;
2637 }
2638
2639 sub diesignal {
2640     local $frame = 0;
2641     local $doret = -2;
2642     $SIG{'ABRT'} = 'DEFAULT';
2643     kill 'ABRT', $$ if $panic++;
2644     if (defined &Carp::longmess) {
2645         local $SIG{__WARN__} = '';
2646         local $Carp::CarpLevel = 2;             # mydie + confess
2647         &warn(Carp::longmess("Signal @_"));
2648     }
2649     else {
2650         print $DB::OUT "Got signal @_\n";
2651     }
2652     kill 'ABRT', $$;
2653 }
2654
2655 sub dbwarn {
2656   local $frame = 0;
2657   local $doret = -2;
2658   local $SIG{__WARN__} = '';
2659   local $SIG{__DIE__} = '';
2660   eval { require Carp } if defined $^S; # If error/warning during compilation,
2661                                         # require may be broken.
2662   CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2663     return unless defined &Carp::longmess;
2664   my ($mysingle,$mytrace) = ($single,$trace);
2665   $single = 0; $trace = 0;
2666   my $mess = Carp::longmess(@_);
2667   ($single,$trace) = ($mysingle,$mytrace);
2668   &warn($mess);
2669 }
2670
2671 sub dbdie {
2672   local $frame = 0;
2673   local $doret = -2;
2674   local $SIG{__DIE__} = '';
2675   local $SIG{__WARN__} = '';
2676   my $i = 0; my $ineval = 0; my $sub;
2677   if ($dieLevel > 2) {
2678       local $SIG{__WARN__} = \&dbwarn;
2679       &warn(@_);                # Yell no matter what
2680       return;
2681   }
2682   if ($dieLevel < 2) {
2683     die @_ if $^S;              # in eval propagate
2684   }
2685   # No need to check $^S, eval is much more robust nowadays
2686   eval { require Carp }; #if defined $^S;# If error/warning during compilation,
2687                                         # require may be broken.
2688
2689   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2690     unless defined &Carp::longmess;
2691
2692   # We do not want to debug this chunk (automatic disabling works
2693   # inside DB::DB, but not in Carp).
2694   my ($mysingle,$mytrace) = ($single,$trace);
2695   $single = 0; $trace = 0;
2696   my $mess = "@_";
2697   {
2698     package Carp;               # Do not include us in the list
2699     eval {
2700       $mess = Carp::longmess(@_);
2701     };
2702   }
2703   ($single,$trace) = ($mysingle,$mytrace);
2704   die $mess;
2705 }
2706
2707 sub warnLevel {
2708   if (@_) {
2709     $prevwarn = $SIG{__WARN__} unless $warnLevel;
2710     $warnLevel = shift;
2711     if ($warnLevel) {
2712       $SIG{__WARN__} = \&DB::dbwarn;
2713     } elsif ($prevwarn) {
2714       $SIG{__WARN__} = $prevwarn;
2715     }
2716   }
2717   $warnLevel;
2718 }
2719
2720 sub dieLevel {
2721   if (@_) {
2722     $prevdie = $SIG{__DIE__} unless $dieLevel;
2723     $dieLevel = shift;
2724     if ($dieLevel) {
2725       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2726       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2727       print $OUT "Stack dump during die enabled",
2728         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2729           if $I_m_init;
2730       print $OUT "Dump printed too.\n" if $dieLevel > 2;
2731     } elsif ($prevdie) {
2732       $SIG{__DIE__} = $prevdie;
2733       print $OUT "Default die handler restored.\n";
2734     }
2735   }
2736   $dieLevel;
2737 }
2738
2739 sub signalLevel {
2740   if (@_) {
2741     $prevsegv = $SIG{SEGV} unless $signalLevel;
2742     $prevbus = $SIG{BUS} unless $signalLevel;
2743     $signalLevel = shift;
2744     if ($signalLevel) {
2745       $SIG{SEGV} = \&DB::diesignal;
2746       $SIG{BUS} = \&DB::diesignal;
2747     } else {
2748       $SIG{SEGV} = $prevsegv;
2749       $SIG{BUS} = $prevbus;
2750     }
2751   }
2752   $signalLevel;
2753 }
2754
2755 sub CvGV_name {
2756   my $in = shift;
2757   my $name = CvGV_name_or_bust($in);
2758   defined $name ? $name : $in;
2759 }
2760
2761 sub CvGV_name_or_bust {
2762   my $in = shift;
2763   return if $skipCvGV;          # Backdoor to avoid problems if XS broken...
2764   return unless ref $in;
2765   $in = \&$in;                  # Hard reference...
2766   eval {require Devel::Peek; 1} or return;
2767   my $gv = Devel::Peek::CvGV($in) or return;
2768   *$gv{PACKAGE} . '::' . *$gv{NAME};
2769 }
2770
2771 sub find_sub {
2772   my $subr = shift;
2773   $sub{$subr} or do {
2774     return unless defined &$subr;
2775     my $name = CvGV_name_or_bust($subr);
2776     my $data;
2777     $data = $sub{$name} if defined $name;
2778     return $data if defined $data;
2779
2780     # Old stupid way...
2781     $subr = \&$subr;            # Hard reference
2782     my $s;
2783     for (keys %sub) {
2784       $s = $_, last if $subr eq \&$_;
2785     }
2786     $sub{$s} if $s;
2787   }
2788 }
2789
2790 sub methods {
2791   my $class = shift;
2792   $class = ref $class if ref $class;
2793   local %seen;
2794   local %packs;
2795   methods_via($class, '', 1);
2796   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2797 }
2798
2799 sub methods_via {
2800   my $class = shift;
2801   return if $packs{$class}++;
2802   my $prefix = shift;
2803   my $prepend = $prefix ? "via $prefix: " : '';
2804   my $name;
2805   for $name (grep {defined &{${"${class}::"}{$_}}}
2806              sort keys %{"${class}::"}) {
2807     next if $seen{ $name }++;
2808     print $DB::OUT "$prepend$name\n";
2809   }
2810   return unless shift;          # Recurse?
2811   for $name (@{"${class}::ISA"}) {
2812     $prepend = $prefix ? $prefix . " -> $name" : $name;
2813     methods_via($name, $prepend, 1);
2814   }
2815 }
2816
2817 sub setman {
2818     $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2819                 ? "man"             # O Happy Day!
2820                 : "perldoc";        # Alas, poor unfortunates
2821 }
2822
2823 sub runman {
2824     my $page = shift;
2825     unless ($page) {
2826         &system("$doccmd $doccmd");
2827         return;
2828     }
2829     # this way user can override, like with $doccmd="man -Mwhatever"
2830     # or even just "man " to disable the path check.
2831     unless ($doccmd eq 'man') {
2832         &system("$doccmd $page");
2833         return;
2834     }
2835
2836     $page = 'perl' if lc($page) eq 'help';
2837
2838     require Config;
2839     my $man1dir = $Config::Config{'man1dir'};
2840     my $man3dir = $Config::Config{'man3dir'};
2841     for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2842     my $manpath = '';
2843     $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2844     $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2845     chop $manpath if $manpath;
2846     # harmless if missing, I figure
2847     my $oldpath = $ENV{MANPATH};
2848     $ENV{MANPATH} = $manpath if $manpath;
2849     my $nopathopt = $^O =~ /dunno what goes here/;
2850     if (CORE::system($doccmd,
2851                 # I just *know* there are men without -M
2852                 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2853             split ' ', $page) )
2854     {
2855         unless ($page =~ /^perl\w/) {
2856             if (grep { $page eq $_ } qw{
2857                 5004delta 5005delta amiga api apio book boot bot call compile
2858                 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2859                 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2860                 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2861                 modinstall modlib number obj op opentut os2 os390 pod port
2862                 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2863                 trap unicode var vms win32 xs xstut
2864               })
2865             {
2866                 $page =~ s/^/perl/;
2867                 CORE::system($doccmd,
2868                         (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2869                         $page);
2870             }
2871         }
2872     }
2873     if (defined $oldpath) {
2874         $ENV{MANPATH} = $manpath;
2875     } else {
2876         delete $ENV{MANPATH};
2877     }
2878 }
2879
2880 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2881
2882 BEGIN {                 # This does not compile, alas.
2883   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
2884   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
2885   $sh = '!';
2886   $rc = ',';
2887   @hist = ('?');
2888   $deep = 100;                  # warning if stack gets this deep
2889   $window = 10;
2890   $preview = 3;
2891   $sub = '';
2892   $SIG{INT} = \&DB::catch;
2893   # This may be enabled to debug debugger:
2894   #$warnLevel = 1 unless defined $warnLevel;
2895   #$dieLevel = 1 unless defined $dieLevel;
2896   #$signalLevel = 1 unless defined $signalLevel;
2897
2898   $db_stop = 0;                 # Compiler warning
2899   $db_stop = 1 << 30;
2900   $level = 0;                   # Level of recursive debugging
2901   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2902   # Triggers bug (?) in perl is we postpone this until runtime:
2903   @postponed = @stack = (0);
2904   $stack_depth = 0;             # Localized $#stack
2905   $doret = -2;
2906   $frame = 0;
2907 }
2908
2909 BEGIN {$^W = $ini_warn;}        # Switch warnings back
2910
2911 #use Carp;                      # This did break, left for debugging
2912
2913 sub db_complete {
2914   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2915   my($text, $line, $start) = @_;
2916   my ($itext, $search, $prefix, $pack) =
2917     ($text, "^\Q${'package'}::\E([^:]+)\$");
2918
2919   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2920                                (map { /$search/ ? ($1) : () } keys %sub)
2921     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2922   return sort grep /^\Q$text/, values %INC # files
2923     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2924   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2925     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2926       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2927   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2928     grep !/^main::/,
2929       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2930                                  # packages
2931         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2932           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
2933   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2934     # We may want to complete to (eval 9), so $text may be wrong
2935     $prefix = length($1) - length($text);
2936     $text = $1;
2937     return sort
2938         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2939   }
2940   if ((substr $text, 0, 1) eq '&') { # subroutines
2941     $text = substr $text, 1;
2942     $prefix = "&";
2943     return sort map "$prefix$_",
2944                grep /^\Q$text/,
2945                  (keys %sub),
2946                  (map { /$search/ ? ($1) : () }
2947                     keys %sub);
2948   }
2949   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2950     $pack = ($1 eq 'main' ? '' : $1) . '::';
2951     $prefix = (substr $text, 0, 1) . $1 . '::';
2952     $text = $2;
2953     my @out
2954       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2955     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2956       return db_complete($out[0], $line, $start);
2957     }
2958     return sort @out;
2959   }
2960   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2961     $pack = ($package eq 'main' ? '' : $package) . '::';
2962     $prefix = substr $text, 0, 1;
2963     $text = substr $text, 1;
2964     my @out = map "$prefix$_", grep /^\Q$text/,
2965        (grep /^_?[a-zA-Z]/, keys %$pack),
2966        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2967     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2968       return db_complete($out[0], $line, $start);
2969     }
2970     return sort @out;
2971   }
2972   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2973     my @out = grep /^\Q$text/, @options;
2974     my $val = option_val($out[0], undef);
2975     my $out = '? ';
2976     if (not defined $val or $val =~ /[\n\r]/) {
2977       # Can do nothing better
2978     } elsif ($val =~ /\s/) {
2979       my $found;
2980       foreach $l (split //, qq/\"\'\#\|/) {
2981         $out = "$l$val$l ", last if (index $val, $l) == -1;
2982       }
2983     } else {
2984       $out = "=$val ";
2985     }
2986     # Default to value if one completion, to question if many
2987     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2988     return sort @out;
2989   }
2990   return $term->filename_list($text); # filenames
2991 }
2992
2993 sub end_report {
2994   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
2995 }
2996
2997 END {
2998   $finished = 1 if $inhibit_exit;      # So that some keys may be disabled.
2999   $fall_off_end = 1 unless $inhibit_exit;
3000   # Do not stop in at_exit() and destructors on exit:
3001   $DB::single = !$fall_off_end && !$runnonstop;
3002   DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3003 }
3004
3005 package DB::fake;
3006
3007 sub at_exit {
3008   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
3009 }
3010
3011 package DB;                     # Do not trace this 1; below!
3012
3013 1;