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