lib/perl5db.pl

   1 package DB;
   2
   3 # Debugger for Perl 5.00x; perl5db.pl patch level:
   4
   5 $header = 'perl5db.pl patch level 0.94';
   6
   7 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
   8 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
   9
  10 # modified Perl debugger, to be run from Emacs in perldb-mode
  11 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  12 # Johan Vromans -- upgrade to 4.0 pl 10
  13 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  14
  15 #
  16 # This file is automatically included if you do perl -d.
  17 # It's probably not useful to include this yourself.
  18 #
  19 # Perl supplies the values for @line and %sub.  It effectively inserts
  20 # a &DB'DB(<linenum>); in front of every place that can have a
  21 # breakpoint. Instead of a subroutine call it calls &DB::sub with
  22 # $DB::sub being the called subroutine. It also inserts a BEGIN
  23 # {require 'perl5db.pl'} before the first line.
  24 #
  25 # Note that no subroutine call is possible until &DB::sub is defined
  26 # (for subroutines defined outside this file). In fact the same is
  27 # true if $deep is not defined.
  28 #
  29 # $Log: perldb.pl,v $
  30
  31 #
  32 # At start reads $rcfile that may set important options.  This file
  33 # may define a subroutine &afterinit that will be executed after the
  34 # debugger is initialized.
  35 #
  36 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
  37 # it as a rest of `O ...' line in debugger prompt.
  38 #
  39 # The options that can be specified only at startup:
  40 # [To set in $rcfile, call &parse_options("optionName=new_value").]
  41 #
  42 # TTY  - the TTY to use for debugging i/o.
  43 #
  44 # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
  45 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
  46 # Term::Rendezvous.  Current variant is to have the name of TTY in this
  47 # file.
  48 #
  49 # ReadLine - If false, dummy ReadLine is used, so you can debug
  50 # ReadLine applications.
  51 #
  52 # NonStop - if true, no i/o is performed until interrupt.
  53 #
  54 # LineInfo - file or pipe to print line number info to.  If it is a
  55 # pipe, a short "emacs like" message is used.
  56 #
  57 # Example $rcfile: (delete leading hashes!)
  58 #
  59 # &parse_options("NonStop=1 LineInfo=db.out");
  60 # sub afterinit { $trace = 1; }
  61 #
  62 # The script will run without human intervention, putting trace
  63 # information into db.out.  (If you interrupt it, you would better
  64 # reset LineInfo to something "interactive"!)
  65 #
  66
  67 # Needed for the statement after exec():
  68
  69 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
  70 local($^W) = 0;                 # Switch run-time warnings off during init.
  71 warn (                  # Do not ;-)
  72       $dumpvar::hashDepth,
  73       $dumpvar::arrayDepth,
  74       $dumpvar::dumpDBFiles,
  75       $dumpvar::dumpPackages,
  76       $dumpvar::quoteHighBit,
  77       $dumpvar::printUndef,
  78       $dumpvar::globPrint,
  79       $readline::Tk_toloop,
  80       $dumpvar::usageOnly,
  81       @ARGS,
  82       $Carp::CarpLevel,
  83       $panic,
  84       $first_time,
  85      ) if 0;
  86
  87 # Command-line + PERLLIB:
  88 @ini_INC = @INC;
  89
  90 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
  91
  92 $trace = $signal = $single = 0; # Uninitialized warning suppression
  93                                 # (local $^W cannot help - other packages!).
  94 @stack = (0);
  95
  96 $option{PrintRet} = 1;
  97
  98 @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
  99                   compactDump veryCompact quote HighBit undefPrint
 100                   globPrint PrintRet UsageOnly frame
 101                   TTY noTTY ReadLine NonStop LineInfo
 102                   recallCommand ShellBang pager tkRunning
 103                   signalLevel warnLevel dieLevel);
 104
 105 %optionVars    = (
 106                  hashDepth      => \$dumpvar::hashDepth,
 107                  arrayDepth     => \$dumpvar::arrayDepth,
 108                  DumpDBFiles    => \$dumpvar::dumpDBFiles,
 109                  DumpPackages   => \$dumpvar::dumpPackages,
 110                  HighBit        => \$dumpvar::quoteHighBit,
 111                  undefPrint     => \$dumpvar::printUndef,
 112                  globPrint      => \$dumpvar::globPrint,
 113                  tkRunning      => \$readline::Tk_toloop,
 114                  UsageOnly      => \$dumpvar::usageOnly,
 115                   frame           => \$frame,
 116 );
 117
 118 %optionAction  = (
 119                   compactDump   => \&dumpvar::compactDump,
 120                   veryCompact   => \&dumpvar::veryCompact,
 121                   quote         => \&dumpvar::quote,
 122                   TTY           => \&TTY,
 123                   noTTY         => \&noTTY,
 124                   ReadLine      => \&ReadLine,
 125                   NonStop       => \&NonStop,
 126                   LineInfo      => \&LineInfo,
 127                   recallCommand => \&recallCommand,
 128                   ShellBang     => \&shellBang,
 129                   pager         => \&pager,
 130                   signalLevel   => \&signalLevel,
 131                   warnLevel     => \&warnLevel,
 132                   dieLevel      => \&dieLevel,
 133                  );
 134
 135 %optionRequire = (
 136                   compactDump   => 'dumpvar.pl',
 137                   veryCompact   => 'dumpvar.pl',
 138                   quote         => 'dumpvar.pl',
 139                  );
 140
 141 # These guys may be defined in $ENV{PERL5DB} :
 142 $rl = 1 unless defined $rl;
 143 warnLevel($warnLevel);
 144 dieLevel($dieLevel);
 145 signalLevel($signalLevel);
 146 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
 147 &recallCommand("!") unless defined $prc;
 148 &shellBang("!") unless defined $psh;
 149
 150 if (-e "/dev/tty") {
 151   $rcfile=".perldb";
 152 } else {
 153   $rcfile="perldb.ini";
 154 }
 155
 156 if (-f $rcfile) {
 157     do "./$rcfile";
 158 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
 159     do "$ENV{LOGDIR}/$rcfile";
 160 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
 161     do "$ENV{HOME}/$rcfile";
 162 }
 163
 164 if (defined $ENV{PERLDB_OPTS}) {
 165   parse_options($ENV{PERLDB_OPTS});
 166 }
 167
 168 if (exists $ENV{PERLDB_RESTART}) {
 169   delete $ENV{PERLDB_RESTART};
 170   # $restart = 1;
 171   @hist = get_list('PERLDB_HIST');
 172   my @visited = get_list("PERLDB_VISITED");
 173   for (0 .. $#visited) {
 174     %{$postponed{$visited[$_]}} = get_list("PERLDB_FILE_$_");
 175   }
 176   my %opt = get_list("PERLDB_OPT");
 177   my ($opt,$val);
 178   while (($opt,$val) = each %opt) {
 179     $val =~ s/[\\\']/\\$1/g;
 180     parse_options("$opt'$val'");
 181   }
 182   @INC = get_list("PERLDB_INC");
 183   @ini_INC = @INC;
 184 }
 185
 186 if ($notty) {
 187   $runnonstop = 1;
 188 } else {
 189   # Is Perl being run from Emacs?
 190   $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
 191   $rl = 0, shift(@main::ARGV) if $emacs;
 192
 193   #require Term::ReadLine;
 194
 195   if (-e "/dev/tty") {
 196     $console = "/dev/tty";
 197   } elsif (-e "con") {
 198     $console = "con";
 199   } else {
 200     $console = "sys\$command";
 201   }
 202
 203   # Around a bug:
 204   if (defined $ENV{OS2_SHELL} and $emacs) { # In OS/2
 205     $console = undef;
 206   }
 207
 208   $console = $tty if defined $tty;
 209
 210   if (defined $console) {
 211     open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
 212     open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
 213       || open(OUT,">&STDOUT");  # so we don't dongle stdout
 214   } else {
 215     open(IN,"<&STDIN");
 216     open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
 217     $console = 'STDIN/OUT';
 218   }
 219   # so open("|more") can read from STDOUT and so we don't dingle stdin
 220   $IN = \*IN;
 221
 222   $OUT = \*OUT;
 223   select($OUT);
 224   $| = 1;                       # for DB::OUT
 225   select(STDOUT);
 226
 227   $LINEINFO = $OUT unless defined $LINEINFO;
 228   $lineinfo = $console unless defined $lineinfo;
 229
 230   $| = 1;                       # for real STDOUT
 231
 232   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
 233   unless ($runnonstop) {
 234     print $OUT "\nLoading DB routines from $header\n";
 235     print $OUT ("Emacs support ",
 236                 $emacs ? "enabled" : "available",
 237                 ".\n");
 238     print $OUT "\nEnter h or `h h' for help.\n\n";
 239   }
 240 }
 241
 242 @ARGS = @ARGV;
 243 for (@args) {
 244     s/\'/\\\'/g;
 245     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
 246 }
 247
 248 if (defined &afterinit) {       # May be defined in $rcfile
 249   &afterinit();
 250 }
 251
 252 ############################################################ Subroutines
 253
 254 sub DB {
 255     unless ($first_time++) {    # Do when-running init
 256       if ($runnonstop) {                # Disable until signal
 257         for ($i=0; $i <= $#stack; ) {
 258             $stack[$i++] &= ~1;
 259         }
 260         $single = 0;
 261         return;
 262       }
 263       # Define a subroutine in which we will stop
 264 #       eval <<'EOE';
 265 # sub at_end::db {"Debuggee terminating";}
 266 # END {
 267 #   $DB::step = 1;
 268 #   print $OUT "Debuggee terminating.\n";
 269 #   &at_end::db;}
 270 # EOE
 271     }
 272     &save;
 273     if ($doret) {
 274         $doret = 0;
 275         if ($option{PrintRet}) {
 276             print $OUT "$retctx context return from $lastsub:",
 277               ($retctx eq 'list') ? "\n" : " " ;
 278             dumpit( ($retctx eq 'list') ? \@ret : $ret );
 279         }
 280     }
 281     ($package, $filename, $line) = caller;
 282     $filename_ini = $filename;
 283     $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
 284       "package $package;";      # this won't let them modify, alas
 285     local(*dbline) = "::_<$filename";
 286     install_breakpoints($filename) unless $visited{$filename}++;
 287     $max = $#dbline;
 288     if (($stop,$action) = split(/\0/,$dbline{$line})) {
 289         if ($stop eq '1') {
 290             $signal |= 1;
 291         } elsif ($stop) {
 292             $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
 293             $dbline{$line} =~ s/;9($|\0)/$1/;
 294         }
 295     }
 296     if ($single || $trace || $signal) {
 297         $term || &setterm;
 298         if ($emacs) {
 299             $position = "\032\032$filename:$line:0\n";
 300             print $LINEINFO $position;
 301         } else {
 302             $sub =~ s/\'/::/;
 303             $prefix = $sub =~ /::/ ? "" : "${'package'}::";
 304             $prefix .= "$sub($filename:";
 305             $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
 306             if (length($prefix) > 30) {
 307                 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
 308                 print $LINEINFO $position;
 309                 $prefix = "";
 310                 $infix = ":\t";
 311             } else {
 312                 $infix = "):\t";
 313                 $position = "$prefix$line$infix$dbline[$line]$after";
 314                 print $LINEINFO $position;
 315             }
 316             for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
 317                 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
 318                 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
 319                 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
 320                 print $LINEINFO $incr_pos;
 321                 $position .= $incr_pos;
 322             }
 323         }
 324     }
 325     $evalarg = $action, &eval if $action;
 326     if ($single || $signal) {
 327         local $level = $level + 1;
 328         $evalarg = $pre, &eval if $pre;
 329         print $OUT $#stack . " levels deep in subroutine calls!\n"
 330           if $single & 4;
 331         $start = $line;
 332       CMD:
 333         while (($term || &setterm),
 334                defined ($cmd=&readline("  DB" . ('<' x $level) .
 335                                        ($#hist+1) . ('>' x $level) .
 336                                        " "))) {
 337             #{                  # <-- Do we know what this brace is for?
 338                 $single = 0;
 339                 $signal = 0;
 340                 $cmd =~ s/\\$/\n/ && do {
 341                     $cmd .= &readline("  cont: ");
 342                     redo CMD;
 343                 };
 344                 $cmd =~ /^q$/ && exit 0;
 345                 $cmd =~ /^$/ && ($cmd = $laststep);
 346                 push(@hist,$cmd) if length($cmd) > 1;
 347               PIPE: {
 348                     ($i) = split(/\s+/,$cmd);
 349                     eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
 350                     $cmd =~ /^h$/ && do {
 351                         print $OUT $help;
 352                         next CMD; };
 353                     $cmd =~ /^h\s+h$/ && do {
 354                         print $OUT $summary;
 355                         next CMD; };
 356                     $cmd =~ /^h\s+(\S)$/ && do {
 357                         my $asked = "\Q$1";
 358                         if ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/m) {
 359                             print $OUT $1;
 360                         } else {
 361                             print $OUT "`$asked' is not a debugger command.\n";
 362                         }
 363                         next CMD; };
 364                     $cmd =~ /^t$/ && do {
 365                         $trace = !$trace;
 366                         print $OUT "Trace = ".($trace?"on":"off")."\n";
 367                         next CMD; };
 368                     $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
 369                         $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
 370                         foreach $subname (sort(keys %sub)) {
 371                             if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
 372                                 print $OUT $subname,"\n";
 373                             }
 374                         }
 375                         next CMD; };
 376                     $cmd =~ s/^X\b/V $package/;
 377                     $cmd =~ /^V$/ && do {
 378                         $cmd = "V $package"; };
 379                     $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
 380                         local ($savout) = select($OUT);
 381                         $packname = $1;
 382                         @vars = split(' ',$2);
 383                         do 'dumpvar.pl' unless defined &main::dumpvar;
 384                         if (defined &main::dumpvar) {
 385                             local $frame = 0;
 386                             &main::dumpvar($packname,@vars);
 387                         } else {
 388                             print $OUT "dumpvar.pl not available.\n";
 389                         }
 390                         select ($savout);
 391                         next CMD; };
 392                     $cmd =~ s/^x\b/ / && do { # So that will be evaled
 393                         $onetimeDump = 1; };
 394                     $cmd =~ /^f\b\s*(.*)/ && do {
 395                         $file = $1;
 396                         if (!$file) {
 397                             print $OUT "The old f command is now the r command.\n";
 398                             print $OUT "The new f command switches filenames.\n";
 399                             next CMD;
 400                         }
 401                         if (!defined $main::{'_<' . $file}) {
 402                             if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
 403                                               $file = substr($try,2);
 404                                               print "\n$file:\n";
 405                                           }}
 406                         }
 407                         if (!defined $main::{'_<' . $file}) {
 408                             print $OUT "There's no code here matching $file.\n";
 409                             next CMD;
 410                         } elsif ($file ne $filename) {
 411                             *dbline = "::_<$file";
 412                             $visited{$file}++;
 413                             $max = $#dbline;
 414                             $filename = $file;
 415                             $start = 1;
 416                             $cmd = "l";
 417                         } };
 418                     $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
 419                         $subname = $1;
 420                         $subname =~ s/\'/::/;
 421                         $subname = "main::".$subname unless $subname =~ /::/;
 422                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 423                         @pieces = split(/:/,$sub{$subname});
 424                         $subrange = pop @pieces;
 425                         $file = join(':', @pieces);
 426                         if ($file ne $filename) {
 427                             *dbline = "::_<$file";
 428                             $visited{$file}++;
 429                             $max = $#dbline;
 430                             $filename = $file;
 431                         }
 432                         if ($subrange) {
 433                             if (eval($subrange) < -$window) {
 434                                 $subrange =~ s/-.*/+/;
 435                             }
 436                             $cmd = "l $subrange";
 437                         } else {
 438                             print $OUT "Subroutine $subname not found.\n";
 439                             next CMD;
 440                         } };
 441                     $cmd =~ /^\.$/ && do {
 442                         $start = $line;
 443                         $filename = $filename_ini;
 444                         *dbline = "::_<$filename";
 445                         $max = $#dbline;
 446                         print $LINEINFO $position;
 447                         next CMD };
 448                     $cmd =~ /^w\b\s*(\d*)$/ && do {
 449                         $incr = $window - 1;
 450                         $start = $1 if $1;
 451                         $start -= $preview;
 452                         #print $OUT 'l ' . $start . '-' . ($start + $incr);
 453                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 454                     $cmd =~ /^-$/ && do {
 455                         $incr = $window - 1;
 456                         $cmd = 'l ' . ($start-$window*2) . '+'; };
 457                     $cmd =~ /^l$/ && do {
 458                         $incr = $window - 1;
 459                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 460                     $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
 461                         $start = $1 if $1;
 462                         $incr = $2;
 463                         $incr = $window - 1 unless $incr;
 464                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
 465                     $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
 466                         $end = (!defined $2) ? $max : ($4 ? $4 : $2);
 467                         $end = $max if $end > $max;
 468                         $i = $2;
 469                         $i = $line if $i eq '.';
 470                         $i = 1 if $i < 1;
 471                         if ($emacs) {
 472                             print $OUT "\032\032$filename:$i:0\n";
 473                             $i = $end;
 474                         } else {
 475                             for (; $i <= $end; $i++) {
 476                                 ($stop,$action) = split(/\0/, $dbline{$i});
 477                                 $arrow = ($i==$line
 478                                           and $filename eq $filename_ini)
 479                                   ?  '==>'
 480                                     : ':' ;
 481                                 $arrow .= 'b' if $stop;
 482                                 $arrow .= 'a' if $action;
 483                                 print $OUT "$i$arrow\t", $dbline[$i];
 484                                 last if $signal;
 485                             }
 486                         }
 487                         $start = $i; # remember in case they want more
 488                         $start = $max if $start > $max;
 489                         next CMD; };
 490                     $cmd =~ /^D$/ && do {
 491                         print $OUT "Deleting all breakpoints...\n";
 492                         for ($i = 1; $i <= $max ; $i++) {
 493                             if (defined $dbline{$i}) {
 494                                 $dbline{$i} =~ s/^[^\0]+//;
 495                                 if ($dbline{$i} =~ s/^\0?$//) {
 496                                     delete $dbline{$i};
 497                                 }
 498                             }
 499                         }
 500                         next CMD; };
 501                     $cmd =~ /^L$/ && do {
 502                         for ($i = 1; $i <= $max; $i++) {
 503                             if (defined $dbline{$i}) {
 504                                 print $OUT "$i:\t", $dbline[$i];
 505                                 ($stop,$action) = split(/\0/, $dbline{$i});
 506                                 print $OUT "  break if (", $stop, ")\n"
 507                                   if $stop;
 508                                 print $OUT "  action:  ", $action, "\n"
 509                                   if $action;
 510                                 last if $signal;
 511                             }
 512                         }
 513                         next CMD; };
 514                     $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
 515                         $subname = $1;
 516                         $cond = $2 || '1';
 517                         $subname =~ s/\'/::/;
 518                         $subname = "${'package'}::" . $subname
 519                           unless $subname =~ /::/;
 520                         $subname = "main".$subname if substr($subname,0,2) eq "::";
 521                         # Filename below can contain ':'
 522                         ($file,$i) = ($sub{$subname} =~ /^(.*):(.*)$/);
 523                         $i += 0;
 524                         if ($i) {
 525                             $filename = $file;
 526                             *dbline = "::_<$filename";
 527                             $visited{$filename}++;
 528                             $max = $#dbline;
 529                             ++$i while $dbline[$i] == 0 && $i < $max;
 530                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 531                         } else {
 532                             print $OUT "Subroutine $subname not found.\n";
 533                         }
 534                         next CMD; };
 535                     $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
 536                         $i = ($1?$1:$line);
 537                         $cond = $2 || '1';
 538                         if ($dbline[$i] == 0) {
 539                             print $OUT "Line $i not breakable.\n";
 540                         } else {
 541                             $dbline{$i} =~ s/^[^\0]*/$cond/;
 542                         }
 543                         next CMD; };
 544                     $cmd =~ /^d\b\s*(\d+)?/ && do {
 545                         $i = ($1?$1:$line);
 546                         $dbline{$i} =~ s/^[^\0]*//;
 547                         delete $dbline{$i} if $dbline{$i} eq '';
 548                         next CMD; };
 549                     $cmd =~ /^A$/ && do {
 550                         for ($i = 1; $i <= $max ; $i++) {
 551                             if (defined $dbline{$i}) {
 552                                 $dbline{$i} =~ s/\0[^\0]*//;
 553                                 delete $dbline{$i} if $dbline{$i} eq '';
 554                             }
 555                         }
 556                         next CMD; };
 557                     $cmd =~ /^O\s*$/ && do {
 558                         for (@options) {
 559                             &dump_option($_);
 560                         }
 561                         next CMD; };
 562                     $cmd =~ /^O\s*(\S.*)/ && do {
 563                         parse_options($1);
 564                         next CMD; };
 565                     $cmd =~ /^<\s*(.*)/ && do {
 566                         $pre = action($1);
 567                         next CMD; };
 568                     $cmd =~ /^>\s*(.*)/ && do {
 569                         $post = action($1);
 570                         next CMD; };
 571                     $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
 572                         $i = $1; $j = $3;
 573                         if ($dbline[$i] == 0) {
 574                             print $OUT "Line $i may not have an action.\n";
 575                         } else {
 576                             $dbline{$i} =~ s/\0[^\0]*//;
 577                             $dbline{$i} .= "\0" . action($j);
 578                         }
 579                         next CMD; };
 580                     $cmd =~ /^n$/ && do {
 581                         $single = 2;
 582                         $laststep = $cmd;
 583                         last CMD; };
 584                     $cmd =~ /^s$/ && do {
 585                         $single = 1;
 586                         $laststep = $cmd;
 587                         last CMD; };
 588                     $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
 589                         $i = $1;
 590                         if ($i =~ /\D/) { # subroutine name
 591                             ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/);
 592                             $i += 0;
 593                             if ($i) {
 594                                 $filename = $file;
 595                                 *dbline = "::_<$filename";
 596                                 $visited{$filename}++;
 597                                 $max = $#dbline;
 598                                 ++$i while $dbline[$i] == 0 && $i < $max;
 599                             } else {
 600                                 print $OUT "Subroutine $subname not found.\n";
 601                                 next CMD;
 602                             }
 603                         }
 604                         if ($i) {
 605                             if ($dbline[$i] == 0) {
 606                                 print $OUT "Line $i not breakable.\n";
 607                                 next CMD;
 608                             }
 609                             $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
 610                         }
 611                         for ($i=0; $i <= $#stack; ) {
 612                             $stack[$i++] &= ~1;
 613                         }
 614                         last CMD; };
 615                     $cmd =~ /^r$/ && do {
 616                         $stack[$#stack] |= 1;
 617                         $doret = 1;
 618                         last CMD; };
 619                     $cmd =~ /^R$/ && do {
 620                         print $OUT "Warning: a lot of settings and command-line options may be lost!\n";
 621                         my (@script, @flags, $cl);
 622                         push @flags, '-w' if $ini_warn;
 623                         # Put all the old includes at the start to get
 624                         # the same debugger.
 625                         for (@ini_INC) {
 626                           push @flags, '-I', $_;
 627                         }
 628                         # Arrange for setting the old INC:
 629                         set_list("PERLDB_INC", @ini_INC);
 630                         if ($0 eq '-e') {
 631                           for (1..$#{'::_<-e'}) { # The first line is PERL5DB
 632                             chomp ($cl =  $ {'::_<-e'}[$_]);
 633                             push @script, '-e', $cl;
 634                           }
 635                         } else {
 636                           @script = $0;
 637                         }
 638                         set_list("PERLDB_HIST",
 639                                  $term->Features->{getHistory}
 640                                  ? $term->GetHistory : @hist);
 641                         my @visited = keys %visited;
 642                         set_list("PERLDB_VISITED", @visited);
 643                         set_list("PERLDB_OPT", %option);
 644                         for (0 .. $#visited) {
 645                           *dbline = "::_<$visited[$_]";
 646                           set_list("PERLDB_FILE_$_", %dbline);
 647                         }
 648                         $ENV{PERLDB_RESTART} = 1;
 649                         #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
 650                         exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
 651                         print $OUT "exec failed: $!\n";
 652                         last CMD; };
 653                     $cmd =~ /^T$/ && do {
 654                         local($p,$f,$l,$s,$h,$a,$e,$r,@a,@sub);
 655                         for ($i = 1;
 656                              ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i);
 657                              $i++) {
 658                             @a = ();
 659                             for $arg (@args) {
 660                                 $_ = "$arg";
 661                                 s/([\'\\])/\\$1/g;
 662                                 s/([^\0]*)/'$1'/
 663                                   unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
 664                                 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
 665                                 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
 666                                 push(@a, $_);
 667                             }
 668                             $w = $w ? '@ = ' : '$ = ';
 669                             $a = $h ? '(' . join(', ', @a) . ')' : '';
 670                             $e =~ s/\n\s*\;\s*\Z// if $e;
 671                             $e =~ s/[\\\']/\\$1/g if $e;
 672                             if ($r) {
 673                               $s = "require '$e'";
 674                             } elsif (defined $r) {
 675                               $s = "eval '$e'";
 676                             } elsif ($s eq '(eval)') {
 677                               $s = "eval {...}";
 678                             }
 679                             $f = "file `$f'" unless $f eq '-e';
 680                             push(@sub, "$w$s$a called from $f line $l\n");
 681                             last if $signal;
 682                         }
 683                         for ($i=0; $i <= $#sub; $i++) {
 684                             last if $signal;
 685                             print $OUT $sub[$i];
 686                         }
 687                         next CMD; };
 688                     $cmd =~ /^\/(.*)$/ && do {
 689                         $inpat = $1;
 690                         $inpat =~ s:([^\\])/$:$1:;
 691                         if ($inpat ne "") {
 692                             eval '$inpat =~ m'."\a$inpat\a";
 693                             if ($@ ne "") {
 694                                 print $OUT "$@";
 695                                 next CMD;
 696                             }
 697                             $pat = $inpat;
 698                         }
 699                         $end = $start;
 700                         eval '
 701                             for (;;) {
 702                                 ++$start;
 703                                 $start = 1 if ($start > $max);
 704                                 last if ($start == $end);
 705                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
 706                                     if ($emacs) {
 707                                         print $OUT "\032\032$filename:$start:0\n";
 708                                     } else {
 709                                         print $OUT "$start:\t", $dbline[$start], "\n";
 710                                     }
 711                                     last;
 712                                 }
 713                             } ';
 714                         print $OUT "/$pat/: not found\n" if ($start == $end);
 715                         next CMD; };
 716                     $cmd =~ /^\?(.*)$/ && do {
 717                         $inpat = $1;
 718                         $inpat =~ s:([^\\])\?$:$1:;
 719                         if ($inpat ne "") {
 720                             eval '$inpat =~ m'."\a$inpat\a";
 721                             if ($@ ne "") {
 722                                 print $OUT "$@";
 723                                 next CMD;
 724                             }
 725                             $pat = $inpat;
 726                         }
 727                         $end = $start;
 728                         eval '
 729                             for (;;) {
 730                                 --$start;
 731                                 $start = $max if ($start <= 0);
 732                                 last if ($start == $end);
 733                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
 734                                     if ($emacs) {
 735                                         print $OUT "\032\032$filename:$start:0\n";
 736                                     } else {
 737                                         print $OUT "$start:\t", $dbline[$start], "\n";
 738                                     }
 739                                     last;
 740                                 }
 741                             } ';
 742                         print $OUT "?$pat?: not found\n" if ($start == $end);
 743                         next CMD; };
 744                     $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
 745                         pop(@hist) if length($cmd) > 1;
 746                         $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
 747                         $cmd = $hist[$i] . "\n";
 748                         print $OUT $cmd;
 749                         redo CMD; };
 750                     $cmd =~ /^$sh$sh\s*/ && do {
 751                         &system($');
 752                         next CMD; };
 753                     $cmd =~ /^$rc([^$rc].*)$/ && do {
 754                         $pat = "^$1";
 755                         pop(@hist) if length($cmd) > 1;
 756                         for ($i = $#hist; $i; --$i) {
 757                             last if $hist[$i] =~ /$pat/;
 758                         }
 759                         if (!$i) {
 760                             print $OUT "No such command!\n\n";
 761                             next CMD;
 762                         }
 763                         $cmd = $hist[$i] . "\n";
 764                         print $OUT $cmd;
 765                         redo CMD; };
 766                     $cmd =~ /^$sh$/ && do {
 767                         &system($ENV{SHELL}||"/bin/sh");
 768                         next CMD; };
 769                     $cmd =~ /^$sh\s*/ && do {
 770                         &system($ENV{SHELL}||"/bin/sh","-c",$');
 771                         next CMD; };
 772                     $cmd =~ /^H\b\s*(-(\d+))?/ && do {
 773                         $end = $2?($#hist-$2):0;
 774                         $hist = 0 if $hist < 0;
 775                         for ($i=$#hist; $i>$end; $i--) {
 776                             print $OUT "$i: ",$hist[$i],"\n"
 777                               unless $hist[$i] =~ /^.?$/;
 778                         };
 779                         next CMD; };
 780                     $cmd =~ s/^p$/print \$DB::OUT \$_/;
 781                     $cmd =~ s/^p\b/print \$DB::OUT /;
 782                     $cmd =~ /^=/ && do {
 783                         if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
 784                             $alias{$k}="s~$k~$v~";
 785                             print $OUT "$k = $v\n";
 786                         } elsif ($cmd =~ /^=\s*$/) {
 787                             foreach $k (sort keys(%alias)) {
 788                                 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
 789                                     print $OUT "$k = $v\n";
 790                                 } else {
 791                                     print $OUT "$k\t$alias{$k}\n";
 792                                 };
 793                             };
 794                         };
 795                         next CMD; };
 796                     $cmd =~ /^\|\|?\s*[^|]/ && do {
 797                         if ($pager =~ /^\|/) {
 798                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
 799                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
 800                         } else {
 801                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
 802                         }
 803                         unless ($piped=open(OUT,$pager)) {
 804                             &warn("Can't pipe output to `$pager'");
 805                             if ($pager =~ /^\|/) {
 806                                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
 807                                 open(STDOUT,">&SAVEOUT")
 808                                   || &warn("Can't restore STDOUT");
 809                                 close(SAVEOUT);
 810                             } else {
 811                                 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
 812                             }
 813                             next CMD;
 814                         }
 815                         $SIG{PIPE}= "DB::catch" if $pager =~ /^\|/
 816                           && "" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE};
 817                         $selected= select(OUT);
 818                         $|= 1;
 819                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
 820                         $cmd =~ s/^\|+\s*//;
 821                         redo PIPE; };
 822                     # XXX Local variants do not work!
 823                     $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
 824                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
 825                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
 826                 }               # PIPE:
 827             #}                  # <-- Do we know what this brace is for?
 828             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
 829             if ($onetimeDump) {
 830                 $onetimeDump = undef;
 831             } else {
 832                 print $OUT "\n";
 833             }
 834         } continue {            # CMD:
 835             if ($piped) {
 836                 if ($pager =~ /^\|/) {
 837                     $?= 0;  close(OUT) || &warn("Can't close DB::OUT");
 838                     &warn( "Pager `$pager' failed: ",
 839                           ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
 840                           ( $? & 128 ) ? " (core dumped)" : "",
 841                           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
 842                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
 843                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
 844                     $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq "DB::catch";
 845                     # Will stop ignoring SIGPIPE if done like nohup(1)
 846                     # does SIGINT but Perl doesn't give us a choice.
 847                 } else {
 848                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
 849                 }
 850                 close(SAVEOUT);
 851                 select($selected), $selected= "" unless $selected eq "";
 852                 $piped= "";
 853             }
 854         }                       # CMD:
 855         if ($post) {
 856             $evalarg = $post; &eval;
 857         }
 858     }                           # if ($single || $signal)
 859     ($@, $!, $,, $/, $\, $^W) = @saved;
 860     ();
 861 }
 862
 863 # The following code may be executed now:
 864 # BEGIN {warn 4}
 865
 866 sub sub {
 867     print $LINEINFO ' ' x $#stack, "entering $sub\n" if $frame;
 868     push(@stack, $single);
 869     $single &= 1;
 870     $single |= 4 if $#stack == $deep;
 871     if (wantarray) {
 872         @ret = &$sub;
 873         $single |= pop(@stack);
 874         $retctx = "list";
 875         $lastsub = $sub;
 876 print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
 877         @ret;
 878     } else {
 879         $ret = &$sub;
 880         $single |= pop(@stack);
 881         $retctx = "scalar";
 882         $lastsub = $sub;
 883 print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
 884         $ret;
 885     }
 886 }
 887
 888 sub save {
 889     @saved = ($@, $!, $,, $/, $\, $^W);
 890     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
 891 }
 892
 893 # The following takes its argument via $evalarg to preserve current @_
 894
 895 sub eval {
 896     my @res;
 897     {
 898         local (@stack) = @stack; # guard against recursive debugging
 899         my $otrace = $trace;
 900         my $osingle = $single;
 901         my $od = $^D;
 902         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
 903         $trace = $otrace;
 904         $single = $osingle;
 905         $^D = $od;
 906     }
 907     my $at = $@;
 908     eval "&DB::save";
 909     if ($at) {
 910         print $OUT $at;
 911     } elsif ($onetimeDump) {
 912         dumpit(\@res);
 913     }
 914 }
 915
 916 sub install_breakpoints {
 917   my $filename = shift;
 918   return unless exists $postponed{$filename};
 919   my %break = %{$postponed{$filename}};
 920   for (keys %break) {
 921     my $i = $_;
 922     #if (/\D/) {                        # Subroutine name
 923     #}
 924     $dbline{$i} = $break{$_};   # Cannot be done before the file is around
 925   }
 926 }
 927
 928 sub dumpit {
 929     local ($savout) = select($OUT);
 930     do 'dumpvar.pl' unless defined &main::dumpValue;
 931     if (defined &main::dumpValue) {
 932         local $frame = 0;
 933         &main::dumpValue(shift);
 934     } else {
 935         print $OUT "dumpvar.pl not available.\n";
 936     }
 937     select ($savout);
 938 }
 939
 940 sub action {
 941     my $action = shift;
 942     while ($action =~ s/\\$//) {
 943         #print $OUT "+ ";
 944         #$action .= "\n";
 945         $action .= &gets;
 946     }
 947     $action;
 948 }
 949
 950 sub gets {
 951     local($.);
 952     #<IN>;
 953     &readline("cont: ");
 954 }
 955
 956 sub system {
 957     # We save, change, then restore STDIN and STDOUT to avoid fork() since
 958     # many non-Unix systems can do system() but have problems with fork().
 959     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
 960     open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
 961     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
 962     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
 963     system(@_);
 964     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
 965     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
 966     close(SAVEIN); close(SAVEOUT);
 967     &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
 968           ( $? & 128 ) ? " (core dumped)" : "",
 969           ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
 970     $?;
 971 }
 972
 973 sub setterm {
 974     local $frame = 0;
 975     eval "require Term::ReadLine;" or die $@;
 976     if ($notty) {
 977         if ($tty) {
 978             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
 979             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
 980             $IN = \*IN;
 981             $OUT = \*OUT;
 982             my $sel = select($OUT);
 983             $| = 1;
 984             select($sel);
 985         } else {
 986             eval "require Term::Rendezvous;" or die $@;
 987             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
 988             my $term_rv = new Term::Rendezvous $rv;
 989             $IN = $term_rv->IN;
 990             $OUT = $term_rv->OUT;
 991         }
 992     }
 993     if (!$rl) {
 994         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
 995     } else {
 996         $term = new Term::ReadLine 'perldb', $IN, $OUT;
 997
 998         $readline::rl_basic_word_break_characters .= "[:"
 999           if defined $readline::rl_basic_word_break_characters
1000             and index($readline::rl_basic_word_break_characters, ":") == -1;
1001     }
1002     $LINEINFO = $OUT unless defined $LINEINFO;
1003     $lineinfo = $console unless defined $lineinfo;
1004     $term->MinLine(2);
1005     if ($term->Features->{setHistory} and "@hist" ne "?") {
1006       $term->SetHistory(@hist);
1007     }
1008 }
1009
1010 sub readline {
1011   if (@typeahead) {
1012     my $left = @typeahead;
1013     my $got = shift @typeahead;
1014     print $OUT "auto(-$left)", shift, $got, "\n";
1015     $term->AddHistory($got)
1016       if length($got) > 1 and defined $term->Features->{addHistory};
1017     return $got;
1018   }
1019   local $frame = 0;
1020   $term->readline(@_);
1021 }
1022
1023 sub dump_option {
1024     my ($opt, $val)= @_;
1025     if (defined $optionVars{$opt}
1026         and defined $ {$optionVars{$opt}}) {
1027         $val = $ {$optionVars{$opt}};
1028     } elsif (defined $optionAction{$opt}
1029         and defined &{$optionAction{$opt}}) {
1030         $val = &{$optionAction{$opt}}();
1031     } elsif (defined $optionAction{$opt}
1032              and not defined $option{$opt}
1033              or defined $optionVars{$opt}
1034              and not defined $ {$optionVars{$opt}}) {
1035         $val = 'N/A';
1036     } else {
1037         $val = $option{$opt};
1038     }
1039     $val =~ s/[\\\']/\\$&/g;
1040     printf $OUT "%20s = '%s'\n", $opt, $val;
1041 }
1042
1043 sub parse_options {
1044     local($_)= @_;
1045     while ($_ ne "") {
1046         s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1047         my ($opt,$sep) = ($1,$2);
1048         my $val;
1049         if ("?" eq $sep) {
1050             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1051               if /^\S/;
1052             #&dump_option($opt);
1053         } elsif ($sep !~ /\S/) {
1054             $val = "1";
1055         } elsif ($sep eq "=") {
1056             s/^(\S*)($|\s+)//;
1057             $val = $1;
1058         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1059             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1060             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1061               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1062             $val = $1;
1063             $val =~ s/\\([\\$end])/$1/g;
1064         }
1065         my ($option);
1066         my $matches =
1067           grep(  /^\Q$opt/ && ($option = $_),  @options  );
1068         $matches =  grep(  /^\Q$opt/i && ($option = $_),  @options  )
1069           unless $matches;
1070         print $OUT "Unknown option `$opt'\n" unless $matches;
1071         print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1072         $option{$option} = $val if $matches == 1 and defined $val;
1073         eval "local \$frame = 0; require '$optionRequire{$option}'"
1074           if $matches == 1 and defined $optionRequire{$option} and defined $val;
1075         $ {$optionVars{$option}} = $val
1076           if $matches == 1
1077             and defined $optionVars{$option} and defined $val;
1078         & {$optionAction{$option}} ($val)
1079           if $matches == 1
1080             and defined $optionAction{$option}
1081               and defined &{$optionAction{$option}} and defined $val;
1082         &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1083         s/^\s+//;
1084     }
1085 }
1086
1087 sub set_list {
1088   my ($stem,@list) = @_;
1089   my $val;
1090   $ENV{"$ {stem}_n"} = @list;
1091   for $i (0 .. $#list) {
1092     $val = $list[$i];
1093     $val =~ s/\\/\\\\/g;
1094     $val =~ s/[\0-\37\177\200-\377]/"\\0x" . unpack('H2',$&)/eg;
1095     $ENV{"$ {stem}_$i"} = $val;
1096   }
1097 }
1098
1099 sub get_list {
1100   my $stem = shift;
1101   my @list;
1102   my $n = delete $ENV{"$ {stem}_n"};
1103   my $val;
1104   for $i (0 .. $n - 1) {
1105     $val = delete $ENV{"$ {stem}_$i"};
1106     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1107     push @list, $val;
1108   }
1109   @list;
1110 }
1111
1112 sub catch {
1113     $signal = 1;
1114 }
1115
1116 sub warn {
1117     my($msg)= join("",@_);
1118     $msg .= ": $!\n" unless $msg =~ /\n$/;
1119     print $OUT $msg;
1120 }
1121
1122 sub TTY {
1123     if ($term) {
1124         &warn("Too late to set TTY!\n") if @_;
1125     } else {
1126         $tty = shift if @_;
1127     }
1128     $tty or $console;
1129 }
1130
1131 sub noTTY {
1132     if ($term) {
1133         &warn("Too late to set noTTY!\n") if @_;
1134     } else {
1135         $notty = shift if @_;
1136     }
1137     $notty;
1138 }
1139
1140 sub ReadLine {
1141     if ($term) {
1142         &warn("Too late to set ReadLine!\n") if @_;
1143     } else {
1144         $rl = shift if @_;
1145     }
1146     $rl;
1147 }
1148
1149 sub NonStop {
1150     if ($term) {
1151         &warn("Too late to set up NonStop mode!\n") if @_;
1152     } else {
1153         $runnonstop = shift if @_;
1154     }
1155     $runnonstop;
1156 }
1157
1158 sub pager {
1159     if (@_) {
1160         $pager = shift;
1161         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1162     }
1163     $pager;
1164 }
1165
1166 sub shellBang {
1167     if (@_) {
1168         $sh = quotemeta shift;
1169         $sh .= "\\b" if $sh =~ /\w$/;
1170     }
1171     $psh = $sh;
1172     $psh =~ s/\\b$//;
1173     $psh =~ s/\\(.)/$1/g;
1174     &sethelp;
1175     $psh;
1176 }
1177
1178 sub recallCommand {
1179     if (@_) {
1180         $rc = quotemeta shift;
1181         $rc .= "\\b" if $rc =~ /\w$/;
1182     }
1183     $prc = $rc;
1184     $prc =~ s/\\b$//;
1185     $prc =~ s/\\(.)/$1/g;
1186     &sethelp;
1187     $prc;
1188 }
1189
1190 sub LineInfo {
1191     return $lineinfo unless @_;
1192     $lineinfo = shift;
1193     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1194     $emacs = ($stream =~ /^\|/);
1195     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1196     $LINEINFO = \*LINEINFO;
1197     my $save = select($LINEINFO);
1198     $| = 1;
1199     select($save);
1200     $lineinfo;
1201 }
1202
1203 sub sethelp {
1204     $help = "
1205 T               Stack trace.
1206 s [expr]        Single step [in expr].
1207 n [expr]        Next, steps over subroutine calls [in expr].
1208 <CR>            Repeat last n or s command.
1209 r               Return from current subroutine.
1210 c [line]        Continue; optionally inserts a one-time-only breakpoint
1211                 at the specified line.
1212 l min+incr      List incr+1 lines starting at min.
1213 l min-max       List lines min through max.
1214 l line          List single line.
1215 l subname       List first window of lines from subroutine.
1216 l               List next window of lines.
1217 -               List previous window of lines.
1218 w [line]        List window around line.
1219 .               Return to the executed line.
1220 f filename      Switch to viewing filename.
1221 /pattern/       Search forwards for pattern; final / is optional.
1222 ?pattern?       Search backwards for pattern; final ? is optional.
1223 L               List all breakpoints and actions for the current file.
1224 S [[!]pattern]  List subroutine names [not] matching pattern.
1225 t               Toggle trace mode.
1226 t expr          Trace through execution of expr.
1227 b [line] [condition]
1228                 Set breakpoint; line defaults to the current execution line;
1229                 condition breaks if it evaluates to true, defaults to '1'.
1230 b subname [condition]
1231                 Set breakpoint at first line of subroutine.
1232 d [line]        Delete the breakpoint for line.
1233 D               Delete all breakpoints.
1234 a [line] command
1235                 Set an action to be done before the line is executed.
1236                 Sequence is: check for breakpoint, print line if necessary,
1237                 do action, prompt user if breakpoint or step, evaluate line.
1238 A               Delete all actions.
1239 V [pkg [vars]]  List some (default all) variables in package (default current).
1240                 Use ~pattern and !pattern for positive and negative regexps.
1241 X [vars]        Same as \"V currentpackage [vars]\".
1242 x expr          Evals expression in array context, dumps the result.
1243 O [opt[=val]] [opt\"val\"] [opt?]...
1244                 Set or query values of options.  val defaults to 1.  opt can
1245                 be abbreviated.  Several options can be listed.
1246     recallCommand, ShellBang:   chars used to recall command or spawn shell;
1247     pager:                      program for output of \"|cmd\";
1248   The following options affect what happens with V, X, and x commands:
1249     arrayDepth, hashDepth:      print only first N elements ('' for all);
1250     compactDump, veryCompact:   change style of array and hash dump;
1251     globPrint:                  whether to print contents of globs;
1252     DumpDBFiles:                dump arrays holding debugged files;
1253     DumpPackages:               dump symbol tables of packages;
1254     quote, HighBit, undefPrint: change style of string dump;
1255     tkRunning:                  run Tk while prompting (with ReadLine);
1256     signalLevel warnLevel dieLevel:     level of verbosity;
1257   Option PrintRet affects printing of return value after r command,
1258          frame    affects printing messages on entry and exit from subroutines.
1259                 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1260                 You can put additional initialization options TTY, noTTY,
1261                 ReadLine, and NonStop there.
1262 < command       Define command to run before each prompt.
1263 > command       Define command to run after each prompt.
1264 $prc number     Redo a previous command (default previous command).
1265 $prc -number    Redo number'th-to-last command.
1266 $prc pattern    Redo last command that started with pattern.
1267                 See 'O recallCommand' too.
1268 $psh$psh cmd    Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1269   . ( $rc eq $sh ? "" : "
1270 $psh [cmd]      Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1271                 See 'O shellBang' too.
1272 H -number       Display last number commands (default all).
1273 p expr          Same as \"print DB::OUT expr\" in current package.
1274 |dbcmd          Run debugger command, piping DB::OUT to current pager.
1275 ||dbcmd         Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1276 \= [alias value]        Define a command alias, or list current aliases.
1277 command         Execute as a perl statement in current package.
1278 R               Pure-man-restart of debugger, debugger state and command-line
1279                 options are lost.
1280 h [db_command]  Get help [on a specific debugger command], enter |h to page.
1281 h h             Summary of debugger commands.
1282 q or ^D         Quit.
1283
1284 ";
1285     $summary = <<"END_SUM";
1286 List/search source lines:               Control script execution:
1287   l [ln|sub]  List source code            T           Stack trace
1288   - or .      List previous/current line  s [expr]    Single step [in expr]
1289   w [line]    List around line            n [expr]    Next, steps over subs
1290   f filename  View source in file         <CR>        Repeat last n or s
1291   /pattern/   Search forward              r           Return from subroutine
1292   ?pattern?   Search backward             c [line]    Continue until line
1293 Debugger controls:                        L           List break pts & actions
1294   O [...]     Set debugger options        t [expr]    Toggle trace [trace expr]
1295   < command   Command for before prompt   b [ln] [c]  Set breakpoint
1296   > command   Command for after prompt    b sub [c]   Set breakpoint for sub
1297   $prc [N|pat]   Redo a previous command     d [line]    Delete a breakpoint
1298   H [-num]    Display last num commands   D           Delete all breakpoints
1299   = [a val]   Define/list an alias        a [ln] cmd  Do cmd before line
1300   h [db_cmd]  Get help on command         A           Delete all actions
1301   |[|]dbcmd   Send output to pager        $psh\[$psh\] syscmd Run cmd in a subprocess
1302   q or ^D     Quit                        R           Attempt a restart
1303 Data Examination:             expr     Execute perl code, also see: s,n,t expr
1304   S [[!]pat]    List subroutine names [not] matching pattern
1305   V [Pk [Vars]] List Variables in Package.  Vars can be ~pattern or !pattern.
1306   X [Vars]      Same as \"V current_package [Vars]\".
1307   x expr        Evals expression in array context, dumps the result.
1308   p expr        Print expression (uses script's current package).
1309 END_SUM
1310                                 # '); # Fix balance of Emacs parsing
1311 }
1312
1313 sub diesignal {
1314     local $frame = 0;
1315     $SIG{'ABRT'} = DEFAULT;
1316     kill 'ABRT', $$ if $panic++;
1317     print $DB::OUT "Got $_[0]!\n";      # in the case cannot continue
1318     local $SIG{__WARN__} = '';
1319     require Carp;
1320     local $Carp::CarpLevel = 2;         # mydie + confess
1321     &warn(Carp::longmess("Signal @_"));
1322     kill 'ABRT', $$;
1323 }
1324
1325 sub dbwarn {
1326   local $frame = 0;
1327   local $SIG{__WARN__} = '';
1328   require Carp;
1329   #&warn("Entering dbwarn\n");
1330   my ($mysingle,$mytrace) = ($single,$trace);
1331   $single = 0; $trace = 0;
1332   my $mess = Carp::longmess(@_);
1333   ($single,$trace) = ($mysingle,$mytrace);
1334   #&warn("Warning in dbwarn\n");
1335   &warn($mess);
1336   #&warn("Exiting dbwarn\n");
1337 }
1338
1339 sub dbdie {
1340   local $frame = 0;
1341   local $SIG{__DIE__} = '';
1342   local $SIG{__WARN__} = '';
1343   my $i = 0; my $ineval = 0; my $sub;
1344   #&warn("Entering dbdie\n");
1345   if ($dieLevel != 2) {
1346     while ((undef,undef,undef,$sub) = caller(++$i)) {
1347       $ineval = 1, last if $sub eq '(eval)';
1348     }
1349     {
1350       local $SIG{__WARN__} = \&dbwarn;
1351       &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1352     }
1353     #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1354     die @_ if $ineval and $dieLevel < 2;
1355   }
1356   require Carp;
1357   # We do not want to debug this chunk (automatic disabling works
1358   # inside DB::DB, but not in Carp).
1359   my ($mysingle,$mytrace) = ($single,$trace);
1360   $single = 0; $trace = 0;
1361   my $mess = Carp::longmess(@_);
1362   ($single,$trace) = ($mysingle,$mytrace);
1363   #&warn("dieing loudly in dbdie\n");
1364   die $mess;
1365 }
1366
1367 sub warnLevel {
1368   if (@_) {
1369     $prevwarn = $SIG{__WARN__} unless $warnLevel;
1370     $warnLevel = shift;
1371     if ($warnLevel) {
1372       $SIG{__WARN__} = 'DB::dbwarn';
1373     } else {
1374       $SIG{__WARN__} = $prevwarn;
1375     }
1376   }
1377   $warnLevel;
1378 }
1379
1380 sub dieLevel {
1381   if (@_) {
1382     $prevdie = $SIG{__DIE__} unless $dieLevel;
1383     $dieLevel = shift;
1384     if ($dieLevel) {
1385       $SIG{__DIE__} = 'DB::dbdie'; # if $dieLevel < 2;
1386       #$SIG{__DIE__} = 'DB::diehard' if $dieLevel >= 2;
1387       print $OUT "Stack dump during die enabled",
1388         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1389       print $OUT "Dump printed too.\n" if $dieLevel > 2;
1390     } else {
1391       $SIG{__DIE__} = $prevdie;
1392       print $OUT "Default die handler restored.\n";
1393     }
1394   }
1395   $dieLevel;
1396 }
1397
1398 sub signalLevel {
1399   if (@_) {
1400     $prevsegv = $SIG{SEGV} unless $signalLevel;
1401     $prevbus = $SIG{BUS} unless $signalLevel;
1402     $signalLevel = shift;
1403     if ($signalLevel) {
1404       $SIG{SEGV} = 'DB::diesignal';
1405       $SIG{BUS} = 'DB::diesignal';
1406     } else {
1407       $SIG{SEGV} = $prevsegv;
1408       $SIG{BUS} = $prevbus;
1409     }
1410   }
1411   $signalLevel;
1412 }
1413
1414 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1415
1416 BEGIN {                 # This does not compile, alas.
1417   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
1418   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
1419   $sh = '!';
1420   $rc = ',';
1421   @hist = ('?');
1422   $deep = 100;                  # warning if stack gets this deep
1423   $window = 10;
1424   $preview = 3;
1425   $sub = '';
1426   #$SIG{__WARN__} = "DB::dbwarn";
1427   #$SIG{__DIE__} = 'DB::dbdie';
1428   #$SIG{SEGV} = "DB::diesignal";
1429   #$SIG{BUS} = "DB::diesignal";
1430   $SIG{INT} = "DB::catch";
1431   #$SIG{FPE} = "DB::catch";
1432   #warn "SIGFPE installed";
1433   $warnLevel = 1 unless defined $warnLevel;
1434   $dieLevel = 1 unless defined $dieLevel;
1435   $signalLevel = 1 unless defined $signalLevel;
1436
1437   $db_stop = 0;                 # Compiler warning
1438   $db_stop = 1 << 30;
1439   $level = 0;                   # Level of recursive debugging
1440 }
1441
1442 BEGIN {$^W = $ini_warn;}        # Switch warnings back
1443
1444 #use Carp;                      # This did break, left for debuggin
1445
1446 1;