lib/perl5db.pl

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