lib/perl5db.pl

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