lib/perl5db.pl

   1 package DB;
   2
   3 # Debugger for Perl 5.00x; perl5db.pl patch level:
   4
   5 $VERSION = 1.03;
   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 |= 1 if 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];
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];
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         if ($doret eq $#stack or $frame & 16) {
1186             my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
1187             print $fh ' ' x $#stack if $frame & 16;
1188             print $fh "list context return from $sub:\n";
1189             dumpit($fh, \@ret );
1190             $doret = -2;
1191         }
1192         @ret;
1193     } else {
1194         if (defined wantarray) {
1195             $ret = &$sub;
1196         } else {
1197             &$sub; undef $ret;
1198         };
1199         $single |= pop(@stack);
1200         ($frame & 4
1201          ? ( (print $LINEINFO ' ' x $#stack, "out "),
1202               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1203          : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1204         if ($doret eq $#stack or $frame & 16 and defined wantarray) {
1205             my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
1206             print $fh (' ' x $#stack) if $frame & 16;
1207             print $fh (defined wantarray
1208                          ? "scalar context return from $sub: "
1209                          : "void context return from $sub\n");
1210             dumpit( $fh, $ret ) if defined wantarray;
1211             $doret = -2;
1212         }
1213         $ret;
1214     }
1215 }
1216
1217 sub save {
1218     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1219     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1220 }
1221
1222 # The following takes its argument via $evalarg to preserve current @_
1223
1224 sub eval {
1225     my @res;
1226     {
1227         local (@stack) = @stack; # guard against recursive debugging
1228         my $otrace = $trace;
1229         my $osingle = $single;
1230         my $od = $^D;
1231         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1232         $trace = $otrace;
1233         $single = $osingle;
1234         $^D = $od;
1235     }
1236     my $at = $@;
1237     local $saved[0];            # Preserve the old value of $@
1238     eval { &DB::save };
1239     if ($at) {
1240         print $OUT $at;
1241     } elsif ($onetimeDump eq 'dump') {
1242         dumpit($OUT, \@res);
1243     } elsif ($onetimeDump eq 'methods') {
1244         methods($res[0]);
1245     }
1246     @res;
1247 }
1248
1249 sub postponed_sub {
1250   my $subname = shift;
1251   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1252     my $offset = $1 || 0;
1253     # Filename below can contain ':'
1254     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1255     if ($i) {
1256       $i += $offset;
1257       local *dbline = $main::{'_<' . $file};
1258       local $^W = 0;            # != 0 is magical below
1259       $had_breakpoints{$file}++;
1260       my $max = $#dbline;
1261       ++$i until $dbline[$i] != 0 or $i >= $max;
1262       $dbline{$i} = delete $postponed{$subname};
1263     } else {
1264       print $OUT "Subroutine $subname not found.\n";
1265     }
1266     return;
1267   }
1268   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1269   #print $OUT "In postponed_sub for `$subname'.\n";
1270 }
1271
1272 sub postponed {
1273   if ($ImmediateStop) {
1274     $ImmediateStop = 0;
1275     $signal = 1;
1276   }
1277   return &postponed_sub
1278     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1279   # Cannot be done before the file is compiled
1280   local *dbline = shift;
1281   my $filename = $dbline;
1282   $filename =~ s/^_<//;
1283   $signal = 1, print $OUT "'$filename' loaded...\n"
1284     if $break_on_load{$filename};
1285   print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1286   return unless $postponed_file{$filename};
1287   $had_breakpoints{$filename}++;
1288   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1289   my $key;
1290   for $key (keys %{$postponed_file{$filename}}) {
1291     $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1292   }
1293   delete $postponed_file{$filename};
1294 }
1295
1296 sub dumpit {
1297     local ($savout) = select(shift);
1298     my $osingle = $single;
1299     my $otrace = $trace;
1300     $single = $trace = 0;
1301     local $frame = 0;
1302     local $doret = -2;
1303     unless (defined &main::dumpValue) {
1304         do 'dumpvar.pl';
1305     }
1306     if (defined &main::dumpValue) {
1307         &main::dumpValue(shift);
1308     } else {
1309         print $OUT "dumpvar.pl not available.\n";
1310     }
1311     $single = $osingle;
1312     $trace = $otrace;
1313     select ($savout);
1314 }
1315
1316 # Tied method do not create a context, so may get wrong message:
1317
1318 sub print_trace {
1319   my $fh = shift;
1320   my @sub = dump_trace($_[0] + 1, $_[1]);
1321   my $short = $_[2];            # Print short report, next one for sub name
1322   my $s;
1323   for ($i=0; $i <= $#sub; $i++) {
1324     last if $signal;
1325     local $" = ', ';
1326     my $args = defined $sub[$i]{args}
1327     ? "(@{ $sub[$i]{args} })"
1328       : '' ;
1329     $args = (substr $args, 0, $maxtrace - 3) . '...'
1330       if length $args > $maxtrace;
1331     my $file = $sub[$i]{file};
1332     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1333     $s = $sub[$i]{sub};
1334     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1335     if ($short) {
1336       my $sub = @_ >= 4 ? $_[3] : $s;
1337       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1338     } else {
1339       print $fh "$sub[$i]{context} = $s$args" .
1340         " called from $file" .
1341           " line $sub[$i]{line}\n";
1342     }
1343   }
1344 }
1345
1346 sub dump_trace {
1347   my $skip = shift;
1348   my $count = shift || 1e9;
1349   $skip++;
1350   $count += $skip;
1351   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1352   my $nothard = not $frame & 8;
1353   local $frame = 0;             # Do not want to trace this.
1354   my $otrace = $trace;
1355   $trace = 0;
1356   for ($i = $skip;
1357        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1358        $i++) {
1359     @a = ();
1360     for $arg (@args) {
1361       my $type;
1362       if (not defined $arg) {
1363         push @a, "undef";
1364       } elsif ($nothard and tied $arg) {
1365         push @a, "tied";
1366       } elsif ($nothard and $type = ref $arg) {
1367         push @a, "ref($type)";
1368       } else {
1369         local $_ = "$arg";      # Safe to stringify now - should not call f().
1370         s/([\'\\])/\\$1/g;
1371         s/(.*)/'$1'/s
1372           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1373         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1374         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1375         push(@a, $_);
1376       }
1377     }
1378     $context = $context ? '@' : (defined $context ? "\$" : '.');
1379     $args = $h ? [@a] : undef;
1380     $e =~ s/\n\s*\;\s*\Z// if $e;
1381     $e =~ s/([\\\'])/\\$1/g if $e;
1382     if ($r) {
1383       $sub = "require '$e'";
1384     } elsif (defined $r) {
1385       $sub = "eval '$e'";
1386     } elsif ($sub eq '(eval)') {
1387       $sub = "eval {...}";
1388     }
1389     push(@sub, {context => $context, sub => $sub, args => $args,
1390                 file => $file, line => $line});
1391     last if $signal;
1392   }
1393   $trace = $otrace;
1394   @sub;
1395 }
1396
1397 sub action {
1398     my $action = shift;
1399     while ($action =~ s/\\$//) {
1400         #print $OUT "+ ";
1401         #$action .= "\n";
1402         $action .= &gets;
1403     }
1404     $action;
1405 }
1406
1407 sub gets {
1408     local($.);
1409     #<IN>;
1410     &readline("cont: ");
1411 }
1412
1413 sub system {
1414     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1415     # many non-Unix systems can do system() but have problems with fork().
1416     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1417     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1418     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1419     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1420     system(@_);
1421     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1422     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1423     close(SAVEIN); close(SAVEOUT);
1424     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1425           ( $? & 128 ) ? " (core dumped)" : "",
1426           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1427     $?;
1428 }
1429
1430 sub setterm {
1431     local $frame = 0;
1432     local $doret = -2;
1433     local @stack = @stack;              # Prevent growth by failing `use'.
1434     eval { require Term::ReadLine } or die $@;
1435     if ($notty) {
1436         if ($tty) {
1437             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1438             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1439             $IN = \*IN;
1440             $OUT = \*OUT;
1441             my $sel = select($OUT);
1442             $| = 1;
1443             select($sel);
1444         } else {
1445             eval "require Term::Rendezvous;" or die $@;
1446             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1447             my $term_rv = new Term::Rendezvous $rv;
1448             $IN = $term_rv->IN;
1449             $OUT = $term_rv->OUT;
1450         }
1451     }
1452     if (!$rl) {
1453         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1454     } else {
1455         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1456
1457         $rl_attribs = $term->Attribs;
1458         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1459           if defined $rl_attribs->{basic_word_break_characters}
1460             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1461         $rl_attribs->{special_prefixes} = '$@&%';
1462         $rl_attribs->{completer_word_break_characters} .= '$@&%';
1463         $rl_attribs->{completion_function} = \&db_complete;
1464     }
1465     $LINEINFO = $OUT unless defined $LINEINFO;
1466     $lineinfo = $console unless defined $lineinfo;
1467     $term->MinLine(2);
1468     if ($term->Features->{setHistory} and "@hist" ne "?") {
1469       $term->SetHistory(@hist);
1470     }
1471     ornaments($ornaments) if defined $ornaments;
1472     $term_pid = $$;
1473 }
1474
1475 sub resetterm {                 # We forked, so we need a different TTY
1476     $term_pid = $$;
1477     if (defined &get_fork_TTY) {
1478       &get_fork_TTY;
1479     } elsif (not defined $fork_TTY
1480              and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1481              and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1482         # Possibly _inside_ XTERM
1483         open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1484  sleep 10000000' |];
1485         $fork_TTY = <XT>;
1486         chomp $fork_TTY;
1487     }
1488     if (defined $fork_TTY) {
1489       TTY($fork_TTY);
1490       undef $fork_TTY;
1491     } else {
1492       print_help(<<EOP);
1493 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1494   Define B<\$DB::fork_TTY>
1495        - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1496   The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1497   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1498   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1499 EOP
1500     }
1501 }
1502
1503 sub readline {
1504   if (@typeahead) {
1505     my $left = @typeahead;
1506     my $got = shift @typeahead;
1507     print $OUT "auto(-$left)", shift, $got, "\n";
1508     $term->AddHistory($got)
1509       if length($got) > 1 and defined $term->Features->{addHistory};
1510     return $got;
1511   }
1512   local $frame = 0;
1513   local $doret = -2;
1514   $term->readline(@_);
1515 }
1516
1517 sub dump_option {
1518     my ($opt, $val)= @_;
1519     $val = option_val($opt,'N/A');
1520     $val =~ s/([\\\'])/\\$1/g;
1521     printf $OUT "%20s = '%s'\n", $opt, $val;
1522 }
1523
1524 sub option_val {
1525     my ($opt, $default)= @_;
1526     my $val;
1527     if (defined $optionVars{$opt}
1528         and defined $ {$optionVars{$opt}}) {
1529         $val = $ {$optionVars{$opt}};
1530     } elsif (defined $optionAction{$opt}
1531         and defined &{$optionAction{$opt}}) {
1532         $val = &{$optionAction{$opt}}();
1533     } elsif (defined $optionAction{$opt}
1534              and not defined $option{$opt}
1535              or defined $optionVars{$opt}
1536              and not defined $ {$optionVars{$opt}}) {
1537         $val = $default;
1538     } else {
1539         $val = $option{$opt};
1540     }
1541     $val
1542 }
1543
1544 sub parse_options {
1545     local($_)= @_;
1546     while ($_ ne "") {
1547         s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1548         my ($opt,$sep) = ($1,$2);
1549         my $val;
1550         if ("?" eq $sep) {
1551             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1552               if /^\S/;
1553             #&dump_option($opt);
1554         } elsif ($sep !~ /\S/) {
1555             $val = "1";
1556         } elsif ($sep eq "=") {
1557             s/^(\S*)($|\s+)//;
1558             $val = $1;
1559         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1560             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1561             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1562               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1563             $val = $1;
1564             $val =~ s/\\([\\$end])/$1/g;
1565         }
1566         my ($option);
1567         my $matches =
1568           grep(  /^\Q$opt/ && ($option = $_),  @options  );
1569         $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
1570           unless $matches;
1571         print $OUT "Unknown option `$opt'\n" unless $matches;
1572         print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1573         $option{$option} = $val if $matches == 1 and defined $val;
1574         eval "local \$frame = 0; local \$doret = -2;
1575               require '$optionRequire{$option}'"
1576           if $matches == 1 and defined $optionRequire{$option} and defined $val;
1577         $ {$optionVars{$option}} = $val
1578           if $matches == 1
1579             and defined $optionVars{$option} and defined $val;
1580         & {$optionAction{$option}} ($val)
1581           if $matches == 1
1582             and defined $optionAction{$option}
1583               and defined &{$optionAction{$option}} and defined $val;
1584         &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1585         s/^\s+//;
1586     }
1587 }
1588
1589 sub set_list {
1590   my ($stem,@list) = @_;
1591   my $val;
1592   $ENV{"$ {stem}_n"} = @list;
1593   for $i (0 .. $#list) {
1594     $val = $list[$i];
1595     $val =~ s/\\/\\\\/g;
1596     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1597     $ENV{"$ {stem}_$i"} = $val;
1598   }
1599 }
1600
1601 sub get_list {
1602   my $stem = shift;
1603   my @list;
1604   my $n = delete $ENV{"$ {stem}_n"};
1605   my $val;
1606   for $i (0 .. $n - 1) {
1607     $val = delete $ENV{"$ {stem}_$i"};
1608     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1609     push @list, $val;
1610   }
1611   @list;
1612 }
1613
1614 sub catch {
1615     $signal = 1;
1616     return;                     # Put nothing on the stack - malloc/free land!
1617 }
1618
1619 sub warn {
1620     my($msg)= join("",@_);
1621     $msg .= ": $!\n" unless $msg =~ /\n$/;
1622     print $OUT $msg;
1623 }
1624
1625 sub TTY {
1626     if (@_ and $term and $term->Features->{newTTY}) {
1627       my ($in, $out) = shift;
1628       if ($in =~ /,/) {
1629         ($in, $out) = split /,/, $in, 2;
1630       } else {
1631         $out = $in;
1632       }
1633       open IN, $in or die "cannot open `$in' for read: $!";
1634       open OUT, ">$out" or die "cannot open `$out' for write: $!";
1635       $term->newTTY(\*IN, \*OUT);
1636       $IN       = \*IN;
1637       $OUT      = \*OUT;
1638       return $tty = $in;
1639     } elsif ($term and @_) {
1640         &warn("Too late to set TTY, enabled on next `R'!\n");
1641     }
1642     $tty = shift if @_;
1643     $tty or $console;
1644 }
1645
1646 sub noTTY {
1647     if ($term) {
1648         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1649     }
1650     $notty = shift if @_;
1651     $notty;
1652 }
1653
1654 sub ReadLine {
1655     if ($term) {
1656         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1657     }
1658     $rl = shift if @_;
1659     $rl;
1660 }
1661
1662 sub tkRunning {
1663     if ($ {$term->Features}{tkRunning}) {
1664         return $term->tkRunning(@_);
1665     } else {
1666         print $OUT "tkRunning not supported by current ReadLine package.\n";
1667         0;
1668     }
1669 }
1670
1671 sub NonStop {
1672     if ($term) {
1673         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1674     }
1675     $runnonstop = shift if @_;
1676     $runnonstop;
1677 }
1678
1679 sub pager {
1680     if (@_) {
1681         $pager = shift;
1682         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1683     }
1684     $pager;
1685 }
1686
1687 sub shellBang {
1688     if (@_) {
1689         $sh = quotemeta shift;
1690         $sh .= "\\b" if $sh =~ /\w$/;
1691     }
1692     $psh = $sh;
1693     $psh =~ s/\\b$//;
1694     $psh =~ s/\\(.)/$1/g;
1695     &sethelp;
1696     $psh;
1697 }
1698
1699 sub ornaments {
1700   if (defined $term) {
1701     local ($warnLevel,$dieLevel) = (0, 1);
1702     return '' unless $term->Features->{ornaments};
1703     eval { $term->ornaments(@_) } || '';
1704   } else {
1705     $ornaments = shift;
1706   }
1707 }
1708
1709 sub recallCommand {
1710     if (@_) {
1711         $rc = quotemeta shift;
1712         $rc .= "\\b" if $rc =~ /\w$/;
1713     }
1714     $prc = $rc;
1715     $prc =~ s/\\b$//;
1716     $prc =~ s/\\(.)/$1/g;
1717     &sethelp;
1718     $prc;
1719 }
1720
1721 sub LineInfo {
1722     return $lineinfo unless @_;
1723     $lineinfo = shift;
1724     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1725     $emacs = ($stream =~ /^\|/);
1726     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1727     $LINEINFO = \*LINEINFO;
1728     my $save = select($LINEINFO);
1729     $| = 1;
1730     select($save);
1731     $lineinfo;
1732 }
1733
1734 sub list_versions {
1735   my %version;
1736   my $file;
1737   for (keys %INC) {
1738     $file = $_;
1739     s,\.p[lm]$,,i ;
1740     s,/,::,g ;
1741     s/^perl5db$/DB/;
1742     s/^Term::ReadLine::readline$/readline/;
1743     if (defined $ { $_ . '::VERSION' }) {
1744       $version{$file} = "$ { $_ . '::VERSION' } from ";
1745     }
1746     $version{$file} .= $INC{$file};
1747   }
1748   do 'dumpvar.pl' unless defined &main::dumpValue;
1749   if (defined &main::dumpValue) {
1750     local $frame = 0;
1751     &main::dumpValue(\%version);
1752   } else {
1753     print $OUT "dumpvar.pl not available.\n";
1754   }
1755 }
1756
1757 sub sethelp {
1758     $help = "
1759 B<T>            Stack trace.
1760 B<s> [I<expr>]  Single step [in I<expr>].
1761 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
1762 <B<CR>>         Repeat last B<n> or B<s> command.
1763 B<r>            Return from current subroutine.
1764 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
1765                 at the specified position.
1766 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
1767 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
1768 B<l> I<line>            List single I<line>.
1769 B<l> I<subname> List first window of lines from subroutine.
1770 B<l>            List next window of lines.
1771 B<->            List previous window of lines.
1772 B<w> [I<line>]  List window around I<line>.
1773 B<.>            Return to the executed line.
1774 B<f> I<filename>        Switch to viewing I<filename>. Must be loaded.
1775 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
1776 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
1777 B<L>            List all breakpoints and actions.
1778 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1779 B<t>            Toggle trace mode.
1780 B<t> I<expr>            Trace through execution of I<expr>.
1781 B<b> [I<line>] [I<condition>]
1782                 Set breakpoint; I<line> defaults to the current execution line;
1783                 I<condition> breaks if it evaluates to true, defaults to '1'.
1784 B<b> I<subname> [I<condition>]
1785                 Set breakpoint at first line of subroutine.
1786 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1787 B<b> B<postpone> I<subname> [I<condition>]
1788                 Set breakpoint at first line of subroutine after
1789                 it is compiled.
1790 B<b> B<compile> I<subname>
1791                 Stop after the subroutine is compiled.
1792 B<d> [I<line>]  Delete the breakpoint for I<line>.
1793 B<D>            Delete all breakpoints.
1794 B<a> [I<line>] I<command>
1795                 Set an action to be done before the I<line> is executed.
1796                 Sequence is: check for breakpoint/watchpoint, print line
1797                 if necessary, do action, prompt user if necessary,
1798                 execute expression.
1799 B<A>            Delete all actions.
1800 B<W> I<expr>            Add a global watch-expression.
1801 B<W>            Delete all watch-expressions.
1802 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1803                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1804 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
1805 B<x> I<expr>            Evals expression in array context, dumps the result.
1806 B<m> I<expr>            Evals expression in array context, prints methods callable
1807                 on the first element of the result.
1808 B<m> I<class>           Prints methods callable via the given class.
1809 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1810                 Set or query values of options.  I<val> defaults to 1.  I<opt> can
1811                 be abbreviated.  Several options can be listed.
1812     I<recallCommand>, I<ShellBang>:     chars used to recall command or spawn shell;
1813     I<pager>:                   program for output of \"|cmd\";
1814     I<tkRunning>:                       run Tk while prompting (with ReadLine);
1815     I<signalLevel> I<warnLevel> I<dieLevel>:    level of verbosity;
1816     I<inhibit_exit>             Allows stepping off the end of the script.
1817     I<ImmediateStop>            Debugger should stop as early as possible.
1818   The following options affect what happens with B<V>, B<X>, and B<x> commands:
1819     I<arrayDepth>, I<hashDepth>:        print only first N elements ('' for all);
1820     I<compactDump>, I<veryCompact>:     change style of array and hash dump;
1821     I<globPrint>:                       whether to print contents of globs;
1822     I<DumpDBFiles>:             dump arrays holding debugged files;
1823     I<DumpPackages>:            dump symbol tables of packages;
1824     I<DumpReused>:              dump contents of \"reused\" addresses;
1825     I<quote>, I<HighBit>, I<undefPrint>:        change style of string dump;
1826   Option I<PrintRet> affects printing of return value after B<r> command,
1827          I<frame>    affects printing messages on entry and exit from subroutines.
1828          I<AutoTrace> affects printing messages on every possible breaking point.
1829          I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1830          I<ornaments> affects screen appearance of the command line.
1831                 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1832                 You can put additional initialization options I<TTY>, I<noTTY>,
1833                 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1834 B<<> I<expr>            Define Perl command to run before each prompt.
1835 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
1836 B<>> I<expr>            Define Perl command to run after each prompt.
1837 B<>>B<>> I<expr>        Add to the list of Perl commands to run after each prompt.
1838 B<{> I<db_command>      Define debugger command to run before each prompt.
1839 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
1840 B<$prc> I<number>       Redo a previous command (default previous command).
1841 B<$prc> I<-number>      Redo number'th-to-last command.
1842 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
1843                 See 'B<O> I<recallCommand>' too.
1844 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1845   . ( $rc eq $sh ? "" : "
1846 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1847                 See 'B<O> I<shellBang>' too.
1848 B<H> I<-number> Display last number commands (default all).
1849 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
1850 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
1851 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1852 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
1853 I<command>              Execute as a perl statement in current package.
1854 B<v>            Show versions of loaded modules.
1855 B<R>            Pure-man-restart of debugger, some of debugger state
1856                 and command-line options may be lost.
1857                 Currently the following setting are preserved:
1858                 history, breakpoints and actions, debugger B<O>ptions
1859                 and the following command-line options: I<-w>, I<-I>, I<-e>.
1860 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
1861 B<h h>          Summary of debugger commands.
1862 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
1863
1864 ";
1865     $summary = <<"END_SUM";
1866 I<List/search source lines:>               I<Control script execution:>
1867   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
1868   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
1869   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
1870   B<f> I<filename>  View source in file         <B<CR>>        Repeat last B<n> or B<s>
1871   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
1872   B<v>        Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
1873 I<Debugger controls:>                        B<L>           List break/watch/actions
1874   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
1875   B<<>[B<<>] or B<{>[B<{>] [I<cmd>]   Do before prompt   B<b> [I<ln>|I<event>] [I<cnd>]  Set breakpoint
1876   B<>>[B<>>] [I<cmd>]  Do after prompt             B<b> I<sub> [I<cnd>] Set breakpoint for sub
1877   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
1878   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
1879   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
1880   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
1881   B<|>[B<|>]I<dbcmd>   Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1882   B<q> or B<^D>     Quit                          B<R>        Attempt a restart
1883 I<Data Examination:>          B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1884   B<x>|B<m> I<expr>     Evals expr in array context, dumps the result or lists methods.
1885   B<p> I<expr>  Print expression (uses script's current package).
1886   B<S> [[B<!>]I<pat>]   List subroutine names [not] matching pattern
1887   B<V> [I<Pk> [I<Vars>]]        List Variables in Package.  Vars can be ~pattern or !pattern.
1888   B<X> [I<Vars>]        Same as \"B<V> I<current_package> [I<Vars>]\".
1889 END_SUM
1890                                 # ')}}; # Fix balance of Emacs parsing
1891 }
1892
1893 sub print_help {
1894   my $message = shift;
1895   if (@Term::ReadLine::TermCap::rl_term_set) {
1896     $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1897     $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1898   }
1899   print $OUT $message;
1900 }
1901
1902 sub diesignal {
1903     local $frame = 0;
1904     local $doret = -2;
1905     $SIG{'ABRT'} = 'DEFAULT';
1906     kill 'ABRT', $$ if $panic++;
1907     if (defined &Carp::longmess) {
1908         local $SIG{__WARN__} = '';
1909         local $Carp::CarpLevel = 2;             # mydie + confess
1910         &warn(Carp::longmess("Signal @_"));
1911     }
1912     else {
1913         print $DB::OUT "Got signal @_\n";
1914     }
1915     kill 'ABRT', $$;
1916 }
1917
1918 sub dbwarn {
1919   local $frame = 0;
1920   local $doret = -2;
1921   local $SIG{__WARN__} = '';
1922   local $SIG{__DIE__} = '';
1923   eval { require Carp } if defined $^S; # If error/warning during compilation,
1924                                         # require may be broken.
1925   warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1926     return unless defined &Carp::longmess;
1927   my ($mysingle,$mytrace) = ($single,$trace);
1928   $single = 0; $trace = 0;
1929   my $mess = Carp::longmess(@_);
1930   ($single,$trace) = ($mysingle,$mytrace);
1931   &warn($mess);
1932 }
1933
1934 sub dbdie {
1935   local $frame = 0;
1936   local $doret = -2;
1937   local $SIG{__DIE__} = '';
1938   local $SIG{__WARN__} = '';
1939   my $i = 0; my $ineval = 0; my $sub;
1940   if ($dieLevel > 2) {
1941       local $SIG{__WARN__} = \&dbwarn;
1942       &warn(@_);                # Yell no matter what
1943       return;
1944   }
1945   if ($dieLevel < 2) {
1946     die @_ if $^S;              # in eval propagate
1947   }
1948   eval { require Carp } if defined $^S; # If error/warning during compilation,
1949                                         # require may be broken.
1950   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1951     unless defined &Carp::longmess;
1952   # We do not want to debug this chunk (automatic disabling works
1953   # inside DB::DB, but not in Carp).
1954   my ($mysingle,$mytrace) = ($single,$trace);
1955   $single = 0; $trace = 0;
1956   my $mess = Carp::longmess(@_);
1957   ($single,$trace) = ($mysingle,$mytrace);
1958   die $mess;
1959 }
1960
1961 sub warnLevel {
1962   if (@_) {
1963     $prevwarn = $SIG{__WARN__} unless $warnLevel;
1964     $warnLevel = shift;
1965     if ($warnLevel) {
1966       $SIG{__WARN__} = \&DB::dbwarn;
1967     } else {
1968       $SIG{__WARN__} = $prevwarn;
1969     }
1970   }
1971   $warnLevel;
1972 }
1973
1974 sub dieLevel {
1975   if (@_) {
1976     $prevdie = $SIG{__DIE__} unless $dieLevel;
1977     $dieLevel = shift;
1978     if ($dieLevel) {
1979       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1980       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1981       print $OUT "Stack dump during die enabled",
1982         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1983           if $I_m_init;
1984       print $OUT "Dump printed too.\n" if $dieLevel > 2;
1985     } else {
1986       $SIG{__DIE__} = $prevdie;
1987       print $OUT "Default die handler restored.\n";
1988     }
1989   }
1990   $dieLevel;
1991 }
1992
1993 sub signalLevel {
1994   if (@_) {
1995     $prevsegv = $SIG{SEGV} unless $signalLevel;
1996     $prevbus = $SIG{BUS} unless $signalLevel;
1997     $signalLevel = shift;
1998     if ($signalLevel) {
1999       $SIG{SEGV} = \&DB::diesignal;
2000       $SIG{BUS} = \&DB::diesignal;
2001     } else {
2002       $SIG{SEGV} = $prevsegv;
2003       $SIG{BUS} = $prevbus;
2004     }
2005   }
2006   $signalLevel;
2007 }
2008
2009 sub find_sub {
2010   my $subr = shift;
2011   return unless defined &$subr;
2012   $sub{$subr} or do {
2013     $subr = \&$subr;            # Hard reference
2014     my $s;
2015     for (keys %sub) {
2016       $s = $_, last if $subr eq \&$_;
2017     }
2018     $sub{$s} if $s;
2019   }
2020 }
2021
2022 sub methods {
2023   my $class = shift;
2024   $class = ref $class if ref $class;
2025   local %seen;
2026   local %packs;
2027   methods_via($class, '', 1);
2028   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2029 }
2030
2031 sub methods_via {
2032   my $class = shift;
2033   return if $packs{$class}++;
2034   my $prefix = shift;
2035   my $prepend = $prefix ? "via $prefix: " : '';
2036   my $name;
2037   for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2038              sort keys %{"$ {class}::"}) {
2039     next if $seen{ $name }++;
2040     print $DB::OUT "$prepend$name\n";
2041   }
2042   return unless shift;          # Recurse?
2043   for $name (@{"$ {class}::ISA"}) {
2044     $prepend = $prefix ? $prefix . " -> $name" : $name;
2045     methods_via($name, $prepend, 1);
2046   }
2047 }
2048
2049 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2050
2051 BEGIN {                 # This does not compile, alas.
2052   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
2053   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
2054   $sh = '!';
2055   $rc = ',';
2056   @hist = ('?');
2057   $deep = 100;                  # warning if stack gets this deep
2058   $window = 10;
2059   $preview = 3;
2060   $sub = '';
2061   $SIG{INT} = \&DB::catch;
2062   # This may be enabled to debug debugger:
2063   #$warnLevel = 1 unless defined $warnLevel;
2064   #$dieLevel = 1 unless defined $dieLevel;
2065   #$signalLevel = 1 unless defined $signalLevel;
2066
2067   $db_stop = 0;                 # Compiler warning
2068   $db_stop = 1 << 30;
2069   $level = 0;                   # Level of recursive debugging
2070   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2071   # Triggers bug (?) in perl is we postpone this until runtime:
2072   @postponed = @stack = (0);
2073   $doret = -2;
2074   $frame = 0;
2075 }
2076
2077 BEGIN {$^W = $ini_warn;}        # Switch warnings back
2078
2079 #use Carp;                      # This did break, left for debuggin
2080
2081 sub db_complete {
2082   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2083   my($text, $line, $start) = @_;
2084   my ($itext, $search, $prefix, $pack) =
2085     ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2086
2087   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2088                                (map { /$search/ ? ($1) : () } keys %sub)
2089     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2090   return sort grep /^\Q$text/, values %INC # files
2091     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2092   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2093     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2094       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2095   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2096     grep !/^main::/,
2097       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2098                                  # packages
2099         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2100           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
2101   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2102     # We may want to complete to (eval 9), so $text may be wrong
2103     $prefix = length($1) - length($text);
2104     $text = $1;
2105     return sort
2106         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2107   }
2108   if ((substr $text, 0, 1) eq '&') { # subroutines
2109     $text = substr $text, 1;
2110     $prefix = "&";
2111     return sort map "$prefix$_",
2112                grep /^\Q$text/,
2113                  (keys %sub),
2114                  (map { /$search/ ? ($1) : () }
2115                     keys %sub);
2116   }
2117   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2118     $pack = ($1 eq 'main' ? '' : $1) . '::';
2119     $prefix = (substr $text, 0, 1) . $1 . '::';
2120     $text = $2;
2121     my @out
2122       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2123     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2124       return db_complete($out[0], $line, $start);
2125     }
2126     return sort @out;
2127   }
2128   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2129     $pack = ($package eq 'main' ? '' : $package) . '::';
2130     $prefix = substr $text, 0, 1;
2131     $text = substr $text, 1;
2132     my @out = map "$prefix$_", grep /^\Q$text/,
2133        (grep /^_?[a-zA-Z]/, keys %$pack),
2134        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2135     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2136       return db_complete($out[0], $line, $start);
2137     }
2138     return sort @out;
2139   }
2140   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2141     my @out = grep /^\Q$text/, @options;
2142     my $val = option_val($out[0], undef);
2143     my $out = '? ';
2144     if (not defined $val or $val =~ /[\n\r]/) {
2145       # Can do nothing better
2146     } elsif ($val =~ /\s/) {
2147       my $found;
2148       foreach $l (split //, qq/\"\'\#\|/) {
2149         $out = "$l$val$l ", last if (index $val, $l) == -1;
2150       }
2151     } else {
2152       $out = "=$val ";
2153     }
2154     # Default to value if one completion, to question if many
2155     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2156     return sort @out;
2157   }
2158   return $term->filename_list($text); # filenames
2159 }
2160
2161 sub end_report {
2162   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
2163 }
2164
2165 END {
2166   $finished = $inhibit_exit;    # So that some keys may be disabled.
2167   # Do not stop in at_exit() and destructors on exit:
2168   $DB::single = !$exiting && !$runnonstop;
2169   DB::fake::at_exit() unless $exiting or $runnonstop;
2170 }
2171
2172 package DB::fake;
2173
2174 sub at_exit {
2175   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
2176 }
2177
2178 package DB;                     # Do not trace this 1; below!
2179
2180 1;