lib/perl5db.pl

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