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