lib/perl5db.pl

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