lib/perl5db.pl

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