lib/perl5db.pl

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