lib/perl5db.pl

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