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