lib/perl5db.pl

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