lib/perl5db.pl

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