lib/perl5db.pl

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