lib/perl5db.pl

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