lib/perl5db.pl

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