lib/perl5db.pl

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