lib/perl5db.pl

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