lib/perl5db.pl

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