This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b8ac49018cac5f2291d7a9ca450c509e7b012f41
[perl5.git] / lib / perl5db.pl
1 package DB;
2
3 # Debugger for Perl 5.00x; perl5db.pl patch level:
4
5 $VERSION = 1.07;
6 $header = "perl5db.pl version $VERSION";
7
8 #
9 # This file is automatically included if you do perl -d.
10 # It's probably not useful to include this yourself.
11 #
12 # Perl supplies the values for %sub.  It effectively inserts
13 # a &DB'DB(); in front of every place that can have a
14 # breakpoint. Instead of a subroutine call it calls &DB::sub with
15 # $DB::sub being the called subroutine. It also inserts a BEGIN
16 # {require 'perl5db.pl'} before the first line.
17 #
18 # After each `require'd file is compiled, but before it is executed, a
19 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
20 # $filename is the expanded name of the `require'd file (as found as
21 # value of %INC).
22 #
23 # Additional services from Perl interpreter:
24 #
25 # if caller() is called from the package DB, it provides some
26 # additional data.
27 #
28 # The array @{$main::{'_<'.$filename} is the line-by-line contents of
29 # $filename.
30 #
31 # The hash %{'_<'.$filename} contains breakpoints and action (it is
32 # keyed by line number), and individual entries are settable (as
33 # opposed to the whole hash). Only true/false is important to the
34 # interpreter, though the values used by perl5db.pl have the form
35 # "$break_condition\0$action". Values are magical in numeric context.
36 #
37 # The scalar ${'_<'.$filename} contains $filename.
38 #
39 # Note that no subroutine call is possible until &DB::sub is defined
40 # (for subroutines defined outside of the package DB). In fact the same is
41 # true if $deep is not defined.
42 #
43 # $Log: perldb.pl,v $
44
45 #
46 # At start reads $rcfile that may set important options.  This file
47 # may define a subroutine &afterinit that will be executed after the
48 # debugger is initialized.
49 #
50 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
51 # it as a rest of `O ...' line in debugger prompt.
52 #
53 # The options that can be specified only at startup:
54 # [To set in $rcfile, call &parse_options("optionName=new_value").]
55 #
56 # TTY  - the TTY to use for debugging i/o.
57 #
58 # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
59 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
60 # Term::Rendezvous.  Current variant is to have the name of TTY in this
61 # file.
62 #
63 # ReadLine - If false, dummy ReadLine is used, so you can debug
64 # ReadLine applications.
65 #
66 # NonStop - if true, no i/o is performed until interrupt.
67 #
68 # LineInfo - file or pipe to print line number info to.  If it is a
69 # pipe, a short "emacs like" message is used.
70 #
71 # RemotePort - host:port to connect to on remote host for remote debugging.
72 #
73 # Example $rcfile: (delete leading hashes!)
74 #
75 # &parse_options("NonStop=1 LineInfo=db.out");
76 # sub afterinit { $trace = 1; }
77 #
78 # The script will run without human intervention, putting trace
79 # information into db.out.  (If you interrupt it, you would better
80 # reset LineInfo to something "interactive"!)
81 #
82 ##################################################################
83
84 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
85 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
86
87 # modified Perl debugger, to be run from Emacs in perldb-mode
88 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
89 # Johan Vromans -- upgrade to 4.0 pl 10
90 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
91
92 # Changelog:
93
94 # A lot of things changed after 0.94. First of all, core now informs
95 # debugger about entry into XSUBs, overloaded operators, tied operations,
96 # BEGIN and END. Handy with `O f=2'.
97
98 # This can make debugger a little bit too verbose, please be patient
99 # and report your problems promptly.
100
101 # Now the option frame has 3 values: 0,1,2.
102
103 # Note that if DESTROY returns a reference to the object (or object),
104 # the deletion of data may be postponed until the next function call,
105 # due to the need to examine the return value.
106
107 # Changes: 0.95: `v' command shows versions.
108 # Changes: 0.96: `v' command shows version of readline.
109 #       primitive completion works (dynamic variables, subs for `b' and `l',
110 #               options). Can `p %var'
111 #       Better help (`h <' now works). New commands <<, >>, {, {{.
112 #       {dump|print}_trace() coded (to be able to do it from <<cmd).
113 #       `c sub' documented.
114 #       At last enough magic combined to stop after the end of debuggee.
115 #       !! should work now (thanks to Emacs bracket matching an extra
116 #       `]' in a regexp is caught).
117 #       `L', `D' and `A' span files now (as documented).
118 #       Breakpoints in `require'd code are possible (used in `R').
119 #       Some additional words on internal work of debugger.
120 #       `b load filename' implemented.
121 #       `b postpone subr' implemented.
122 #       now only `q' exits debugger (overwriteable on $inhibit_exit).
123 #       When restarting debugger breakpoints/actions persist.
124 #     Buglet: When restarting debugger only one breakpoint/action per 
125 #               autoloaded function persists.
126 # Changes: 0.97: NonStop will not stop in at_exit().
127 #       Option AutoTrace implemented.
128 #       Trace printed differently if frames are printed too.
129 #       new `inhibitExit' option.
130 #       printing of a very long statement interruptible.
131 # Changes: 0.98: New command `m' for printing possible methods
132 #       'l -' is a synonim for `-'.
133 #       Cosmetic bugs in printing stack trace.
134 #       `frame' & 8 to print "expanded args" in stack trace.
135 #       Can list/break in imported subs.
136 #       new `maxTraceLen' option.
137 #       frame & 4 and frame & 8 granted.
138 #       new command `m'
139 #       nonstoppable lines do not have `:' near the line number.
140 #       `b compile subname' implemented.
141 #       Will not use $` any more.
142 #       `-' behaves sane now.
143 # Changes: 0.99: Completion for `f', `m'.
144 #       `m' will remove duplicate names instead of duplicate functions.
145 #       `b load' strips trailing whitespace.
146 #       completion ignores leading `|'; takes into account current package
147 #       when completing a subroutine name (same for `l').
148 # Changes: 1.07: Many fixed by tchrist 13-March-2000
149 #   BUG FIXES:
150 #   + Added bare mimimal security checks on perldb rc files, plus
151 #     comments on what else is needed.
152 #   + Fixed the ornaments that made "|h" completely unusable.
153 #     They are not used in print_help if they will hurt.  Strip pod
154 #     if we're paging to less.
155 #   + Fixed mis-formatting of help messages caused by ornaments
156 #     to restore Larry's original formatting.  
157 #   + Fixed many other formatting errors.  The code is still suboptimal, 
158 #     and needs a lot of work at restructuing. It's also misindented
159 #     in many places.
160 #   + Fixed bug where trying to look at an option like your pager
161 #     shows "1".  
162 #   + Fixed some $? processing.  Note: if you use csh or tcsh, you will
163 #     lose.  You should consider shell escapes not using their shell,
164 #     or else not caring about detailed status.  This should really be
165 #     unified into one place, too.
166 #   + Fixed bug where invisible trailing whitespace on commands hoses you,
167 #     tricking Perl into thinking you wern't calling a debugger command!
168 #   + Fixed bug where leading whitespace on commands hoses you.  (One
169 #     suggests a leading semicolon or any other irrelevant non-whitespace
170 #     to indicate literal Perl code.)
171 #   + Fixed bugs that ate warnings due to wrong selected handle.
172 #   + Fixed a precedence bug on signal stuff.
173 #   + Fixed some unseemly wording.
174 #   + Fixed bug in help command trying to call perl method code.
175 #   + Fixed to call dumpvar from exception handler.  SIGPIPE killed us.
176 #   ENHANCEMENTS:
177 #   + Added some comments.  This code is still nasty spaghetti.
178 #   + Added message if you clear your pre/post command stacks which was
179 #     very easy to do if you just typed a bare >, <, or {.  (A command
180 #     without an argument should *never* be a destructive action; this
181 #     API is fundamentally screwed up; likewise option setting, which
182 #     is equally buggered.)
183 #   + Added command stack dump on argument of "?" for >, <, or {.
184 #   + Added a semi-built-in doc viewer command that calls man with the
185 #     proper %Config::Config path (and thus gets caching, man -k, etc),
186 #     or else perldoc on obstreperous platforms.
187 #   + Added to and rearranged the help information.
188 #   + Detected apparent misuse of { ... } to declare a block; this used
189 #     to work but now is a command, and mysteriously gave no complaint.
190
191 ####################################################################
192
193 # Needed for the statement after exec():
194
195 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
196 local($^W) = 0;                 # Switch run-time warnings off during init.
197 warn (                  # Do not ;-)
198       $dumpvar::hashDepth,     
199       $dumpvar::arrayDepth,    
200       $dumpvar::dumpDBFiles,   
201       $dumpvar::dumpPackages,  
202       $dumpvar::quoteHighBit,  
203       $dumpvar::printUndef,    
204       $dumpvar::globPrint,     
205       $dumpvar::usageOnly,
206       @ARGS,
207       $Carp::CarpLevel,
208       $panic,
209       $second_time,
210      ) if 0;
211
212 # Command-line + PERLLIB:
213 @ini_INC = @INC;
214
215 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
216
217 $trace = $signal = $single = 0; # Uninitialized warning suppression
218                                 # (local $^W cannot help - other packages!).
219 $inhibit_exit = $option{PrintRet} = 1;
220
221 @options     = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
222                   compactDump veryCompact quote HighBit undefPrint
223                   globPrint PrintRet UsageOnly frame AutoTrace
224                   TTY noTTY ReadLine NonStop LineInfo maxTraceLen
225                   recallCommand ShellBang pager tkRunning ornaments
226                   signalLevel warnLevel dieLevel inhibit_exit
227                   ImmediateStop bareStringify
228                   RemotePort);
229
230 %optionVars    = (
231                  hashDepth      => \$dumpvar::hashDepth,
232                  arrayDepth     => \$dumpvar::arrayDepth,
233                  DumpDBFiles    => \$dumpvar::dumpDBFiles,
234                  DumpPackages   => \$dumpvar::dumpPackages,
235                  DumpReused     => \$dumpvar::dumpReused,
236                  HighBit        => \$dumpvar::quoteHighBit,
237                  undefPrint     => \$dumpvar::printUndef,
238                  globPrint      => \$dumpvar::globPrint,
239                  UsageOnly      => \$dumpvar::usageOnly,     
240                  bareStringify  => \$dumpvar::bareStringify,
241                  frame          => \$frame,
242                  AutoTrace      => \$trace,
243                  inhibit_exit   => \$inhibit_exit,
244                  maxTraceLen    => \$maxtrace,
245                  ImmediateStop  => \$ImmediateStop,
246                  RemotePort     => \$remoteport,
247 );
248
249 %optionAction  = (
250                   compactDump   => \&dumpvar::compactDump,
251                   veryCompact   => \&dumpvar::veryCompact,
252                   quote         => \&dumpvar::quote,
253                   TTY           => \&TTY,
254                   noTTY         => \&noTTY,
255                   ReadLine      => \&ReadLine,
256                   NonStop       => \&NonStop,
257                   LineInfo      => \&LineInfo,
258                   recallCommand => \&recallCommand,
259                   ShellBang     => \&shellBang,
260                   pager         => \&pager,
261                   signalLevel   => \&signalLevel,
262                   warnLevel     => \&warnLevel,
263                   dieLevel      => \&dieLevel,
264                   tkRunning     => \&tkRunning,
265                   ornaments     => \&ornaments,
266                   RemotePort    => \&RemotePort,
267                  );
268
269 %optionRequire = (
270                   compactDump   => 'dumpvar.pl',
271                   veryCompact   => 'dumpvar.pl',
272                   quote         => 'dumpvar.pl',
273                  );
274
275 # These guys may be defined in $ENV{PERL5DB} :
276 $rl             = 1     unless defined $rl;
277 $warnLevel      = 0     unless defined $warnLevel;
278 $dieLevel       = 0     unless defined $dieLevel;
279 $signalLevel    = 1     unless defined $signalLevel;
280 $pre            = []    unless defined $pre;
281 $post           = []    unless defined $post;
282 $pretype        = []    unless defined $pretype;
283
284 warnLevel($warnLevel);
285 dieLevel($dieLevel);
286 signalLevel($signalLevel);
287
288 &pager(
289     (defined($ENV{PAGER}) 
290         ? $ENV{PAGER}
291         : ($^O eq 'os2' 
292            ? 'cmd /c more' 
293            : 'more'))) unless defined $pager;
294 setman();
295 &recallCommand("!") unless defined $prc;
296 &shellBang("!") unless defined $psh;
297 $maxtrace = 400 unless defined $maxtrace;
298
299 if (-e "/dev/tty") {  # this is the wrong metric!
300   $rcfile=".perldb";
301 } else {
302   $rcfile="perldb.ini";
303 }
304
305 # This isn't really safe, because there's a race
306 # between checking and opening.  The solution is to
307 # open and fstat the handle, but then you have to read and
308 # eval the contents.  But then the silly thing gets
309 # your lexical scope, which is unfortunately at best.
310 sub safe_do { 
311     my $file = shift;
312
313     # Just exactly what part of the word "CORE::" don't you understand?
314     local $SIG{__WARN__};  
315     local $SIG{__DIE__};    
316
317     unless (is_safe_file($file)) {
318         CORE::warn <<EO_GRIPE;
319 perldb: Must not source insecure rcfile $file.
320         You or the superuser must be the owner, and it must not 
321         be writable by anyone but its owner.
322 EO_GRIPE
323         return;
324     } 
325
326     do $file;
327     CORE::warn("perldb: couldn't parse $file: $@") if $@;
328 }
329
330
331 # Verifies that owner is either real user or superuser and that no
332 # one but owner may write to it.  This function is of limited use
333 # when called on a path instead of upon a handle, because there are
334 # no guarantees that filename (by dirent) whose file (by ino) is
335 # eventually accessed is the same as the one tested. 
336 # Assumes that the file's existence is not in doubt.
337 sub is_safe_file {
338     my $path = shift;
339     stat($path) || return;      # mysteriously vaporized
340     my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
341
342     return 0 if $uid != 0 && $uid != $<;
343     return 0 if $mode & 022;
344     return 1;
345 }
346
347 if (-f $rcfile) {
348     safe_do("./$rcfile");
349
350 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
351     safe_do("$ENV{HOME}/$rcfile");
352 }
353 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
354     safe_do("$ENV{LOGDIR}/$rcfile");
355 }
356
357 if (defined $ENV{PERLDB_OPTS}) {
358   parse_options($ENV{PERLDB_OPTS});
359 }
360
361 # Here begin the unreadable code.  It needs fixing.
362
363 if (exists $ENV{PERLDB_RESTART}) {
364   delete $ENV{PERLDB_RESTART};
365   # $restart = 1;
366   @hist = get_list('PERLDB_HIST');
367   %break_on_load = get_list("PERLDB_ON_LOAD");
368   %postponed = get_list("PERLDB_POSTPONE");
369   my @had_breakpoints= get_list("PERLDB_VISITED");
370   for (0 .. $#had_breakpoints) {
371     my %pf = get_list("PERLDB_FILE_$_");
372     $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
373   }
374   my %opt = get_list("PERLDB_OPT");
375   my ($opt,$val);
376   while (($opt,$val) = each %opt) {
377     $val =~ s/[\\\']/\\$1/g;
378     parse_options("$opt'$val'");
379   }
380   @INC = get_list("PERLDB_INC");
381   @ini_INC = @INC;
382   $pretype = [get_list("PERLDB_PRETYPE")];
383   $pre = [get_list("PERLDB_PRE")];
384   $post = [get_list("PERLDB_POST")];
385   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
386 }
387
388 if ($notty) {
389   $runnonstop = 1;
390 } else {
391   # Is Perl being run from a slave editor or graphical debugger?
392   $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
393   $rl = 0, shift(@main::ARGV) if $slave_editor;
394
395   #require Term::ReadLine;
396
397   if ($^O eq 'cygwin') {
398     # /dev/tty is binary. use stdin for textmode
399     undef $console;
400   } elsif (-e "/dev/tty") {
401     $console = "/dev/tty";
402   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
403     $console = "con";
404   } else {
405     $console = "sys\$command";
406   }
407
408   if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
409     $console = undef;
410   }
411
412   # Around a bug:
413   if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
414     $console = undef;
415   }
416
417   if ($^O eq 'epoc') {
418     $console = undef;
419   }
420
421   $console = $tty if defined $tty;
422
423   if (defined $remoteport) {
424     require IO::Socket;
425     $OUT = new IO::Socket::INET( Timeout  => '10',
426                                  PeerAddr => $remoteport,
427                                  Proto    => 'tcp',
428                                );
429     if (!$OUT) { die "Could not create socket to connect to remote host."; }
430     $IN = $OUT;
431   }
432   else {
433     if (defined $console) {
434       open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
435       open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
436         || open(OUT,">&STDOUT");        # so we don't dongle stdout
437     } else {
438       open(IN,"<&STDIN");
439       open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
440       $console = 'STDIN/OUT';
441     }
442     # so open("|more") can read from STDOUT and so we don't dingle stdin
443     $IN = \*IN;
444
445     $OUT = \*OUT;
446   }
447   select($OUT);
448   $| = 1;                       # for DB::OUT
449   select(STDOUT);
450
451   $LINEINFO = $OUT unless defined $LINEINFO;
452   $lineinfo = $console unless defined $lineinfo;
453
454   $| = 1;                       # for real STDOUT
455
456   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
457   unless ($runnonstop) {
458     print $OUT "\nLoading DB routines from $header\n";
459     print $OUT ("Editor support ",
460                 $slave_editor ? "enabled" : "available",
461                 ".\n");
462     print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
463   }
464 }
465
466 @ARGS = @ARGV;
467 for (@args) {
468     s/\'/\\\'/g;
469     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
470 }
471
472 if (defined &afterinit) {       # May be defined in $rcfile
473   &afterinit();
474 }
475
476 $I_m_init = 1;
477
478 ############################################################ Subroutines
479
480 sub DB {
481     # _After_ the perl program is compiled, $single is set to 1:
482     if ($single and not $second_time++) {
483       if ($runnonstop) {        # Disable until signal
484         for ($i=0; $i <= $stack_depth; ) {
485             $stack[$i++] &= ~1;
486         }
487         $single = 0;
488         # return;                       # Would not print trace!
489       } elsif ($ImmediateStop) {
490         $ImmediateStop = 0;
491         $signal = 1;
492       }
493     }
494     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
495     &save;
496     ($package, $filename, $line) = caller;
497     $filename_ini = $filename;
498     $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
499       "package $package;";      # this won't let them modify, alas
500     local(*dbline) = $main::{'_<' . $filename};
501     $max = $#dbline;
502     if (($stop,$action) = split(/\0/,$dbline{$line})) {
503         if ($stop eq '1') {
504             $signal |= 1;
505         } elsif ($stop) {
506             $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
507             $dbline{$line} =~ s/;9($|\0)/$1/;
508         }
509     }
510     my $was_signal = $signal;
511     if ($trace & 2) {
512       for (my $n = 0; $n <= $#to_watch; $n++) {
513         $evalarg = $to_watch[$n];
514         local $onetimeDump;     # Do not output results
515         my ($val) = &eval;      # Fix context (&eval is doing array)?
516         $val = ( (defined $val) ? "'$val'" : 'undef' );
517         if ($val ne $old_watch[$n]) {
518           $signal = 1;
519           print $OUT <<EOP;
520 Watchpoint $n:\t$to_watch[$n] changed:
521     old value:\t$old_watch[$n]
522     new value:\t$val
523 EOP
524           $old_watch[$n] = $val;
525         }
526       }
527     }
528     if ($trace & 4) {           # User-installed watch
529       return if watchfunction($package, $filename, $line) 
530         and not $single and not $was_signal and not ($trace & ~4);
531     }
532     $was_signal = $signal;
533     $signal = 0;
534     if ($single || ($trace & 1) || $was_signal) {
535         if ($slave_editor) {
536             $position = "\032\032$filename:$line:0\n";
537             print $LINEINFO $position;
538         } elsif ($package eq 'DB::fake') {
539           $term || &setterm;
540           print_help(<<EOP);
541 Debugged program terminated.  Use B<q> to quit or B<R> to restart,
542   use B<O> I<inhibit_exit> to avoid stopping after program termination,
543   B<h q>, B<h R> or B<h O> to get additional info.  
544 EOP
545           $package = 'main';
546           $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
547             "package $package;";        # this won't let them modify, alas
548         } else {
549             $sub =~ s/\'/::/;
550             $prefix = $sub =~ /::/ ? "" : "${'package'}::";
551             $prefix .= "$sub($filename:";
552             $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
553             if (length($prefix) > 30) {
554                 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
555                 $prefix = "";
556                 $infix = ":\t";
557             } else {
558                 $infix = "):\t";
559                 $position = "$prefix$line$infix$dbline[$line]$after";
560             }
561             if ($frame) {
562                 print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
563             } else {
564                 print $LINEINFO $position;
565             }
566             for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
567                 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
568                 last if $signal;
569                 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
570                 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
571                 $position .= $incr_pos;
572                 if ($frame) {
573                     print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
574                 } else {
575                     print $LINEINFO $incr_pos;
576                 }
577             }
578         }
579     }
580     $evalarg = $action, &eval if $action;
581     if ($single || $was_signal) {
582         local $level = $level + 1;
583         foreach $evalarg (@$pre) {
584           &eval;
585         }
586         print $OUT $stack_depth . " levels deep in subroutine calls!\n"
587           if $single & 4;
588         $start = $line;
589         $incr = -1;             # for backward motion.
590         @typeahead = (@$pretype, @typeahead);
591       CMD:
592         while (($term || &setterm),
593                ($term_pid == $$ or &resetterm),
594                defined ($cmd=&readline("  DB" . ('<' x $level) .
595                                        ($#hist+1) . ('>' x $level) .
596                                        " "))) 
597         {
598                 $single = 0;
599                 $signal = 0;
600                 $cmd =~ s/\\$/\n/ && do {
601                     $cmd .= &readline("  cont: ");
602                     redo CMD;
603                 };
604                 $cmd =~ /^$/ && ($cmd = $laststep);
605                 push(@hist,$cmd) if length($cmd) > 1;
606               PIPE: {
607                     $cmd =~ s/^\s+//s;   # trim annoying leading whitespace
608                     $cmd =~ s/\s+$//s;   # trim annoying trailing whitespace
609                     ($i) = split(/\s+/,$cmd);
610                     if ($alias{$i}) { 
611                         # squelch the sigmangler
612                         local $SIG{__DIE__};
613                         local $SIG{__WARN__};
614                         eval "\$cmd =~ $alias{$i}";
615                         if ($@) {
616                             print $OUT "Couldn't evaluate `$i' alias: $@";
617                             next CMD;
618                         } 
619                     }
620                     $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
621                     $cmd =~ /^h$/ && do {
622                         print_help($help);
623                         next CMD; };
624                     $cmd =~ /^h\s+h$/ && do {
625                         print_help($summary);
626                         next CMD; };
627                     # support long commands; otherwise bogus errors
628                     # happen when you ask for h on <CR> for example
629                     $cmd =~ /^h\s+(\S.*)$/ && do {      
630                         my $asked = $1;                 # for proper errmsg
631                         my $qasked = quotemeta($asked); # for searching
632                         # XXX: finds CR but not <CR>
633                         if ($help =~ /^<?(?:[IB]<)$qasked/m) {
634                           while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
635                             print_help($1);
636                           }
637                         } else {
638                             print_help("B<$asked> is not a debugger command.\n");
639                         }
640                         next CMD; };
641                     $cmd =~ /^t$/ && do {
642                         $trace ^= 1;
643                         print $OUT "Trace = " .
644                             (($trace & 1) ? "on" : "off" ) . "\n";
645                         next CMD; };
646                     $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
647                         $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
648                         foreach $subname (sort(keys %sub)) {
649                             if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
650                                 print $OUT $subname,"\n";
651                             }
652                         }
653                         next CMD; };
654                     $cmd =~ /^v$/ && do {
655                         list_versions(); next CMD};
656                     $cmd =~ s/^X\b/V $package/;
657                     $cmd =~ /^V$/ && do {
658                         $cmd = "V $package"; };
659                     $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
660                         local ($savout) = select($OUT);
661                         $packname = $1;
662                         @vars = split(' ',$2);
663                         do 'dumpvar.pl' unless defined &main::dumpvar;
664                         if (defined &main::dumpvar) {
665                             local $frame = 0;
666                             local $doret = -2;
667                             # must detect sigpipe failures
668                             eval { &main::dumpvar($packname,@vars) };
669                             if ($@) {
670                                 die unless $@ =~ /dumpvar print failed/;
671                             } 
672                         } else {
673                             print $OUT "dumpvar.pl not available.\n";
674                         }
675                         select ($savout);
676                         next CMD; };
677                     $cmd =~ s/^x\b/ / && do { # So that will be evaled
678                         $onetimeDump = 'dump'; };
679                     $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
680                         methods($1); next CMD};
681                     $cmd =~ s/^m\b/ / && do { # So this will be evaled
682                         $onetimeDump = 'methods'; };
683                     $cmd =~ /^f\b\s*(.*)/ && do {
684                         $file = $1;
685                         $file =~ s/\s+$//;
686                         if (!$file) {
687                             print $OUT "The old f command is now the r command.\n";
688                             print $OUT "The new f command switches filenames.\n";
689                             next CMD;
690                         }
691                         if (!defined $main::{'_<' . $file}) {
692                             if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
693                                               $try = substr($try,2);
694                                               print $OUT "Choosing $try matching `$file':\n";
695                                               $file = $try;
696                                           }}
697                         }
698                         if (!defined $main::{'_<' . $file}) {
699                             print $OUT "No file matching `$file' is loaded.\n";
700                             next CMD;
701                         } elsif ($file ne $filename) {
702                             *dbline = $main::{'_<' . $file};
703                             $max = $#dbline;
704                             $filename = $file;
705                             $start = 1;
706                             $cmd = "l";
707                           } else {
708                             print $OUT "Already in $file.\n";
709                             next CMD;
710                           }
711                       };
712                     $cmd =~ s/^l\s+-\s*$/-/;
713                     $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
714                         $evalarg = $2;
715                         my ($s) = &eval;
716                         print($OUT "Error: $@\n"), next CMD if $@;
717                         $s = CvGV_name($s);
718                         print($OUT "Interpreted as: $1 $s\n");
719                         $cmd = "$1 $s";
720                     };
721                     $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
722                         $subname = $1;
723                         $subname =~ s/\'/::/;
724                         $subname = $package."::".$subname 
725                           unless $subname =~ /::/;
726                         $subname = "main".$subname if substr($subname,0,2) eq "::";
727                         @pieces = split(/:/,find_sub($subname) || $sub{$subname});
728                         $subrange = pop @pieces;
729                         $file = join(':', @pieces);
730                         if ($file ne $filename) {
731                             print $OUT "Switching to file '$file'.\n"
732                                 unless $slave_editor;
733                             *dbline = $main::{'_<' . $file};
734                             $max = $#dbline;
735                             $filename = $file;
736                         }
737                         if ($subrange) {
738                             if (eval($subrange) < -$window) {
739                                 $subrange =~ s/-.*/+/;
740                             }
741                             $cmd = "l $subrange";
742                         } else {
743                             print $OUT "Subroutine $subname not found.\n";
744                             next CMD;
745                         } };
746                     $cmd =~ /^\.$/ && do {
747                         $incr = -1;             # for backward motion.
748                         $start = $line;
749                         $filename = $filename_ini;
750                         *dbline = $main::{'_<' . $filename};
751                         $max = $#dbline;
752                         print $LINEINFO $position;
753                         next CMD };
754                     $cmd =~ /^w\b\s*(\d*)$/ && do {
755                         $incr = $window - 1;
756                         $start = $1 if $1;
757                         $start -= $preview;
758                         #print $OUT 'l ' . $start . '-' . ($start + $incr);
759                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
760                     $cmd =~ /^-$/ && do {
761                         $start -= $incr + $window + 1;
762                         $start = 1 if $start <= 0;
763                         $incr = $window - 1;
764                         $cmd = 'l ' . ($start) . '+'; };
765                     $cmd =~ /^l$/ && do {
766                         $incr = $window - 1;
767                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
768                     $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
769                         $start = $1 if $1;
770                         $incr = $2;
771                         $incr = $window - 1 unless $incr;
772                         $cmd = 'l ' . $start . '-' . ($start + $incr); };
773                     $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
774                         $end = (!defined $2) ? $max : ($4 ? $4 : $2);
775                         $end = $max if $end > $max;
776                         $i = $2;
777                         $i = $line if $i eq '.';
778                         $i = 1 if $i < 1;
779                         $incr = $end - $i;
780                         if ($slave_editor) {
781                             print $OUT "\032\032$filename:$i:0\n";
782                             $i = $end;
783                         } else {
784                             for (; $i <= $end; $i++) {
785                                 ($stop,$action) = split(/\0/, $dbline{$i});
786                                 $arrow = ($i==$line 
787                                           and $filename eq $filename_ini) 
788                                   ?  '==>' 
789                                     : ($dbline[$i]+0 ? ':' : ' ') ;
790                                 $arrow .= 'b' if $stop;
791                                 $arrow .= 'a' if $action;
792                                 print $OUT "$i$arrow\t", $dbline[$i];
793                                 $i++, last if $signal;
794                             }
795                             print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
796                         }
797                         $start = $i; # remember in case they want more
798                         $start = $max if $start > $max;
799                         next CMD; };
800                     $cmd =~ /^D$/ && do {
801                       print $OUT "Deleting all breakpoints...\n";
802                       my $file;
803                       for $file (keys %had_breakpoints) {
804                         local *dbline = $main::{'_<' . $file};
805                         my $max = $#dbline;
806                         my $was;
807                         
808                         for ($i = 1; $i <= $max ; $i++) {
809                             if (defined $dbline{$i}) {
810                                 $dbline{$i} =~ s/^[^\0]+//;
811                                 if ($dbline{$i} =~ s/^\0?$//) {
812                                     delete $dbline{$i};
813                                 }
814                             }
815                         }
816                         
817                         if (not $had_breakpoints{$file} &= ~1) {
818                             delete $had_breakpoints{$file};
819                         }
820                       }
821                       undef %postponed;
822                       undef %postponed_file;
823                       undef %break_on_load;
824                       next CMD; };
825                     $cmd =~ /^L$/ && do {
826                       my $file;
827                       for $file (keys %had_breakpoints) {
828                         local *dbline = $main::{'_<' . $file};
829                         my $max = $#dbline;
830                         my $was;
831                         
832                         for ($i = 1; $i <= $max; $i++) {
833                             if (defined $dbline{$i}) {
834                                 print $OUT "$file:\n" unless $was++;
835                                 print $OUT " $i:\t", $dbline[$i];
836                                 ($stop,$action) = split(/\0/, $dbline{$i});
837                                 print $OUT "   break if (", $stop, ")\n"
838                                   if $stop;
839                                 print $OUT "   action:  ", $action, "\n"
840                                   if $action;
841                                 last if $signal;
842                             }
843                         }
844                       }
845                       if (%postponed) {
846                         print $OUT "Postponed breakpoints in subroutines:\n";
847                         my $subname;
848                         for $subname (keys %postponed) {
849                           print $OUT " $subname\t$postponed{$subname}\n";
850                           last if $signal;
851                         }
852                       }
853                       my @have = map { # Combined keys
854                         keys %{$postponed_file{$_}}
855                       } keys %postponed_file;
856                       if (@have) {
857                         print $OUT "Postponed breakpoints in files:\n";
858                         my ($file, $line);
859                         for $file (keys %postponed_file) {
860                           my $db = $postponed_file{$file};
861                           print $OUT " $file:\n";
862                           for $line (sort {$a <=> $b} keys %$db) {
863                                 print $OUT "  $line:\n";
864                                 my ($stop,$action) = split(/\0/, $$db{$line});
865                                 print $OUT "    break if (", $stop, ")\n"
866                                   if $stop;
867                                 print $OUT "    action:  ", $action, "\n"
868                                   if $action;
869                                 last if $signal;
870                           }
871                           last if $signal;
872                         }
873                       }
874                       if (%break_on_load) {
875                         print $OUT "Breakpoints on load:\n";
876                         my $file;
877                         for $file (keys %break_on_load) {
878                           print $OUT " $file\n";
879                           last if $signal;
880                         }
881                       }
882                       if ($trace & 2) {
883                         print $OUT "Watch-expressions:\n";
884                         my $expr;
885                         for $expr (@to_watch) {
886                           print $OUT " $expr\n";
887                           last if $signal;
888                         }
889                       }
890                       next CMD; };
891                     $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
892                         my $file = $1; $file =~ s/\s+$//;
893                         {
894                           $break_on_load{$file} = 1;
895                           $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
896                           $file .= '.pm', redo unless $file =~ /\./;
897                         }
898                         $had_breakpoints{$file} |= 1;
899                         print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
900                         next CMD; };
901                     $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
902                         my $cond = length $3 ? $3 : '1';
903                         my ($subname, $break) = ($2, $1 eq 'postpone');
904                         $subname =~ s/\'/::/g;
905                         $subname = "${'package'}::" . $subname
906                           unless $subname =~ /::/;
907                         $subname = "main".$subname if substr($subname,0,2) eq "::";
908                         $postponed{$subname} = $break 
909                           ? "break +0 if $cond" : "compile";
910                         next CMD; };
911                     $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
912                         $subname = $1;
913                         $cond = length $2 ? $2 : '1';
914                         $subname =~ s/\'/::/g;
915                         $subname = "${'package'}::" . $subname
916                           unless $subname =~ /::/;
917                         $subname = "main".$subname if substr($subname,0,2) eq "::";
918                         # Filename below can contain ':'
919                         ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
920                         $i += 0;
921                         if ($i) {
922                             local $filename = $file;
923                             local *dbline = $main::{'_<' . $filename};
924                             $had_breakpoints{$filename} |= 1;
925                             $max = $#dbline;
926                             ++$i while $dbline[$i] == 0 && $i < $max;
927                             $dbline{$i} =~ s/^[^\0]*/$cond/;
928                         } else {
929                             print $OUT "Subroutine $subname not found.\n";
930                         }
931                         next CMD; };
932                     $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
933                         $i = $1 || $line;
934                         $cond = defined $2 ? $2 : '1';
935                         if ($dbline[$i] == 0) {
936                             print $OUT "Line $i not breakable.\n";
937                         } else {
938                             $had_breakpoints{$filename} |= 1;
939                             $dbline{$i} =~ s/^[^\0]*/$cond/;
940                         }
941                         next CMD; };
942                     $cmd =~ /^d\b\s*(\d*)/ && do {
943                         $i = $1 || $line;
944                         if ($dbline[$i] == 0) {
945                             print $OUT "Line $i not breakable.\n";
946                         } else {
947                             $dbline{$i} =~ s/^[^\0]*//;
948                             delete $dbline{$i} if $dbline{$i} eq '';
949                         }
950                         next CMD; };
951                     $cmd =~ /^A$/ && do {
952                       print $OUT "Deleting all actions...\n";
953                       my $file;
954                       for $file (keys %had_breakpoints) {
955                         local *dbline = $main::{'_<' . $file};
956                         my $max = $#dbline;
957                         my $was;
958                         
959                         for ($i = 1; $i <= $max ; $i++) {
960                             if (defined $dbline{$i}) {
961                                 $dbline{$i} =~ s/\0[^\0]*//;
962                                 delete $dbline{$i} if $dbline{$i} eq '';
963                             }
964                         }
965                         
966                         unless ($had_breakpoints{$file} &= ~2) {
967                             delete $had_breakpoints{$file};
968                         }
969                       }
970                       next CMD; };
971                     $cmd =~ /^O\s*$/ && do {
972                         for (@options) {
973                             &dump_option($_);
974                         }
975                         next CMD; };
976                     $cmd =~ /^O\s*(\S.*)/ && do {
977                         parse_options($1);
978                         next CMD; };
979                     $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
980                         push @$pre, action($1);
981                         next CMD; };
982                     $cmd =~ /^>>\s*(.*)/ && do {
983                         push @$post, action($1);
984                         next CMD; };
985                     $cmd =~ /^<\s*(.*)/ && do {
986                         unless ($1) {
987                             print $OUT "All < actions cleared.\n";
988                             $pre = [];
989                             next CMD;
990                         } 
991                         if ($1 eq '?') {
992                             unless (@$pre) {
993                                 print $OUT "No pre-prompt Perl actions.\n";
994                                 next CMD;
995                             } 
996                             print $OUT "Perl commands run before each prompt:\n";
997                             for my $action ( @$pre ) {
998                                 print $OUT "\t< -- $action\n";
999                             } 
1000                             next CMD;
1001                         } 
1002                         $pre = [action($1)];
1003                         next CMD; };
1004                     $cmd =~ /^>\s*(.*)/ && do {
1005                         unless ($1) {
1006                             print $OUT "All > actions cleared.\n";
1007                             $post = [];
1008                             next CMD;
1009                         }
1010                         if ($1 eq '?') {
1011                             unless (@$post) {
1012                                 print $OUT "No post-prompt Perl actions.\n";
1013                                 next CMD;
1014                             } 
1015                             print $OUT "Perl commands run after each prompt:\n";
1016                             for my $action ( @$post ) {
1017                                 print $OUT "\t> -- $action\n";
1018                             } 
1019                             next CMD;
1020                         } 
1021                         $post = [action($1)];
1022                         next CMD; };
1023                     $cmd =~ /^\{\{\s*(.*)/ && do {
1024                         if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { 
1025                             print $OUT "{{ is now a debugger command\n",
1026                                 "use `;{{' if you mean Perl code\n";
1027                             $cmd = "h {{";
1028                             redo CMD;
1029                         } 
1030                         push @$pretype, $1;
1031                         next CMD; };
1032                     $cmd =~ /^\{\s*(.*)/ && do {
1033                         unless ($1) {
1034                             print $OUT "All { actions cleared.\n";
1035                             $pretype = [];
1036                             next CMD;
1037                         }
1038                         if ($1 eq '?') {
1039                             unless (@$pretype) {
1040                                 print $OUT "No pre-prompt debugger actions.\n";
1041                                 next CMD;
1042                             } 
1043                             print $OUT "Debugger commands run before each prompt:\n";
1044                             for my $action ( @$pretype ) {
1045                                 print $OUT "\t{ -- $action\n";
1046                             } 
1047                             next CMD;
1048                         } 
1049                         if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { 
1050                             print $OUT "{ is now a debugger command\n",
1051                                 "use `;{' if you mean Perl code\n";
1052                             $cmd = "h {";
1053                             redo CMD;
1054                         } 
1055                         $pretype = [$1];
1056                         next CMD; };
1057                     $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1058                         $i = $1 || $line; $j = $2;
1059                         if (length $j) {
1060                             if ($dbline[$i] == 0) {
1061                                 print $OUT "Line $i may not have an action.\n";
1062                             } else {
1063                                 $had_breakpoints{$filename} |= 2;
1064                                 $dbline{$i} =~ s/\0[^\0]*//;
1065                                 $dbline{$i} .= "\0" . action($j);
1066                             }
1067                         } else {
1068                             $dbline{$i} =~ s/\0[^\0]*//;
1069                             delete $dbline{$i} if $dbline{$i} eq '';
1070                         }
1071                         next CMD; };
1072                     $cmd =~ /^n$/ && do {
1073                         end_report(), next CMD if $finished and $level <= 1;
1074                         $single = 2;
1075                         $laststep = $cmd;
1076                         last CMD; };
1077                     $cmd =~ /^s$/ && do {
1078                         end_report(), next CMD if $finished and $level <= 1;
1079                         $single = 1;
1080                         $laststep = $cmd;
1081                         last CMD; };
1082                     $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1083                         end_report(), next CMD if $finished and $level <= 1;
1084                         $subname = $i = $1;
1085                         #  Probably not needed, since we finish an interactive
1086                         #  sub-session anyway...
1087                         # local $filename = $filename;
1088                         # local *dbline = *dbline;      # XXX Would this work?!
1089                         if ($i =~ /\D/) { # subroutine name
1090                             $subname = $package."::".$subname 
1091                                 unless $subname =~ /::/;
1092                             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1093                             $i += 0;
1094                             if ($i) {
1095                                 $filename = $file;
1096                                 *dbline = $main::{'_<' . $filename};
1097                                 $had_breakpoints{$filename} |= 1;
1098                                 $max = $#dbline;
1099                                 ++$i while $dbline[$i] == 0 && $i < $max;
1100                             } else {
1101                                 print $OUT "Subroutine $subname not found.\n";
1102                                 next CMD; 
1103                             }
1104                         }
1105                         if ($i) {
1106                             if ($dbline[$i] == 0) {
1107                                 print $OUT "Line $i not breakable.\n";
1108                                 next CMD;
1109                             }
1110                             $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1111                         }
1112                         for ($i=0; $i <= $stack_depth; ) {
1113                             $stack[$i++] &= ~1;
1114                         }
1115                         last CMD; };
1116                     $cmd =~ /^r$/ && do {
1117                         end_report(), next CMD if $finished and $level <= 1;
1118                         $stack[$stack_depth] |= 1;
1119                         $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1120                         last CMD; };
1121                     $cmd =~ /^R$/ && do {
1122                         print $OUT "Warning: some settings and command-line options may be lost!\n";
1123                         my (@script, @flags, $cl);
1124                         push @flags, '-w' if $ini_warn;
1125                         # Put all the old includes at the start to get
1126                         # the same debugger.
1127                         for (@ini_INC) {
1128                           push @flags, '-I', $_;
1129                         }
1130                         # Arrange for setting the old INC:
1131                         set_list("PERLDB_INC", @ini_INC);
1132                         if ($0 eq '-e') {
1133                           for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1134                                 chomp ($cl =  ${'::_<-e'}[$_]);
1135                             push @script, '-e', $cl;
1136                           }
1137                         } else {
1138                           @script = $0;
1139                         }
1140                         set_list("PERLDB_HIST", 
1141                                  $term->Features->{getHistory} 
1142                                  ? $term->GetHistory : @hist);
1143                         my @had_breakpoints = keys %had_breakpoints;
1144                         set_list("PERLDB_VISITED", @had_breakpoints);
1145                         set_list("PERLDB_OPT", %option);
1146                         set_list("PERLDB_ON_LOAD", %break_on_load);
1147                         my @hard;
1148                         for (0 .. $#had_breakpoints) {
1149                           my $file = $had_breakpoints[$_];
1150                           *dbline = $main::{'_<' . $file};
1151                           next unless %dbline or $postponed_file{$file};
1152                           (push @hard, $file), next 
1153                             if $file =~ /^\(eval \d+\)$/;
1154                           my @add;
1155                           @add = %{$postponed_file{$file}}
1156                             if $postponed_file{$file};
1157                           set_list("PERLDB_FILE_$_", %dbline, @add);
1158                         }
1159                         for (@hard) { # Yes, really-really...
1160                           # Find the subroutines in this eval
1161                           *dbline = $main::{'_<' . $_};
1162                           my ($quoted, $sub, %subs, $line) = quotemeta $_;
1163                           for $sub (keys %sub) {
1164                             next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1165                             $subs{$sub} = [$1, $2];
1166                           }
1167                           unless (%subs) {
1168                             print $OUT
1169                               "No subroutines in $_, ignoring breakpoints.\n";
1170                             next;
1171                           }
1172                         LINES: for $line (keys %dbline) {
1173                             # One breakpoint per sub only:
1174                             my ($offset, $sub, $found);
1175                           SUBS: for $sub (keys %subs) {
1176                               if ($subs{$sub}->[1] >= $line # Not after the subroutine
1177                                   and (not defined $offset # Not caught
1178                                        or $offset < 0 )) { # or badly caught
1179                                 $found = $sub;
1180                                 $offset = $line - $subs{$sub}->[0];
1181                                 $offset = "+$offset", last SUBS if $offset >= 0;
1182                               }
1183                             }
1184                             if (defined $offset) {
1185                               $postponed{$found} =
1186                                 "break $offset if $dbline{$line}";
1187                             } else {
1188                               print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1189                             }
1190                           }
1191                         }
1192                         set_list("PERLDB_POSTPONE", %postponed);
1193                         set_list("PERLDB_PRETYPE", @$pretype);
1194                         set_list("PERLDB_PRE", @$pre);
1195                         set_list("PERLDB_POST", @$post);
1196                         set_list("PERLDB_TYPEAHEAD", @typeahead);
1197                         $ENV{PERLDB_RESTART} = 1;
1198                         #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1199                         exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS;
1200                         print $OUT "exec failed: $!\n";
1201                         last CMD; };
1202                     $cmd =~ /^T$/ && do {
1203                         print_trace($OUT, 1); # skip DB
1204                         next CMD; };
1205                     $cmd =~ /^W\s*$/ && do {
1206                         $trace &= ~2;
1207                         @to_watch = @old_watch = ();
1208                         next CMD; };
1209                     $cmd =~ /^W\b\s*(.*)/s && do {
1210                         push @to_watch, $1;
1211                         $evalarg = $1;
1212                         my ($val) = &eval;
1213                         $val = (defined $val) ? "'$val'" : 'undef' ;
1214                         push @old_watch, $val;
1215                         $trace |= 2;
1216                         next CMD; };
1217                     $cmd =~ /^\/(.*)$/ && do {
1218                         $inpat = $1;
1219                         $inpat =~ s:([^\\])/$:$1:;
1220                         if ($inpat ne "") {
1221                             # squelch the sigmangler
1222                             local $SIG{__DIE__};
1223                             local $SIG{__WARN__};
1224                             eval '$inpat =~ m'."\a$inpat\a";    
1225                             if ($@ ne "") {
1226                                 print $OUT "$@";
1227                                 next CMD;
1228                             }
1229                             $pat = $inpat;
1230                         }
1231                         $end = $start;
1232                         $incr = -1;
1233                         eval '
1234                             for (;;) {
1235                                 ++$start;
1236                                 $start = 1 if ($start > $max);
1237                                 last if ($start == $end);
1238                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1239                                     if ($slave_editor) {
1240                                         print $OUT "\032\032$filename:$start:0\n";
1241                                     } else {
1242                                         print $OUT "$start:\t", $dbline[$start], "\n";
1243                                     }
1244                                     last;
1245                                 }
1246                             } ';
1247                         print $OUT "/$pat/: not found\n" if ($start == $end);
1248                         next CMD; };
1249                     $cmd =~ /^\?(.*)$/ && do {
1250                         $inpat = $1;
1251                         $inpat =~ s:([^\\])\?$:$1:;
1252                         if ($inpat ne "") {
1253                             # squelch the sigmangler
1254                             local $SIG{__DIE__};
1255                             local $SIG{__WARN__};
1256                             eval '$inpat =~ m'."\a$inpat\a";    
1257                             if ($@ ne "") {
1258                                 print $OUT $@;
1259                                 next CMD;
1260                             }
1261                             $pat = $inpat;
1262                         }
1263                         $end = $start;
1264                         $incr = -1;
1265                         eval '
1266                             for (;;) {
1267                                 --$start;
1268                                 $start = $max if ($start <= 0);
1269                                 last if ($start == $end);
1270                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1271                                     if ($slave_editor) {
1272                                         print $OUT "\032\032$filename:$start:0\n";
1273                                     } else {
1274                                         print $OUT "$start:\t", $dbline[$start], "\n";
1275                                     }
1276                                     last;
1277                                 }
1278                             } ';
1279                         print $OUT "?$pat?: not found\n" if ($start == $end);
1280                         next CMD; };
1281                     $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1282                         pop(@hist) if length($cmd) > 1;
1283                         $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1284                         $cmd = $hist[$i];
1285                         print $OUT $cmd, "\n";
1286                         redo CMD; };
1287                     $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1288                         &system($1);
1289                         next CMD; };
1290                     $cmd =~ /^$rc([^$rc].*)$/ && do {
1291                         $pat = "^$1";
1292                         pop(@hist) if length($cmd) > 1;
1293                         for ($i = $#hist; $i; --$i) {
1294                             last if $hist[$i] =~ /$pat/;
1295                         }
1296                         if (!$i) {
1297                             print $OUT "No such command!\n\n";
1298                             next CMD;
1299                         }
1300                         $cmd = $hist[$i];
1301                         print $OUT $cmd, "\n";
1302                         redo CMD; };
1303                     $cmd =~ /^$sh$/ && do {
1304                         &system($ENV{SHELL}||"/bin/sh");
1305                         next CMD; };
1306                     $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1307                         # XXX: using csh or tcsh destroys sigint retvals!
1308                         #&system($1);  # use this instead
1309                         &system($ENV{SHELL}||"/bin/sh","-c",$1);
1310                         next CMD; };
1311                     $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1312                         $end = $2 ? ($#hist-$2) : 0;
1313                         $hist = 0 if $hist < 0;
1314                         for ($i=$#hist; $i>$end; $i--) {
1315                             print $OUT "$i: ",$hist[$i],"\n"
1316                               unless $hist[$i] =~ /^.?$/;
1317                         };
1318                         next CMD; };
1319                     $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1320                         runman($1);
1321                         next CMD; };
1322                     $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1323                     $cmd =~ s/^p\b/print {\$DB::OUT} /;
1324                     $cmd =~ s/^=\s*// && do {
1325                         my @keys;
1326                         if (length $cmd == 0) {
1327                             @keys = sort keys %alias;
1328                         } 
1329                         elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1330                             # can't use $_ or kill //g state
1331                             for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1332                             $alias{$k} = "s\a$k\a$v\a";
1333                             # squelch the sigmangler
1334                             local $SIG{__DIE__};
1335                             local $SIG{__WARN__};
1336                             unless (eval "sub { s\a$k\a$v\a }; 1") {
1337                                 print $OUT "Can't alias $k to $v: $@\n"; 
1338                                 delete $alias{$k};
1339                                 next CMD;
1340                             } 
1341                             @keys = ($k);
1342                         } 
1343                         else {
1344                             @keys = ($cmd);
1345                         } 
1346                         for my $k (@keys) {
1347                             if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
1348                                 print $OUT "$k\t= $1\n";
1349                             } 
1350                             elsif (defined $alias{$k}) {
1351                                     print $OUT "$k\t$alias{$k}\n";
1352                             } 
1353                             else {
1354                                 print "No alias for $k\n";
1355                             } 
1356                         }
1357                         next CMD; };
1358                     $cmd =~ /^\|\|?\s*[^|]/ && do {
1359                         if ($pager =~ /^\|/) {
1360                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1361                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1362                         } else {
1363                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1364                         }
1365                         fix_less();
1366                         unless ($piped=open(OUT,$pager)) {
1367                             &warn("Can't pipe output to `$pager'");
1368                             if ($pager =~ /^\|/) {
1369                                 open(OUT,">&STDOUT") # XXX: lost message
1370                                     || &warn("Can't restore DB::OUT");
1371                                 open(STDOUT,">&SAVEOUT")
1372                                   || &warn("Can't restore STDOUT");
1373                                 close(SAVEOUT);
1374                             } else {
1375                                 open(OUT,">&STDOUT") # XXX: lost message
1376                                     || &warn("Can't restore DB::OUT");
1377                             }
1378                             next CMD;
1379                         }
1380                         $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1381                             && ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
1382                         $selected= select(OUT);
1383                         $|= 1;
1384                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1385                         $cmd =~ s/^\|+\s*//;
1386                         redo PIPE; 
1387                     };
1388                     # XXX Local variants do not work!
1389                     $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1390                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1391                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1392                 }               # PIPE:
1393             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1394             if ($onetimeDump) {
1395                 $onetimeDump = undef;
1396             } elsif ($term_pid == $$) {
1397                 print $OUT "\n";
1398             }
1399         } continue {            # CMD:
1400             if ($piped) {
1401                 if ($pager =~ /^\|/) {
1402                     $? = 0;  
1403                     # we cannot warn here: the handle is missing --tchrist
1404                     close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1405
1406                     # most of the $? crud was coping with broken cshisms
1407                     if ($?) {
1408                         print SAVEOUT "Pager `$pager' failed: ";
1409                         if ($? == -1) {
1410                             print SAVEOUT "shell returned -1\n";
1411                         } elsif ($? >> 8) {
1412                             print SAVEOUT 
1413                               ( $? & 127 ) ? " (SIG#".($?&127).")" : "", 
1414                               ( $? & 128 ) ? " -- core dumped" : "", "\n";
1415                         } else {
1416                             print SAVEOUT "status ", ($? >> 8), "\n";
1417                         } 
1418                     } 
1419
1420                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1421                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1422                     $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1423                     # Will stop ignoring SIGPIPE if done like nohup(1)
1424                     # does SIGINT but Perl doesn't give us a choice.
1425                 } else {
1426                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1427                 }
1428                 close(SAVEOUT);
1429                 select($selected), $selected= "" unless $selected eq "";
1430                 $piped= "";
1431             }
1432         }                       # CMD:
1433         $exiting = 1 unless defined $cmd;
1434         foreach $evalarg (@$post) {
1435           &eval;
1436         }
1437     }                           # if ($single || $signal)
1438     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1439     ();
1440 }
1441
1442 # The following code may be executed now:
1443 # BEGIN {warn 4}
1444
1445 sub sub {
1446     my ($al, $ret, @ret) = "";
1447     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1448         $al = " for $$sub";
1449     }
1450     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1451     $#stack = $stack_depth;
1452     $stack[-1] = $single;
1453     $single &= 1;
1454     $single |= 4 if $stack_depth == $deep;
1455     ($frame & 4 
1456      ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in  "), 
1457          # Why -1? But it works! :-(
1458          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1459      : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1460     if (wantarray) {
1461         @ret = &$sub;
1462         $single |= $stack[$stack_depth--];
1463         ($frame & 4 
1464          ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 
1465              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1466          : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1467         if ($doret eq $stack_depth or $frame & 16) {
1468             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1469             print $fh ' ' x $stack_depth if $frame & 16;
1470             print $fh "list context return from $sub:\n"; 
1471             dumpit($fh, \@ret );
1472             $doret = -2;
1473         }
1474         @ret;
1475     } else {
1476         if (defined wantarray) {
1477             $ret = &$sub;
1478         } else {
1479             &$sub; undef $ret;
1480         };
1481         $single |= $stack[$stack_depth--];
1482         ($frame & 4 
1483          ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 
1484               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1485          : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1486         if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1487             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1488             print $fh (' ' x $stack_depth) if $frame & 16;
1489             print $fh (defined wantarray 
1490                          ? "scalar context return from $sub: " 
1491                          : "void context return from $sub\n");
1492             dumpit( $fh, $ret ) if defined wantarray;
1493             $doret = -2;
1494         }
1495         $ret;
1496     }
1497 }
1498
1499 sub save {
1500     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1501     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1502 }
1503
1504 # The following takes its argument via $evalarg to preserve current @_
1505
1506 sub eval {
1507     # 'my' would make it visible from user code
1508     #    but so does local! --tchrist  
1509     local @res;                 
1510     {
1511         local $otrace = $trace;
1512         local $osingle = $single;
1513         local $od = $^D;
1514         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1515         $trace = $otrace;
1516         $single = $osingle;
1517         $^D = $od;
1518     }
1519     my $at = $@;
1520     local $saved[0];            # Preserve the old value of $@
1521     eval { &DB::save };
1522     if ($at) {
1523         print $OUT $at;
1524     } elsif ($onetimeDump eq 'dump') {
1525         dumpit($OUT, \@res);
1526     } elsif ($onetimeDump eq 'methods') {
1527         methods($res[0]);
1528     }
1529     @res;
1530 }
1531
1532 sub postponed_sub {
1533   my $subname = shift;
1534   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1535     my $offset = $1 || 0;
1536     # Filename below can contain ':'
1537     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1538     if ($i) {
1539       $i += $offset;
1540       local *dbline = $main::{'_<' . $file};
1541       local $^W = 0;            # != 0 is magical below
1542       $had_breakpoints{$file} |= 1;
1543       my $max = $#dbline;
1544       ++$i until $dbline[$i] != 0 or $i >= $max;
1545       $dbline{$i} = delete $postponed{$subname};
1546     } else {
1547       print $OUT "Subroutine $subname not found.\n";
1548     }
1549     return;
1550   }
1551   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1552   #print $OUT "In postponed_sub for `$subname'.\n";
1553 }
1554
1555 sub postponed {
1556   if ($ImmediateStop) {
1557     $ImmediateStop = 0;
1558     $signal = 1;
1559   }
1560   return &postponed_sub
1561     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1562   # Cannot be done before the file is compiled
1563   local *dbline = shift;
1564   my $filename = $dbline;
1565   $filename =~ s/^_<//;
1566   $signal = 1, print $OUT "'$filename' loaded...\n"
1567     if $break_on_load{$filename};
1568   print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1569   return unless $postponed_file{$filename};
1570   $had_breakpoints{$filename} |= 1;
1571   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1572   my $key;
1573   for $key (keys %{$postponed_file{$filename}}) {
1574     $dbline{$key} = ${$postponed_file{$filename}}{$key};
1575   }
1576   delete $postponed_file{$filename};
1577 }
1578
1579 sub dumpit {
1580     local ($savout) = select(shift);
1581     my $osingle = $single;
1582     my $otrace = $trace;
1583     $single = $trace = 0;
1584     local $frame = 0;
1585     local $doret = -2;
1586     unless (defined &main::dumpValue) {
1587         do 'dumpvar.pl';
1588     }
1589     if (defined &main::dumpValue) {
1590         &main::dumpValue(shift);
1591     } else {
1592         print $OUT "dumpvar.pl not available.\n";
1593     }
1594     $single = $osingle;
1595     $trace = $otrace;
1596     select ($savout);    
1597 }
1598
1599 # Tied method do not create a context, so may get wrong message:
1600
1601 sub print_trace {
1602   my $fh = shift;
1603   my @sub = dump_trace($_[0] + 1, $_[1]);
1604   my $short = $_[2];            # Print short report, next one for sub name
1605   my $s;
1606   for ($i=0; $i <= $#sub; $i++) {
1607     last if $signal;
1608     local $" = ', ';
1609     my $args = defined $sub[$i]{args} 
1610     ? "(@{ $sub[$i]{args} })"
1611       : '' ;
1612     $args = (substr $args, 0, $maxtrace - 3) . '...' 
1613       if length $args > $maxtrace;
1614     my $file = $sub[$i]{file};
1615     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1616     $s = $sub[$i]{sub};
1617     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;    
1618     if ($short) {
1619       my $sub = @_ >= 4 ? $_[3] : $s;
1620       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1621     } else {
1622       print $fh "$sub[$i]{context} = $s$args" .
1623         " called from $file" . 
1624           " line $sub[$i]{line}\n";
1625     }
1626   }
1627 }
1628
1629 sub dump_trace {
1630   my $skip = shift;
1631   my $count = shift || 1e9;
1632   $skip++;
1633   $count += $skip;
1634   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1635   my $nothard = not $frame & 8;
1636   local $frame = 0;             # Do not want to trace this.
1637   my $otrace = $trace;
1638   $trace = 0;
1639   for ($i = $skip; 
1640        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); 
1641        $i++) {
1642     @a = ();
1643     for $arg (@args) {
1644       my $type;
1645       if (not defined $arg) {
1646         push @a, "undef";
1647       } elsif ($nothard and tied $arg) {
1648         push @a, "tied";
1649       } elsif ($nothard and $type = ref $arg) {
1650         push @a, "ref($type)";
1651       } else {
1652         local $_ = "$arg";      # Safe to stringify now - should not call f().
1653         s/([\'\\])/\\$1/g;
1654         s/(.*)/'$1'/s
1655           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1656         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1657         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1658         push(@a, $_);
1659       }
1660     }
1661     $context = $context ? '@' : (defined $context ? "\$" : '.');
1662     $args = $h ? [@a] : undef;
1663     $e =~ s/\n\s*\;\s*\Z// if $e;
1664     $e =~ s/([\\\'])/\\$1/g if $e;
1665     if ($r) {
1666       $sub = "require '$e'";
1667     } elsif (defined $r) {
1668       $sub = "eval '$e'";
1669     } elsif ($sub eq '(eval)') {
1670       $sub = "eval {...}";
1671     }
1672     push(@sub, {context => $context, sub => $sub, args => $args,
1673                 file => $file, line => $line});
1674     last if $signal;
1675   }
1676   $trace = $otrace;
1677   @sub;
1678 }
1679
1680 sub action {
1681     my $action = shift;
1682     while ($action =~ s/\\$//) {
1683         #print $OUT "+ ";
1684         #$action .= "\n";
1685         $action .= &gets;
1686     }
1687     $action;
1688 }
1689
1690 sub unbalanced { 
1691     # i hate using globals!
1692     $balanced_brace_re ||= qr{ 
1693         ^ \{
1694               (?:
1695                  (?> [^{}] + )              # Non-parens without backtracking
1696                |
1697                  (??{ $balanced_brace_re }) # Group with matching parens
1698               ) *
1699           \} $
1700    }x;
1701    return $_[0] !~ m/$balanced_brace_re/;
1702 }
1703
1704 sub gets {
1705     &readline("cont: ");
1706 }
1707
1708 sub system {
1709     # We save, change, then restore STDIN and STDOUT to avoid fork() since
1710     # some non-Unix systems can do system() but have problems with fork().
1711     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1712     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1713     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1714     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1715
1716     # XXX: using csh or tcsh destroys sigint retvals!
1717     system(@_);
1718     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1719     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1720     close(SAVEIN); 
1721     close(SAVEOUT);
1722
1723
1724     # most of the $? crud was coping with broken cshisms
1725     if ($? >> 8) {
1726         &warn("(Command exited ", ($? >> 8), ")\n");
1727     } elsif ($?) { 
1728         &warn( "(Command died of SIG#",  ($? & 127),
1729             (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1730     } 
1731
1732     return $?;
1733
1734 }
1735
1736 sub setterm {
1737     local $frame = 0;
1738     local $doret = -2;
1739     eval { require Term::ReadLine } or die $@;
1740     if ($notty) {
1741         if ($tty) {
1742             open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1743             open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1744             $IN = \*IN;
1745             $OUT = \*OUT;
1746             my $sel = select($OUT);
1747             $| = 1;
1748             select($sel);
1749         } else {
1750             eval "require Term::Rendezvous;" or die;
1751             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1752             my $term_rv = new Term::Rendezvous $rv;
1753             $IN = $term_rv->IN;
1754             $OUT = $term_rv->OUT;
1755         }
1756     }
1757     if (!$rl) {
1758         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1759     } else {
1760         $term = new Term::ReadLine 'perldb', $IN, $OUT;
1761
1762         $rl_attribs = $term->Attribs;
1763         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' 
1764           if defined $rl_attribs->{basic_word_break_characters} 
1765             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1766         $rl_attribs->{special_prefixes} = '$@&%';
1767         $rl_attribs->{completer_word_break_characters} .= '$@&%';
1768         $rl_attribs->{completion_function} = \&db_complete; 
1769     }
1770     $LINEINFO = $OUT unless defined $LINEINFO;
1771     $lineinfo = $console unless defined $lineinfo;
1772     $term->MinLine(2);
1773     if ($term->Features->{setHistory} and "@hist" ne "?") {
1774       $term->SetHistory(@hist);
1775     }
1776     ornaments($ornaments) if defined $ornaments;
1777     $term_pid = $$;
1778 }
1779
1780 sub resetterm {                 # We forked, so we need a different TTY
1781     $term_pid = $$;
1782     if (defined &get_fork_TTY) {
1783       &get_fork_TTY;
1784     } elsif (not defined $fork_TTY 
1785              and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' 
1786              and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { 
1787         # Possibly _inside_ XTERM
1788         open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1789  sleep 10000000' |];
1790         $fork_TTY = <XT>;
1791         chomp $fork_TTY;
1792     }
1793     if (defined $fork_TTY) {
1794       TTY($fork_TTY);
1795       undef $fork_TTY;
1796     } else {
1797       print_help(<<EOP);
1798 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1799   Define B<\$DB::fork_TTY> 
1800        - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1801   The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1802   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1803   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1804 EOP
1805     }
1806 }
1807
1808 sub readline {
1809   local $.;
1810   if (@typeahead) {
1811     my $left = @typeahead;
1812     my $got = shift @typeahead;
1813     print $OUT "auto(-$left)", shift, $got, "\n";
1814     $term->AddHistory($got) 
1815       if length($got) > 1 and defined $term->Features->{addHistory};
1816     return $got;
1817   }
1818   local $frame = 0;
1819   local $doret = -2;
1820   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1821     $OUT->write(join('', @_));
1822     my $stuff;
1823     $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
1824     $stuff;
1825   }
1826   else {
1827     $term->readline(@_);
1828   }
1829 }
1830
1831 sub dump_option {
1832     my ($opt, $val)= @_;
1833     $val = option_val($opt,'N/A');
1834     $val =~ s/([\\\'])/\\$1/g;
1835     printf $OUT "%20s = '%s'\n", $opt, $val;
1836 }
1837
1838 sub option_val {
1839     my ($opt, $default)= @_;
1840     my $val;
1841     if (defined $optionVars{$opt}
1842         and defined ${$optionVars{$opt}}) {
1843         $val = ${$optionVars{$opt}};
1844     } elsif (defined $optionAction{$opt}
1845         and defined &{$optionAction{$opt}}) {
1846         $val = &{$optionAction{$opt}}();
1847     } elsif (defined $optionAction{$opt}
1848              and not defined $option{$opt}
1849              or defined $optionVars{$opt}
1850              and not defined ${$optionVars{$opt}}) {
1851         $val = $default;
1852     } else {
1853         $val = $option{$opt};
1854     }
1855     $val
1856 }
1857
1858 sub parse_options {
1859     local($_)= @_;
1860     # too dangerous to let intuitive usage overwrite important things
1861     # defaultion should never be the default
1862     my %opt_needs_val = map { ( $_ => 1 ) } qw{
1863         arrayDepth hashDepth LineInfo maxTraceLen ornaments
1864         pager quote ReadLine recallCommand RemotePort ShellBang TTY
1865     };
1866     while (length) {
1867         my $val_defaulted;
1868         s/^\s+// && next;
1869         s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
1870         my ($opt,$sep) = ($1,$2);
1871         my $val;
1872         if ("?" eq $sep) {
1873             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1874               if /^\S/;
1875             #&dump_option($opt);
1876         } elsif ($sep !~ /\S/) {
1877             $val_defaulted = 1;
1878             $val = "1";  #  this is an evil default; make 'em set it!
1879         } elsif ($sep eq "=") {
1880
1881             if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { 
1882                 my $quote = $1;
1883                 ($val = $2) =~ s/\\([$quote\\])/$1/g;
1884             } else { 
1885                 s/^(\S*)//;
1886             $val = $1;
1887                 print OUT qq(Option better cleared using $opt=""\n)
1888                     unless length $val;
1889             }
1890
1891         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1892             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1893             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1894               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1895             ($val = $1) =~ s/\\([\\$end])/$1/g;
1896         }
1897
1898         my $option;
1899         my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
1900                    || grep( /^\Q$opt/i && ($option = $_),  @options  );
1901
1902         print($OUT "Unknown option `$opt'\n"), next     unless $matches;
1903         print($OUT "Ambiguous option `$opt'\n"), next   if $matches > 1;
1904
1905        if ($opt_needs_val{$option} && $val_defaulted) {
1906             print $OUT "Option `$opt' is non-boolean.  Use `O $option=VAL' to set, `O $option?' to query\n";
1907             next;
1908         } 
1909
1910         $option{$option} = $val if defined $val;
1911
1912         eval qq{
1913                 local \$frame = 0; 
1914                 local \$doret = -2; 
1915                 require '$optionRequire{$option}';
1916                 1;
1917          } || die  # XXX: shouldn't happen
1918             if  defined $optionRequire{$option}     &&
1919                 defined $val;
1920
1921         ${$optionVars{$option}} = $val      
1922             if  defined $optionVars{$option}        &&
1923                 defined $val;
1924
1925         &{$optionAction{$option}} ($val)    
1926             if defined $optionAction{$option}       &&
1927                defined &{$optionAction{$option}}    &&
1928                defined $val;
1929
1930         # Not $rcfile
1931         dump_option($option)    unless $OUT eq \*STDERR; 
1932     }
1933 }
1934
1935 sub set_list {
1936   my ($stem,@list) = @_;
1937   my $val;
1938   $ENV{"${stem}_n"} = @list;
1939   for $i (0 .. $#list) {
1940     $val = $list[$i];
1941     $val =~ s/\\/\\\\/g;
1942     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1943     $ENV{"${stem}_$i"} = $val;
1944   }
1945 }
1946
1947 sub get_list {
1948   my $stem = shift;
1949   my @list;
1950   my $n = delete $ENV{"${stem}_n"};
1951   my $val;
1952   for $i (0 .. $n - 1) {
1953     $val = delete $ENV{"${stem}_$i"};
1954     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1955     push @list, $val;
1956   }
1957   @list;
1958 }
1959
1960 sub catch {
1961     $signal = 1;
1962     return;                     # Put nothing on the stack - malloc/free land!
1963 }
1964
1965 sub warn {
1966     my($msg)= join("",@_);
1967     $msg .= ": $!\n" unless $msg =~ /\n$/;
1968     print $OUT $msg;
1969 }
1970
1971 sub TTY {
1972     if (@_ and $term and $term->Features->{newTTY}) {
1973       my ($in, $out) = shift;
1974       if ($in =~ /,/) {
1975         ($in, $out) = split /,/, $in, 2;
1976       } else {
1977         $out = $in;
1978       }
1979       open IN, $in or die "cannot open `$in' for read: $!";
1980       open OUT, ">$out" or die "cannot open `$out' for write: $!";
1981       $term->newTTY(\*IN, \*OUT);
1982       $IN       = \*IN;
1983       $OUT      = \*OUT;
1984       return $tty = $in;
1985     } elsif ($term and @_) {
1986         &warn("Too late to set TTY, enabled on next `R'!\n");
1987     } 
1988     $tty = shift if @_;
1989     $tty or $console;
1990 }
1991
1992 sub noTTY {
1993     if ($term) {
1994         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1995     }
1996     $notty = shift if @_;
1997     $notty;
1998 }
1999
2000 sub ReadLine {
2001     if ($term) {
2002         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2003     }
2004     $rl = shift if @_;
2005     $rl;
2006 }
2007
2008 sub RemotePort {
2009     if ($term) {
2010         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2011     }
2012     $remoteport = shift if @_;
2013     $remoteport;
2014 }
2015
2016 sub tkRunning {
2017     if (${$term->Features}{tkRunning}) {
2018         return $term->tkRunning(@_);
2019     } else {
2020         print $OUT "tkRunning not supported by current ReadLine package.\n";
2021         0;
2022     }
2023 }
2024
2025 sub NonStop {
2026     if ($term) {
2027         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2028     }
2029     $runnonstop = shift if @_;
2030     $runnonstop;
2031 }
2032
2033 sub pager {
2034     if (@_) {
2035         $pager = shift;
2036         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2037     }
2038     $pager;
2039 }
2040
2041 sub shellBang {
2042     if (@_) {
2043         $sh = quotemeta shift;
2044         $sh .= "\\b" if $sh =~ /\w$/;
2045     }
2046     $psh = $sh;
2047     $psh =~ s/\\b$//;
2048     $psh =~ s/\\(.)/$1/g;
2049     &sethelp;
2050     $psh;
2051 }
2052
2053 sub ornaments {
2054   if (defined $term) {
2055     local ($warnLevel,$dieLevel) = (0, 1);
2056     return '' unless $term->Features->{ornaments};
2057     eval { $term->ornaments(@_) } || '';
2058   } else {
2059     $ornaments = shift;
2060   }
2061 }
2062
2063 sub recallCommand {
2064     if (@_) {
2065         $rc = quotemeta shift;
2066         $rc .= "\\b" if $rc =~ /\w$/;
2067     }
2068     $prc = $rc;
2069     $prc =~ s/\\b$//;
2070     $prc =~ s/\\(.)/$1/g;
2071     &sethelp;
2072     $prc;
2073 }
2074
2075 sub LineInfo {
2076     return $lineinfo unless @_;
2077     $lineinfo = shift;
2078     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2079     $slave_editor = ($stream =~ /^\|/);
2080     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2081     $LINEINFO = \*LINEINFO;
2082     my $save = select($LINEINFO);
2083     $| = 1;
2084     select($save);
2085     $lineinfo;
2086 }
2087
2088 sub list_versions {
2089   my %version;
2090   my $file;
2091   for (keys %INC) {
2092     $file = $_;
2093     s,\.p[lm]$,,i ;
2094     s,/,::,g ;
2095     s/^perl5db$/DB/;
2096     s/^Term::ReadLine::readline$/readline/;
2097     if (defined ${ $_ . '::VERSION' }) {
2098       $version{$file} = "${ $_ . '::VERSION' } from ";
2099     } 
2100     $version{$file} .= $INC{$file};
2101   }
2102   dumpit($OUT,\%version);
2103 }
2104
2105 sub sethelp {
2106     # XXX: make sure these are tabs between the command and explantion,
2107     #      or print_help will screw up your formatting if you have
2108     #      eeevil ornaments enabled.  This is an insane mess.
2109
2110     $help = "
2111 B<T>            Stack trace.
2112 B<s> [I<expr>]  Single step [in I<expr>].
2113 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
2114 <B<CR>>         Repeat last B<n> or B<s> command.
2115 B<r>            Return from current subroutine.
2116 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
2117                 at the specified position.
2118 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
2119 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
2120 B<l> I<line>            List single I<line>.
2121 B<l> I<subname> List first window of lines from subroutine.
2122 B<l> I<\$var>           List first window of lines from subroutine referenced by I<\$var>.
2123 B<l>            List next window of lines.
2124 B<->            List previous window of lines.
2125 B<w> [I<line>]  List window around I<line>.
2126 B<.>            Return to the executed line.
2127 B<f> I<filename>        Switch to viewing I<filename>. File must be already loaded.
2128                 I<filename> may be either the full name of the file, or a regular
2129                 expression matching the full file name:
2130                 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2131                 Evals (with saved bodies) are considered to be filenames:
2132                 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2133                 (in the order of execution).
2134 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
2135 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
2136 B<L>            List all breakpoints and actions.
2137 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2138 B<t>            Toggle trace mode.
2139 B<t> I<expr>            Trace through execution of I<expr>.
2140 B<b> [I<line>] [I<condition>]
2141                 Set breakpoint; I<line> defaults to the current execution line;
2142                 I<condition> breaks if it evaluates to true, defaults to '1'.
2143 B<b> I<subname> [I<condition>]
2144                 Set breakpoint at first line of subroutine.
2145 B<b> I<\$var>           Set breakpoint at first line of subroutine referenced by I<\$var>.
2146 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2147 B<b> B<postpone> I<subname> [I<condition>]
2148                 Set breakpoint at first line of subroutine after 
2149                 it is compiled.
2150 B<b> B<compile> I<subname>
2151                 Stop after the subroutine is compiled.
2152 B<d> [I<line>]  Delete the breakpoint for I<line>.
2153 B<D>            Delete all breakpoints.
2154 B<a> [I<line>] I<command>
2155                 Set an action to be done before the I<line> is executed;
2156                 I<line> defaults to the current execution line.
2157                 Sequence is: check for breakpoint/watchpoint, print line
2158                 if necessary, do action, prompt user if necessary,
2159                 execute line.
2160 B<a> [I<line>]  Delete the action for I<line>.
2161 B<A>            Delete all actions.
2162 B<W> I<expr>            Add a global watch-expression.
2163 B<W>            Delete all watch-expressions.
2164 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2165                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2166 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
2167 B<x> I<expr>            Evals expression in list context, dumps the result.
2168 B<m> I<expr>            Evals expression in list context, prints methods callable
2169                 on the first element of the result.
2170 B<m> I<class>           Prints methods callable via the given class.
2171
2172 B<<> ?                  List Perl commands to run before each prompt.
2173 B<<> I<expr>            Define Perl command to run before each prompt.
2174 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
2175 B<>> ?                  List Perl commands to run after each prompt.
2176 B<>> I<expr>            Define Perl command to run after each prompt.
2177 B<>>B<>> I<expr>                Add to the list of Perl commands to run after each prompt.
2178 B<{> I<db_command>      Define debugger command to run before each prompt.
2179 B<{> ?                  List debugger commands to run before each prompt.
2180 B<<> I<expr>            Define Perl command to run before each prompt.
2181 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
2182 B<$prc> I<number>       Redo a previous command (default previous command).
2183 B<$prc> I<-number>      Redo number'th-to-last command.
2184 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
2185                 See 'B<O> I<recallCommand>' too.
2186 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2187   . ( $rc eq $sh ? "" : "
2188 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2189                 See 'B<O> I<shellBang>' too.
2190 B<H> I<-number> Display last number commands (default all).
2191 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
2192 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
2193 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2194 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
2195 I<command>              Execute as a perl statement in current package.
2196 B<v>            Show versions of loaded modules.
2197 B<R>            Pure-man-restart of debugger, some of debugger state
2198                 and command-line options may be lost.
2199                 Currently the following setting are preserved: 
2200                 history, breakpoints and actions, debugger B<O>ptions 
2201                 and the following command-line options: I<-w>, I<-I>, I<-e>.
2202
2203 B<O> [I<opt>] ...       Set boolean option to true
2204 B<O> [I<opt>B<?>]       Query options
2205 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... 
2206                 Set options.  Use quotes in spaces in value.
2207     I<recallCommand>, I<ShellBang>      chars used to recall command or spawn shell;
2208     I<pager>                    program for output of \"|cmd\";
2209     I<tkRunning>                        run Tk while prompting (with ReadLine);
2210     I<signalLevel> I<warnLevel> I<dieLevel>     level of verbosity;
2211     I<inhibit_exit>             Allows stepping off the end of the script.
2212     I<ImmediateStop>            Debugger should stop as early as possible.
2213     I<RemotePort>                       Remote hostname:port for remote debugging
2214   The following options affect what happens with B<V>, B<X>, and B<x> commands:
2215     I<arrayDepth>, I<hashDepth>         print only first N elements ('' for all);
2216     I<compactDump>, I<veryCompact>      change style of array and hash dump;
2217     I<globPrint>                        whether to print contents of globs;
2218     I<DumpDBFiles>              dump arrays holding debugged files;
2219     I<DumpPackages>             dump symbol tables of packages;
2220     I<DumpReused>                       dump contents of \"reused\" addresses;
2221     I<quote>, I<HighBit>, I<undefPrint>         change style of string dump;
2222     I<bareStringify>            Do not print the overload-stringified value;
2223   Other options include:
2224     I<PrintRet>         affects printing of return value after B<r> command,
2225     I<frame>            affects printing messages on entry and exit from subroutines.
2226     I<AutoTrace>        affects printing messages on every possible breaking point.
2227     I<maxTraceLen>      gives maximal length of evals/args listed in stack trace.
2228     I<ornaments>        affects screen appearance of the command line.
2229         During startup options are initialized from \$ENV{PERLDB_OPTS}.
2230         You can put additional initialization options I<TTY>, I<noTTY>,
2231         I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2232         `B<R>' after you set them).
2233
2234 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
2235 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
2236 B<h h>          Summary of debugger commands.
2237 B<$doccmd> I<manpage>   Runs the external doc viewer B<$doccmd> command on the 
2238                 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2239                 Set B<\$DB::doccmd> to change viewer.
2240
2241 Type `|h' for a paged display if this was too hard to read.
2242
2243 "; # Fix balance of vi % matching: } }}
2244
2245     $summary = <<"END_SUM";
2246 I<List/search source lines:>               I<Control script execution:>
2247   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
2248   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
2249   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
2250   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
2251   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
2252   B<v>        Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
2253 I<Debugger controls:>                        B<L>           List break/watch/actions
2254   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
2255   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2256   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
2257   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
2258   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
2259   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
2260   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2261   B<q> or B<^D>     Quit                          B<R>        Attempt a restart
2262 I<Data Examination:>          B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2263   B<x>|B<m> I<expr>     Evals expr in list context, dumps the result or lists methods.
2264   B<p> I<expr>  Print expression (uses script's current package).
2265   B<S> [[B<!>]I<pat>]   List subroutine names [not] matching pattern
2266   B<V> [I<Pk> [I<Vars>]]        List Variables in Package.  Vars can be ~pattern or !pattern.
2267   B<X> [I<Vars>]        Same as \"B<V> I<current_package> [I<Vars>]\".
2268 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2269 END_SUM
2270                                 # ')}}; # Fix balance of vi % matching
2271 }
2272
2273 sub print_help {
2274     local $_ = shift;
2275
2276     # Restore proper alignment destroyed by eeevil I<> and B<>
2277     # ornaments: A pox on both their houses!
2278     #
2279     # A help command will have everything up to and including
2280     # the first tab sequence paddeed into a field 16 (or if indented 20)
2281     # wide.  If it's wide than that, an extra space will be added.
2282     s{
2283         ^                       # only matters at start of line
2284           ( \040{4} | \t )*     # some subcommands are indented
2285           ( < ?                 # so <CR> works
2286             [BI] < [^\t\n] + )  # find an eeevil ornament
2287           ( \t+ )               # original separation, discarded
2288           ( .* )                # this will now start (no earlier) than 
2289                                 # column 16
2290     } {
2291         my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2292         my $clean = $command;
2293         $clean =~ s/[BI]<([^>]*)>/$1/g;  
2294     # replace with this whole string:
2295         (length($leadwhite) ? " " x 4 : "")
2296       . $command
2297       . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ")
2298       . $text;
2299
2300     }mgex;
2301
2302     s{                          # handle bold ornaments
2303         B < ( [^>] + | > ) >
2304     } {
2305           $Term::ReadLine::TermCap::rl_term_set[2] 
2306         . $1
2307         . $Term::ReadLine::TermCap::rl_term_set[3]
2308     }gex;
2309
2310     s{                          # handle italic ornaments
2311         I < ( [^>] + | > ) >
2312     } {
2313           $Term::ReadLine::TermCap::rl_term_set[0] 
2314         . $1
2315         . $Term::ReadLine::TermCap::rl_term_set[1]
2316     }gex;
2317
2318     print $OUT $_;
2319 }
2320
2321 sub fix_less {
2322     return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2323     my $is_less = $pager =~ /\bless\b/;
2324     if ($pager =~ /\bmore\b/) { 
2325         my @st_more = stat('/usr/bin/more');
2326         my @st_less = stat('/usr/bin/less');
2327         $is_less = @st_more    && @st_less 
2328                 && $st_more[0] == $st_less[0] 
2329                 && $st_more[1] == $st_less[1];
2330     }
2331     # changes environment!
2332     $ENV{LESS} .= 'r'   if $is_less;
2333 }
2334
2335 sub diesignal {
2336     local $frame = 0;
2337     local $doret = -2;
2338     $SIG{'ABRT'} = 'DEFAULT';
2339     kill 'ABRT', $$ if $panic++;
2340     if (defined &Carp::longmess) {
2341         local $SIG{__WARN__} = '';
2342         local $Carp::CarpLevel = 2;             # mydie + confess
2343         &warn(Carp::longmess("Signal @_"));
2344     }
2345     else {
2346         print $DB::OUT "Got signal @_\n";
2347     }
2348     kill 'ABRT', $$;
2349 }
2350
2351 sub dbwarn { 
2352   local $frame = 0;
2353   local $doret = -2;
2354   local $SIG{__WARN__} = '';
2355   local $SIG{__DIE__} = '';
2356   eval { require Carp } if defined $^S; # If error/warning during compilation,
2357                                         # require may be broken.
2358   warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2359     return unless defined &Carp::longmess;
2360   my ($mysingle,$mytrace) = ($single,$trace);
2361   $single = 0; $trace = 0;
2362   my $mess = Carp::longmess(@_);
2363   ($single,$trace) = ($mysingle,$mytrace);
2364   &warn($mess); 
2365 }
2366
2367 sub dbdie {
2368   local $frame = 0;
2369   local $doret = -2;
2370   local $SIG{__DIE__} = '';
2371   local $SIG{__WARN__} = '';
2372   my $i = 0; my $ineval = 0; my $sub;
2373   if ($dieLevel > 2) {
2374       local $SIG{__WARN__} = \&dbwarn;
2375       &warn(@_);                # Yell no matter what
2376       return;
2377   }
2378   if ($dieLevel < 2) {
2379     die @_ if $^S;              # in eval propagate
2380   }
2381   eval { require Carp } if defined $^S; # If error/warning during compilation,
2382                                         # require may be broken.
2383
2384   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2385     unless defined &Carp::longmess;
2386
2387   # We do not want to debug this chunk (automatic disabling works
2388   # inside DB::DB, but not in Carp).
2389   my ($mysingle,$mytrace) = ($single,$trace);
2390   $single = 0; $trace = 0;
2391   my $mess = Carp::longmess(@_);
2392   ($single,$trace) = ($mysingle,$mytrace);
2393   die $mess;
2394 }
2395
2396 sub warnLevel {
2397   if (@_) {
2398     $prevwarn = $SIG{__WARN__} unless $warnLevel;
2399     $warnLevel = shift;
2400     if ($warnLevel) {
2401       $SIG{__WARN__} = \&DB::dbwarn;
2402     } else {
2403       $SIG{__WARN__} = $prevwarn;
2404     }
2405   }
2406   $warnLevel;
2407 }
2408
2409 sub dieLevel {
2410   if (@_) {
2411     $prevdie = $SIG{__DIE__} unless $dieLevel;
2412     $dieLevel = shift;
2413     if ($dieLevel) {
2414       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2415       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2416       print $OUT "Stack dump during die enabled", 
2417         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2418           if $I_m_init;
2419       print $OUT "Dump printed too.\n" if $dieLevel > 2;
2420     } else {
2421       $SIG{__DIE__} = $prevdie;
2422       print $OUT "Default die handler restored.\n";
2423     }
2424   }
2425   $dieLevel;
2426 }
2427
2428 sub signalLevel {
2429   if (@_) {
2430     $prevsegv = $SIG{SEGV} unless $signalLevel;
2431     $prevbus = $SIG{BUS} unless $signalLevel;
2432     $signalLevel = shift;
2433     if ($signalLevel) {
2434       $SIG{SEGV} = \&DB::diesignal;
2435       $SIG{BUS} = \&DB::diesignal;
2436     } else {
2437       $SIG{SEGV} = $prevsegv;
2438       $SIG{BUS} = $prevbus;
2439     }
2440   }
2441   $signalLevel;
2442 }
2443
2444 sub CvGV_name {
2445   my $in = shift;
2446   my $name = CvGV_name_or_bust($in);
2447   defined $name ? $name : $in;
2448 }
2449
2450 sub CvGV_name_or_bust {
2451   my $in = shift;
2452   return if $skipCvGV;          # Backdoor to avoid problems if XS broken...
2453   $in = \&$in;                  # Hard reference...
2454   eval {require Devel::Peek; 1} or return;
2455   my $gv = Devel::Peek::CvGV($in) or return;
2456   *$gv{PACKAGE} . '::' . *$gv{NAME};
2457 }
2458
2459 sub find_sub {
2460   my $subr = shift;
2461   $sub{$subr} or do {
2462     return unless defined &$subr;
2463     my $name = CvGV_name_or_bust($subr);
2464     my $data;
2465     $data = $sub{$name} if defined $name;
2466     return $data if defined $data;
2467
2468     # Old stupid way...
2469     $subr = \&$subr;            # Hard reference
2470     my $s;
2471     for (keys %sub) {
2472       $s = $_, last if $subr eq \&$_;
2473     }
2474     $sub{$s} if $s;
2475   }
2476 }
2477
2478 sub methods {
2479   my $class = shift;
2480   $class = ref $class if ref $class;
2481   local %seen;
2482   local %packs;
2483   methods_via($class, '', 1);
2484   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2485 }
2486
2487 sub methods_via {
2488   my $class = shift;
2489   return if $packs{$class}++;
2490   my $prefix = shift;
2491   my $prepend = $prefix ? "via $prefix: " : '';
2492   my $name;
2493   for $name (grep {defined &{${"${class}::"}{$_}}} 
2494              sort keys %{"${class}::"}) {
2495     next if $seen{ $name }++;
2496     print $DB::OUT "$prepend$name\n";
2497   }
2498   return unless shift;          # Recurse?
2499   for $name (@{"${class}::ISA"}) {
2500     $prepend = $prefix ? $prefix . " -> $name" : $name;
2501     methods_via($name, $prepend, 1);
2502   }
2503 }
2504
2505 sub setman { 
2506     $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
2507                 ? "man"             # O Happy Day!
2508                 : "perldoc";        # Alas, poor unfortunates
2509 }
2510
2511 sub runman {
2512     my $page = shift;
2513     unless ($page) {
2514         &system("$doccmd $doccmd");
2515         return;
2516     } 
2517     # this way user can override, like with $doccmd="man -Mwhatever"
2518     # or even just "man " to disable the path check.
2519     unless ($doccmd eq 'man') {
2520         &system("$doccmd $page");
2521         return;
2522     } 
2523
2524     $page = 'perl' if lc($page) eq 'help';
2525
2526     require Config;
2527     my $man1dir = $Config::Config{'man1dir'};
2528     my $man3dir = $Config::Config{'man3dir'};
2529     for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ } 
2530     my $manpath = '';
2531     $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2532     $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2533     chop $manpath if $manpath;
2534     # harmless if missing, I figure
2535     my $oldpath = $ENV{MANPATH};
2536     $ENV{MANPATH} = $manpath if $manpath;
2537     my $nopathopt = $^O =~ /dunno what goes here/;
2538     if (system($doccmd, 
2539                 # I just *know* there are men without -M
2540                 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),  
2541             split ' ', $page) )
2542     {
2543         unless ($page =~ /^perl\w/) {
2544             if (grep { $page eq $_ } qw{ 
2545                 5004delta 5005delta amiga api apio book boot bot call compile
2546                 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2547                 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2548                 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2549                 modinstall modlib number obj op opentut os2 os390 pod port 
2550                 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2551                 trap unicode var vms win32 xs xstut
2552               }) 
2553             {
2554                 $page =~ s/^/perl/;
2555                 system($doccmd, 
2556                         (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),  
2557                         $page);
2558             }
2559         }
2560     } 
2561     if (defined $oldpath) {
2562         $ENV{MANPATH} = $manpath;
2563     } else {
2564         delete $ENV{MANPATH};
2565     } 
2566
2567
2568 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2569
2570 BEGIN {                 # This does not compile, alas.
2571   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
2572   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
2573   $sh = '!';
2574   $rc = ',';
2575   @hist = ('?');
2576   $deep = 100;                  # warning if stack gets this deep
2577   $window = 10;
2578   $preview = 3;
2579   $sub = '';
2580   $SIG{INT} = \&DB::catch;
2581   # This may be enabled to debug debugger:
2582   #$warnLevel = 1 unless defined $warnLevel;
2583   #$dieLevel = 1 unless defined $dieLevel;
2584   #$signalLevel = 1 unless defined $signalLevel;
2585
2586   $db_stop = 0;                 # Compiler warning
2587   $db_stop = 1 << 30;
2588   $level = 0;                   # Level of recursive debugging
2589   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2590   # Triggers bug (?) in perl is we postpone this until runtime:
2591   @postponed = @stack = (0);
2592   $stack_depth = 0;             # Localized $#stack
2593   $doret = -2;
2594   $frame = 0;
2595 }
2596
2597 BEGIN {$^W = $ini_warn;}        # Switch warnings back
2598
2599 #use Carp;                      # This did break, left for debuggin
2600
2601 sub db_complete {
2602   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2603   my($text, $line, $start) = @_;
2604   my ($itext, $search, $prefix, $pack) =
2605     ($text, "^\Q${'package'}::\E([^:]+)\$");
2606   
2607   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2608                                (map { /$search/ ? ($1) : () } keys %sub)
2609     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2610   return sort grep /^\Q$text/, values %INC # files
2611     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2612   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2613     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2614       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2615   return sort map {($_, db_complete($_ . "::", "V ", 2))}
2616     grep !/^main::/,
2617       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2618                                  # packages
2619         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ 
2620           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
2621   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2622     # We may want to complete to (eval 9), so $text may be wrong
2623     $prefix = length($1) - length($text);
2624     $text = $1;
2625     return sort 
2626         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2627   }
2628   if ((substr $text, 0, 1) eq '&') { # subroutines
2629     $text = substr $text, 1;
2630     $prefix = "&";
2631     return sort map "$prefix$_", 
2632                grep /^\Q$text/, 
2633                  (keys %sub),
2634                  (map { /$search/ ? ($1) : () } 
2635                     keys %sub);
2636   }
2637   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2638     $pack = ($1 eq 'main' ? '' : $1) . '::';
2639     $prefix = (substr $text, 0, 1) . $1 . '::';
2640     $text = $2;
2641     my @out 
2642       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2643     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2644       return db_complete($out[0], $line, $start);
2645     }
2646     return sort @out;
2647   }
2648   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2649     $pack = ($package eq 'main' ? '' : $package) . '::';
2650     $prefix = substr $text, 0, 1;
2651     $text = substr $text, 1;
2652     my @out = map "$prefix$_", grep /^\Q$text/, 
2653        (grep /^_?[a-zA-Z]/, keys %$pack), 
2654        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2655     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2656       return db_complete($out[0], $line, $start);
2657     }
2658     return sort @out;
2659   }
2660   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2661     my @out = grep /^\Q$text/, @options;
2662     my $val = option_val($out[0], undef);
2663     my $out = '? ';
2664     if (not defined $val or $val =~ /[\n\r]/) {
2665       # Can do nothing better
2666     } elsif ($val =~ /\s/) {
2667       my $found;
2668       foreach $l (split //, qq/\"\'\#\|/) {
2669         $out = "$l$val$l ", last if (index $val, $l) == -1;
2670       }
2671     } else {
2672       $out = "=$val ";
2673     }
2674     # Default to value if one completion, to question if many
2675     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2676     return sort @out;
2677   }
2678   return $term->filename_list($text); # filenames
2679 }
2680
2681 sub end_report {
2682   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
2683 }
2684
2685 END {
2686   $finished = $inhibit_exit;    # So that some keys may be disabled.
2687   # Do not stop in at_exit() and destructors on exit:
2688   $DB::single = !$exiting && !$runnonstop;
2689   DB::fake::at_exit() unless $exiting or $runnonstop;
2690 }
2691
2692 package DB::fake;
2693
2694 sub at_exit {
2695   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
2696 }
2697
2698 package DB;                     # Do not trace this 1; below!
2699
2700 1;