lib/perl5db.pl

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