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