lib/perl5db.pl

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