lib/perl5db.pl

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