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