lib/perl5db.pl

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