lib/perl5db.pl

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