lib/perl5db.pl

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