lib/perl5db.pl

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