lib/perl5db.pl

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