perl 5.003_01: lib/perl5db.pl
[p5sagit/p5-mst-13.2.git] / 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;