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