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