lib/perl5db.pl

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