lib/perl5db.pl

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