lib/perl5db.pl

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