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