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