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      = 0     unless defined $warnLevel;
 278 $dieLevel       = 0     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                     $cmd =~ s/^\s+//s;   # trim annoying leading whitespace
 608                     $cmd =~ s/\s+$//s;   # trim annoying trailing whitespace
 609                     ($i) = split(/\s+/,$cmd);
 610                     if ($alias{$i}) {
 611                         # squelch the sigmangler
 612                         local $SIG{__DIE__};
 613                         local $SIG{__WARN__};
 614                         eval "\$cmd =~ $alias{$i}";
 615                         if ($@) {
 616                             print $OUT "Couldn't evaluate `$i' alias: $@";
 617                             next CMD;
 618                         }
 619                     }
 620                     $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
 621                     $cmd =~ /^h$/ && do {
 622                         print_help($help);
 623                         next CMD; };
 624                     $cmd =~ /^h\s+h$/ && do {
 625                         print_help($summary);
 626                         next CMD; };
 627                     # support long commands; otherwise bogus errors
 628                     # happen when you ask for h on <CR> for example
 629                     $cmd =~ /^h\s+(\S.*)$/ && do {
 630                         my $asked = $1;                 # for proper errmsg
 631                         my $qasked = quotemeta($asked); # for searching
 632                         # XXX: finds CR but not <CR>
 633                         if ($help =~ /^<?(?:[IB]<)$qasked/m) {
 634                           while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
 635                             print_help($1);
 636                           }
 637                         } else {
 638                             print_help("B<$asked> is not a debugger command.\n");
 639                         }
 640                         next CMD; };
 641                     $cmd =~ /^t$/ && do {
 642                         $trace ^= 1;
 643                         print $OUT "Trace = " .
 644                             (($trace & 1) ? "on" : "off" ) . "\n";
 645                         next CMD; };
 646                     $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
 647                         $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
 648                         foreach $subname (sort(keys %sub)) {
 649                             if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
 650                                 print $OUT $subname,"\n";
 651                             }
 652                         }
 653                         next CMD; };
 654                     $cmd =~ /^v$/ && do {
 655                         list_versions(); next CMD};
 656                     $cmd =~ s/^X\b/V $package/;
 657                     $cmd =~ /^V$/ && do {
 658                         $cmd = "V $package"; };
 659                     $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
 660                         local ($savout) = select($OUT);
 661                         $packname = $1;
 662                         @vars = split(' ',$2);
 663                         do 'dumpvar.pl' unless defined &main::dumpvar;
 664                         if (defined &main::dumpvar) {
 665                             local $frame = 0;
 666                             local $doret = -2;
 667                             # must detect sigpipe failures
 668                             eval { &main::dumpvar($packname,@vars) };
 669                             if ($@) {
 670                                 die unless $@ =~ /dumpvar print failed/;
 671                             }
 672                         } else {
 673                             print $OUT "dumpvar.pl not available.\n";
 674                         }
 675                         select ($savout);
 676                         next CMD; };
 677                     $cmd =~ s/^x\b/ / && do { # So that will be evaled
 678                         $onetimeDump = 'dump'; };
 679                     $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
 680                         methods($1); next CMD};
 681                     $cmd =~ s/^m\b/ / && do { # So this will be evaled
 682                         $onetimeDump = 'methods'; };
 683                     $cmd =~ /^f\b\s*(.*)/ && do {
 684                         $file = $1;
 685                         $file =~ s/\s+$//;
 686                         if (!$file) {
 687                             print $OUT "The old f command is now the r command.\n";
 688                             print $OUT "The new f command switches filenames.\n";
 689                             next CMD;
 690                         }
 691                         if (!defined $main::{'_<' . $file}) {
 692                             if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
 693                                               $try = substr($try,2);
 694                                               print $OUT "Choosing $try matching `$file':\n";
 695                                               $file = $try;
 696                                           }}
 697                         }
 698                         if (!defined $main::{'_<' . $file}) {
 699                             print $OUT "No file matching `$file' is loaded.\n";
 700                             next CMD;
 701                         } elsif ($file ne $filename) {
 702                             *dbline = $main::{'_<' . $file};
 703                             $max = $#dbline;
 704                             $filename = $file;
 705                             $start = 1;
 706                             $cmd = "l";
 707                           } else {
 708                             print $OUT "Already in $file.\n";
 709                             next CMD;
 710                           }
 711                       };
 712                     $cmd =~ s/^l\s+-\s*$/-/;
 713                     $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
 714                         $evalarg = $2;
 715                         my ($s) = &eval;
 716                         print($OUT "Error: $@\n"), next CMD if $@;
 717                         $s = CvGV_name($s);
 718                         print($OUT "Interpreted as: $1 $s\n");
 719                         $cmd = "$1 $s";
 720                     };
 721                     $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
 722                         $subname = $1;
 723                         $subname =~ s/\'/::/;
 724                         $subname = $package."::".$subname
 725                           unless $subname =~ /::/;
 726                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 727                         @pieces = split(/:/,find_sub($subname) || $sub{$subname});
 728                         $subrange = pop @pieces;
 729                         $file = join(':', @pieces);
 730                         if ($file ne $filename) {
 731                             print $OUT "Switching to file '$file'.\n"
 732                                 unless $slave_editor;
 733                             *dbline = $main::{'_<' . $file};
 734                             $max = $#dbline;
 735                             $filename = $file;
 736                         }
 737                         if ($subrange) {
 738                             if (eval($subrange) < -$window) {
 739                                 $subrange =~ s/-.*/+/;
 740                             }
 741                             $cmd = "l $subrange";
 742                         } else {
 743                             print $OUT "Subroutine $subname not found.\n";
 744                             next CMD;
 745                         } };
 746                     $cmd =~ /^\.$/ && do {
 747                         $incr = -1;             # for backward motion.
 748                         $start = $line;
 749                         $filename = $filename_ini;
 750                         *dbline = $main::{'_<' . $filename};
 751                         $max = $#dbline;
 752                         print $LINEINFO $position;
 753                         next CMD };
 754                     $cmd =~ /^w\b\s*(\d*)$/ && do {
 755                         $incr = $window - 1;
 756                         $start = $1 if $1;
 757                         $start -= $preview;
 758                         #print $OUT 'l ' . $start . '-' . ($start + $incr);
 759                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 760                     $cmd =~ /^-$/ && do {
 761                         $start -= $incr + $window + 1;
 762                         $start = 1 if $start <= 0;
 763                         $incr = $window - 1;
 764                         $cmd = 'l ' . ($start) . '+'; };
 765                     $cmd =~ /^l$/ && do {
 766                         $incr = $window - 1;
 767                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 768                     $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
 769                         $start = $1 if $1;
 770                         $incr = $2;
 771                         $incr = $window - 1 unless $incr;
 772                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 773                     $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 774                         $end = (!defined $2) ? $max : ($4 ? $4 : $2);
 775                         $end = $max if $end > $max;
 776                         $i = $2;
 777                         $i = $line if $i eq '.';
 778                         $i = 1 if $i < 1;
 779                         $incr = $end - $i;
 780                         if ($slave_editor) {
 781                             print $OUT "\032\032$filename:$i:0\n";
 782                             $i = $end;
 783                         } else {
 784                             for (; $i <= $end; $i++) {
 785                                 ($stop,$action) = split(/\0/, $dbline{$i});
 786                                 $arrow = ($i==$line
 787                                           and $filename eq $filename_ini)
 788                                   ?  '==>'
 789                                     : ($dbline[$i]+0 ? ':' : ' ') ;
 790                                 $arrow .= 'b' if $stop;
 791                                 $arrow .= 'a' if $action;
 792                                 print $OUT "$i$arrow\t", $dbline[$i];
 793                                 $i++, last if $signal;
 794                             }
 795                             print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
 796                         }
 797                         $start = $i; # remember in case they want more
 798                         $start = $max if $start > $max;
 799                         next CMD; };
 800                     $cmd =~ /^D$/ && do {
 801                       print $OUT "Deleting all breakpoints...\n";
 802                       my $file;
 803                       for $file (keys %had_breakpoints) {
 804                         local *dbline = $main::{'_<' . $file};
 805                         my $max = $#dbline;
 806                         my $was;
 807
 808                         for ($i = 1; $i <= $max ; $i++) {
 809                             if (defined $dbline{$i}) {
 810                                 $dbline{$i} =~ s/^[^\0]+//;
 811                                 if ($dbline{$i} =~ s/^\0?$//) {
 812                                     delete $dbline{$i};
 813                                 }
 814                             }
 815                         }
 816
 817                         if (not $had_breakpoints{$file} &= ~1) {
 818                             delete $had_breakpoints{$file};
 819                         }
 820                       }
 821                       undef %postponed;
 822                       undef %postponed_file;
 823                       undef %break_on_load;
 824                       next CMD; };
 825                     $cmd =~ /^L$/ && do {
 826                       my $file;
 827                       for $file (keys %had_breakpoints) {
 828                         local *dbline = $main::{'_<' . $file};
 829                         my $max = $#dbline;
 830                         my $was;
 831
 832                         for ($i = 1; $i <= $max; $i++) {
 833                             if (defined $dbline{$i}) {
 834                                 print $OUT "$file:\n" unless $was++;
 835                                 print $OUT " $i:\t", $dbline[$i];
 836                                 ($stop,$action) = split(/\0/, $dbline{$i});
 837                                 print $OUT "   break if (", $stop, ")\n"
 838                                   if $stop;
 839                                 print $OUT "   action:  ", $action, "\n"
 840                                   if $action;
 841                                 last if $signal;
 842                             }
 843                         }
 844                       }
 845                       if (%postponed) {
 846                         print $OUT "Postponed breakpoints in subroutines:\n";
 847                         my $subname;
 848                         for $subname (keys %postponed) {
 849                           print $OUT " $subname\t$postponed{$subname}\n";
 850                           last if $signal;
 851                         }
 852                       }
 853                       my @have = map { # Combined keys
 854                         keys %{$postponed_file{$_}}
 855                       } keys %postponed_file;
 856                       if (@have) {
 857                         print $OUT "Postponed breakpoints in files:\n";
 858                         my ($file, $line);
 859                         for $file (keys %postponed_file) {
 860                           my $db = $postponed_file{$file};
 861                           print $OUT " $file:\n";
 862                           for $line (sort {$a <=> $b} keys %$db) {
 863                                 print $OUT "  $line:\n";
 864                                 my ($stop,$action) = split(/\0/, $$db{$line});
 865                                 print $OUT "    break if (", $stop, ")\n"
 866                                   if $stop;
 867                                 print $OUT "    action:  ", $action, "\n"
 868                                   if $action;
 869                                 last if $signal;
 870                           }
 871                           last if $signal;
 872                         }
 873                       }
 874                       if (%break_on_load) {
 875                         print $OUT "Breakpoints on load:\n";
 876                         my $file;
 877                         for $file (keys %break_on_load) {
 878                           print $OUT " $file\n";
 879                           last if $signal;
 880                         }
 881                       }
 882                       if ($trace & 2) {
 883                         print $OUT "Watch-expressions:\n";
 884                         my $expr;
 885                         for $expr (@to_watch) {
 886                           print $OUT " $expr\n";
 887                           last if $signal;
 888                         }
 889                       }
 890                       next CMD; };
 891                     $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
 892                         my $file = $1; $file =~ s/\s+$//;
 893                         {
 894                           $break_on_load{$file} = 1;
 895                           $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
 896                           $file .= '.pm', redo unless $file =~ /\./;
 897                         }
 898                         $had_breakpoints{$file} |= 1;
 899                         print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
 900                         next CMD; };
 901                     $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 902                         my $cond = $3 || '1';
 903                         my ($subname, $break) = ($2, $1 eq 'postpone');
 904                         $subname =~ s/\'/::/;
 905                         $subname = "${'package'}::" . $subname
 906                           unless $subname =~ /::/;
 907                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 908                         $postponed{$subname} = $break
 909                           ? "break +0 if $cond" : "compile";
 910                         next CMD; };
 911                     $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
 912                         $subname = $1;
 913                         $cond = $2 || '1';
 914                         $subname =~ s/\'/::/;
 915                         $subname = "${'package'}::" . $subname
 916                           unless $subname =~ /::/;
 917                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 918                         # Filename below can contain ':'
 919                         ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
 920                         $i += 0;
 921                         if ($i) {
 922                             local $filename = $file;
 923                             local *dbline = $main::{'_<' . $filename};
 924                             $had_breakpoints{$filename} |= 1;
 925                             $max = $#dbline;
 926                             ++$i while $dbline[$i] == 0 && $i < $max;
 927                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 928                         } else {
 929                             print $OUT "Subroutine $subname not found.\n";
 930                         }
 931                         next CMD; };
 932                     $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
 933                         $i = $1 || $line;
 934                         $cond = $2 || '1';
 935                         if ($dbline[$i] == 0) {
 936                             print $OUT "Line $i not breakable.\n";
 937                         } else {
 938                             $had_breakpoints{$filename} |= 1;
 939                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 940                         }
 941                         next CMD; };
 942                     $cmd =~ /^d\b\s*(\d*)/ && do {
 943                         $i = $1 || $line;
 944                         $dbline{$i} =~ s/^[^\0]*//;
 945                         delete $dbline{$i} if $dbline{$i} eq '';
 946                         next CMD; };
 947                     $cmd =~ /^A$/ && do {
 948                       print $OUT "Deleting all actions...\n";
 949                       my $file;
 950                       for $file (keys %had_breakpoints) {
 951                         local *dbline = $main::{'_<' . $file};
 952                         my $max = $#dbline;
 953                         my $was;
 954
 955                         for ($i = 1; $i <= $max ; $i++) {
 956                             if (defined $dbline{$i}) {
 957                                 $dbline{$i} =~ s/\0[^\0]*//;
 958                                 delete $dbline{$i} if $dbline{$i} eq '';
 959                             }
 960                         }
 961
 962                         unless ($had_breakpoints{$file} &= ~2) {
 963                             delete $had_breakpoints{$file};
 964                         }
 965                       }
 966                       next CMD; };
 967                     $cmd =~ /^O\s*$/ && do {
 968                         for (@options) {
 969                             &dump_option($_);
 970                         }
 971                         next CMD; };
 972                     $cmd =~ /^O\s*(\S.*)/ && do {
 973                         parse_options($1);
 974                         next CMD; };
 975                     $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
 976                         push @$pre, action($1);
 977                         next CMD; };
 978                     $cmd =~ /^>>\s*(.*)/ && do {
 979                         push @$post, action($1);
 980                         next CMD; };
 981                     $cmd =~ /^<\s*(.*)/ && do {
 982                         unless ($1) {
 983                             print OUT "All < actions cleared.\n";
 984                             $pre = [];
 985                             next CMD;
 986                         }
 987                         if ($1 eq '?') {
 988                             unless (@$pre) {
 989                                 print OUT "No pre-prompt Perl actions.\n";
 990                                 next CMD;
 991                             }
 992                             print OUT "Perl commands run before each prompt:\n";
 993                             for my $action ( @$pre ) {
 994                                 print "\t< -- $action\n";
 995                             }
 996                             next CMD;
 997                         }
 998                         $pre = [action($1)];
 999                         next CMD; };
