lib/perl5db.pl

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