lib/perl5db.pl

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