lib/perl5db.pl

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