lib/perl5db.pl

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