lib/perl5db.pl

   1 package DB;
   2
   3 # Debugger for Perl 5.00x; perl5db.pl patch level:
   4
   5 $VERSION = 1.0401;
   6 $header = "perl5db.pl version $VERSION";
   7
   8 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
   9 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
  10
  11 # modified Perl debugger, to be run from Emacs in perldb-mode
  12 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  13 # Johan Vromans -- upgrade to 4.0 pl 10
  14 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  15
  16 #
  17 # This file is automatically included if you do perl -d.
  18 # It's probably not useful to include this yourself.
  19 #
  20 # Perl supplies the values for %sub.  It effectively inserts
  21 # a &DB'DB(); in front of every place that can have a
  22 # breakpoint. Instead of a subroutine call it calls &DB::sub with
  23 # $DB::sub being the called subroutine. It also inserts a BEGIN
  24 # {require 'perl5db.pl'} before the first line.
  25 #
  26 # After each `require'd file is compiled, but before it is executed, a
  27 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
  28 # $filename is the expanded name of the `require'd file (as found as
  29 # value of %INC).
  30 #
  31 # Additional services from Perl interpreter:
  32 #
  33 # if caller() is called from the package DB, it provides some
  34 # additional data.
  35 #
  36 # The array @{$main::{'_<'.$filename} is the line-by-line contents of
  37 # $filename.
  38 #
  39 # The hash %{'_<'.$filename} contains breakpoints and action (it is
  40 # keyed by line number), and individual entries are settable (as
  41 # opposed to the whole hash). Only true/false is important to the
  42 # interpreter, though the values used by perl5db.pl have the form
  43 # "$break_condition\0$action". Values are magical in numeric context.
  44 #
  45 # The scalar ${'_<'.$filename} contains "_<$filename".
  46 #
  47 # Note that no subroutine call is possible until &DB::sub is defined
  48 # (for subroutines defined outside of the package DB). In fact the same is
  49 # true if $deep is not defined.
  50 #
  51 # $Log: perldb.pl,v $
  52
  53 #
  54 # At start reads $rcfile that may set important options.  This file
  55 # may define a subroutine &afterinit that will be executed after the
  56 # debugger is initialized.
  57 #
  58 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
  59 # it as a rest of `O ...' line in debugger prompt.
  60 #
  61 # The options that can be specified only at startup:
  62 # [To set in $rcfile, call &parse_options("optionName=new_value").]
  63 #
  64 # TTY  - the TTY to use for debugging i/o.
  65 #
  66 # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  67 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  68 # Term::Rendezvous.  Current variant is to have the name of TTY in this
  69 # file.
  70 #
  71 # ReadLine - If false, dummy ReadLine is used, so you can debug
  72 # ReadLine applications.
  73 #
  74 # NonStop - if true, no i/o is performed until interrupt.
  75 #
  76 # LineInfo - file or pipe to print line number info to.  If it is a
  77 # pipe, a short "emacs like" message is used.
  78 #
  79 # Example $rcfile: (delete leading hashes!)
  80 #
  81 # &parse_options("NonStop=1 LineInfo=db.out");
  82 # sub afterinit { $trace = 1; }
  83 #
  84 # The script will run without human intervention, putting trace
  85 # information into db.out.  (If you interrupt it, you would better
  86 # reset LineInfo to something "interactive"!)
  87 #
  88 ##################################################################
  89 # Changelog:
  90
  91 # A lot of things changed after 0.94. First of all, core now informs
  92 # debugger about entry into XSUBs, overloaded operators, tied operations,
  93 # BEGIN and END. Handy with `O f=2'.
  94
  95 # This can make debugger a little bit too verbose, please be patient
  96 # and report your problems promptly.
  97
  98 # Now the option frame has 3 values: 0,1,2.
  99
 100 # Note that if DESTROY returns a reference to the object (or object),
 101 # the deletion of data may be postponed until the next function call,
 102 # due to the need to examine the return value.
 103
 104 # Changes: 0.95: `v' command shows versions.
 105 # Changes: 0.96: `v' command shows version of readline.
 106 #       primitive completion works (dynamic variables, subs for `b' and `l',
 107 #               options). Can `p %var'
 108 #       Better help (`h <' now works). New commands <<, >>, {, {{.
 109 #       {dump|print}_trace() coded (to be able to do it from <<cmd).
 110 #       `c sub' documented.
 111 #       At last enough magic combined to stop after the end of debuggee.
 112 #       !! should work now (thanks to Emacs bracket matching an extra
 113 #       `]' in a regexp is caught).
 114 #       `L', `D' and `A' span files now (as documented).
 115 #       Breakpoints in `require'd code are possible (used in `R').
 116 #       Some additional words on internal work of debugger.
 117 #       `b load filename' implemented.
 118 #       `b postpone subr' implemented.
 119 #       now only `q' exits debugger (overwriteable on $inhibit_exit).
 120 #       When restarting debugger breakpoints/actions persist.
 121 #     Buglet: When restarting debugger only one breakpoint/action per
 122 #               autoloaded function persists.
 123 # Changes: 0.97: NonStop will not stop in at_exit().
 124 #       Option AutoTrace implemented.
 125 #       Trace printed differently if frames are printed too.
 126 #       new `inhibitExit' option.
 127 #       printing of a very long statement interruptible.
 128 # Changes: 0.98: New command `m' for printing possible methods
 129 #       'l -' is a synonim for `-'.
 130 #       Cosmetic bugs in printing stack trace.
 131 #       `frame' & 8 to print "expanded args" in stack trace.
 132 #       Can list/break in imported subs.
 133 #       new `maxTraceLen' option.
 134 #       frame & 4 and frame & 8 granted.
 135 #       new command `m'
 136 #       nonstoppable lines do not have `:' near the line number.
 137 #       `b compile subname' implemented.
 138 #       Will not use $` any more.
 139 #       `-' behaves sane now.
 140 # Changes: 0.99: Completion for `f', `m'.
 141 #       `m' will remove duplicate names instead of duplicate functions.
 142 #       `b load' strips trailing whitespace.
 143 #       completion ignores leading `|'; takes into account current package
 144 #       when completing a subroutine name (same for `l').
 145
 146 ####################################################################
 147
 148 # Needed for the statement after exec():
 149
 150 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
 151 local($^W) = 0;                 # Switch run-time warnings off during init.
 152 warn (                  # Do not ;-)
 153       $dumpvar::hashDepth,
 154       $dumpvar::arrayDepth,
 155       $dumpvar::dumpDBFiles,
 156       $dumpvar::dumpPackages,
 157       $dumpvar::quoteHighBit,
 158       $dumpvar::printUndef,
 159       $dumpvar::globPrint,
 160       $dumpvar::usageOnly,
 161       @ARGS,
 162       $Carp::CarpLevel,
 163       $panic,
 164       $second_time,
 165      ) if 0;
 166
 167 # Command-line + PERLLIB:
 168 @ini_INC = @INC;
 169
 170 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
 171
 172 $trace = $signal = $single = 0; # Uninitialized warning suppression
 173                                 # (local $^W cannot help - other packages!).
 174 $inhibit_exit = $option{PrintRet} = 1;
 175
 176 @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
 177                   compactDump veryCompact quote HighBit undefPrint
 178                   globPrint PrintRet UsageOnly frame AutoTrace
 179                   TTY noTTY ReadLine NonStop LineInfo maxTraceLen
 180                   recallCommand ShellBang pager tkRunning ornaments
 181                   signalLevel warnLevel dieLevel inhibit_exit
 182                   ImmediateStop bareStringify);
 183
 184 %optionVars    = (
 185                  hashDepth      => \$dumpvar::hashDepth,
 186                  arrayDepth     => \$dumpvar::arrayDepth,
 187                  DumpDBFiles    => \$dumpvar::dumpDBFiles,
 188                  DumpPackages   => \$dumpvar::dumpPackages,
 189                  DumpReused     => \$dumpvar::dumpReused,
 190                  HighBit        => \$dumpvar::quoteHighBit,
 191                  undefPrint     => \$dumpvar::printUndef,
 192                  globPrint      => \$dumpvar::globPrint,
 193                  UsageOnly      => \$dumpvar::usageOnly,
 194                  bareStringify  => \$dumpvar::bareStringify,
 195                  frame          => \$frame,
 196                  AutoTrace      => \$trace,
 197                  inhibit_exit   => \$inhibit_exit,
 198                  maxTraceLen    => \$maxtrace,
 199                  ImmediateStop  => \$ImmediateStop,
 200 );
 201
 202 %optionAction  = (
 203                   compactDump   => \&dumpvar::compactDump,
 204                   veryCompact   => \&dumpvar::veryCompact,
 205                   quote         => \&dumpvar::quote,
 206                   TTY           => \&TTY,
 207                   noTTY         => \&noTTY,
 208                   ReadLine      => \&ReadLine,
 209                   NonStop       => \&NonStop,
 210                   LineInfo      => \&LineInfo,
 211                   recallCommand => \&recallCommand,
 212                   ShellBang     => \&shellBang,
 213                   pager         => \&pager,
 214                   signalLevel   => \&signalLevel,
 215                   warnLevel     => \&warnLevel,
 216                   dieLevel      => \&dieLevel,
 217                   tkRunning     => \&tkRunning,
 218                   ornaments     => \&ornaments,
 219                  );
 220
 221 %optionRequire = (
 222                   compactDump   => 'dumpvar.pl',
 223                   veryCompact   => 'dumpvar.pl',
 224                   quote         => 'dumpvar.pl',
 225                  );
 226
 227 # These guys may be defined in $ENV{PERL5DB} :
 228 $rl = 1 unless defined $rl;
 229 $warnLevel = 1 unless defined $warnLevel;
 230 $dieLevel = 1 unless defined $dieLevel;
 231 $signalLevel = 1 unless defined $signalLevel;
 232 $pre = [] unless defined $pre;
 233 $post = [] unless defined $post;
 234 $pretype = [] unless defined $pretype;
 235 warnLevel($warnLevel);
 236 dieLevel($dieLevel);
 237 signalLevel($signalLevel);
 238 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
 239 &recallCommand("!") unless defined $prc;
 240 &shellBang("!") unless defined $psh;
 241 $maxtrace = 400 unless defined $maxtrace;
 242
 243 if (-e "/dev/tty") {
 244   $rcfile=".perldb";
 245 } else {
 246   $rcfile="perldb.ini";
 247 }
 248
 249 if (-f $rcfile) {
 250     do "./$rcfile";
 251 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
 252     do "$ENV{LOGDIR}/$rcfile";
 253 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
 254     do "$ENV{HOME}/$rcfile";
 255 }
 256
 257 if (defined $ENV{PERLDB_OPTS}) {
 258   parse_options($ENV{PERLDB_OPTS});
 259 }
 260
 261 if (exists $ENV{PERLDB_RESTART}) {
 262   delete $ENV{PERLDB_RESTART};
 263   # $restart = 1;
 264   @hist = get_list('PERLDB_HIST');
 265   %break_on_load = get_list("PERLDB_ON_LOAD");
 266   %postponed = get_list("PERLDB_POSTPONE");
 267   my @had_breakpoints= get_list("PERLDB_VISITED");
 268   for (0 .. $#had_breakpoints) {
 269     my %pf = get_list("PERLDB_FILE_$_");
 270     $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
 271   }
 272   my %opt = get_list("PERLDB_OPT");
 273   my ($opt,$val);
 274   while (($opt,$val) = each %opt) {
 275     $val =~ s/[\\\']/\\$1/g;
 276     parse_options("$opt'$val'");
 277   }
 278   @INC = get_list("PERLDB_INC");
 279   @ini_INC = @INC;
 280   $pretype = [get_list("PERLDB_PRETYPE")];
 281   $pre = [get_list("PERLDB_PRE")];
 282   $post = [get_list("PERLDB_POST")];
 283   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
 284 }
 285
 286 if ($notty) {
 287   $runnonstop = 1;
 288 } else {
 289   # Is Perl being run from Emacs?
 290   $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
 291   $rl = 0, shift(@main::ARGV) if $emacs;
 292
 293   #require Term::ReadLine;
 294
 295   if (-e "/dev/tty") {
 296     $console = "/dev/tty";
 297   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
 298     $console = "con";
 299   } else {
 300     $console = "sys\$command";
 301   }
 302
 303   if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
 304     $console = undef;
 305   }
 306
 307   # Around a bug:
 308   if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
 309     $console = undef;
 310   }
 311
 312   $console = $tty if defined $tty;
 313
 314   if (defined $console) {
 315     open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
 316     open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
 317       || open(OUT,">&STDOUT");  # so we don't dongle stdout
 318   } else {
 319     open(IN,"<&STDIN");
 320     open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
 321     $console = 'STDIN/OUT';
 322   }
 323   # so open("|more") can read from STDOUT and so we don't dingle stdin
 324   $IN = \*IN;
 325
 326   $OUT = \*OUT;
 327   select($OUT);
 328   $| = 1;                       # for DB::OUT
 329   select(STDOUT);
 330
 331   $LINEINFO = $OUT unless defined $LINEINFO;
 332   $lineinfo = $console unless defined $lineinfo;
 333
 334   $| = 1;                       # for real STDOUT
 335
 336   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
 337   unless ($runnonstop) {
 338     print $OUT "\nLoading DB routines from $header\n";
 339     print $OUT ("Emacs support ",
 340                 $emacs ? "enabled" : "available",
 341                 ".\n");
 342     print $OUT "\nEnter h or `h h' for help.\n\n";
 343   }
 344 }
 345
 346 @ARGS = @ARGV;
 347 for (@args) {
 348     s/\'/\\\'/g;
 349     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
 350 }
 351
 352 if (defined &afterinit) {       # May be defined in $rcfile
 353   &afterinit();
 354 }
 355
 356 $I_m_init = 1;
 357
 358 ############################################################ Subroutines
 359
 360 sub DB {
 361     # _After_ the perl program is compiled, $single is set to 1:
 362     if ($single and not $second_time++) {
 363       if ($runnonstop) {        # Disable until signal
 364         for ($i=0; $i <= $#stack; ) {
 365             $stack[$i++] &= ~1;
 366         }
 367         $single = 0;
 368         # return;                       # Would not print trace!
 369       } elsif ($ImmediateStop) {
 370         $ImmediateStop = 0;
 371         $signal = 1;
 372       }
 373     }
 374     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
 375     &save;
 376     ($package, $filename, $line) = caller;
 377     $filename_ini = $filename;
 378     $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
 379       "package $package;";      # this won't let them modify, alas
 380     local(*dbline) = $main::{'_<' . $filename};
 381     $max = $#dbline;
 382     if (($stop,$action) = split(/\0/,$dbline{$line})) {
 383         if ($stop eq '1') {
 384             $signal |= 1;
 385         } elsif ($stop) {
 386             $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
 387             $dbline{$line} =~ s/;9($|\0)/$1/;
 388         }
 389     }
 390     my $was_signal = $signal;
 391     if ($trace & 2) {
 392       for (my $n = 0; $n <= $#to_watch; $n++) {
 393         $evalarg = $to_watch[$n];
 394         local $onetimeDump;     # Do not output results
 395         my ($val) = &eval;      # Fix context (&eval is doing array)?
 396         $val = ( (defined $val) ? "'$val'" : 'undef' );
 397         if ($val ne $old_watch[$n]) {
 398           $signal = 1;
 399           print $OUT <<EOP;
 400 Watchpoint $n:\t$to_watch[$n] changed:
 401     old value:\t$old_watch[$n]
 402     new value:\t$val
 403 EOP
 404           $old_watch[$n] = $val;
 405         }
 406       }
 407     }
 408     if ($trace & 4) {           # User-installed watch
 409       return if watchfunction($package, $filename, $line)
 410         and not $single and not $was_signal and not ($trace & ~4);
 411     }
 412     $was_signal = $signal;
 413     $signal = 0;
 414     if ($single || ($trace & 1) || $was_signal) {
 415         $term || &setterm;
 416         if ($emacs) {
 417             $position = "\032\032$filename:$line:0\n";
 418             print $LINEINFO $position;
 419         } elsif ($package eq 'DB::fake') {
 420           print_help(<<EOP);
 421 Debugged program terminated.  Use B<q> to quit or B<R> to restart,
 422   use B<O> I<inhibit_exit> to avoid stopping after program termination,
 423   B<h q>, B<h R> or B<h O> to get additional info.
 424 EOP
 425           $package = 'main';
 426           $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
 427             "package $package;";        # this won't let them modify, alas
 428         } else {
 429             $sub =~ s/\'/::/;
 430             $prefix = $sub =~ /::/ ? "" : "${'package'}::";
 431             $prefix .= "$sub($filename:";
 432             $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
 433             if (length($prefix) > 30) {
 434                 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
 435                 $prefix = "";
 436                 $infix = ":\t";
 437             } else {
 438                 $infix = "):\t";
 439                 $position = "$prefix$line$infix$dbline[$line]$after";
 440             }
 441             if ($frame) {
 442                 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
 443             } else {
 444                 print $LINEINFO $position;
 445             }
 446             for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
 447                 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
 448                 last if $signal;
 449                 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
 450                 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
 451                 $position .= $incr_pos;
 452                 if ($frame) {
 453                     print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
 454                 } else {
 455                     print $LINEINFO $incr_pos;
 456                 }
 457             }
 458         }
 459     }
 460     $evalarg = $action, &eval if $action;
 461     if ($single || $was_signal) {
 462         local $level = $level + 1;
 463         foreach $evalarg (@$pre) {
 464           &eval;
 465         }
 466         print $OUT $#stack . " levels deep in subroutine calls!\n"
 467           if $single & 4;
 468         $start = $line;
 469         $incr = -1;             # for backward motion.
 470         @typeahead = @$pretype, @typeahead;
 471       CMD:
 472         while (($term || &setterm),
 473                ($term_pid == $$ or &resetterm),
 474                defined ($cmd=&readline("  DB" . ('<' x $level) .
 475                                        ($#hist+1) . ('>' x $level) .
 476                                        " "))) {
 477                 $single = 0;
 478                 $signal = 0;
 479                 $cmd =~ s/\\$/\n/ && do {
 480                     $cmd .= &readline("  cont: ");
 481                     redo CMD;
 482                 };
 483                 $cmd =~ /^$/ && ($cmd = $laststep);
 484                 push(@hist,$cmd) if length($cmd) > 1;
 485               PIPE: {
 486                     ($i) = split(/\s+/,$cmd);
 487                     eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
 488                     $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
 489                     $cmd =~ /^h$/ && do {
 490                         print_help($help);
 491                         next CMD; };
 492                     $cmd =~ /^h\s+h$/ && do {
 493                         print_help($summary);
 494                         next CMD; };
 495                     $cmd =~ /^h\s+(\S)$/ && do {
 496                         my $asked = "\Q$1";
 497                         if ($help =~ /^(?:[IB]<)$asked/m) {
 498                           while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
 499                             print_help($1);
 500                           }
 501                         } else {
 502                             print_help("B<$asked> is not a debugger command.\n");
 503                         }
 504                         next CMD; };
 505                     $cmd =~ /^t$/ && do {
 506                         ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
 507                         print $OUT "Trace = " .
 508                             (($trace & 1) ? "on" : "off" ) . "\n";
 509                         next CMD; };
 510                     $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
 511                         $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
 512                         foreach $subname (sort(keys %sub)) {
 513                             if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
 514                                 print $OUT $subname,"\n";
 515                             }
 516                         }
 517                         next CMD; };
 518                     $cmd =~ /^v$/ && do {
 519                         list_versions(); next CMD};
 520                     $cmd =~ s/^X\b/V $package/;
 521                     $cmd =~ /^V$/ && do {
 522                         $cmd = "V $package"; };
 523                     $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
 524                         local ($savout) = select($OUT);
 525                         $packname = $1;
 526                         @vars = split(' ',$2);
 527                         do 'dumpvar.pl' unless defined &main::dumpvar;
 528                         if (defined &main::dumpvar) {
 529                             local $frame = 0;
 530                             local $doret = -2;
 531                             &main::dumpvar($packname,@vars);
 532                         } else {
 533                             print $OUT "dumpvar.pl not available.\n";
 534                         }
 535                         select ($savout);
 536                         next CMD; };
 537                     $cmd =~ s/^x\b/ / && do { # So that will be evaled
 538                         $onetimeDump = 'dump'; };
 539                     $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
 540                         methods($1); next CMD};
 541                     $cmd =~ s/^m\b/ / && do { # So this will be evaled
 542                         $onetimeDump = 'methods'; };
 543                     $cmd =~ /^f\b\s*(.*)/ && do {
 544                         $file = $1;
 545                         $file =~ s/\s+$//;
 546                         if (!$file) {
 547                             print $OUT "The old f command is now the r command.\n";
 548                             print $OUT "The new f command switches filenames.\n";
 549                             next CMD;
 550                         }
 551                         if (!defined $main::{'_<' . $file}) {
 552                             if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
 553                                               $try = substr($try,2);
 554                                               print $OUT "Choosing $try matching `$file':\n";
 555                                               $file = $try;
 556                                           }}
 557                         }
 558                         if (!defined $main::{'_<' . $file}) {
 559                             print $OUT "No file matching `$file' is loaded.\n";
 560                             next CMD;
 561                         } elsif ($file ne $filename) {
 562                             *dbline = $main::{'_<' . $file};
 563                             $max = $#dbline;
 564                             $filename = $file;
 565                             $start = 1;
 566                             $cmd = "l";
 567                           } else {
 568                             print $OUT "Already in $file.\n";
 569                             next CMD;
 570                           }
 571                       };
 572                     $cmd =~ s/^l\s+-\s*$/-/;
 573                     $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
 574                         $subname = $1;
 575                         $subname =~ s/\'/::/;
 576                         $subname = $package."::".$subname
 577                           unless $subname =~ /::/;
 578                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 579                         @pieces = split(/:/,find_sub($subname));
 580                         $subrange = pop @pieces;
 581                         $file = join(':', @pieces);
 582                         if ($file ne $filename) {
 583                             *dbline = $main::{'_<' . $file};
 584                             $max = $#dbline;
 585                             $filename = $file;
 586                         }
 587                         if ($subrange) {
 588                             if (eval($subrange) < -$window) {
 589                                 $subrange =~ s/-.*/+/;
 590                             }
 591                             $cmd = "l $subrange";
 592                         } else {
 593                             print $OUT "Subroutine $subname not found.\n";
 594                             next CMD;
 595                         } };
 596                     $cmd =~ /^\.$/ && do {
 597                         $incr = -1;             # for backward motion.
 598                         $start = $line;
 599                         $filename = $filename_ini;
 600                         *dbline = $main::{'_<' . $filename};
 601                         $max = $#dbline;
 602                         print $LINEINFO $position;
 603                         next CMD };
 604                     $cmd =~ /^w\b\s*(\d*)$/ && do {
 605                         $incr = $window - 1;
 606                         $start = $1 if $1;
 607                         $start -= $preview;
 608                         #print $OUT 'l ' . $start . '-' . ($start + $incr);
 609                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 610                     $cmd =~ /^-$/ && do {
 611                         $start -= $incr + $window + 1;
 612                         $start = 1 if $start <= 0;
 613                         $incr = $window - 1;
 614                         $cmd = 'l ' . ($start) . '+'; };
 615                     $cmd =~ /^l$/ && do {
 616                         $incr = $window - 1;
 617                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 618                     $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
 619                         $start = $1 if $1;
 620                         $incr = $2;
 621                         $incr = $window - 1 unless $incr;
 622                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 623                     $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 624                         $end = (!defined $2) ? $max : ($4 ? $4 : $2);
 625                         $end = $max if $end > $max;
 626                         $i = $2;
 627                         $i = $line if $i eq '.';
 628                         $i = 1 if $i < 1;
 629                         $incr = $end - $i;
 630                         if ($emacs) {
 631                             print $OUT "\032\032$filename:$i:0\n";
 632                             $i = $end;
 633                         } else {
 634                             for (; $i <= $end; $i++) {
 635                                 ($stop,$action) = split(/\0/, $dbline{$i});
 636                                 $arrow = ($i==$line
 637                                           and $filename eq $filename_ini)
 638                                   ?  '==>'
 639                                     : ($dbline[$i]+0 ? ':' : ' ') ;
 640                                 $arrow .= 'b' if $stop;
 641                                 $arrow .= 'a' if $action;
 642                                 print $OUT "$i$arrow\t", $dbline[$i];
 643                                 last if $signal;
 644                             }
 645                         }
 646                         $start = $i; # remember in case they want more
 647                         $start = $max if $start > $max;
 648                         next CMD; };
 649                     $cmd =~ /^D$/ && do {
 650                       print $OUT "Deleting all breakpoints...\n";
 651                       my $file;
 652                       for $file (keys %had_breakpoints) {
 653                         local *dbline = $main::{'_<' . $file};
 654                         my $max = $#dbline;
 655                         my $was;
 656
 657                         for ($i = 1; $i <= $max ; $i++) {
 658                             if (defined $dbline{$i}) {
 659                                 $dbline{$i} =~ s/^[^\0]+//;
 660                                 if ($dbline{$i} =~ s/^\0?$//) {
 661                                     delete $dbline{$i};
 662                                 }
 663                             }
 664                         }
 665                       }
 666                       undef %postponed;
 667                       undef %postponed_file;
 668                       undef %break_on_load;
 669                       undef %had_breakpoints;
 670                       next CMD; };
 671                     $cmd =~ /^L$/ && do {
 672                       my $file;
 673                       for $file (keys %had_breakpoints) {
 674                         local *dbline = $main::{'_<' . $file};
 675                         my $max = $#dbline;
 676                         my $was;
 677
 678                         for ($i = 1; $i <= $max; $i++) {
 679                             if (defined $dbline{$i}) {
 680                                 print "$file:\n" unless $was++;
 681                                 print $OUT " $i:\t", $dbline[$i];
 682                                 ($stop,$action) = split(/\0/, $dbline{$i});
 683                                 print $OUT "   break if (", $stop, ")\n"
 684                                   if $stop;
 685                                 print $OUT "   action:  ", $action, "\n"
 686                                   if $action;
 687                                 last if $signal;
 688                             }
 689                         }
 690                       }
 691                       if (%postponed) {
 692                         print $OUT "Postponed breakpoints in subroutines:\n";
 693                         my $subname;
 694                         for $subname (keys %postponed) {
 695                           print $OUT " $subname\t$postponed{$subname}\n";
 696                           last if $signal;
 697                         }
 698                       }
 699                       my @have = map { # Combined keys
 700                         keys %{$postponed_file{$_}}
 701                       } keys %postponed_file;
 702                       if (@have) {
 703                         print $OUT "Postponed breakpoints in files:\n";
 704                         my ($file, $line);
 705                         for $file (keys %postponed_file) {
 706                           my $db = $postponed_file{$file};
 707                           print $OUT " $file:\n";
 708                           for $line (sort {$a <=> $b} keys %$db) {
 709                                 print $OUT "  $line:\n";
 710                                 my ($stop,$action) = split(/\0/, $$db{$line});
 711                                 print $OUT "    break if (", $stop, ")\n"
 712                                   if $stop;
 713                                 print $OUT "    action:  ", $action, "\n"
 714                                   if $action;
 715                                 last if $signal;
 716                           }
 717                           last if $signal;
 718                         }
 719                       }
 720                       if (%break_on_load) {
 721                         print $OUT "Breakpoints on load:\n";
 722                         my $file;
 723                         for $file (keys %break_on_load) {
 724                           print $OUT " $file\n";
 725                           last if $signal;
 726                         }
 727                       }
 728                       if ($trace & 2) {
 729                         print $OUT "Watch-expressions:\n";
 730                         my $expr;
 731                         for $expr (@to_watch) {
 732                           print $OUT " $expr\n";
 733                           last if $signal;
 734                         }
 735                       }
 736                       next CMD; };
 737                     $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
 738                         my $file = $1; $file =~ s/\s+$//;
 739                         {
 740                           $break_on_load{$file} = 1;
 741                           $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
 742                           $file .= '.pm', redo unless $file =~ /\./;
 743                         }
 744                         $had_breakpoints{$file} = 1;
 745                         print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
 746                         next CMD; };
 747                     $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 748                         my $cond = $3 || '1';
 749                         my ($subname, $break) = ($2, $1 eq 'postpone');
 750                         $subname =~ s/\'/::/;
 751                         $subname = "${'package'}::" . $subname
 752                           unless $subname =~ /::/;
 753                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 754                         $postponed{$subname} = $break
 755                           ? "break +0 if $cond" : "compile";
 756                         next CMD; };
 757                     $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 758                         $subname = $1;
 759                         $cond = $2 || '1';
 760                         $subname =~ s/\'/::/;
 761                         $subname = "${'package'}::" . $subname
 762                           unless $subname =~ /::/;
 763                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 764                         # Filename below can contain ':'
 765                         ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
 766                         $i += 0;
 767                         if ($i) {
 768                             $filename = $file;
 769                             *dbline = $main::{'_<' . $filename};
 770                             $had_breakpoints{$filename} = 1;
 771                             $max = $#dbline;
 772                             ++$i while $dbline[$i] == 0 && $i < $max;
 773                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 774                         } else {
 775                             print $OUT "Subroutine $subname not found.\n";
 776                         }
 777                         next CMD; };
 778                     $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
 779                         $i = ($1?$1:$line);
 780                         $cond = $2 || '1';
 781                         if ($dbline[$i] == 0) {
 782                             print $OUT "Line $i not breakable.\n";
 783                         } else {
 784                             $had_breakpoints{$filename} = 1;
 785                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 786                         }
 787                         next CMD; };
 788                     $cmd =~ /^d\b\s*(\d+)?/ && do {
 789                         $i = ($1?$1:$line);
 790                         $dbline{$i} =~ s/^[^\0]*//;
 791                         delete $dbline{$i} if $dbline{$i} eq '';
 792                         next CMD; };
 793                     $cmd =~ /^A$/ && do {
 794                       my $file;
 795                       for $file (keys %had_breakpoints) {
 796                         local *dbline = $main::{'_<' . $file};
 797                         my $max = $#dbline;
 798                         my $was;
 799
 800                         for ($i = 1; $i <= $max ; $i++) {
 801                             if (defined $dbline{$i}) {
 802                                 $dbline{$i} =~ s/\0[^\0]*//;
 803                                 delete $dbline{$i} if $dbline{$i} eq '';
 804                             }
 805                         }
 806                       }
 807                       next CMD; };
 808                     $cmd =~ /^O\s*$/ && do {
 809                         for (@options) {
 810                             &dump_option($_);
 811                         }
 812                         next CMD; };
 813                     $cmd =~ /^O\s*(\S.*)/ && do {
 814                         parse_options($1);
 815                         next CMD; };
 816                     $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
 817                         push @$pre, action($1);
 818                         next CMD; };
 819                     $cmd =~ /^>>\s*(.*)/ && do {
 820                         push @$post, action($1);
 821                         next CMD; };
 822                     $cmd =~ /^<\s*(.*)/ && do {
 823                         $pre = [], next CMD unless $1;
 824                         $pre = [action($1)];
 825                         next CMD; };
 826                     $cmd =~ /^>\s*(.*)/ && do {
 827                         $post = [], next CMD unless $1;
 828                         $post = [action($1)];
 829                         next CMD; };
 830                     $cmd =~ /^\{\{\s*(.*)/ && do {
 831                         push @$pretype, $1;
 832                         next CMD; };
 833                     $cmd =~ /^\{\s*(.*)/ && do {
 834                         $pretype = [], next CMD unless $1;
 835                         $pretype = [$1];
 836                         next CMD; };
 837                     $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
 838                         $i = $1; $j = $3;
 839                         if ($dbline[$i] == 0) {
 840                             print $OUT "Line $i may not have an action.\n";
 841                         } else {
 842                             $dbline{$i} =~ s/\0[^\0]*//;
 843                             $dbline{$i} .= "\0" . action($j);
 844                         }
 845                         next CMD; };
 846                     $cmd =~ /^n$/ && do {
 847                         end_report(), next CMD if $finished and $level <= 1;
 848                         $single = 2;
 849                         $laststep = $cmd;
 850                         last CMD; };
 851                     $cmd =~ /^s$/ && do {
 852                         end_report(), next CMD if $finished and $level <= 1;
 853                         $single = 1;
 854                         $laststep = $cmd;
 855                         last CMD; };
 856                     $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
 857                         end_report(), next CMD if $finished and $level <= 1;
 858                         $subname = $i = $1;
 859                         if ($i =~ /\D/) { # subroutine name
 860                             $subname = $package."::".$subname
 861                                 unless $subname =~ /::/;
 862                             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
 863                             $i += 0;
 864                             if ($i) {
 865                                 $filename = $file;
 866                                 *dbline = $main::{'_<' . $filename};
 867                                 $had_breakpoints{$filename}++;
 868                                 $max = $#dbline;
 869                                 ++$i while $dbline[$i] == 0 && $i < $max;
 870                             } else {
 871                                 print $OUT "Subroutine $subname not found.\n";
 872                                 next CMD;
 873                             }
 874                         }
 875                         if ($i) {
 876                             if ($dbline[$i] == 0) {
 877                                 print $OUT "Line $i not breakable.\n";
 878                                 next CMD;
 879                             }
 880                             $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
 881                         }
 882                         for ($i=0; $i <= $#stack; ) {
 883                             $stack[$i++] &= ~1;
 884                         }
 885                         last CMD; };
 886                     $cmd =~ /^r$/ && do {
 887                         end_report(), next CMD if $finished and $level <= 1;
 888                         $stack[$#stack] |= 1;
 889                         $doret = $option{PrintRet} ? $#stack - 1 : -2;
 890                         last CMD; };
 891                     $cmd =~ /^R$/ && do {
 892                         print $OUT "Warning: some settings and command-line options may be lost!\n";
 893                         my (@script, @flags, $cl);
 894                         push @flags, '-w' if $ini_warn;
 895                         # Put all the old includes at the start to get
 896                         # the same debugger.
 897                         for (@ini_INC) {
 898                           push @flags, '-I', $_;
 899                         }
 900                         # Arrange for setting the old INC:
 901                         set_list("PERLDB_INC", @ini_INC);
 902                         if ($0 eq '-e') {
 903                           for (1..$#{'::_<-e'}) { # The first line is PERL5DB
 904                             chomp ($cl =  $ {'::_<-e'}[$_]);
 905                             push @script, '-e', $cl;
 906                           }
 907                         } else {
 908                           @script = $0;
 909                         }
 910                         set_list("PERLDB_HIST",
 911                                  $term->Features->{getHistory}
 912                                  ? $term->GetHistory : @hist);
 913                         my @had_breakpoints = keys %had_breakpoints;
 914                         set_list("PERLDB_VISITED", @had_breakpoints);
 915                         set_list("PERLDB_OPT", %option);
 916                         set_list("PERLDB_ON_LOAD", %break_on_load);
 917                         my @hard;
 918                         for (0 .. $#had_breakpoints) {
 919                           my $file = $had_breakpoints[$_];
 920                           *dbline = $main::{'_<' . $file};
 921                           next unless %dbline or $postponed_file{$file};
 922                           (push @hard, $file), next
 923                             if $file =~ /^\(eval \d+\)$/;
 924                           my @add;
 925                           @add = %{$postponed_file{$file}}
 926                             if $postponed_file{$file};
 927                           set_list("PERLDB_FILE_$_", %dbline, @add);
 928                         }
 929                         for (@hard) { # Yes, really-really...
 930                           # Find the subroutines in this eval
 931                           *dbline = $main::{'_<' . $_};
 932                           my ($quoted, $sub, %subs, $line) = quotemeta $_;
 933                           for $sub (keys %sub) {
 934                             next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
 935                             $subs{$sub} = [$1, $2];
 936                           }
 937                           unless (%subs) {
 938                             print $OUT
 939                               "No subroutines in $_, ignoring breakpoints.\n";
 940                             next;
 941                           }
 942                         LINES: for $line (keys %dbline) {
 943                             # One breakpoint per sub only:
 944                             my ($offset, $sub, $found);
 945                           SUBS: for $sub (keys %subs) {
 946                               if ($subs{$sub}->[1] >= $line # Not after the subroutine
 947                                   and (not defined $offset # Not caught
 948                                        or $offset < 0 )) { # or badly caught
 949                                 $found = $sub;
 950                                 $offset = $line - $subs{$sub}->[0];
 951                                 $offset = "+$offset", last SUBS if $offset >= 0;
 952                               }
 953                             }
 954                             if (defined $offset) {
 955                               $postponed{$found} =
 956                                 "break $offset if $dbline{$line}";
 957                             } else {
 958                               print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
 959                             }
 960                           }
 961                         }
 962                         set_list("PERLDB_POSTPONE", %postponed);
 963                         set_list("PERLDB_PRETYPE", @$pretype);
 964                         set_list("PERLDB_PRE", @$pre);
 965                         set_list("PERLDB_POST", @$post);
 966                         set_list("PERLDB_TYPEAHEAD", @typeahead);
 967                         $ENV{PERLDB_RESTART} = 1;
 968                         #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
 969                         exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
 970                         print $OUT "exec failed: $!\n";
 971                         last CMD; };
 972                     $cmd =~ /^T$/ && do {
 973                         print_trace($OUT, 1); # skip DB
 974                         next CMD; };
 975                     $cmd =~ /^W\s*$/ && do {
 976                         $trace &= ~2;
 977                         @to_watch = @old_watch = ();
 978                         next CMD; };
 979                     $cmd =~ /^W\b\s*(.*)/s && do {
 980                         push @to_watch, $1;
 981                         $evalarg = $1;
 982                         my ($val) = &eval;
 983                         $val = (defined $val) ? "'$val'" : 'undef' ;
 984                         push @old_watch, $val;
 985                         $trace |= 2;
 986                         next CMD; };
 987                     $cmd =~ /^\/(.*)$/ && do {
 988                         $inpat = $1;
 989                         $inpat =~ s:([^\\])/$:$1:;
 990                         if ($inpat ne "") {
 991                             eval '$inpat =~ m'."\a$inpat\a";
 992                             if ($@ ne "") {
 993                                 print $OUT "$@";
 994                                 next CMD;
 995                             }
 996                             $pat = $inpat;
 997                         }
 998                         $end = $start;
 999                         $incr = -1;
1000                         eval '
1001                             for (;;) {
1002                                 ++$start;
1003                                 $start = 1 if ($start > $max);
1004                                 last if ($start == $end);
1005                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1006                                     if ($emacs) {
1007                                         print $OUT "\032\032$filename:$start:0\n";
1008                                     } else {
1009                                         print $OUT "$start:\t", $dbline[$start], "\n";
1010                                     }
1011                                     last;
1012                                 }
1013                             } ';
1014                         print $OUT "/$pat/: not found\n" if ($start == $end);
1015                         next CMD; };
1016                     $cmd =~ /^\?(.*)$/ && do {
1017                         $inpat = $1;
1018                         $inpat =~ s:([^\\])\?$:$1:;
1019                         if ($inpat ne "") {
1020                             eval '$inpat =~ m'."\a$inpat\a";
1021                             if ($@ ne "") {
1022                                 print $OUT "$@";
1023                                 next CMD;
1024                             }
1025                             $pat = $inpat;
1026                         }
1027                         $end = $start;
1028                         $incr = -1;
1029                         eval '
1030                             for (;;) {
1031                                 --$start;
1032                                 $start = $max if ($start <= 0);
1033                                 last if ($start == $end);
1034                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1035                                     if ($emacs) {
1036                                         print $OUT "\032\032$filename:$start:0\n";
1037                                     } else {
1038                                         print $OUT "$start:\t", $dbline[$start], "\n";
1039                                     }
1040                                     last;
1041                                 }
1042                             } ';
1043                         print $OUT "?$pat?: not found\n" if ($start == $end);
1044                         next CMD; };
1045                     $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1046                         pop(@hist) if length($cmd) > 1;
1047                         $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1048                         $cmd = $hist[$i];
1049                         print $OUT $cmd;
1050                         redo CMD; };
1051                     $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1052                         &system($1);
1053                         next CMD; };
1054                     $cmd =~ /^$rc([^$rc].*)$/ && do {
1055                         $pat = "^$1";
1056                         pop(@hist) if length($cmd) > 1;
1057                         for ($i = $#hist; $i; --$i) {
1058                             last if $hist[$i] =~ /$pat/;
1059                         }
1060                         if (!$i) {
1061                             print $OUT "No such command!\n\n";
1062                             next CMD;
1063                         }
1064                         $cmd = $hist[$i];
1065                         print $OUT $cmd;
1066                         redo CMD; };
1067                     $cmd =~ /^$sh$/ && do {
1068                         &system($ENV{SHELL}||"/bin/sh");
1069                         next CMD; };
1070                     $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1071                         &system($ENV{SHELL}||"/bin/sh","-c",$1);
1072                         next CMD; };
1073                     $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1074                         $end = $2?($#hist-$2):0;
1075                         $hist = 0 if $hist < 0;
1076                         for ($i=$#hist; $i>$end; $i--) {
1077                             print $OUT "$i: ",$hist[$i],"\n"
1078                               unless $hist[$i] =~ /^.?$/;
1079                         };
1080                         next CMD; };
1081                     $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1082                     $cmd =~ s/^p\b/print {\$DB::OUT} /;
1083                     $cmd =~ /^=/ && do {
1084                         if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1085                             $alias{$k}="s~$k~$v~";
1086                             print $OUT "$k = $v\n";
1087                         } elsif ($cmd =~ /^=\s*$/) {
1088                             foreach $k (sort keys(%alias)) {
1089                                 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1090                                     print $OUT "$k = $v\n";
1091                                 } else {
1092                                     print $OUT "$k\t$alias{$k}\n";
1093                                 };
1094                             };
1095                         };
1096                         next CMD; };
1097                     $cmd =~ /^\|\|?\s*[^|]/ && do {
1098                         if ($pager =~ /^\|/) {
1099                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1100                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1101                         } else {
1102                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1103                         }
1104                         unless ($piped=open(OUT,$pager)) {
1105                             &warn("Can't pipe output to `$pager'");
1106                             if ($pager =~ /^\|/) {
1107                                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1108                                 open(STDOUT,">&SAVEOUT")
1109                                   || &warn("Can't restore STDOUT");
1110                                 close(SAVEOUT);
1111                             } else {
1112                                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1113                             }
1114                             next CMD;
1115                         }
1116                         $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1117                           && "" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE};
1118                         $selected= select(OUT);
1119                         $|= 1;
1120                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1121                         $cmd =~ s/^\|+\s*//;
1122                         redo PIPE; };
1123                     # XXX Local variants do not work!
1124                     $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1125                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1126                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1127                 }               # PIPE:
1128             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1129             if ($onetimeDump) {
1130                 $onetimeDump = undef;
1131             } elsif ($term_pid == $$) {
1132                 print $OUT "\n";
1133             }
1134         } continue {            # CMD:
1135             if ($piped) {
1136                 if ($pager =~ /^\|/) {
1137                     $?= 0;  close(OUT) || &warn("Can't close DB::OUT");
1138                     &warn( "Pager `$pager' failed: ",
1139                           ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1140                           ( $? & 128 ) ? " (core dumped)" : "",
1141                           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1142                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1143                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1144                     $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1145                     # Will stop ignoring SIGPIPE if done like nohup(1)
1146                     # does SIGINT but Perl doesn't give us a choice.
1147                 } else {
1148                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1149                 }
1150                 close(SAVEOUT);
1151                 select($selected), $selected= "" unless $selected eq "";
1152                 $piped= "";
1153             }
1154         }                       # CMD:
1155         $exiting = 1 unless defined $cmd;
1156         foreach $evalarg (@$post) {
1157           &eval;
1158         }
1159     }                           # if ($single || $signal)
1160     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1161     ();
1162 }
1163
1164 # The following code may be executed now:
1165 # BEGIN {warn 4}
1166
1167 sub sub {
1168     my ($al, $ret, @ret) = "";
1169     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1170         $al = " for $$sub";
1171     }
1172     push(@stack, $single);
1173     $single &= 1;
1174     $single |= 4 if $#stack == $deep;
1175     ($frame & 4
1176      ? ( (print $LINEINFO ' ' x ($#stack - 1), "in  "),
1177          # Why -1? But it works! :-(
1178          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1179      : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1180     if (wantarray) {
1181         @ret = &$sub;
1182         $single |= pop(@stack);
1183         ($frame & 4
1184          ? ( (print $LINEINFO ' ' x $#stack, "out "),
1185              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1186          : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1187         if ($doret eq $#stack or $frame & 16) {
1188             my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
1189             print $fh ' ' x $#stack if $frame & 16;
1190             print $fh "list context return from $sub:\n";
1191             dumpit($fh, \@ret );
1192             $doret = -2;
1193         }
1194         @ret;
1195     } else {
1196         if (defined wantarray) {
1197             $ret = &$sub;
1198         } else {
1199             &$sub; undef $ret;
1200         };
1201         $single |= pop(@stack);
1202         ($frame & 4
1203          ? ( (print $LINEINFO ' ' x $#stack, "out "),
1204               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1205          : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1206         if ($doret eq $#stack or $frame & 16 and defined wantarray) {
1207             my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
1208             print $fh (' ' x $#stack) if $frame & 16;
1209             print $fh (defined wantarray
1210                          ? "scalar context return from $sub: "
1211                          : "void context return from $sub\n");
1212             dumpit( $fh, $ret ) if defined wantarray;
1213             $doret = -2;
1214         }
1215         $ret;
1216     }
1217 }
1218
1219 sub save {
1220     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1221     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1222 }
1223
1224 # The following takes its argument via $evalarg to preserve current @_
1225
1226 sub eval {
1227     my @res;
1228     {
1229         local (@stack) = @stack; # guard against recursive debugging
1230         my $otrace = $trace;
1231         my $osingle = $single;
1232         my $od = $^D;
1233         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1234         $trace = $otrace;
1235         $single = $osingle;
1236         $^D = $od;
1237     }
1238     my $at = $@;
1239     local $saved[0];            # Preserve the old value of $@
1240     eval { &DB::save };
1241     if ($at) {
1242         print $OUT $at;
1243     } elsif ($onetimeDump eq 'dump') {
1244         dumpit($OUT, \@res);
1245     } elsif ($onetimeDump eq 'methods') {
1246         methods($res[0]);
1247     }
1248     @res;
1249 }
1250
1251 sub postponed_sub {
1252   my $subname = shift;
1253   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1254     my $offset = $1 || 0;
1255     # Filename below can contain ':'
1256     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1257     if ($i) {
1258       $i += $offset;
1259       local *dbline = $main::{'_<' . $file};
1260       local $^W = 0;            # != 0 is magical below
1261       $had_breakpoints{$file}++;
1262       my $max = $#dbline;
1263       ++$i until $dbline[$i] != 0 or $i >= $max;
1264       $dbline{$i} = delete $postponed{$subname};
1265     } else {
1266       print $OUT "Subroutine $subname not found.\n";
1267     }
1268     return;
1269   }
1270   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1271   #print $OUT "In postponed_sub for `$subname'.\n";
1272 }
1273
1274 sub postponed {
1275   if ($ImmediateStop) {
1276     $ImmediateStop = 0;
1277     $signal = 1;
1278   }
1279   return &postponed_sub
1280     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1281   # Cannot be done before the file is compiled
1282   local *dbline = shift;
1283   my $filename = $dbline;
1284   $filename =~ s/^_<//;
1285   $signal = 1, print $OUT "'$filename' loaded...\n"
1286     if $break_on_load{$filename};
1287   print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1288   return unless $postponed_file{$filename};
1289   $had_breakpoints{$filename}++;
1290   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1291   my $key;
1292   for $key (keys %{$postponed_file{$filename}}) {
1293     $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1294   }
1295   delete $postponed_file{$filename};
1296 }
1297
1298 sub dumpit {
1299     local ($savout) = select(shift);
1300     my $osingle = $single;
1301     my $otrace = $trace;
1302     $single = $trace = 0;
1303     local $frame = 0;
1304     local $doret = -2;
1305     unless (defined &main::dumpValue) {
1306         do 'dumpvar.pl';
1307     }
1308     if (defined &main::dumpValue) {
1309         &main::dumpValue(shift);
1310     } else {
1311         print $OUT "dumpvar.pl not available.\n";
1312     }
1313     $single = $osingle;
1314     $trace = $otrace;
1315     select ($savout);
1316 }
1317
1318 # Tied method do not create a context, so may get wrong message:
1319
1320 sub print_trace {
1321   my $fh = shift;
1322   my @sub = dump_trace($_[0] + 1, $_[1]);
1323   my $short = $_[2];            # Print short report, next one for sub name
1324   my $s;
1325   for ($i=0; $i <= $#sub; $i++) {
1326     last if $signal;
1327     local $" = ', ';
1328     my $args = defined $sub[$i]{args}
1329     ? "(@{ $sub[$i]{args} })"
1330       : '' ;
1331     $args = (substr $args, 0, $maxtrace - 3) . '...'
1332       if length $args > $maxtrace;
1333     my $file = $sub[$i]{file};
1334     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1335     $s = $sub[$i]{sub};
1336     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1337     if ($short) {
1338       my $sub = @_ >= 4 ? $_[3] : $s;
1339       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1340     } else {
1341       print $fh "$sub[$i]{context} = $s$args" .
1342         " called from $file" .
1343           " line $sub[$i]{line}\n";
1344     }
1345   }
1346 }
1347
1348 sub dump_trace {
1349   my $skip = shift;
1350   my $count = shift || 1e9;
1351   $skip++;
1352   $count += $skip;
1353   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1354   my $nothard = not $frame & 8;
1355   local $frame = 0;             # Do not want to trace this.
1356   my $otrace = $trace;
1357   $trace = 0;
1358   for ($i = $skip;
1359        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1360        $i++) {
1361     @a = ();
1362     for $arg (@args) {
1363       my $type;
1364       if (not defined $arg) {
1365         push @a, "undef";
1366       } elsif ($nothard and tied $arg) {
1367         push @a, "tied";
1368       } elsif ($nothard and $type = ref $arg) {
1369         push @a, "ref($type)";
1370       } else {
1371         local $_ = "$arg";      # Safe to stringify now - should not call f().
1372         s/([\'\\])/\\$1/g;
1373         s/(.*)/'$1'/s
1374           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1375         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1376         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1377         push(@a, $_);
1378       }
1379     }
1380     $context = $context ? '@' : (defined $context ? "\$" : '.');
1381     $args = $h ? [@a] : undef;
1382     $e =~ s/\n\s*\;\s*\Z// if $e;
1383     $e =~ s/([\\\'])/\\$1/g if $e;
1384     if ($r) {
1385       $sub = "require '$e'";
1386     } elsif (defined $r) {
1387       $sub = "eval '$e'";
1388     } elsif ($sub eq '(eval)') {
1389       $sub = "eval {...}";
1390     }
1391     push(@sub, {context => $context, sub => $sub, args => $args,
1392                 file => $file, line => $line});
1393     last if $signal;
1394   }
1395   $trace = $otrace;
1396   @sub;
1397 }
1398
1399 sub action {
1400     my $action = shift;
1401     while ($action =~ s/\\$//) {
1402         #print $OUT "+ ";
1403         #$action .= "\n";
1404         $action .= &gets;
1405     }
1406     $action;
1407 }
1408
1409 sub gets {
1410     local($.);
1411     #<IN>;
1412     &readline("cont: ");
1413 }
1414
1415 sub system {
1416     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1417     # many non-Unix systems can do system() but have problems with fork().
1418     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1419     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1420     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1421     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1422     system(@_);
1423     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1424     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1425     close(SAVEIN); close(SAVEOUT);
1426     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1427           ( $? & 128 ) ? " (core dumped)" : "",
1428           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1429     $?;
1430 }
1431
1432 sub setterm {
1433     local $frame = 0;
1434     local $doret = -2;
1435     local @stack = @stack;              # Prevent growth by failing `use'.
1436     eval { require Term::ReadLine } or die $@;
1437     if ($notty) {
1438         if ($tty) {
1439             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1440             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1441             $IN = \*IN;
1442             $OUT = \*OUT;
1443             my $sel = select($OUT);
1444             $| = 1;
1445             select($sel);
1446         } else {
1447             eval "require Term::Rendezvous;" or die $@;
1448             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1449             my $term_rv = new Term::Rendezvous $rv;
1450             $IN = $term_rv->IN;
1451             $OUT = $term_rv->OUT;
1452         }
1453     }
1454     if (!$rl) {
1455         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1456     } else {
1457         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1458
1459         $rl_attribs = $term->Attribs;
1460         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1461           if defined $rl_attribs->{basic_word_break_characters}
1462             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1463         $rl_attribs->{special_prefixes} = '$@&%';
1464         $rl_attribs->{completer_word_break_characters} .= '$@&%';
1465         $rl_attribs->{completion_function} = \&db_complete;
1466     }
1467     $LINEINFO = $OUT unless defined $LINEINFO;
1468     $lineinfo = $console unless defined $lineinfo;
1469     $term->MinLine(2);
1470     if ($term->Features->{setHistory} and "@hist" ne "?") {
1471       $term->SetHistory(@hist);
1472     }
1473     ornaments($ornaments) if defined $ornaments;
1474     $term_pid = $$;
1475 }
1476
1477 sub resetterm {                 # We forked, so we need a different TTY
1478     $term_pid = $$;
1479     if (defined &get_fork_TTY) {
1480       &get_fork_TTY;
1481     } elsif (not defined $fork_TTY
1482              and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1483              and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1484         # Possibly _inside_ XTERM
1485         open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1486  sleep 10000000' |];
1487         $fork_TTY = <XT>;
1488         chomp $fork_TTY;
1489     }
1490     if (defined $fork_TTY) {
1491       TTY($fork_TTY);
1492       undef $fork_TTY;
1493     } else {
1494       print_help(<<EOP);
1495 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1496   Define B<\$DB::fork_TTY>
1497        - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1498   The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1499   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1500   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1501 EOP
1502     }
1503 }
1504
1505 sub readline {
1506   if (@typeahead) {
1507     my $left = @typeahead;
1508     my $got = shift @typeahead;
1509     print $OUT "auto(-$left)", shift, $got, "\n";
1510     $term->AddHistory($got)
1511       if length($got) > 1 and defined $term->Features->{addHistory};
1512     return $got;
1513   }
1514   local $frame = 0;
1515   local $doret = -2;
1516   $term->readline(@_);
1517 }
1518
1519 sub dump_option {
1520     my ($opt, $val)= @_;
1521     $val = option_val($opt,'N/A');
1522     $val =~ s/([\\\'])/\\$1/g;
1523     printf $OUT "%20s = '%s'\n", $opt, $val;
1524 }
1525
1526 sub option_val {
1527     my ($opt, $default)= @_;
1528     my $val;
1529     if (defined $optionVars{$opt}
1530         and defined $ {$optionVars{$opt}}) {
1531         $val = $ {$optionVars{$opt}};
1532     } elsif (defined $optionAction{$opt}
1533         and defined &{$optionAction{$opt}}) {
1534         $val = &{$optionAction{$opt}}();
1535     } elsif (defined $optionAction{$opt}
1536              and not defined $option{$opt}
1537              or defined $optionVars{$opt}
1538              and not defined $ {$optionVars{$opt}}) {
1539         $val = $default;
1540     } else {
1541         $val = $option{$opt};
1542     }
1543     $val
1544 }
1545
1546 sub parse_options {
1547     local($_)= @_;
1548     while ($_ ne "") {
1549         s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1550         my ($opt,$sep) = ($1,$2);
1551         my $val;
1552         if ("?" eq $sep) {
1553             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1554               if /^\S/;
1555             #&dump_option($opt);
1556         } elsif ($sep !~ /\S/) {
1557             $val = "1";
1558         } elsif ($sep eq "=") {
1559             s/^(\S*)($|\s+)//;
1560             $val = $1;
1561         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1562             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1563             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1564               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1565             $val = $1;
1566             $val =~ s/\\([\\$end])/$1/g;
1567         }
1568         my ($option);
1569         my $matches =
1570           grep(  /^\Q$opt/ && ($option = $_),  @options  );
1571         $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
1572           unless $matches;
1573         print $OUT "Unknown option `$opt'\n" unless $matches;
1574         print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1575         $option{$option} = $val if $matches == 1 and defined $val;
1576         eval "local \$frame = 0; local \$doret = -2;
1577               require '$optionRequire{$option}'"
1578           if $matches == 1 and defined $optionRequire{$option} and defined $val;
1579         $ {$optionVars{$option}} = $val
1580           if $matches == 1
1581             and defined $optionVars{$option} and defined $val;
1582         & {$optionAction{$option}} ($val)
1583           if $matches == 1
1584             and defined $optionAction{$option}
1585               and defined &{$optionAction{$option}} and defined $val;
1586         &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1587         s/^\s+//;
1588     }
1589 }
1590
1591 sub set_list {
1592   my ($stem,@list) = @_;
1593   my $val;
1594   $ENV{"$ {stem}_n"} = @list;
1595   for $i (0 .. $#list) {
1596     $val = $list[$i];
1597     $val =~ s/\\/\\\\/g;
1598     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1599     $ENV{"$ {stem}_$i"} = $val;
1600   }
1601 }
1602
1603 sub get_list {
1604   my $stem = shift;
1605   my @list;
1606   my $n = delete $ENV{"$ {stem}_n"};
1607   my $val;
1608   for $i (0 .. $n - 1) {
1609     $val = delete $ENV{"$ {stem}_$i"};
1610     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1611     push @list, $val;
1612   }
1613   @list;
1614 }
1615
1616 sub catch {
1617     $signal = 1;
1618     return;                     # Put nothing on the stack - malloc/free land!
1619 }
1620
1621 sub warn {
1622     my($msg)= join("",@_);
1623     $msg .= ": $!\n" unless $msg =~ /\n$/;
1624     print $OUT $msg;
1625 }
1626
1627 sub TTY {
1628     if (@_ and $term and $term->Features->{newTTY}) {
1629       my ($in, $out) = shift;
1630       if ($in =~ /,/) {
1631         ($in, $out) = split /,/, $in, 2;
1632       } else {
1633         $out = $in;
1634       }
1635       open IN, $in or die "cannot open `$in' for read: $!";
1636       open OUT, ">$out" or die "cannot open `$out' for write: $!";
1637       $term->newTTY(\*IN, \*OUT);
1638       $IN       = \*IN;
1639       $OUT      = \*OUT;
1640       return $tty = $in;
1641     } elsif ($term and @_) {
1642         &warn("Too late to set TTY, enabled on next `R'!\n");
1643     }
1644     $tty = shift if @_;
1645     $tty or $console;
1646 }
1647
1648 sub noTTY {
1649     if ($term) {
1650         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1651     }
1652     $notty = shift if @_;
1653     $notty;
1654 }
1655
1656 sub ReadLine {
1657     if ($term) {
1658         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1659     }
1660     $rl = shift if @_;
1661     $rl;
1662 }
1663
1664 sub tkRunning {
1665     if ($ {$term->Features}{tkRunning}) {
1666         return $term->tkRunning(@_);
1667     } else {
1668         print $OUT "tkRunning not supported by current ReadLine package.\n";
1669         0;
1670     }
1671 }
1672
1673 sub NonStop {
1674     if ($term) {
1675         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1676     }
1677     $runnonstop = shift if @_;
1678     $runnonstop;
1679 }
1680
1681 sub pager {
1682     if (@_) {
1683         $pager = shift;
1684         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1685     }
1686     $pager;
1687 }
1688
1689 sub shellBang {
1690     if (@_) {
1691         $sh = quotemeta shift;
1692         $sh .= "\\b" if $sh =~ /\w$/;
1693     }
1694     $psh = $sh;
1695     $psh =~ s/\\b$//;
1696     $psh =~ s/\\(.)/$1/g;
1697     &sethelp;
1698     $psh;
1699 }
1700
1701 sub ornaments {
1702   if (defined $term) {
1703     local ($warnLevel,$dieLevel) = (0, 1);
1704     return '' unless $term->Features->{ornaments};
1705     eval { $term->ornaments(@_) } || '';
1706   } else {
1707     $ornaments = shift;
1708   }
1709 }
1710
1711 sub recallCommand {
1712     if (@_) {
1713         $rc = quotemeta shift;
1714         $rc .= "\\b" if $rc =~ /\w$/;
1715     }
1716     $prc = $rc;
1717     $prc =~ s/\\b$//;
1718     $prc =~ s/\\(.)/$1/g;
1719     &sethelp;
1720     $prc;
1721 }
1722
1723 sub LineInfo {
1724     return $lineinfo unless @_;
1725     $lineinfo = shift;
1726     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1727     $emacs = ($stream =~ /^\|/);
1728     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1729     $LINEINFO = \*LINEINFO;
1730     my $save = select($LINEINFO);
1731     $| = 1;
1732     select($save);
1733     $lineinfo;
1734 }
1735
1736 sub list_versions {
1737   my %version;
1738   my $file;
1739   for (keys %INC) {
1740     $file = $_;
1741     s,\.p[lm]$,,i ;
1742     s,/,::,g ;
1743     s/^perl5db$/DB/;
1744     s/^Term::ReadLine::readline$/readline/;
1745     if (defined $ { $_ . '::VERSION' }) {
1746       $version{$file} = "$ { $_ . '::VERSION' } from ";
1747     }
1748     $version{$file} .= $INC{$file};
1749   }
1750   do 'dumpvar.pl' unless defined &main::dumpValue;
1751   if (defined &main::dumpValue) {
1752     local $frame = 0;
1753     &main::dumpValue(\%version);
1754   } else {
1755     print $OUT "dumpvar.pl not available.\n";
1756   }
1757 }
1758
1759 sub sethelp {
1760     $help = "
1761 B<T>            Stack trace.
1762 B<s> [I<expr>]  Single step [in I<expr>].
1763 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
1764 <B<CR>>         Repeat last B<n> or B<s> command.
1765 B<r>            Return from current subroutine.
1766 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
1767                 at the specified position.
1768 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
1769 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
1770 B<l> I<line>            List single I<line>.
1771 B<l> I<subname> List first window of lines from subroutine.
1772 B<l>            List next window of lines.
1773 B<->            List previous window of lines.
1774 B<w> [I<line>]  List window around I<line>.
1775 B<.>            Return to the executed line.
1776 B<f> I<filename>        Switch to viewing I<filename>. Must be loaded.
1777 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
1778 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
1779 B<L>            List all breakpoints and actions.
1780 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1781 B<t>            Toggle trace mode.
1782 B<t> I<expr>            Trace through execution of I<expr>.
1783 B<b> [I<line>] [I<condition>]
1784                 Set breakpoint; I<line> defaults to the current execution line;
1785                 I<condition> breaks if it evaluates to true, defaults to '1'.
1786 B<b> I<subname> [I<condition>]
1787                 Set breakpoint at first line of subroutine.
1788 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1789 B<b> B<postpone> I<subname> [I<condition>]
1790                 Set breakpoint at first line of subroutine after
1791                 it is compiled.
1792 B<b> B<compile> I<subname>
1793                 Stop after the subroutine is compiled.
1794 B<d> [I<line>]  Delete the breakpoint for I<line>.
1795 B<D>            Delete all breakpoints.
1796 B<a> [I<line>] I<command>
1797                 Set an action to be done before the I<line> is executed.
1798                 Sequence is: check for breakpoint/watchpoint, print line
1799                 if necessary, do action, prompt user if necessary,
1800                 execute expression.
1801 B<A>            Delete all actions.
1802 B<W> I<expr>            Add a global watch-expression.
1803 B<W>            Delete all watch-expressions.
1804 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1805                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1806 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
1807 B<x> I<expr>            Evals expression in array context, dumps the result.
1808 B<m> I<expr>            Evals expression in array context, prints methods callable
1809                 on the first element of the result.
1810 B<m> I<class>           Prints methods callable via the given class.
1811 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1812                 Set or query values of options.  I<val> defaults to 1.  I<opt> can
1813                 be abbreviated.  Several options can be listed.
1814     I<recallCommand>, I<ShellBang>:     chars used to recall command or spawn shell;
1815     I<pager>:                   program for output of \"|cmd\";
1816     I<tkRunning>:                       run Tk while prompting (with ReadLine);
1817     I<signalLevel> I<warnLevel> I<dieLevel>:    level of verbosity;
1818     I<inhibit_exit>             Allows stepping off the end of the script.
1819     I<ImmediateStop>            Debugger should stop as early as possible.
1820   The following options affect what happens with B<V>, B<X>, and B<x> commands:
1821     I<arrayDepth>, I<hashDepth>:        print only first N elements ('' for all);
1822     I<compactDump>, I<veryCompact>:     change style of array and hash dump;
1823     I<globPrint>:                       whether to print contents of globs;
1824     I<DumpDBFiles>:             dump arrays holding debugged files;
1825     I<DumpPackages>:            dump symbol tables of packages;
1826     I<DumpReused>:              dump contents of \"reused\" addresses;
1827     I<quote>, I<HighBit>, I<undefPrint>:        change style of string dump;
1828     I<bareStringify>:           Do not print the overload-stringified value;
1829   Option I<PrintRet> affects printing of return value after B<r> command,
1830          I<frame>    affects printing messages on entry and exit from subroutines.
1831          I<AutoTrace> affects printing messages on every possible breaking point.
1832          I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1833          I<ornaments> affects screen appearance of the command line.
1834                 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1835                 You can put additional initialization options I<TTY>, I<noTTY>,
1836                 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1837 B<<> I<expr>            Define Perl command to run before each prompt.
1838 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
1839 B<>> I<expr>            Define Perl command to run after each prompt.
1840 B<>>B<>> I<expr>        Add to the list of Perl commands to run after each prompt.
1841 B<{> I<db_command>      Define debugger command to run before each prompt.
1842 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
1843 B<$prc> I<number>       Redo a previous command (default previous command).
1844 B<$prc> I<-number>      Redo number'th-to-last command.
1845 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
1846                 See 'B<O> I<recallCommand>' too.
1847 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1848   . ( $rc eq $sh ? "" : "
1849 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1850                 See 'B<O> I<shellBang>' too.
1851 B<H> I<-number> Display last number commands (default all).
1852 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
1853 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
1854 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1855 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
1856 I<command>              Execute as a perl statement in current package.
1857 B<v>            Show versions of loaded modules.
1858 B<R>            Pure-man-restart of debugger, some of debugger state
1859                 and command-line options may be lost.
1860                 Currently the following setting are preserved:
1861                 history, breakpoints and actions, debugger B<O>ptions
1862                 and the following command-line options: I<-w>, I<-I>, I<-e>.
1863 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
1864 B<h h>          Summary of debugger commands.
1865 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
1866
1867 ";
1868     $summary = <<"END_SUM";
1869 I<List/search source lines:>               I<Control script execution:>
1870   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
1871   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
1872   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
1873   B<f> I<filename>  View source in file         <B<CR>>        Repeat last B<n> or B<s>
1874   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
1875   B<v>        Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
1876 I<Debugger controls:>                        B<L>           List break/watch/actions
1877   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
1878   B<<>[B<<>] or B<{>[B<{>] [I<cmd>]   Do before prompt   B<b> [I<ln>|I<event>] [I<cnd>]  Set breakpoint
1879   B<>>[B<>>] [I<cmd>]  Do after prompt             B<b> I<sub> [I<cnd>] Set breakpoint for sub
1880   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
1881   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
1882   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
1883   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
1884   B<|>[B<|>]I<dbcmd>   Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1885   B<q> or B<^D>     Quit                          B<R>        Attempt a restart
1886 I<Data Examination:>          B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1887   B<x>|B<m> I<expr>     Evals expr in array context, dumps the result or lists methods.
1888   B<p> I<expr>  Print expression (uses script's current package).
1889   B<S> [[B<!>]I<pat>]   List subroutine names [not] matching pattern
1890   B<V> [I<Pk> [I<Vars>]]        List Variables in Package.  Vars can be ~pattern or !pattern.
1891   B<X> [I<Vars>]        Same as \"B<V> I<current_package> [I<Vars>]\".
1892 END_SUM
1893                                 # ')}}; # Fix balance of Emacs parsing
1894 }
1895
1896 sub print_help {
1897   my $message = shift;
1898   if (@Term::ReadLine::TermCap::rl_term_set) {
1899     $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1900     $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1901   }
1902   print $OUT $message;
1903 }
1904
1905 sub diesignal {
1906     local $frame = 0;
1907     local $doret = -2;
1908     $SIG{'ABRT'} = 'DEFAULT';
1909     kill 'ABRT', $$ if $panic++;
1910     if (defined &Carp::longmess) {
1911         local $SIG{__WARN__} = '';
1912         local $Carp::CarpLevel = 2;             # mydie + confess
1913         &warn(Carp::longmess("Signal @_"));
1914     }
1915     else {
1916         print $DB::OUT "Got signal @_\n";
1917     }
1918     kill 'ABRT', $$;
1919 }
1920
1921 sub dbwarn {
1922   local $frame = 0;
1923   local $doret = -2;
1924   local $SIG{__WARN__} = '';
1925   local $SIG{__DIE__} = '';
1926   eval { require Carp } if defined $^S; # If error/warning during compilation,
1927                                         # require may be broken.
1928   warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1929     return unless defined &Carp::longmess;
1930   my ($mysingle,$mytrace) = ($single,$trace);
1931   $single = 0; $trace = 0;
1932   my $mess = Carp::longmess(@_);
1933   ($single,$trace) = ($mysingle,$mytrace);
1934   &warn($mess);
1935 }
1936
1937 sub dbdie {
1938   local $frame = 0;
1939   local $doret = -2;
1940   local $SIG{__DIE__} = '';
1941   local $SIG{__WARN__} = '';
1942   my $i = 0; my $ineval = 0; my $sub;
1943   if ($dieLevel > 2) {
1944       local $SIG{__WARN__} = \&dbwarn;
1945       &warn(@_);                # Yell no matter what
1946       return;
1947   }
1948   if ($dieLevel < 2) {
1949     die @_ if $^S;              # in eval propagate
1950   }
1951   eval { require Carp } if defined $^S; # If error/warning during compilation,
1952                                         # require may be broken.
1953   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1954     unless defined &Carp::longmess;
1955   # We do not want to debug this chunk (automatic disabling works
1956   # inside DB::DB, but not in Carp).
1957   my ($mysingle,$mytrace) = ($single,$trace);
1958   $single = 0; $trace = 0;
1959   my $mess = Carp::longmess(@_);
1960   ($single,$trace) = ($mysingle,$mytrace);
1961   die $mess;
1962 }
1963
1964 sub warnLevel {
1965   if (@_) {
1966     $prevwarn = $SIG{__WARN__} unless $warnLevel;
1967     $warnLevel = shift;
1968     if ($warnLevel) {
1969       $SIG{__WARN__} = \&DB::dbwarn;
1970     } else {
1971       $SIG{__WARN__} = $prevwarn;
1972     }
1973   }
1974   $warnLevel;
1975 }
1976
1977 sub dieLevel {
1978   if (@_) {
1979     $prevdie = $SIG{__DIE__} unless $dieLevel;
1980     $dieLevel = shift;
1981     if ($dieLevel) {
1982       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1983       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1984       print $OUT "Stack dump during die enabled",
1985         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1986           if $I_m_init;
1987       print $OUT "Dump printed too.\n" if $dieLevel > 2;
1988     } else {
1989       $SIG{__DIE__} = $prevdie;
1990       print $OUT "Default die handler restored.\n";
1991     }
1992   }
1993   $dieLevel;
1994 }
1995
1996 sub signalLevel {
1997   if (@_) {
1998     $prevsegv = $SIG{SEGV} unless $signalLevel;
1999     $prevbus = $SIG{BUS} unless $signalLevel;
2000     $signalLevel = shift;
2001     if ($signalLevel) {
2002       $SIG{SEGV} = \&DB::diesignal;
2003       $SIG{BUS} = \&DB::diesignal;
2004     } else {
2005       $SIG{SEGV} = $prevsegv;
2006       $SIG{BUS} = $prevbus;
2007     }
2008   }
2009   $signalLevel;
2010 }
2011
2012 sub find_sub {
2013   my $subr = shift;
2014   return unless defined &$subr;
2015   $sub{$subr} or do {
2016     $subr = \&$subr;            # Hard reference
2017     my $s;
2018     for (keys %sub) {
2019       $s = $_, last if $subr eq \&$_;
2020     }
2021     $sub{$s} if $s;
2022   }
2023 }
2024
2025 sub methods {
2026   my $class = shift;
2027   $class = ref $class if ref $class;
2028   local %seen;
2029   local %packs;
2030   methods_via($class, '', 1);
2031   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2032 }
2033
2034 sub methods_via {
2035   my $class = shift;
2036   return if $packs{$class}++;
2037   my $prefix = shift;
2038   my $prepend = $prefix ? "via $prefix: " : '';
2039   my $name;
2040   for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2041              sort keys %{"$ {class}::"}) {
2042     next if $seen{ $name }++;
2043     print $DB::OUT "$prepend$name\n";
2044   }
2045   return unless shift;          # Recurse?
2046   for $name (@{"$ {class}::ISA"}) {
2047     $prepend = $prefix ? $prefix . " -> $name" : $name;
2048     methods_via($name, $prepend, 1);
2049   }
2050 }
2051
2052 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2053
2054 BEGIN {                 # This does not compile, alas.
2055   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
2056   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
2057   $sh = '!';
2058   $rc = ',';
2059   @hist = ('?');
2060   $deep = 100;                  # warning if stack gets this deep
2061   $window = 10;
2062   $preview = 3;
2063   $sub = '';
2064   $SIG{INT} = \&DB::catch;
2065   # This may be enabled to debug debugger:
2066   #$warnLevel = 1 unless defined $warnLevel;
2067   #$dieLevel = 1 unless defined $dieLevel;
2068   #$signalLevel = 1 unless defined $signalLevel;
2069
2070   $db_stop = 0;                 # Compiler warning
2071   $db_stop = 1 << 30;
2072   $level = 0;                   # Level of recursive debugging
2073   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2074   # Triggers bug (?) in perl is we postpone this until runtime:
2075   @postponed = @stack = (0);
2076   $doret = -2;
2077   $frame = 0;
2078 }
2079
2080 BEGIN {$^W = $ini_warn;}        # Switch warnings back
2081
2082 #use Carp;                      # This did break, left for debuggin
2083
2084 sub db_complete {
2085   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2086   my($text, $line, $start) = @_;
2087   my ($itext, $search, $prefix, $pack) =
2088     ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2089
2090   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2091                                (map { /$search/ ? ($1) : () } keys %sub)
2092     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2093   return sort grep /^\Q$text/, values %INC # files
2094     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2095   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2096     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2097       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2098   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2099     grep !/^main::/,
2100       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2101                                  # packages
2102         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2103           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
2104   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2105     # We may want to complete to (eval 9), so $text may be wrong
2106     $prefix = length($1) - length($text);
2107     $text = $1;
2108     return sort
2109         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2110   }
2111   if ((substr $text, 0, 1) eq '&') { # subroutines
2112     $text = substr $text, 1;
2113     $prefix = "&";
2114     return sort map "$prefix$_",
2115                grep /^\Q$text/,
2116                  (keys %sub),
2117                  (map { /$search/ ? ($1) : () }
2118                     keys %sub);
2119   }
2120   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2121     $pack = ($1 eq 'main' ? '' : $1) . '::';
2122     $prefix = (substr $text, 0, 1) . $1 . '::';
2123     $text = $2;
2124     my @out
2125       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2126     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2127       return db_complete($out[0], $line, $start);
2128     }
2129     return sort @out;
2130   }
2131   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2132     $pack = ($package eq 'main' ? '' : $package) . '::';
2133     $prefix = substr $text, 0, 1;
2134     $text = substr $text, 1;
2135     my @out = map "$prefix$_", grep /^\Q$text/,
2136        (grep /^_?[a-zA-Z]/, keys %$pack),
2137        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2138     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2139       return db_complete($out[0], $line, $start);
2140     }
2141     return sort @out;
2142   }
2143   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2144     my @out = grep /^\Q$text/, @options;
2145     my $val = option_val($out[0], undef);
2146     my $out = '? ';
2147     if (not defined $val or $val =~ /[\n\r]/) {
2148       # Can do nothing better
2149     } elsif ($val =~ /\s/) {
2150       my $found;
2151       foreach $l (split //, qq/\"\'\#\|/) {
2152         $out = "$l$val$l ", last if (index $val, $l) == -1;
2153       }
2154     } else {
2155       $out = "=$val ";
2156     }
2157     # Default to value if one completion, to question if many
2158     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2159     return sort @out;
2160   }
2161   return $term->filename_list($text); # filenames
2162 }
2163
2164 sub end_report {
2165   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
2166 }
2167
2168 END {
2169   $finished = $inhibit_exit;    # So that some keys may be disabled.
2170   # Do not stop in at_exit() and destructors on exit:
2171   $DB::single = !$exiting && !$runnonstop;
2172   DB::fake::at_exit() unless $exiting or $runnonstop;
2173 }
2174
2175 package DB::fake;
2176
2177 sub at_exit {
2178   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
2179 }
2180
2181 package DB;                     # Do not trace this 1; below!
2182
2183 1;