lib/perl5db.pl

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