lib/perl5db.pl

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