lib/perl5db.pl

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