lib/perl5db.pl

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