lib/perl5db.pl

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