lib/perl5db.pl

   1 package DB;
   2
   3 # Debugger for Perl 5.00x; perl5db.pl patch level:
   4
   5 $VERSION = 0.9902;
   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 "  $i:\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 ($sub =~ /(.*)::AUTOLOAD$/) {
1090       $al = " for $ {$1 . '::AUTOLOAD'}";
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         print ($OUT "list context return from $sub:\n"), dumpit( \@ret ),
1104           $doret = -2 if $doret eq $#stack;
1105         ($frame & 4
1106          ? ( (print $LINEINFO ' ' x $#stack, "out "),
1107              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1108          : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1109         @ret;
1110     } else {
1111         $ret = &$sub;
1112         $single |= pop(@stack);
1113         print ($OUT "scalar context return from $sub: "), dumpit( $ret ),
1114           $doret = -2 if $doret eq $#stack;
1115         ($frame & 4
1116          ? ( (print $LINEINFO ' ' x $#stack, "out "),
1117               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1118          : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1119         $ret;
1120     }
1121 }
1122
1123 sub save {
1124     @saved = ($@, $!, $,, $/, $\, $^W);
1125     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1126 }
1127
1128 # The following takes its argument via $evalarg to preserve current @_
1129
1130 sub eval {
1131     my @res;
1132     {
1133         local (@stack) = @stack; # guard against recursive debugging
1134         my $otrace = $trace;
1135         my $osingle = $single;
1136         my $od = $^D;
1137         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1138         $trace = $otrace;
1139         $single = $osingle;
1140         $^D = $od;
1141     }
1142     my $at = $@;
1143     local $saved[0];            # Preserve the old value of $@
1144     eval "&DB::save";
1145     if ($at) {
1146         print $OUT $at;
1147     } elsif ($onetimeDump eq 'dump') {
1148         dumpit(\@res);
1149     } elsif ($onetimeDump eq 'methods') {
1150         methods($res[0]);
1151     }
1152 }
1153
1154 sub postponed_sub {
1155   my $subname = shift;
1156   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1157     my $offset = $1 || 0;
1158     # Filename below can contain ':'
1159     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1160     $i += $offset;
1161     if ($i) {
1162       local *dbline = $main::{'_<' . $file};
1163       local $^W = 0;            # != 0 is magical below
1164       $had_breakpoints{$file}++;
1165       my $max = $#dbline;
1166       ++$i until $dbline[$i] != 0 or $i >= $max;
1167       $dbline{$i} = delete $postponed{$subname};
1168     } else {
1169       print $OUT "Subroutine $subname not found.\n";
1170     }
1171     return;
1172   }
1173   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1174   #print $OUT "In postponed_sub for `$subname'.\n";
1175 }
1176
1177 sub postponed {
1178   return &postponed_sub
1179     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1180   # Cannot be done before the file is compiled
1181   local *dbline = shift;
1182   my $filename = $dbline;
1183   $filename =~ s/^_<//;
1184   $signal = 1, print $OUT "'$filename' loaded...\n"
1185     if $break_on_load{$filename};
1186   print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1187   return unless %{$postponed_file{$filename}};
1188   $had_breakpoints{$filename}++;
1189   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1190   my $key;
1191   for $key (keys %{$postponed_file{$filename}}) {
1192     $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1193   }
1194   undef %{$postponed_file{$filename}};
1195 }
1196
1197 sub dumpit {
1198     local ($savout) = select($OUT);
1199     my $osingle = $single;
1200     my $otrace = $trace;
1201     $single = $trace = 0;
1202     local $frame = 0;
1203     local $doret = -2;
1204     unless (defined &main::dumpValue) {
1205         do 'dumpvar.pl';
1206     }
1207     if (defined &main::dumpValue) {
1208         &main::dumpValue(shift);
1209     } else {
1210         print $OUT "dumpvar.pl not available.\n";
1211     }
1212     $single = $osingle;
1213     $trace = $otrace;
1214     select ($savout);
1215 }
1216
1217 # Tied method do not create a context, so may get wrong message:
1218
1219 sub print_trace {
1220   my $fh = shift;
1221   my @sub = dump_trace($_[0] + 1, $_[1]);
1222   my $short = $_[2];            # Print short report, next one for sub name
1223   my $s;
1224   for ($i=0; $i <= $#sub; $i++) {
1225     last if $signal;
1226     local $" = ', ';
1227     my $args = defined $sub[$i]{args}
1228     ? "(@{ $sub[$i]{args} })"
1229       : '' ;
1230     $args = (substr $args, 0, $maxtrace - 3) . '...'
1231       if length $args > $maxtrace;
1232     my $file = $sub[$i]{file};
1233     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1234     $s = $sub[$i]{sub};
1235     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1236     if ($short) {
1237       my $sub = @_ >= 4 ? $_[3] : $s;
1238       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1239     } else {
1240       print $fh "$sub[$i]{context} = $s$args" .
1241         " called from $file" .
1242           " line $sub[$i]{line}\n";
1243     }
1244   }
1245 }
1246
1247 sub dump_trace {
1248   my $skip = shift;
1249   my $count = shift || 1e9;
1250   $skip++;
1251   $count += $skip;
1252   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1253   my $nothard = not $frame & 8;
1254   local $frame = 0;             # Do not want to trace this.
1255   my $otrace = $trace;
1256   $trace = 0;
1257   for ($i = $skip;
1258        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1259        $i++) {
1260     @a = ();
1261     for $arg (@args) {
1262       my $type;
1263       if (not defined $arg) {
1264         push @a, "undef";
1265       } elsif ($nothard and tied $arg) {
1266         push @a, "tied";
1267       } elsif ($nothard and $type = ref $arg) {
1268         push @a, "ref($type)";
1269       } else {
1270         local $_ = "$arg";      # Safe to stringify now - should not call f().
1271         s/([\'\\])/\\$1/g;
1272         s/(.*)/'$1'/s
1273           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1274         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1275         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1276         push(@a, $_);
1277       }
1278     }
1279     $context = $context ? '@' : "\$";
1280     $args = $h ? [@a] : undef;
1281     $e =~ s/\n\s*\;\s*\Z// if $e;
1282     $e =~ s/([\\\'])/\\$1/g if $e;
1283     if ($r) {
1284       $sub = "require '$e'";
1285     } elsif (defined $r) {
1286       $sub = "eval '$e'";
1287     } elsif ($sub eq '(eval)') {
1288       $sub = "eval {...}";
1289     }
1290     push(@sub, {context => $context, sub => $sub, args => $args,
1291                 file => $file, line => $line});
1292     last if $signal;
1293   }
1294   $trace = $otrace;
1295   @sub;
1296 }
1297
1298 sub action {
1299     my $action = shift;
1300     while ($action =~ s/\\$//) {
1301         #print $OUT "+ ";
1302         #$action .= "\n";
1303         $action .= &gets;
1304     }
1305     $action;
1306 }
1307
1308 sub gets {
1309     local($.);
1310     #<IN>;
1311     &readline("cont: ");
1312 }
1313
1314 sub system {
1315     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1316     # many non-Unix systems can do system() but have problems with fork().
1317     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1318     open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1319     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1320     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1321     system(@_);
1322     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1323     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1324     close(SAVEIN); close(SAVEOUT);
1325     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1326           ( $? & 128 ) ? " (core dumped)" : "",
1327           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1328     $?;
1329 }
1330
1331 sub setterm {
1332     local $frame = 0;
1333     local $doret = -2;
1334     local @stack = @stack;              # Prevent growth by failing `use'.
1335     eval { require Term::ReadLine } or die $@;
1336     if ($notty) {
1337         if ($tty) {
1338             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1339             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1340             $IN = \*IN;
1341             $OUT = \*OUT;
1342             my $sel = select($OUT);
1343             $| = 1;
1344             select($sel);
1345         } else {
1346             eval "require Term::Rendezvous;" or die $@;
1347             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1348             my $term_rv = new Term::Rendezvous $rv;
1349             $IN = $term_rv->IN;
1350             $OUT = $term_rv->OUT;
1351         }
1352     }
1353     if (!$rl) {
1354         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1355     } else {
1356         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1357
1358         $readline::rl_basic_word_break_characters .= "[:"
1359           if defined $readline::rl_basic_word_break_characters
1360             and index($readline::rl_basic_word_break_characters, ":") == -1;
1361         $readline::rl_special_prefixes =
1362           $readline::rl_special_prefixes = '$@&%';
1363         $readline::rl_completer_word_break_characters =
1364           $readline::rl_completer_word_break_characters . '$@&%';
1365         $readline::rl_completion_function =
1366           $readline::rl_completion_function = \&db_complete;
1367     }
1368     $LINEINFO = $OUT unless defined $LINEINFO;
1369     $lineinfo = $console unless defined $lineinfo;
1370     $term->MinLine(2);
1371     if ($term->Features->{setHistory} and "@hist" ne "?") {
1372       $term->SetHistory(@hist);
1373     }
1374 }
1375
1376 sub readline {
1377   if (@typeahead) {
1378     my $left = @typeahead;
1379     my $got = shift @typeahead;
1380     print $OUT "auto(-$left)", shift, $got, "\n";
1381     $term->AddHistory($got)
1382       if length($got) > 1 and defined $term->Features->{addHistory};
1383     return $got;
1384   }
1385   local $frame = 0;
1386   local $doret = -2;
1387   $term->readline(@_);
1388 }
1389
1390 sub dump_option {
1391     my ($opt, $val)= @_;
1392     $val = option_val($opt,'N/A');
1393     $val =~ s/([\\\'])/\\$1/g;
1394     printf $OUT "%20s = '%s'\n", $opt, $val;
1395 }
1396
1397 sub option_val {
1398     my ($opt, $default)= @_;
1399     my $val;
1400     if (defined $optionVars{$opt}
1401         and defined $ {$optionVars{$opt}}) {
1402         $val = $ {$optionVars{$opt}};
1403     } elsif (defined $optionAction{$opt}
1404         and defined &{$optionAction{$opt}}) {
1405         $val = &{$optionAction{$opt}}();
1406     } elsif (defined $optionAction{$opt}
1407              and not defined $option{$opt}
1408              or defined $optionVars{$opt}
1409              and not defined $ {$optionVars{$opt}}) {
1410         $val = $default;
1411     } else {
1412         $val = $option{$opt};
1413     }
1414     $val
1415 }
1416
1417 sub parse_options {
1418     local($_)= @_;
1419     while ($_ ne "") {
1420         s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1421         my ($opt,$sep) = ($1,$2);
1422         my $val;
1423         if ("?" eq $sep) {
1424             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1425               if /^\S/;
1426             #&dump_option($opt);
1427         } elsif ($sep !~ /\S/) {
1428             $val = "1";
1429         } elsif ($sep eq "=") {
1430             s/^(\S*)($|\s+)//;
1431             $val = $1;
1432         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1433             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1434             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1435               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1436             $val = $1;
1437             $val =~ s/\\([\\$end])/$1/g;
1438         }
1439         my ($option);
1440         my $matches =
1441           grep(  /^\Q$opt/ && ($option = $_),  @options  );
1442         $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
1443           unless $matches;
1444         print $OUT "Unknown option `$opt'\n" unless $matches;
1445         print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1446         $option{$option} = $val if $matches == 1 and defined $val;
1447         eval "local \$frame = 0; local \$doret = -2;
1448               require '$optionRequire{$option}'"
1449           if $matches == 1 and defined $optionRequire{$option} and defined $val;
1450         $ {$optionVars{$option}} = $val
1451           if $matches == 1
1452             and defined $optionVars{$option} and defined $val;
1453         & {$optionAction{$option}} ($val)
1454           if $matches == 1
1455             and defined $optionAction{$option}
1456               and defined &{$optionAction{$option}} and defined $val;
1457         &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1458         s/^\s+//;
1459     }
1460 }
1461
1462 sub set_list {
1463   my ($stem,@list) = @_;
1464   my $val;
1465   $ENV{"$ {stem}_n"} = @list;
1466   for $i (0 .. $#list) {
1467     $val = $list[$i];
1468     $val =~ s/\\/\\\\/g;
1469     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1470     $ENV{"$ {stem}_$i"} = $val;
1471   }
1472 }
1473
1474 sub get_list {
1475   my $stem = shift;
1476   my @list;
1477   my $n = delete $ENV{"$ {stem}_n"};
1478   my $val;
1479   for $i (0 .. $n - 1) {
1480     $val = delete $ENV{"$ {stem}_$i"};
1481     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1482     push @list, $val;
1483   }
1484   @list;
1485 }
1486
1487 sub catch {
1488     $signal = 1;
1489     return;                     # Put nothing on the stack - malloc/free land!
1490 }
1491
1492 sub warn {
1493     my($msg)= join("",@_);
1494     $msg .= ": $!\n" unless $msg =~ /\n$/;
1495     print $OUT $msg;
1496 }
1497
1498 sub TTY {
1499     if ($term) {
1500         &warn("Too late to set TTY!\n") if @_;
1501     } else {
1502         $tty = shift if @_;
1503     }
1504     $tty or $console;
1505 }
1506
1507 sub noTTY {
1508     if ($term) {
1509         &warn("Too late to set noTTY!\n") if @_;
1510     } else {
1511         $notty = shift if @_;
1512     }
1513     $notty;
1514 }
1515
1516 sub ReadLine {
1517     if ($term) {
1518         &warn("Too late to set ReadLine!\n") if @_;
1519     } else {
1520         $rl = shift if @_;
1521     }
1522     $rl;
1523 }
1524
1525 sub NonStop {
1526     if ($term) {
1527         &warn("Too late to set up NonStop mode!\n") if @_;
1528     } else {
1529         $runnonstop = shift if @_;
1530     }
1531     $runnonstop;
1532 }
1533
1534 sub pager {
1535     if (@_) {
1536         $pager = shift;
1537         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1538     }
1539     $pager;
1540 }
1541
1542 sub shellBang {
1543     if (@_) {
1544         $sh = quotemeta shift;
1545         $sh .= "\\b" if $sh =~ /\w$/;
1546     }
1547     $psh = $sh;
1548     $psh =~ s/\\b$//;
1549     $psh =~ s/\\(.)/$1/g;
1550     &sethelp;
1551     $psh;
1552 }
1553
1554 sub recallCommand {
1555     if (@_) {
1556         $rc = quotemeta shift;
1557         $rc .= "\\b" if $rc =~ /\w$/;
1558     }
1559     $prc = $rc;
1560     $prc =~ s/\\b$//;
1561     $prc =~ s/\\(.)/$1/g;
1562     &sethelp;
1563     $prc;
1564 }
1565
1566 sub LineInfo {
1567     return $lineinfo unless @_;
1568     $lineinfo = shift;
1569     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1570     $emacs = ($stream =~ /^\|/);
1571     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1572     $LINEINFO = \*LINEINFO;
1573     my $save = select($LINEINFO);
1574     $| = 1;
1575     select($save);
1576     $lineinfo;
1577 }
1578
1579 sub list_versions {
1580   my %version;
1581   my $file;
1582   for (keys %INC) {
1583     $file = $_;
1584     s,\.p[lm]$,,i ;
1585     s,/,::,g ;
1586     s/^perl5db$/DB/;
1587     s/^Term::ReadLine::readline$/readline/;
1588     if (defined $ { $_ . '::VERSION' }) {
1589       $version{$file} = "$ { $_ . '::VERSION' } from ";
1590     }
1591     $version{$file} .= $INC{$file};
1592   }
1593   do 'dumpvar.pl' unless defined &main::dumpValue;
1594   if (defined &main::dumpValue) {
1595     local $frame = 0;
1596     &main::dumpValue(\%version);
1597   } else {
1598     print $OUT "dumpvar.pl not available.\n";
1599   }
1600 }
1601
1602 sub sethelp {
1603     $help = "
1604 T               Stack trace.
1605 s [expr]        Single step [in expr].
1606 n [expr]        Next, steps over subroutine calls [in expr].
1607 <CR>            Repeat last n or s command.
1608 r               Return from current subroutine.
1609 c [line|sub]    Continue; optionally inserts a one-time-only breakpoint
1610                 at the specified position.
1611 l min+incr      List incr+1 lines starting at min.
1612 l min-max       List lines min through max.
1613 l line          List single line.
1614 l subname       List first window of lines from subroutine.
1615 l               List next window of lines.
1616 -               List previous window of lines.
1617 w [line]        List window around line.
1618 .               Return to the executed line.
1619 f filename      Switch to viewing filename. Must be loaded.
1620 /pattern/       Search forwards for pattern; final / is optional.
1621 ?pattern?       Search backwards for pattern; final ? is optional.
1622 L               List all breakpoints and actions.
1623 S [[!]pattern]  List subroutine names [not] matching pattern.
1624 t               Toggle trace mode.
1625 t expr          Trace through execution of expr.
1626 b [line] [condition]
1627                 Set breakpoint; line defaults to the current execution line;
1628                 condition breaks if it evaluates to true, defaults to '1'.
1629 b subname [condition]
1630                 Set breakpoint at first line of subroutine.
1631 b load filename Set breakpoint on `require'ing the given file.
1632 b postpone subname [condition]
1633                 Set breakpoint at first line of subroutine after
1634                 it is compiled.
1635 b compile subname
1636                 Stop after the subroutine is compiled.
1637 d [line]        Delete the breakpoint for line.
1638 D               Delete all breakpoints.
1639 a [line] command
1640                 Set an action to be done before the line is executed.
1641                 Sequence is: check for breakpoint, print line if necessary,
1642                 do action, prompt user if breakpoint or step, evaluate line.
1643 A               Delete all actions.
1644 V [pkg [vars]]  List some (default all) variables in package (default current).
1645                 Use ~pattern and !pattern for positive and negative regexps.
1646 X [vars]        Same as \"V currentpackage [vars]\".
1647 x expr          Evals expression in array context, dumps the result.
1648 m expr          Evals expression in array context, prints methods callable
1649                 on the first element of the result.
1650 m class         Prints methods callable via the given class.
1651 O [opt[=val]] [opt\"val\"] [opt?]...
1652                 Set or query values of options.  val defaults to 1.  opt can
1653                 be abbreviated.  Several options can be listed.
1654     recallCommand, ShellBang:   chars used to recall command or spawn shell;
1655     pager:                      program for output of \"|cmd\";
1656     tkRunning:                  run Tk while prompting (with ReadLine);
1657     signalLevel warnLevel dieLevel:     level of verbosity;
1658     inhibit_exit                Allows stepping off the end of the script.
1659   The following options affect what happens with V, X, and x commands:
1660     arrayDepth, hashDepth:      print only first N elements ('' for all);
1661     compactDump, veryCompact:   change style of array and hash dump;
1662     globPrint:                  whether to print contents of globs;
1663     DumpDBFiles:                dump arrays holding debugged files;
1664     DumpPackages:               dump symbol tables of packages;
1665     quote, HighBit, undefPrint: change style of string dump;
1666   Option PrintRet affects printing of return value after r command,
1667          frame    affects printing messages on entry and exit from subroutines.
1668          AutoTrace affects printing messages on every possible breaking point.
1669          maxTraceLen gives maximal length of evals/args listed in stack trace.
1670                 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1671                 You can put additional initialization options TTY, noTTY,
1672                 ReadLine, and NonStop there.
1673 < command       Define Perl command to run before each prompt.
1674 << command      Add to the list of Perl commands to run before each prompt.
1675 > command       Define Perl command to run after each prompt.
1676 >> command      Add to the list of Perl commands to run after each prompt.
1677 \{ commandline  Define debugger command to run before each prompt.
1678 \{{ commandline Add to the list of debugger commands to run before each prompt.
1679 $prc number     Redo a previous command (default previous command).
1680 $prc -number    Redo number'th-to-last command.
1681 $prc pattern    Redo last command that started with pattern.
1682                 See 'O recallCommand' too.
1683 $psh$psh cmd    Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1684   . ( $rc eq $sh ? "" : "
1685 $psh [cmd]      Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1686                 See 'O shellBang' too.
1687 H -number       Display last number commands (default all).
1688 p expr          Same as \"print {DB::OUT} expr\" in current package.
1689 |dbcmd          Run debugger command, piping DB::OUT to current pager.
1690 ||dbcmd         Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1691 \= [alias value]        Define a command alias, or list current aliases.
1692 command         Execute as a perl statement in current package.
1693 v               Show versions of loaded modules.
1694 R               Pure-man-restart of debugger, some of debugger state
1695                 and command-line options may be lost.
1696                 Currently the following setting are preserved:
1697                 history, breakpoints and actions, debugger Options
1698                 and the following command-line options: -w, -I, -e.
1699 h [db_command]  Get help [on a specific debugger command], enter |h to page.
1700 h h             Summary of debugger commands.
1701 q or ^D         Quit. Set \$DB::finished to 0 to debug global destruction.
1702
1703 ";
1704     $summary = <<"END_SUM";
1705 List/search source lines:               Control script execution:
1706   l [ln|sub]  List source code            T           Stack trace
1707   - or .      List previous/current line  s [expr]    Single step [in expr]
1708   w [line]    List around line            n [expr]    Next, steps over subs
1709   f filename  View source in file         <CR>        Repeat last n or s
1710   /pattern/ ?patt?   Search forw/backw    r           Return from subroutine
1711   v           Show versions of modules    c [ln|sub]  Continue until position
1712 Debugger controls:                        L           List break pts & actions
1713   O [...]     Set debugger options        t [expr]    Toggle trace [trace expr]
1714   <[<] or {[{] [cmd]   Do before prompt   b [ln/event] [c]     Set breakpoint
1715   >[>] [cmd]  Do after prompt             b sub [c]   Set breakpoint for sub
1716   $prc [N|pat]   Redo a previous command     d [line]    Delete a breakpoint
1717   H [-num]    Display last num commands   D           Delete all breakpoints
1718   = [a val]   Define/list an alias        a [ln] cmd  Do cmd before line
1719   h [db_cmd]  Get help on command         A           Delete all actions
1720   |[|]dbcmd   Send output to pager        $psh\[$psh\] syscmd Run cmd in a subprocess
1721   q or ^D     Quit                        R           Attempt a restart
1722 Data Examination:             expr     Execute perl code, also see: s,n,t expr
1723   x|m expr      Evals expr in array context, dumps the result or lists methods.
1724   p expr        Print expression (uses script's current package).
1725   S [[!]pat]    List subroutine names [not] matching pattern
1726   V [Pk [Vars]] List Variables in Package.  Vars can be ~pattern or !pattern.
1727   X [Vars]      Same as \"V current_package [Vars]\".
1728 END_SUM
1729                                 # ')}}; # Fix balance of Emacs parsing
1730 }
1731
1732 sub diesignal {
1733     local $frame = 0;
1734     local $doret = -2;
1735     $SIG{'ABRT'} = 'DEFAULT';
1736     kill 'ABRT', $$ if $panic++;
1737     print $DB::OUT "Got $_[0]!\n";      # in the case cannot continue
1738     local $SIG{__WARN__} = '';
1739     require Carp;
1740     local $Carp::CarpLevel = 2;         # mydie + confess
1741     &warn(Carp::longmess("Signal @_"));
1742     kill 'ABRT', $$;
1743 }
1744
1745 sub dbwarn {
1746   local $frame = 0;
1747   local $doret = -2;
1748   local $SIG{__WARN__} = '';
1749   local $SIG{__DIE__} = '';
1750   eval { require Carp };        # If error/warning during compilation,
1751                                 # require may be broken.
1752   warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1753     unless defined &Carp::longmess;
1754   #&warn("Entering dbwarn\n");
1755   my ($mysingle,$mytrace) = ($single,$trace);
1756   $single = 0; $trace = 0;
1757   my $mess = Carp::longmess(@_);
1758   ($single,$trace) = ($mysingle,$mytrace);
1759   #&warn("Warning in dbwarn\n");
1760   &warn($mess);
1761   #&warn("Exiting dbwarn\n");
1762 }
1763
1764 sub dbdie {
1765   local $frame = 0;
1766   local $doret = -2;
1767   local $SIG{__DIE__} = '';
1768   local $SIG{__WARN__} = '';
1769   my $i = 0; my $ineval = 0; my $sub;
1770   #&warn("Entering dbdie\n");
1771   if ($dieLevel != 2) {
1772     while ((undef,undef,undef,$sub) = caller(++$i)) {
1773       $ineval = 1, last if $sub eq '(eval)';
1774     }
1775     {
1776       local $SIG{__WARN__} = \&dbwarn;
1777       &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1778     }
1779     #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1780     die @_ if $ineval and $dieLevel < 2;
1781   }
1782   eval { require Carp };        # If error/warning during compilation,
1783                                 # require may be broken.
1784   die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1785   # We do not want to debug this chunk (automatic disabling works
1786   # inside DB::DB, but not in Carp).
1787   my ($mysingle,$mytrace) = ($single,$trace);
1788   $single = 0; $trace = 0;
1789   my $mess = Carp::longmess(@_);
1790   ($single,$trace) = ($mysingle,$mytrace);
1791   #&warn("dieing loudly in dbdie\n");
1792   die $mess;
1793 }
1794
1795 sub warnLevel {
1796   if (@_) {
1797     $prevwarn = $SIG{__WARN__} unless $warnLevel;
1798     $warnLevel = shift;
1799     if ($warnLevel) {
1800       $SIG{__WARN__} = \&DB::dbwarn;
1801     } else {
1802       $SIG{__WARN__} = $prevwarn;
1803     }
1804   }
1805   $warnLevel;
1806 }
1807
1808 sub dieLevel {
1809   if (@_) {
1810     $prevdie = $SIG{__DIE__} unless $dieLevel;
1811     $dieLevel = shift;
1812     if ($dieLevel) {
1813       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1814       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1815       print $OUT "Stack dump during die enabled",
1816         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1817       print $OUT "Dump printed too.\n" if $dieLevel > 2;
1818     } else {
1819       $SIG{__DIE__} = $prevdie;
1820       print $OUT "Default die handler restored.\n";
1821     }
1822   }
1823   $dieLevel;
1824 }
1825
1826 sub signalLevel {
1827   if (@_) {
1828     $prevsegv = $SIG{SEGV} unless $signalLevel;
1829     $prevbus = $SIG{BUS} unless $signalLevel;
1830     $signalLevel = shift;
1831     if ($signalLevel) {
1832       $SIG{SEGV} = \&DB::diesignal;
1833       $SIG{BUS} = \&DB::diesignal;
1834     } else {
1835       $SIG{SEGV} = $prevsegv;
1836       $SIG{BUS} = $prevbus;
1837     }
1838   }
1839   $signalLevel;
1840 }
1841
1842 sub find_sub {
1843   my $subr = shift;
1844   return unless defined &$subr;
1845   $sub{$subr} or do {
1846     $subr = \&$subr;            # Hard reference
1847     my $s;
1848     for (keys %sub) {
1849       $s = $_, last if $subr eq \&$_;
1850     }
1851     $sub{$s} if $s;
1852   }
1853 }
1854
1855 sub methods {
1856   my $class = shift;
1857   $class = ref $class if ref $class;
1858   local %seen;
1859   local %packs;
1860   methods_via($class, '', 1);
1861   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
1862 }
1863
1864 sub methods_via {
1865   my $class = shift;
1866   return if $packs{$class}++;
1867   my $prefix = shift;
1868   my $prepend = $prefix ? "via $prefix: " : '';
1869   my $name;
1870   for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
1871              sort keys %{"$ {class}::"}) {
1872     next if $seen{ $name }++;
1873     print $DB::OUT "$prepend$name\n";
1874   }
1875   return unless shift;          # Recurse?
1876   for $name (@{"$ {class}::ISA"}) {
1877     $prepend = $prefix ? $prefix . " -> $name" : $name;
1878     methods_via($name, $prepend, 1);
1879   }
1880 }
1881
1882 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1883
1884 BEGIN {                 # This does not compile, alas.
1885   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
1886   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
1887   $sh = '!';
1888   $rc = ',';
1889   @hist = ('?');
1890   $deep = 100;                  # warning if stack gets this deep
1891   $window = 10;
1892   $preview = 3;
1893   $sub = '';
1894   $SIG{INT} = \&DB::catch;
1895   # This may be enabled to debug debugger:
1896   #$warnLevel = 1 unless defined $warnLevel;
1897   #$dieLevel = 1 unless defined $dieLevel;
1898   #$signalLevel = 1 unless defined $signalLevel;
1899
1900   $db_stop = 0;                 # Compiler warning
1901   $db_stop = 1 << 30;
1902   $level = 0;                   # Level of recursive debugging
1903   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1904   # Triggers bug (?) in perl is we postpone this until runtime:
1905   @postponed = @stack = (0);
1906   $doret = -2;
1907   $frame = 0;
1908 }
1909
1910 BEGIN {$^W = $ini_warn;}        # Switch warnings back
1911
1912 #use Carp;                      # This did break, left for debuggin
1913
1914 sub db_complete {
1915   # Specific code for b l V m f O, &blah, $blah, @blah, %blah
1916   my($text, $line, $start) = @_;
1917   my ($itext, $search, $prefix, $pack) =
1918     ($text, "^\Q$ {package}::\E([^:]+)\$");
1919
1920   return grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
1921                           (map { /$search/ ? ($1) : () } keys %sub)
1922     if (substr $line, 0, $start) =~ /^\|*[bl]\s+((postpone|compile)\s+)?$/;
1923   return grep /^\Q$text/, values %INC # files
1924     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
1925   return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages
1926     if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^($|\w)/;
1927   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
1928     # We may want to complete to (eval 9), so $text may be wrong
1929     $prefix = length($1) - length($text);
1930     $text = $1;
1931     return map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
1932   }
1933   if ((substr $text, 0, 1) eq '&') { # subroutines
1934     $text = substr $text, 1;
1935     $prefix = "&";
1936     return map "$prefix$_",
1937              grep /^\Q$text/,
1938                (keys %sub),
1939                (map { /$search/ ? ($1) : () }
1940                   keys %sub);
1941   }
1942   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
1943     $pack = ($1 eq 'main' ? '' : $1) . '::';
1944     $prefix = (substr $text, 0, 1) . $1 . '::';
1945     $text = $2;
1946     my @out
1947       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
1948     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1949       return db_complete($out[0], $line, $start);
1950     }
1951     return @out;
1952   }
1953   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
1954     $pack = ($package eq 'main' ? '' : $package) . '::';
1955     $prefix = substr $text, 0, 1;
1956     $text = substr $text, 1;
1957     my @out = map "$prefix$_", grep /^\Q$text/,
1958        (grep /^_?[a-zA-Z]/, keys %$pack),
1959        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
1960     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1961       return db_complete($out[0], $line, $start);
1962     }
1963     return @out;
1964   }
1965   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
1966     my @out = grep /^\Q$text/, @options;
1967     my $val = option_val($out[0], undef);
1968     my $out = '? ';
1969     if (not defined $val or $val =~ /[\n\r]/) {
1970       # Can do nothing better
1971     } elsif ($val =~ /\s/) {
1972       my $found;
1973       foreach $l (split //, qq/\"\'\#\|/) {
1974         $out = "$l$val$l ", last if (index $val, $l) == -1;
1975       }
1976     } else {
1977       $out = "=$val ";
1978     }
1979     # Default to value if one completion, to question if many
1980     $readline::rl_completer_terminator_character
1981       = $readline::rl_completer_terminator_character
1982         = (@out == 1 ? $out : '? ');
1983     return @out;
1984   }
1985   return &readline::rl_filename_list($text); # filenames
1986 }
1987
1988 sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
1989
1990 END {
1991   $finished = $inhibit_exit;    # So that some keys may be disabled.
1992   # Do not stop in at_exit() and destructors on exit:
1993   $DB::single = !$exiting && !$runnonstop;
1994   DB::fake::at_exit() unless $exiting or $runnonstop;
1995 }
1996
1997 package DB::fake;
1998
1999 sub at_exit {
2000   "Debuggee terminated. Use `q' to quit and `R' to restart.";
2001 }
2002
2003 package DB;                     # Do not trace this 1; below!
2004
2005 1;