1000                     $cmd =~ /^>\s*(.*)/ && do {
1001                         unless ($1) {
1002                             print OUT "All > actions cleared.\n";
1003                             $post = [];
1004                             next CMD;
1005                         }
1006                         if ($1 eq '?') {
1007                             unless (@$post) {
1008                                 print OUT "No post-prompt Perl actions.\n";
1009                                 next CMD;
1010                             }
1011                             print OUT "Perl commands run after each prompt:\n";
1012                             for my $action ( @$post ) {
1013                                 print "\t> -- $action\n";
1014                             }
1015                             next CMD;
1016                         }
1017                         $post = [action($1)];
1018                         next CMD; };
1019                     $cmd =~ /^\{\{\s*(.*)/ && do {
1020                         if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1021                             print OUT "{{ is now a debugger command\n",
1022                                 "use `;{{' if you mean Perl code\n";
1023                             $cmd = "h {{";
1024                             redo CMD;
1025                         }
1026                         push @$pretype, $1;
1027                         next CMD; };
1028                     $cmd =~ /^\{\s*(.*)/ && do {
1029                         unless ($1) {
1030                             print OUT "All { actions cleared.\n";
1031                             $pretype = [];
1032                             next CMD;
1033                         }
1034                         if ($1 eq '?') {
1035                             unless (@$pretype) {
1036                                 print OUT "No pre-prompt debugger actions.\n";
1037                                 next CMD;
1038                             }
1039                             print OUT "Debugger commands run before each prompt:\n";
1040                             for my $action ( @$pretype ) {
1041                                 print "\t{ -- $action\n";
1042                             }
1043                             next CMD;
1044                         }
1045                         if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1046                             print OUT "{ is now a debugger command\n",
1047                                 "use `;{' if you mean Perl code\n";
1048                             $cmd = "h {";
1049                             redo CMD;
1050                         }
1051                         $pretype = [$1];
1052                         next CMD; };
1053                     $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1054                         $i = $1 || $line; $j = $2;
1055                         if (length $j) {
1056                             if ($dbline[$i] == 0) {
1057                                 print $OUT "Line $i may not have an action.\n";
1058                             } else {
1059                                 $had_breakpoints{$filename} |= 2;
1060                                 $dbline{$i} =~ s/\0[^\0]*//;
1061                                 $dbline{$i} .= "\0" . action($j);
1062                             }
1063                         } else {
1064                             $dbline{$i} =~ s/\0[^\0]*//;
1065                             delete $dbline{$i} if $dbline{$i} eq '';
1066                         }
1067                         next CMD; };
1068                     $cmd =~ /^n$/ && do {
1069                         end_report(), next CMD if $finished and $level <= 1;
1070                         $single = 2;
1071                         $laststep = $cmd;
1072                         last CMD; };
1073                     $cmd =~ /^s$/ && do {
1074                         end_report(), next CMD if $finished and $level <= 1;
1075                         $single = 1;
1076                         $laststep = $cmd;
1077                         last CMD; };
1078                     $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1079                         end_report(), next CMD if $finished and $level <= 1;
1080                         $subname = $i = $1;
1081                         #  Probably not needed, since we finish an interactive
1082                         #  sub-session anyway...
1083                         # local $filename = $filename;
1084                         # local *dbline = *dbline;      # XXX Would this work?!
1085                         if ($i =~ /\D/) { # subroutine name
1086                             $subname = $package."::".$subname
1087                                 unless $subname =~ /::/;
1088                             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1089                             $i += 0;
1090                             if ($i) {
1091                                 $filename = $file;
1092                                 *dbline = $main::{'_<' . $filename};
1093                                 $had_breakpoints{$filename} |= 1;
1094                                 $max = $#dbline;
1095                                 ++$i while $dbline[$i] == 0 && $i < $max;
1096                             } else {
1097                                 print $OUT "Subroutine $subname not found.\n";
1098                                 next CMD;
1099                             }
1100                         }
1101                         if ($i) {
1102                             if ($dbline[$i] == 0) {
1103                                 print $OUT "Line $i not breakable.\n";
1104                                 next CMD;
1105                             }
1106                             $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1107                         }
1108                         for ($i=0; $i <= $stack_depth; ) {
1109                             $stack[$i++] &= ~1;
1110                         }
1111                         last CMD; };
1112                     $cmd =~ /^r$/ && do {
1113                         end_report(), next CMD if $finished and $level <= 1;
1114                         $stack[$stack_depth] |= 1;
1115                         $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1116                         last CMD; };
1117                     $cmd =~ /^R$/ && do {
1118                         print $OUT "Warning: some settings and command-line options may be lost!\n";
1119                         my (@script, @flags, $cl);
1120                         push @flags, '-w' if $ini_warn;
1121                         # Put all the old includes at the start to get
1122                         # the same debugger.
1123                         for (@ini_INC) {
1124                           push @flags, '-I', $_;
1125                         }
1126                         # Arrange for setting the old INC:
1127                         set_list("PERLDB_INC", @ini_INC);
1128                         if ($0 eq '-e') {
1129                           for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1130                                 chomp ($cl =  ${'::_<-e'}[$_]);
1131                             push @script, '-e', $cl;
1132                           }
1133                         } else {
1134                           @script = $0;
1135                         }
1136                         set_list("PERLDB_HIST",
1137                                  $term->Features->{getHistory}
1138                                  ? $term->GetHistory : @hist);
1139                         my @had_breakpoints = keys %had_breakpoints;
1140                         set_list("PERLDB_VISITED", @had_breakpoints);
1141                         set_list("PERLDB_OPT", %option);
1142                         set_list("PERLDB_ON_LOAD", %break_on_load);
1143                         my @hard;
1144                         for (0 .. $#had_breakpoints) {
1145                           my $file = $had_breakpoints[$_];
1146                           *dbline = $main::{'_<' . $file};
1147                           next unless %dbline or $postponed_file{$file};
1148                           (push @hard, $file), next
1149                             if $file =~ /^\(eval \d+\)$/;
1150                           my @add;
1151                           @add = %{$postponed_file{$file}}
1152                             if $postponed_file{$file};
1153                           set_list("PERLDB_FILE_$_", %dbline, @add);
1154                         }
1155                         for (@hard) { # Yes, really-really...
1156                           # Find the subroutines in this eval
1157                           *dbline = $main::{'_<' . $_};
1158                           my ($quoted, $sub, %subs, $line) = quotemeta $_;
1159                           for $sub (keys %sub) {
1160                             next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1161                             $subs{$sub} = [$1, $2];
1162                           }
1163                           unless (%subs) {
1164                             print $OUT
1165                               "No subroutines in $_, ignoring breakpoints.\n";
1166                             next;
1167                           }
1168                         LINES: for $line (keys %dbline) {
1169                             # One breakpoint per sub only:
1170                             my ($offset, $sub, $found);
1171                           SUBS: for $sub (keys %subs) {
1172                               if ($subs{$sub}->[1] >= $line # Not after the subroutine
1173                                   and (not defined $offset # Not caught
1174                                        or $offset < 0 )) { # or badly caught
1175                                 $found = $sub;
1176                                 $offset = $line - $subs{$sub}->[0];
1177                                 $offset = "+$offset", last SUBS if $offset >= 0;
1178                               }
1179                             }
1180                             if (defined $offset) {
1181                               $postponed{$found} =
1182                                 "break $offset if $dbline{$line}";
1183                             } else {
1184                               print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1185                             }
1186                           }
1187                         }
1188                         set_list("PERLDB_POSTPONE", %postponed);
1189                         set_list("PERLDB_PRETYPE", @$pretype);
1190                         set_list("PERLDB_PRE", @$pre);
1191                         set_list("PERLDB_POST", @$post);
1192                         set_list("PERLDB_TYPEAHEAD", @typeahead);
1193                         $ENV{PERLDB_RESTART} = 1;
1194                         #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1195                         exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS;
1196                         print $OUT "exec failed: $!\n";
1197                         last CMD; };
1198                     $cmd =~ /^T$/ && do {
1199                         print_trace($OUT, 1); # skip DB
1200                         next CMD; };
1201                     $cmd =~ /^W\s*$/ && do {
1202                         $trace &= ~2;
1203                         @to_watch = @old_watch = ();
1204                         next CMD; };
1205                     $cmd =~ /^W\b\s*(.*)/s && do {
1206                         push @to_watch, $1;
1207                         $evalarg = $1;
1208                         my ($val) = &eval;
1209                         $val = (defined $val) ? "'$val'" : 'undef' ;
1210                         push @old_watch, $val;
1211                         $trace |= 2;
1212                         next CMD; };
1213                     $cmd =~ /^\/(.*)$/ && do {
1214                         $inpat = $1;
1215                         $inpat =~ s:([^\\])/$:$1:;
1216                         if ($inpat ne "") {
1217                             # squelch the sigmangler
1218                             local $SIG{__DIE__};
1219                             local $SIG{__WARN__};
1220                             eval '$inpat =~ m'."\a$inpat\a";
1221                             if ($@ ne "") {
1222                                 print $OUT "$@";
1223                                 next CMD;
1224                             }
1225                             $pat = $inpat;
1226                         }
1227                         $end = $start;
1228                         $incr = -1;
1229                         eval '
1230                             for (;;) {
1231                                 ++$start;
1232                                 $start = 1 if ($start > $max);
1233                                 last if ($start == $end);
1234                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1235                                     if ($slave_editor) {
1236                                         print $OUT "\032\032$filename:$start:0\n";
1237                                     } else {
1238                                         print $OUT "$start:\t", $dbline[$start], "\n";
1239                                     }
1240                                     last;
1241                                 }
1242                             } ';
1243                         print $OUT "/$pat/: not found\n" if ($start == $end);
1244                         next CMD; };
1245                     $cmd =~ /^\?(.*)$/ && do {
1246                         $inpat = $1;
1247                         $inpat =~ s:([^\\])\?$:$1:;
1248                         if ($inpat ne "") {
1249                             # squelch the sigmangler
1250                             local $SIG{__DIE__};
1251                             local $SIG{__WARN__};
1252                             eval '$inpat =~ m'."\a$inpat\a";
1253                             if ($@ ne "") {
1254                                 print $OUT $@;
1255                                 next CMD;
1256                             }
1257                             $pat = $inpat;
1258                         }
1259                         $end = $start;
1260                         $incr = -1;
1261                         eval '
1262                             for (;;) {
1263                                 --$start;
1264                                 $start = $max if ($start <= 0);
1265                                 last if ($start == $end);
1266                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1267                                     if ($slave_editor) {
1268                                         print $OUT "\032\032$filename:$start:0\n";
1269                                     } else {
1270                                         print $OUT "$start:\t", $dbline[$start], "\n";
1271                                     }
1272                                     last;
1273                                 }
1274                             } ';
1275                         print $OUT "?$pat?: not found\n" if ($start == $end);
1276                         next CMD; };
1277                     $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1278                         pop(@hist) if length($cmd) > 1;
1279                         $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1280                         $cmd = $hist[$i];
1281                         print $OUT $cmd, "\n";
1282                         redo CMD; };
1283                     $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1284                         &system($1);
1285                         next CMD; };
1286                     $cmd =~ /^$rc([^$rc].*)$/ && do {
1287                         $pat = "^$1";
1288                         pop(@hist) if length($cmd) > 1;
1289                         for ($i = $#hist; $i; --$i) {
1290                             last if $hist[$i] =~ /$pat/;
1291                         }
1292                         if (!$i) {
1293                             print $OUT "No such command!\n\n";
1294                             next CMD;
1295                         }
1296                         $cmd = $hist[$i];
1297                         print $OUT $cmd, "\n";
1298                         redo CMD; };
1299                     $cmd =~ /^$sh$/ && do {
1300                         &system($ENV{SHELL}||"/bin/sh");
1301                         next CMD; };
1302                     $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1303                         # XXX: using csh or tcsh destroys sigint retvals!
1304                         #&system($1);  # use this instead
1305                         &system($ENV{SHELL}||"/bin/sh","-c",$1);
1306                         next CMD; };
1307                     $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1308                         $end = $2 ? ($#hist-$2) : 0;
1309                         $hist = 0 if $hist < 0;
1310                         for ($i=$#hist; $i>$end; $i--) {
1311                             print $OUT "$i: ",$hist[$i],"\n"
1312                               unless $hist[$i] =~ /^.?$/;
1313                         };
1314                         next CMD; };
1315                     $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1316                         runman($1);
1317                         next CMD; };
1318                     $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1319                     $cmd =~ s/^p\b/print {\$DB::OUT} /;
1320                     $cmd =~ s/^=\s*// && do {
1321                         my @keys;
1322                         if (length $cmd == 0) {
1323                             @keys = sort keys %alias;
1324                         }
1325                         elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1326                             # can't use $_ or kill //g state
1327                             for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1328                             $alias{$k} = "s\a$k\a$v\a";
1329                             # squelch the sigmangler
1330                             local $SIG{__DIE__};
1331                             local $SIG{__WARN__};
1332                             unless (eval "sub { s\a$k\a$v\a }; 1") {
1333                                 print $OUT "Can't alias $k to $v: $@\n";
1334                                 delete $alias{$k};
1335                                 next CMD;
1336                             }
1337                             @keys = ($k);
1338                         }
1339                         else {
1340                             @keys = ($cmd);
1341                         }
1342                         for my $k (@keys) {
1343                             if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
1344                                 print $OUT "$k\t= $1\n";
1345                             }
1346                             elsif (defined $alias{$k}) {
1347                                     print $OUT "$k\t$alias{$k}\n";
1348                             }
1349                             else {
1350                                 print "No alias for $k\n";
1351                             }
1352                         }
1353                         next CMD; };
1354                     $cmd =~ /^\|\|?\s*[^|]/ && do {
1355                         if ($pager =~ /^\|/) {
1356                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1357                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1358                         } else {
1359                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1360                         }
1361                         fix_less();
1362                         unless ($piped=open(OUT,$pager)) {
1363                             &warn("Can't pipe output to `$pager'");
1364                             if ($pager =~ /^\|/) {
1365                                 open(OUT,">&STDOUT") # XXX: lost message
1366                                     || &warn("Can't restore DB::OUT");
1367                                 open(STDOUT,">&SAVEOUT")
1368                                   || &warn("Can't restore STDOUT");
1369                                 close(SAVEOUT);
1370                             } else {
1371                                 open(OUT,">&STDOUT") # XXX: lost message
1372                                     || &warn("Can't restore DB::OUT");
1373                             }
1374                             next CMD;
1375                         }
1376                         $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1377                             && ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
1378                         $selected= select(OUT);
1379                         $|= 1;
1380                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1381                         $cmd =~ s/^\|+\s*//;
1382                         redo PIPE;
1383                     };
1384                     # XXX Local variants do not work!
1385                     $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1386                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1387                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1388                 }               # PIPE:
1389             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1390             if ($onetimeDump) {
1391                 $onetimeDump = undef;
1392             } elsif ($term_pid == $$) {
1393                 print $OUT "\n";
1394             }
1395         } continue {            # CMD:
1396             if ($piped) {
1397                 if ($pager =~ /^\|/) {
1398                     $? = 0;
1399                     # we cannot warn here: the handle is missing --tchrist
1400                     close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1401
1402                     # most of the $? crud was coping with broken cshisms
1403                     if ($?) {
1404                         print SAVEOUT "Pager `$pager' failed: ";
1405                         if ($? == -1) {
1406                             print SAVEOUT "shell returned -1\n";
1407                         } elsif ($? >> 8) {
1408                             print SAVEOUT
1409                               ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1410                               ( $? & 128 ) ? " -- core dumped" : "", "\n";
1411                         } else {
1412                             print SAVEOUT "status ", ($? >> 8), "\n";
1413                         }
1414                     }
1415
1416                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1417                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1418                     $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1419                     # Will stop ignoring SIGPIPE if done like nohup(1)
1420                     # does SIGINT but Perl doesn't give us a choice.
1421                 } else {
1422                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1423                 }
1424                 close(SAVEOUT);
1425                 select($selected), $selected= "" unless $selected eq "";
1426                 $piped= "";
1427             }
1428         }                       # CMD:
1429         $exiting = 1 unless defined $cmd;
1430         foreach $evalarg (@$post) {
1431           &eval;
1432         }
1433     }                           # if ($single || $signal)
1434     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1435     ();
1436 }
1437
1438 # The following code may be executed now:
1439 # BEGIN {warn 4}
1440
1441 sub sub {
1442     my ($al, $ret, @ret) = "";
1443     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1444         $al = " for $$sub";
1445     }
1446     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1447     $#stack = $stack_depth;
1448     $stack[-1] = $single;
1449     $single &= 1;
1450     $single |= 4 if $stack_depth == $deep;
1451     ($frame & 4
1452      ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in  "),
1453          # Why -1? But it works! :-(
1454          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1455      : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1456     if (wantarray) {
1457         @ret = &$sub;
1458         $single |= $stack[$stack_depth--];
1459         ($frame & 4
1460          ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1461              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1462          : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1463         if ($doret eq $stack_depth or $frame & 16) {
1464             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1465             print $fh ' ' x $stack_depth if $frame & 16;
1466             print $fh "list context return from $sub:\n";
1467             dumpit($fh, \@ret );
1468             $doret = -2;
1469         }
1470         @ret;
1471     } else {
1472         if (defined wantarray) {
1473             $ret = &$sub;
1474         } else {
1475             &$sub; undef $ret;
1476         };
1477         $single |= $stack[$stack_depth--];
1478         ($frame & 4
1479          ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1480               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1481          : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1482         if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1483             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1484             print $fh (' ' x $stack_depth) if $frame & 16;
1485             print $fh (defined wantarray
1486                          ? "scalar context return from $sub: "
1487                          : "void context return from $sub\n");
1488             dumpit( $fh, $ret ) if defined wantarray;
1489             $doret = -2;
1490         }
1491         $ret;
1492     }
1493 }
1494
1495 sub save {
1496     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1497     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1498 }
1499
1500 # The following takes its argument via $evalarg to preserve current @_
1501
1502 sub eval {
1503     # 'my' would make it visible from user code
1504     #    but so does local! --tchrist
1505     local @res;
1506     {
1507         local $otrace = $trace;
1508         local $osingle = $single;
1509         local $od = $^D;
1510         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1511         $trace = $otrace;
1512         $single = $osingle;
1513         $^D = $od;
1514     }
1515     my $at = $@;
1516     local $saved[0];            # Preserve the old value of $@
1517     eval { &DB::save };
1518     if ($at) {
1519         print $OUT $at;
1520     } elsif ($onetimeDump eq 'dump') {
1521         dumpit($OUT, \@res);
1522     } elsif ($onetimeDump eq 'methods') {
1523         methods($res[0]);
1524     }
1525     @res;
1526 }
1527
1528 sub postponed_sub {
1529   my $subname = shift;
1530   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1531     my $offset = $1 || 0;
1532     # Filename below can contain ':'
1533     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1534     if ($i) {
1535       $i += $offset;
1536       local *dbline = $main::{'_<' . $file};
1537       local $^W = 0;            # != 0 is magical below
1538       $had_breakpoints{$file} |= 1;
1539       my $max = $#dbline;
1540       ++$i until $dbline[$i] != 0 or $i >= $max;
1541       $dbline{$i} = delete $postponed{$subname};
1542     } else {
1543       print $OUT "Subroutine $subname not found.\n";
1544     }
1545     return;
1546   }
1547   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1548   #print $OUT "In postponed_sub for `$subname'.\n";
1549 }
1550
1551 sub postponed {
1552   if ($ImmediateStop) {
1553     $ImmediateStop = 0;
1554     $signal = 1;
1555   }
1556   return &postponed_sub
1557     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1558   # Cannot be done before the file is compiled
1559   local *dbline = shift;
1560   my $filename = $dbline;
1561   $filename =~ s/^_<//;
1562   $signal = 1, print $OUT "'$filename' loaded...\n"
1563     if $break_on_load{$filename};
1564   print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1565   return unless $postponed_file{$filename};
1566   $had_breakpoints{$filename} |= 1;
1567   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1568   my $key;
1569   for $key (keys %{$postponed_file{$filename}}) {
1570     $dbline{$key} = ${$postponed_file{$filename}}{$key};
1571   }
1572   delete $postponed_file{$filename};
1573 }
1574
1575 sub dumpit {
1576     local ($savout) = select(shift);
1577     my $osingle = $single;
1578     my $otrace = $trace;
1579     $single = $trace = 0;
1580     local $frame = 0;
1581     local $doret = -2;
1582     unless (defined &main::dumpValue) {
1583         do 'dumpvar.pl';
1584     }
1585     if (defined &main::dumpValue) {
1586         &main::dumpValue(shift);
1587     } else {
1588         print $OUT "dumpvar.pl not available.\n";
1589     }
1590     $single = $osingle;
1591     $trace = $otrace;
1592     select ($savout);
1593 }
1594
1595 # Tied method do not create a context, so may get wrong message:
1596
1597 sub print_trace {
1598   my $fh = shift;
1599   my @sub = dump_trace($_[0] + 1, $_[1]);
1600   my $short = $_[2];            # Print short report, next one for sub name
1601   my $s;
1602   for ($i=0; $i <= $#sub; $i++) {
1603     last if $signal;
1604     local $" = ', ';
1605     my $args = defined $sub[$i]{args}
1606     ? "(@{ $sub[$i]{args} })"
1607       : '' ;
1608     $args = (substr $args, 0, $maxtrace - 3) . '...'
1609       if length $args > $maxtrace;
1610     my $file = $sub[$i]{file};
1611     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1612     $s = $sub[$i]{sub};
1613     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1614     if ($short) {
1615       my $sub = @_ >= 4 ? $_[3] : $s;
1616       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1617     } else {
1618       print $fh "$sub[$i]{context} = $s$args" .
1619         " called from $file" .
1620           " line $sub[$i]{line}\n";
1621     }
1622   }
1623 }
1624
1625 sub dump_trace {
1626   my $skip = shift;
1627   my $count = shift || 1e9;
1628   $skip++;
1629   $count += $skip;
1630   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1631   my $nothard = not $frame & 8;
1632   local $frame = 0;             # Do not want to trace this.
1633   my $otrace = $trace;
1634   $trace = 0;
1635   for ($i = $skip;
1636        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1637        $i++) {
1638     @a = ();
1639     for $arg (@args) {
1640       my $type;
1641       if (not defined $arg) {
1642         push @a, "undef";
1643       } elsif ($nothard and tied $arg) {
1644         push @a, "tied";
1645       } elsif ($nothard and $type = ref $arg) {
1646         push @a, "ref($type)";
1647       } else {
1648         local $_ = "$arg";      # Safe to stringify now - should not call f().
1649         s/([\'\\])/\\$1/g;
1650         s/(.*)/'$1'/s
1651           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1652         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1653         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1654         push(@a, $_);
1655       }
1656     }
1657     $context = $context ? '@' : (defined $context ? "\$" : '.');
1658     $args = $h ? [@a] : undef;
1659     $e =~ s/\n\s*\;\s*\Z// if $e;
1660     $e =~ s/([\\\'])/\\$1/g if $e;
1661     if ($r) {
1662       $sub = "require '$e'";
1663     } elsif (defined $r) {
1664       $sub = "eval '$e'";
1665     } elsif ($sub eq '(eval)') {
1666       $sub = "eval {...}";
1667     }
1668     push(@sub, {context => $context, sub => $sub, args => $args,
1669                 file => $file, line => $line});
1670     last if $signal;
1671   }
1672   $trace = $otrace;
1673   @sub;
1674 }
1675
1676 sub action {
1677     my $action = shift;
1678     while ($action =~ s/\\$//) {
1679         #print $OUT "+ ";
1680         #$action .= "\n";
1681         $action .= &gets;
1682     }
1683     $action;
1684 }
1685
1686 sub unbalanced {
1687     # i hate using globals!
1688     $balanced_brace_re ||= qr{
1689         ^ \{
1690               (?:
1691                  (?> [^{}] + )              # Non-parens without backtracking
1692                |
1693                  (??{ $balanced_brace_re }) # Group with matching parens
1694               ) *
1695           \} $
1696    }x;
1697    return $_[0] !~ m/$balanced_brace_re/;
1698 }
1699
1700 sub gets {
1701     local($.);
1702     #<IN>;
1703     &readline("cont: ");
1704 }
1705
1706 sub system {
1707     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1708     # some non-Unix systems can do system() but have problems with fork().
1709     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1710     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1711     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1712     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1713
1714     # XXX: using csh or tcsh destroys sigint retvals!
1715     system(@_);
1716     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1717     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1718     close(SAVEIN);
1719     close(SAVEOUT);
1720
1721
1722     # most of the $? crud was coping with broken cshisms
1723     if ($? >> 8) {
1724         &warn("(Command exited ", ($? >> 8), ")\n");
1725     } elsif ($?) {
1726         &warn( "(Command died of SIG#",  ($? & 127),
1727             (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1728     }
1729
1730     return $?;
1731
1732 }
1733
1734 sub setterm {
1735     local $frame = 0;
1736     local $doret = -2;
1737     eval { require Term::ReadLine } or die $@;
1738     if ($notty) {
1739         if ($tty) {
1740             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1741             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1742             $IN = \*IN;
1743             $OUT = \*OUT;
1744             my $sel = select($OUT);
1745             $| = 1;
1746             select($sel);
1747         } else {
1748             eval "require Term::Rendezvous;" or die;
1749             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1750             my $term_rv = new Term::Rendezvous $rv;
1751             $IN = $term_rv->IN;
1752             $OUT = $term_rv->OUT;
1753         }
1754     }
1755     if (!$rl) {
1756         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1757     } else {
1758         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1759
1760         $rl_attribs = $term->Attribs;
1761         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1762           if defined $rl_attribs->{basic_word_break_characters}
1763             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1764         $rl_attribs->{special_prefixes} = '$@&%';
1765         $rl_attribs->{completer_word_break_characters} .= '$@&%';
1766         $rl_attribs->{completion_function} = \&db_complete;
1767     }
1768     $LINEINFO = $OUT unless defined $LINEINFO;
1769     $lineinfo = $console unless defined $lineinfo;
1770     $term->MinLine(2);
1771     if ($term->Features->{setHistory} and "@hist" ne "?") {
1772       $term->SetHistory(@hist);
1773     }
1774     ornaments($ornaments) if defined $ornaments;
1775     $term_pid = $$;
1776 }
1777
1778 sub resetterm {                 # We forked, so we need a different TTY
1779     $term_pid = $$;
1780     if (defined &get_fork_TTY) {
1781       &get_fork_TTY;
1782     } elsif (not defined $fork_TTY
1783              and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1784              and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1785         # Possibly _inside_ XTERM
1786         open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1787  sleep 10000000' |];
1788         $fork_TTY = <XT>;
1789         chomp $fork_TTY;
1790     }
1791     if (defined $fork_TTY) {
1792       TTY($fork_TTY);
1793       undef $fork_TTY;
1794     } else {
1795       print_help(<<EOP);
1796 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1797   Define B<\$DB::fork_TTY>
1798        - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1799   The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1800   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1801   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1802 EOP
1803     }
1804 }
1805
1806 sub readline {
1807   if (@typeahead) {
1808     my $left = @typeahead;
1809     my $got = shift @typeahead;
1810     print $OUT "auto(-$left)", shift, $got, "\n";
1811     $term->AddHistory($got)
1812       if length($got) > 1 and defined $term->Features->{addHistory};
1813     return $got;
1814   }
1815   local $frame = 0;
1816   local $doret = -2;
1817   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1818     print $OUT @_;
1819     my $stuff;
1820     $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
1821     $stuff;
1822   }
1823   else {
1824     $term->readline(@_);
1825   }
1826 }
1827
1828 sub dump_option {
1829     my ($opt, $val)= @_;
1830     $val = option_val($opt,'N/A');
1831     $val =~ s/([\\\'])/\\$1/g;
1832     printf $OUT "%20s = '%s'\n", $opt, $val;
1833 }
1834
1835 sub option_val {
1836     my ($opt, $default)= @_;
1837     my $val;
1838     if (defined $optionVars{$opt}
1839         and defined ${$optionVars{$opt}}) {
1840         $val = ${$optionVars{$opt}};
1841     } elsif (defined $optionAction{$opt}
1842         and defined &{$optionAction{$opt}}) {
1843         $val = &{$optionAction{$opt}}();
1844     } elsif (defined $optionAction{$opt}
1845              and not defined $option{$opt}
1846              or defined $optionVars{$opt}
1847              and not defined ${$optionVars{$opt}}) {
1848         $val = $default;
1849     } else {
1850         $val = $option{$opt};
1851     }
1852     $val
1853 }
1854
1855 sub parse_options {
1856     local($_)= @_;
1857     # too dangerous to let intuitive usage overwrite important things
1858     # defaultion should never be the default
1859     my %opt_needs_val = map { ( $_ => 1 ) } qw{
1860         arrayDepth hashDepth LineInfo maxTraceLen ornaments
1861         pager quote ReadLine recallCommand RemotePort ShellBang TTY
1862     };
1863     while (length) {
1864         my $val_defaulted;
1865         s/^\s+// && next;
1866         s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
1867         my ($opt,$sep) = ($1,$2);
1868         my $val;
1869         if ("?" eq $sep) {
1870             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1871               if /^\S/;
1872             #&dump_option($opt);
1873         } elsif ($sep !~ /\S/) {
1874             $val_defaulted = 1;
1875             $val = "1";  #  this is an evil default; make 'em set it!
1876         } elsif ($sep eq "=") {
1877
1878             if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
1879                 my $quote = $1;
1880                 ($val = $2) =~ s/\\([$quote\\])/$1/g;
1881             } else {
1882                 s/^(\S*)//;
1883             $val = $1;
1884                 print OUT qq(Option better cleared using $opt=""\n)
1885                     unless length $val;
1886             }
1887
1888         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1889             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1890             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1891               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1892             ($val = $1) =~ s/\\([\\$end])/$1/g;
1893         }
1894
1895         my $option;
1896         my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
1897                    || grep( /^\Q$opt/i && ($option = $_),  @options  );
1898
1899         print($OUT "Unknown option `$opt'\n"), next     unless $matches;
1900         print($OUT "Ambiguous option `$opt'\n"), next   if $matches > 1;
1901
1902        if ($opt_needs_val{$option} && $val_defaulted) {
1903             print $OUT "Option `$opt' is non-boolean.  Use `O $option=VAL' to set, `O $option?' to query\n";
1904             next;
1905         }
1906
1907         $option{$option} = $val if defined $val;
1908
1909         eval qq{
1910                 local \$frame = 0;
1911                 local \$doret = -2;
1912                 require '$optionRequire{$option}';
1913                 1;
1914          } || die  # XXX: shouldn't happen
1915             if  defined $optionRequire{$option}     &&
1916                 defined $val;
1917
1918         ${$optionVars{$option}} = $val
1919             if  defined $optionVars{$option}        &&
1920                 defined $val;
1921
1922         &{$optionAction{$option}} ($val)
1923             if defined $optionAction{$option}       &&
1924                defined &{$optionAction{$option}}    &&
1925                defined $val;
1926
1927         # Not $rcfile
1928         dump_option($option)    unless $OUT eq \*STDERR;
1929     }
1930 }
1931
1932 sub set_list {
1933   my ($stem,@list) = @_;
1934   my $val;
1935   $ENV{"${stem}_n"} = @list;
1936   for $i (0 .. $#list) {
1937     $val = $list[$i];
1938     $val =~ s/\\/\\\\/g;
1939     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1940     $ENV{"${stem}_$i"} = $val;
1941   }
1942 }
1943
1944 sub get_list {
1945   my $stem = shift;
1946   my @list;
1947   my $n = delete $ENV{"${stem}_n"};
1948   my $val;
1949   for $i (0 .. $n - 1) {
1950     $val = delete $ENV{"${stem}_$i"};
1951     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1952     push @list, $val;
1953   }
1954   @list;
1955 }
1956
1957 sub catch {
1958     $signal = 1;
1959     return;                     # Put nothing on the stack - malloc/free land!
1960 }
1961
1962 sub warn {
1963     my($msg)= join("",@_);
1964     $msg .= ": $!\n" unless $msg =~ /\n$/;
1965     print $OUT $msg;
1966 }
1967
1968 sub TTY {
1969     if (@_ and $term and $term->Features->{newTTY}) {
1970       my ($in, $out) = shift;
1971       if ($in =~ /,/) {
1972         ($in, $out) = split /,/, $in, 2;
1973       } else {
1974         $out = $in;
1975       }
1976       open IN, $in or die "cannot open `$in' for read: $!";
1977       open OUT, ">$out" or die "cannot open `$out' for write: $!";
1978       $term->newTTY(\*IN, \*OUT);
1979       $IN       = \*IN;
1980       $OUT      = \*OUT;
1981       return $tty = $in;
1982     } elsif ($term and @_) {
1983         &warn("Too late to set TTY, enabled on next `R'!\n");
1984     }
1985     $tty = shift if @_;
1986     $tty or $console;
1987 }
1988
1989 sub noTTY {
1990     if ($term) {
1991         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1992     }
1993     $notty = shift if @_;
1994     $notty;
1995 }
1996
1997 sub ReadLine {
1998     if ($term) {
1999         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2000     }
2001     $rl = shift if @_;
2002     $rl;
2003 }
2004
2005 sub RemotePort {
2006     if ($term) {
2007         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2008     }
2009     $remoteport = shift if @_;
2010     $remoteport;
2011 }
2012
2013 sub tkRunning {
2014     if (${$term->Features}{tkRunning}) {
2015         return $term->tkRunning(@_);
2016     } else {
2017         print $OUT "tkRunning not supported by current ReadLine package.\n";
2018         0;
2019     }
2020 }
2021
2022 sub NonStop {
2023     if ($term) {
2024         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2025     }
2026     $runnonstop = shift if @_;
2027     $runnonstop;
2028 }
2029
2030 sub pager {
2031     if (@_) {
2032         $pager = shift;
2033         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2034     }
2035     $pager;
2036 }
2037
2038 sub shellBang {
2039     if (@_) {
2040         $sh = quotemeta shift;
2041         $sh .= "\\b" if $sh =~ /\w$/;
2042     }
2043     $psh = $sh;
2044     $psh =~ s/\\b$//;
2045     $psh =~ s/\\(.)/$1/g;
2046     &sethelp;
2047     $psh;
2048 }
2049
2050 sub ornaments {
2051   if (defined $term) {
2052     local ($warnLevel,$dieLevel) = (0, 1);
2053     return '' unless $term->Features->{ornaments};
2054     eval { $term->ornaments(@_) } || '';
2055   } else {
2056     $ornaments = shift;
2057   }
2058 }
2059
2060 sub recallCommand {
2061     if (@_) {
2062         $rc = quotemeta shift;
2063         $rc .= "\\b" if $rc =~ /\w$/;
2064     }
2065     $prc = $rc;
2066     $prc =~ s/\\b$//;
2067     $prc =~ s/\\(.)/$1/g;
2068     &sethelp;
2069     $prc;
2070 }
2071
2072 sub LineInfo {
2073     return $lineinfo unless @_;
2074     $lineinfo = shift;
2075     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2076     $slave_editor = ($stream =~ /^\|/);
2077     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2078     $LINEINFO = \*LINEINFO;
2079     my $save = select($LINEINFO);
2080     $| = 1;
2081     select($save);
2082     $lineinfo;
2083 }
2084
2085 sub list_versions {
2086   my %version;
2087   my $file;
2088   for (keys %INC) {
2089     $file = $_;
2090     s,\.p[lm]$,,i ;
2091     s,/,::,g ;
2092     s/^perl5db$/DB/;
2093     s/^Term::ReadLine::readline$/readline/;
2094     if (defined ${ $_ . '::VERSION' }) {
2095       $version{$file} = "${ $_ . '::VERSION' } from ";
2096     }
2097     $version{$file} .= $INC{$file};
2098   }
2099   dumpit($OUT,\%version);
2100 }
2101
2102 sub sethelp {
2103     # XXX: make sure these are tabs between the command and explantion,
2104     #      or print_help will screw up your formatting if you have
2105     #      eeevil ornaments enabled.  This is an insane mess.
2106
2107     $help = "
2108 B<T>            Stack trace.
2109 B<s> [I<expr>]  Single step [in I<expr>].
2110 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
2111 <B<CR>>         Repeat last B<n> or B<s> command.
2112 B<r>            Return from current subroutine.
2113 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
2114                 at the specified position.
2115 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
2116 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
2117 B<l> I<line>            List single I<line>.
2118 B<l> I<subname> List first window of lines from subroutine.
2119 B<l> I<\$var>           List first window of lines from subroutine referenced by I<\$var>.
2120 B<l>            List next window of lines.
2121 B<->            List previous window of lines.
2122 B<w> [I<line>]  List window around I<line>.
2123 B<.>            Return to the executed line.
2124 B<f> I<filename>        Switch to viewing I<filename>. File must be already loaded.
2125                 I<filename> may be either the full name of the file, or a regular
2126                 expression matching the full file name:
2127                 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2128                 Evals (with saved bodies) are considered to be filenames:
2129                 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2130                 (in the order of execution).
2131 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
2132 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
2133 B<L>            List all breakpoints and actions.
2134 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2135 B<t>            Toggle trace mode.
2136 B<t> I<expr>            Trace through execution of I<expr>.
2137 B<b> [I<line>] [I<condition>]
2138                 Set breakpoint; I<line> defaults to the current execution line;
2139                 I<condition> breaks if it evaluates to true, defaults to '1'.
2140 B<b> I<subname> [I<condition>]
2141                 Set breakpoint at first line of subroutine.
2142 B<b> I<\$var>           Set breakpoint at first line of subroutine referenced by I<\$var>.
2143 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2144 B<b> B<postpone> I<subname> [I<condition>]
2145                 Set breakpoint at first line of subroutine after
2146                 it is compiled.
2147 B<b> B<compile> I<subname>
2148                 Stop after the subroutine is compiled.
2149 B<d> [I<line>]  Delete the breakpoint for I<line>.
2150 B<D>            Delete all breakpoints.
2151 B<a> [I<line>] I<command>
2152                 Set an action to be done before the I<line> is executed;
2153                 I<line> defaults to the current execution line.
2154                 Sequence is: check for breakpoint/watchpoint, print line
2155                 if necessary, do action, prompt user if necessary,
2156                 execute line.
2157 B<a> [I<line>]  Delete the action for I<line>.
2158 B<A>            Delete all actions.
2159 B<W> I<expr>            Add a global watch-expression.
2160 B<W>            Delete all watch-expressions.
2161 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2162                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2163 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
2164 B<x> I<expr>            Evals expression in array context, dumps the result.
2165 B<m> I<expr>            Evals expression in array context, prints methods callable
2166                 on the first element of the result.
2167 B<m> I<class>           Prints methods callable via the given class.
2168
2169 B<<> ?                  List Perl commands to run before each prompt.
2170 B<<> I<expr>            Define Perl command to run before each prompt.
2171 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
2172 B<>> ?                  List Perl commands to run after each prompt.
2173 B<>> I<expr>            Define Perl command to run after each prompt.
2174 B<>>B<>> I<expr>                Add to the list of Perl commands to run after each prompt.
2175 B<{> I<db_command>      Define debugger command to run before each prompt.
2176 B<{> ?                  List debugger commands to run before each prompt.
2177 B<<> I<expr>            Define Perl command to run before each prompt.
2178 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
2179 B<$prc> I<number>       Redo a previous command (default previous command).
2180 B<$prc> I<-number>      Redo number'th-to-last command.
2181 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
2182                 See 'B<O> I<recallCommand>' too.
2183 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2184   . ( $rc eq $sh ? "" : "
2185 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2186                 See 'B<O> I<shellBang>' too.
2187 B<H> I<-number> Display last number commands (default all).
2188 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
2189 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
2190 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2191 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
2192 I<command>              Execute as a perl statement in current package.
2193 B<v>            Show versions of loaded modules.
2194 B<R>            Pure-man-restart of debugger, some of debugger state
2195                 and command-line options may be lost.
2196                 Currently the following setting are preserved:
2197                 history, breakpoints and actions, debugger B<O>ptions
2198                 and the following command-line options: I<-w>, I<-I>, I<-e>.
2199
2200 B<O> [I<opt>] ...       Set boolean option to true
2201 B<O> [I<opt>B<?>]       Query options
2202 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2203                 Set options.  Use quotes in spaces in value.
2204     I<recallCommand>, I<ShellBang>      chars used to recall command or spawn shell;
2205     I<pager>                    program for output of \"|cmd\";
2206     I<tkRunning>                        run Tk while prompting (with ReadLine);
2207     I<signalLevel> I<warnLevel> I<dieLevel>     level of verbosity;
2208     I<inhibit_exit>             Allows stepping off the end of the script.
2209     I<ImmediateStop>            Debugger should stop as early as possible.
2210     I<RemotePort>                       Remote hostname:port for remote debugging
2211   The following options affect what happens with B<V>, B<X>, and B<x> commands:
2212     I<arrayDepth>, I<hashDepth>         print only first N elements ('' for all);
2213     I<compactDump>, I<veryCompact>      change style of array and hash dump;
2214     I<globPrint>                        whether to print contents of globs;
2215     I<DumpDBFiles>              dump arrays holding debugged files;
2216     I<DumpPackages>             dump symbol tables of packages;
2217     I<DumpReused>                       dump contents of \"reused\" addresses;
2218     I<quote>, I<HighBit>, I<undefPrint>         change style of string dump;
2219     I<bareStringify>            Do not print the overload-stringified value;
2220   Other options include:
2221     I<PrintRet>         affects printing of return value after B<r> command,
2222     I<frame>            affects printing messages on entry and exit from subroutines.
2223     I<AutoTrace>        affects printing messages on every possible breaking point.
2224     I<maxTraceLen>      gives maximal length of evals/args listed in stack trace.
2225     I<ornaments>        affects screen appearance of the command line.
2226         During startup options are initialized from \$ENV{PERLDB_OPTS}.
2227         You can put additional initialization options I<TTY>, I<noTTY>,
2228         I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2229         `B<R>' after you set them).
2230
2231 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
2232 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
2233 B<h h>          Summary of debugger commands.
2234 B<$doccmd> I<manpage>   Runs the external doc viewer B<$doccmd> command on the
2235                 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2236                 Set B<\$DB::doccmd> to change viewer.
2237
2238 Type `|h' for a paged display if this was too hard to read.
2239
2240 "; # Fix balance of vi % matching: } }}
2241
2242     $summary = <<"END_SUM";
2243 I<List/search source lines:>               I<Control script execution:>
2244   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
2245   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
2246   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
2247   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
2248   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
2249   B<v>        Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
2250 I<Debugger controls:>                        B<L>           List break/watch/actions
2251   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
2252   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2253   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
2254   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
2255   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
2256   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
2257   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2258   B<q> or B<^D>     Quit                          B<R>        Attempt a restart
2259 I<Data Examination:>          B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2260   B<x>|B<m> I<expr>     Evals expr in array context, dumps the result or lists methods.
2261   B<p> I<expr>  Print expression (uses script's current package).
2262   B<S> [[B<!>]I<pat>]   List subroutine names [not] matching pattern
2263   B<V> [I<Pk> [I<Vars>]]        List Variables in Package.  Vars can be ~pattern or !pattern.
2264   B<X> [I<Vars>]        Same as \"B<V> I<current_package> [I<Vars>]\".
2265 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2266 END_SUM
2267                                 # ')}}; # Fix balance of vi % matching
2268 }
2269
2270 sub print_help {
2271     local $_ = shift;
2272
2273     # Restore proper alignment destroyed by eeevil I<> and B<>
2274     # ornaments: A pox on both their houses!
2275     #
2276     # A help command will have everything up to and including
2277     # the first tab sequence paddeed into a field 16 (or if indented 20)
2278     # wide.  If it's wide than that, an extra space will be added.
2279     s{
2280         ^                       # only matters at start of line
2281           ( \040{4} | \t )*     # some subcommands are indented
2282           ( < ?                 # so <CR> works
2283             [BI] < [^\t\n] + )  # find an eeevil ornament
2284           ( \t+ )               # original separation, discarded
2285           ( .* )                # this will now start (no earlier) than
2286                                 # column 16
2287     } {
2288         my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2289         my $clean = $command;
2290         $clean =~ s/[BI]<([^>]*)>/$1/g;
2291     # replace with this whole string:
2292         (length($leadwhite) ? " " x 4 : "")
2293       . $command
2294       . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ")
2295       . $text;
2296
2297     }mgex;
2298
2299     s{                          # handle bold ornaments
2300         B < ( [^>] + | > ) >
2301     } {
2302           $Term::ReadLine::TermCap::rl_term_set[2]
2303         . $1
2304         . $Term::ReadLine::TermCap::rl_term_set[3]
2305     }gex;
2306
2307     s{                          # handle italic ornaments
2308         I < ( [^>] + | > ) >
2309     } {
2310           $Term::ReadLine::TermCap::rl_term_set[0]
2311         . $1
2312         . $Term::ReadLine::TermCap::rl_term_set[1]
2313     }gex;
2314
2315     print $OUT $_;
2316 }
2317
2318 sub fix_less {
2319     return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2320     my $is_less = $pager =~ /\bless\b/;
2321     if ($pager =~ /\bmore\b/) {
2322         my @st_more = stat('/usr/bin/more');
2323         my @st_less = stat('/usr/bin/less');
2324         $is_less = @st_more    && @st_less
2325                 && $st_more[0] == $st_less[0]
2326                 && $st_more[1] == $st_less[1];
2327     }
2328     # changes environment!
2329     $ENV{LESS} .= 'r'   if $is_less;
2330 }
2331
2332 sub diesignal {
2333     local $frame = 0;
2334     local $doret = -2;
2335     $SIG{'ABRT'} = 'DEFAULT';
2336     kill 'ABRT', $$ if $panic++;
2337     if (defined &Carp::longmess) {
2338         local $SIG{__WARN__} = '';
2339         local $Carp::CarpLevel = 2;             # mydie + confess
2340         &warn(Carp::longmess("Signal @_"));
2341     }
2342     else {
2343         print $DB::OUT "Got signal @_\n";
2344     }
2345     kill 'ABRT', $$;
2346 }
2347
2348 sub dbwarn {
2349   local $frame = 0;
2350   local $doret = -2;
2351   local $SIG{__WARN__} = '';
2352   local $SIG{__DIE__} = '';
2353   eval { require Carp } if defined $^S; # If error/warning during compilation,
2354                                         # require may be broken.
2355   warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2356     return unless defined &Carp::longmess;
2357   my ($mysingle,$mytrace) = ($single,$trace);
2358   $single = 0; $trace = 0;
2359   my $mess = Carp::longmess(@_);
2360   ($single,$trace) = ($mysingle,$mytrace);
2361   &warn($mess);
2362 }
2363
2364 sub dbdie {
2365   local $frame = 0;
2366   local $doret = -2;
2367   local $SIG{__DIE__} = '';
2368   local $SIG{__WARN__} = '';
2369   my $i = 0; my $ineval = 0; my $sub;
2370   if ($dieLevel > 2) {
2371       local $SIG{__WARN__} = \&dbwarn;
2372       &warn(@_);                # Yell no matter what
2373       return;
2374   }
2375   if ($dieLevel < 2) {
2376     die @_ if $^S;              # in eval propagate
2377   }
2378   eval { require Carp } if defined $^S; # If error/warning during compilation,
2379                                         # require may be broken.
2380
2381   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2382     unless defined &Carp::longmess;
2383
2384   # We do not want to debug this chunk (automatic disabling works
2385   # inside DB::DB, but not in Carp).
2386   my ($mysingle,$mytrace) = ($single,$trace);
2387   $single = 0; $trace = 0;
2388   my $mess = Carp::longmess(@_);
2389   ($single,$trace) = ($mysingle,$mytrace);
2390   die $mess;
2391 }
2392
2393 sub warnLevel {
2394   if (@_) {
2395     $prevwarn = $SIG{__WARN__} unless $warnLevel;
2396     $warnLevel = shift;
2397     if ($warnLevel) {
2398       $SIG{__WARN__} = \&DB::dbwarn;
2399     } else {
2400       $SIG{__WARN__} = $prevwarn;
2401     }
2402   }
2403   $warnLevel;
2404 }
2405
2406 sub dieLevel {
2407   if (@_) {
2408     $prevdie = $SIG{__DIE__} unless $dieLevel;
2409     $dieLevel = shift;
2410     if ($dieLevel) {
2411       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2412       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2413       print $OUT "Stack dump during die enabled",
2414         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2415           if $I_m_init;
2416       print $OUT "Dump printed too.\n" if $dieLevel > 2;
2417     } else {
2418       $SIG{__DIE__} = $prevdie;
2419       print $OUT "Default die handler restored.\n";
2420     }
2421   }
2422   $dieLevel;
2423 }
2424
2425 sub signalLevel {
2426   if (@_) {
2427     $prevsegv = $SIG{SEGV} unless $signalLevel;
2428     $prevbus = $SIG{BUS} unless $signalLevel;
2429     $signalLevel = shift;
2430     if ($signalLevel) {
2431       $SIG{SEGV} = \&DB::diesignal;
2432       $SIG{BUS} = \&DB::diesignal;
2433     } else {
2434       $SIG{SEGV} = $prevsegv;
2435       $SIG{BUS} = $prevbus;
2436     }
2437   }
2438   $signalLevel;
2439 }
2440
2441 sub CvGV_name {
2442   my $in = shift;
2443   my $name = CvGV_name_or_bust($in);
2444   defined $name ? $name : $in;
2445 }
2446
2447 sub CvGV_name_or_bust {
2448   my $in = shift;
2449   return if $skipCvGV;          # Backdoor to avoid problems if XS broken...
2450   $in = \&$in;                  # Hard reference...
2451   eval {require Devel::Peek; 1} or return;
2452   my $gv = Devel::Peek::CvGV($in) or return;
2453   *$gv{PACKAGE} . '::' . *$gv{NAME};
2454 }
2455
2456 sub find_sub {
2457   my $subr = shift;
2458   $sub{$subr} or do {
2459     return unless defined &$subr;
2460     my $name = CvGV_name_or_bust($subr);
2461     my $data;
2462     $data = $sub{$name} if defined $name;
2463     return $data if defined $data;
2464
2465     # Old stupid way...
2466     $subr = \&$subr;            # Hard reference
2467     my $s;
2468     for (keys %sub) {
2469       $s = $_, last if $subr eq \&$_;
2470     }
2471     $sub{$s} if $s;
2472   }
2473 }
2474
2475 sub methods {
2476   my $class = shift;
2477   $class = ref $class if ref $class;
2478   local %seen;
2479   local %packs;
2480   methods_via($class, '', 1);
2481   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2482 }
2483
2484 sub methods_via {
2485   my $class = shift;
2486   return if $packs{$class}++;
2487   my $prefix = shift;
2488   my $prepend = $prefix ? "via $prefix: " : '';
2489   my $name;
2490   for $name (grep {defined &{${"${class}::"}{$_}}}
2491              sort keys %{"${class}::"}) {
2492     next if $seen{ $name }++;
2493     print $DB::OUT "$prepend$name\n";
2494   }
2495   return unless shift;          # Recurse?
2496   for $name (@{"${class}::ISA"}) {
2497     $prepend = $prefix ? $prefix . " -> $name" : $name;
2498     methods_via($name, $prepend, 1);
2499   }
2500 }
2501
2502 sub setman {
2503     $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
2504                 ? "man"             # O Happy Day!
2505                 : "perldoc";        # Alas, poor unfortunates
2506 }
2507
2508 sub runman {
2509     my $page = shift;
2510     unless ($page) {
2511         &system("$doccmd $doccmd");
2512         return;
2513     }
2514     # this way user can override, like with $doccmd="man -Mwhatever"
2515     # or even just "man " to disable the path check.
2516     unless ($doccmd eq 'man') {
2517         &system("$doccmd $page");
2518         return;
2519     }
2520
2521     $page = 'perl' if lc($page) eq 'help';
2522
2523     require Config;
2524     my $man1dir = $Config::Config{'man1dir'};
2525     my $man3dir = $Config::Config{'man3dir'};
2526     for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2527     my $manpath = '';
2528     $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2529     $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2530     chop $manpath if $manpath;
2531     # harmless if missing, I figure
2532     my $oldpath = $ENV{MANPATH};
2533     $ENV{MANPATH} = $manpath if $manpath;
2534     my $nopathopt = $^O =~ /dunno what goes here/;
2535     if (system($doccmd,
2536                 # I just *know* there are men without -M
2537                 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2538             split ' ', $page) )
2539     {
2540         unless ($page =~ /^perl\w/) {
2541             if (grep { $page eq $_ } qw{
2542                 5004delta 5005delta amiga api apio book boot bot call compile
2543                 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2544                 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2545                 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2546                 modinstall modlib number obj op opentut os2 os390 pod port
2547                 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2548                 trap unicode var vms win32 xs xstut
2549               })
2550             {
2551                 $page =~ s/^/perl/;
2552                 system($doccmd,
2553                         (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2554                         $page);
2555             }
2556         }
2557     }
2558     if (defined $oldpath) {
2559         $ENV{MANPATH} = $manpath;
2560     } else {
2561         delete $ENV{MANPATH};
2562     }
2563 }
2564
2565 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2566
2567 BEGIN {                 # This does not compile, alas.
2568   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
2569   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
2570   $sh = '!';
2571   $rc = ',';
2572   @hist = ('?');
2573   $deep = 100;                  # warning if stack gets this deep
2574   $window = 10;
2575   $preview = 3;
2576   $sub = '';
2577   $SIG{INT} = \&DB::catch;
2578   # This may be enabled to debug debugger:
2579   #$warnLevel = 1 unless defined $warnLevel;
2580   #$dieLevel = 1 unless defined $dieLevel;
2581   #$signalLevel = 1 unless defined $signalLevel;
2582
2583   $db_stop = 0;                 # Compiler warning
2584   $db_stop = 1 << 30;
2585   $level = 0;                   # Level of recursive debugging
2586   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2587   # Triggers bug (?) in perl is we postpone this until runtime:
2588   @postponed = @stack = (0);
2589   $stack_depth = 0;             # Localized $#stack
2590   $doret = -2;
2591   $frame = 0;
2592 }
2593
2594 BEGIN {$^W = $ini_warn;}        # Switch warnings back
2595
2596 #use Carp;                      # This did break, left for debuggin
2597
2598 sub db_complete {
2599   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2600   my($text, $line, $start) = @_;
2601   my ($itext, $search, $prefix, $pack) =
2602     ($text, "^\Q${'package'}::\E([^:]+)\$");
2603
2604   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2605                                (map { /$search/ ? ($1) : () } keys %sub)
2606     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2607   return sort grep /^\Q$text/, values %INC # files
2608     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2609   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2610     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2611       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2612   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2613     grep !/^main::/,
2614       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2615                                  # packages
2616         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2617           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
2618   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2619     # We may want to complete to (eval 9), so $text may be wrong
2620     $prefix = length($1) - length($text);
2621     $text = $1;
2622     return sort
2623         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2624   }
2625   if ((substr $text, 0, 1) eq '&') { # subroutines
2626     $text = substr $text, 1;
2627     $prefix = "&";
2628     return sort map "$prefix$_",
2629                grep /^\Q$text/,
2630                  (keys %sub),
2631                  (map { /$search/ ? ($1) : () }
2632                     keys %sub);
2633   }
2634   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2635     $pack = ($1 eq 'main' ? '' : $1) . '::';
2636     $prefix = (substr $text, 0, 1) . $1 . '::';
2637     $text = $2;
2638     my @out
2639       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2640     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2641       return db_complete($out[0], $line, $start);
2642     }
2643     return sort @out;
2644   }
2645   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2646     $pack = ($package eq 'main' ? '' : $package) . '::';
2647     $prefix = substr $text, 0, 1;
2648     $text = substr $text, 1;
2649     my @out = map "$prefix$_", grep /^\Q$text/,
2650        (grep /^_?[a-zA-Z]/, keys %$pack),
2651        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2652     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2653       return db_complete($out[0], $line, $start);
2654     }
2655     return sort @out;
2656   }
2657   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2658     my @out = grep /^\Q$text/, @options;
2659     my $val = option_val($out[0], undef);
2660     my $out = '? ';
2661     if (not defined $val or $val =~ /[\n\r]/) {
2662       # Can do nothing better
2663     } elsif ($val =~ /\s/) {
2664       my $found;
2665       foreach $l (split //, qq/\"\'\#\|/) {
2666         $out = "$l$val$l ", last if (index $val, $l) == -1;
2667       }
2668     } else {
2669       $out = "=$val ";
2670     }
2671     # Default to value if one completion, to question if many
2672     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2673     return sort @out;
2674   }
2675   return $term->filename_list($text); # filenames
2676 }
2677
2678 sub end_report {
2679   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
2680 }
2681
2682 END {
2683   $finished = $inhibit_exit;    # So that some keys may be disabled.
2684   # Do not stop in at_exit() and destructors on exit:
2685   $DB::single = !$exiting && !$runnonstop;
2686   DB::fake::at_exit() unless $exiting or $runnonstop;
2687 }
2688
2689 package DB::fake;
2690
2691 sub at_exit {
2692   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
2693 }
2694
2695 package DB;                     # Do not trace this 1; below!
2696
2697 1;