This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: dumpvar.pl bug
[perl5.git] / lib / perl5db.pl
1 package DB;
2
3 # Debugger for Perl 5.00x; perl5db.pl patch level:
4 $VERSION = 1.17;
5 $header  = "perl5db.pl version $VERSION";
6
7 # It is crucial that there is no lexicals in scope of `eval ""' down below
8 sub eval {
9     # 'my' would make it visible from user code
10     #    but so does local! --tchrist  [... into @DB::res, not @res. IZ]
11     local @res;
12     {
13         local $otrace = $trace;
14         local $osingle = $single;
15         local $od = $^D;
16         { ($evalarg) = $evalarg =~ /(.*)/s; }
17         @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
18         $trace = $otrace;
19         $single = $osingle;
20         $^D = $od;
21     }
22     my $at = $@;
23     local $saved[0];            # Preserve the old value of $@
24     eval { &DB::save };
25     if ($at) {
26         local $\ = '';
27         print $OUT $at;
28     } elsif ($onetimeDump) {
29       if ($onetimeDump eq 'dump')  {
30         local $option{dumpDepth} = $onetimedumpDepth 
31           if defined $onetimedumpDepth;
32         dumpit($OUT, \@res);
33       } elsif ($onetimeDump eq 'methods') {
34         methods($res[0]) ;
35       }
36     }
37     @res;
38 }
39
40 # After this point it is safe to introduce lexicals
41 # However, one should not overdo it: leave as much control from outside as possible
42 #
43 # This file is automatically included if you do perl -d.
44 # It's probably not useful to include this yourself.
45 #
46 # Before venturing further into these twisty passages, it is 
47 # wise to read the perldebguts man page or risk the ire of dragons.
48 #
49 # Perl supplies the values for %sub.  It effectively inserts
50 # a &DB::DB(); in front of every place that can have a
51 # breakpoint. Instead of a subroutine call it calls &DB::sub with
52 # $DB::sub being the called subroutine. It also inserts a BEGIN
53 # {require 'perl5db.pl'} before the first line.
54 #
55 # After each `require'd file is compiled, but before it is executed, a
56 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
57 # $filename is the expanded name of the `require'd file (as found as
58 # value of %INC).
59 #
60 # Additional services from Perl interpreter:
61 #
62 # if caller() is called from the package DB, it provides some
63 # additional data.
64 #
65 # The array @{$main::{'_<'.$filename}} (herein called @dbline) is the
66 # line-by-line contents of $filename.
67 #
68 # The hash %{'_<'.$filename} (herein called %dbline) contains
69 # breakpoints and action (it is keyed by line number), and individual
70 # entries are settable (as opposed to the whole hash). Only true/false
71 # is important to the interpreter, though the values used by
72 # perl5db.pl have the form "$break_condition\0$action". Values are
73 # magical in numeric context.
74 #
75 # The scalar ${'_<'.$filename} contains $filename.
76 #
77 # Note that no subroutine call is possible until &DB::sub is defined
78 # (for subroutines defined outside of the package DB). In fact the same is
79 # true if $deep is not defined.
80 #
81 # $Log: perldb.pl,v $
82
83 #
84 # At start reads $rcfile that may set important options.  This file
85 # may define a subroutine &afterinit that will be executed after the
86 # debugger is initialized.
87 #
88 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
89 # it as a rest of `O ...' line in debugger prompt.
90 #
91 # The options that can be specified only at startup:
92 # [To set in $rcfile, call &parse_options("optionName=new_value").]
93 #
94 # TTY  - the TTY to use for debugging i/o.
95 #
96 # noTTY - if set, goes in NonStop mode.  On interrupt if TTY is not set
97 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
98 # Term::Rendezvous.  Current variant is to have the name of TTY in this
99 # file.
100 #
101 # ReadLine - If false, dummy ReadLine is used, so you can debug
102 # ReadLine applications.
103 #
104 # NonStop - if true, no i/o is performed until interrupt.
105 #
106 # LineInfo - file or pipe to print line number info to.  If it is a
107 # pipe, a short "emacs like" message is used.
108 #
109 # RemotePort - host:port to connect to on remote host for remote debugging.
110 #
111 # Example $rcfile: (delete leading hashes!)
112 #
113 # &parse_options("NonStop=1 LineInfo=db.out");
114 # sub afterinit { $trace = 1; }
115 #
116 # The script will run without human intervention, putting trace
117 # information into db.out.  (If you interrupt it, you would better
118 # reset LineInfo to something "interactive"!)
119 #
120 ##################################################################
121
122 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
123
124 # modified Perl debugger, to be run from Emacs in perldb-mode
125 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
126 # Johan Vromans -- upgrade to 4.0 pl 10
127 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
128
129 # Changelog:
130
131 # A lot of things changed after 0.94. First of all, core now informs
132 # debugger about entry into XSUBs, overloaded operators, tied operations,
133 # BEGIN and END. Handy with `O f=2'.
134
135 # This can make debugger a little bit too verbose, please be patient
136 # and report your problems promptly.
137
138 # Now the option frame has 3 values: 0,1,2.
139
140 # Note that if DESTROY returns a reference to the object (or object),
141 # the deletion of data may be postponed until the next function call,
142 # due to the need to examine the return value.
143
144 # Changes: 0.95: `v' command shows versions.
145 # Changes: 0.96: `v' command shows version of readline.
146 #       primitive completion works (dynamic variables, subs for `b' and `l',
147 #               options). Can `p %var'
148 #       Better help (`h <' now works). New commands <<, >>, {, {{.
149 #       {dump|print}_trace() coded (to be able to do it from <<cmd).
150 #       `c sub' documented.
151 #       At last enough magic combined to stop after the end of debuggee.
152 #       !! should work now (thanks to Emacs bracket matching an extra
153 #       `]' in a regexp is caught).
154 #       `L', `D' and `A' span files now (as documented).
155 #       Breakpoints in `require'd code are possible (used in `R').
156 #       Some additional words on internal work of debugger.
157 #       `b load filename' implemented.
158 #       `b postpone subr' implemented.
159 #       now only `q' exits debugger (overwritable on $inhibit_exit).
160 #       When restarting debugger breakpoints/actions persist.
161 #     Buglet: When restarting debugger only one breakpoint/action per 
162 #               autoloaded function persists.
163 # Changes: 0.97: NonStop will not stop in at_exit().
164 #       Option AutoTrace implemented.
165 #       Trace printed differently if frames are printed too.
166 #       new `inhibitExit' option.
167 #       printing of a very long statement interruptible.
168 # Changes: 0.98: New command `m' for printing possible methods
169 #       'l -' is a synonym for `-'.
170 #       Cosmetic bugs in printing stack trace.
171 #       `frame' & 8 to print "expanded args" in stack trace.
172 #       Can list/break in imported subs.
173 #       new `maxTraceLen' option.
174 #       frame & 4 and frame & 8 granted.
175 #       new command `m'
176 #       nonstoppable lines do not have `:' near the line number.
177 #       `b compile subname' implemented.
178 #       Will not use $` any more.
179 #       `-' behaves sane now.
180 # Changes: 0.99: Completion for `f', `m'.
181 #       `m' will remove duplicate names instead of duplicate functions.
182 #       `b load' strips trailing whitespace.
183 #       completion ignores leading `|'; takes into account current package
184 #       when completing a subroutine name (same for `l').
185 # Changes: 1.07: Many fixed by tchrist 13-March-2000
186 #   BUG FIXES:
187 #   + Added bare minimal security checks on perldb rc files, plus
188 #     comments on what else is needed.
189 #   + Fixed the ornaments that made "|h" completely unusable.
190 #     They are not used in print_help if they will hurt.  Strip pod
191 #     if we're paging to less.
192 #   + Fixed mis-formatting of help messages caused by ornaments
193 #     to restore Larry's original formatting.  
194 #   + Fixed many other formatting errors.  The code is still suboptimal, 
195 #     and needs a lot of work at restructuring.  It's also misindented
196 #     in many places.
197 #   + Fixed bug where trying to look at an option like your pager
198 #     shows "1".  
199 #   + Fixed some $? processing.  Note: if you use csh or tcsh, you will
200 #     lose.  You should consider shell escapes not using their shell,
201 #     or else not caring about detailed status.  This should really be
202 #     unified into one place, too.
203 #   + Fixed bug where invisible trailing whitespace on commands hoses you,
204 #     tricking Perl into thinking you weren't calling a debugger command!
205 #   + Fixed bug where leading whitespace on commands hoses you.  (One
206 #     suggests a leading semicolon or any other irrelevant non-whitespace
207 #     to indicate literal Perl code.)
208 #   + Fixed bugs that ate warnings due to wrong selected handle.
209 #   + Fixed a precedence bug on signal stuff.
210 #   + Fixed some unseemly wording.
211 #   + Fixed bug in help command trying to call perl method code.
212 #   + Fixed to call dumpvar from exception handler.  SIGPIPE killed us.
213 #   ENHANCEMENTS:
214 #   + Added some comments.  This code is still nasty spaghetti.
215 #   + Added message if you clear your pre/post command stacks which was
216 #     very easy to do if you just typed a bare >, <, or {.  (A command
217 #     without an argument should *never* be a destructive action; this
218 #     API is fundamentally screwed up; likewise option setting, which
219 #     is equally buggered.)
220 #   + Added command stack dump on argument of "?" for >, <, or {.
221 #   + Added a semi-built-in doc viewer command that calls man with the
222 #     proper %Config::Config path (and thus gets caching, man -k, etc),
223 #     or else perldoc on obstreperous platforms.
224 #   + Added to and rearranged the help information.
225 #   + Detected apparent misuse of { ... } to declare a block; this used
226 #     to work but now is a command, and mysteriously gave no complaint.
227 #
228 # Changes: 1.08: Apr 25, 2001  Jon Eveland <jweveland@yahoo.com>
229 #   BUG FIX:
230 #   + This patch to perl5db.pl cleans up formatting issues on the help
231 #     summary (h h) screen in the debugger.  Mostly columnar alignment
232 #     issues, plus converted the printed text to use all spaces, since
233 #     tabs don't seem to help much here.
234 #
235 # Changes: 1.09: May 19, 2001  Ilya Zakharevich <ilya@math.ohio-state.edu>
236 #   0) Minor bugs corrected;
237 #   a) Support for auto-creation of new TTY window on startup, either
238 #      unconditionally, or if started as a kid of another debugger session;
239 #   b) New `O'ption CreateTTY
240 #       I<CreateTTY>       bits control attempts to create a new TTY on events:
241 #                          1: on fork()   2: debugger is started inside debugger
242 #                          4: on startup
243 #   c) Code to auto-create a new TTY window on OS/2 (currently one
244 #      extra window per session - need named pipes to have more...);
245 #   d) Simplified interface for custom createTTY functions (with a backward
246 #      compatibility hack); now returns the TTY name to use; return of ''
247 #      means that the function reset the I/O handles itself;
248 #   d') Better message on the semantic of custom createTTY function;
249 #   e) Convert the existing code to create a TTY into a custom createTTY
250 #      function;
251 #   f) Consistent support for TTY names of the form "TTYin,TTYout";
252 #   g) Switch line-tracing output too to the created TTY window;
253 #   h) make `b fork' DWIM with CORE::GLOBAL::fork;
254 #   i) High-level debugger API cmd_*():
255 #      cmd_b_load($filenamepart)            # b load filenamepart
256 #      cmd_b_line($lineno [, $cond])        # b lineno [cond]
257 #      cmd_b_sub($sub [, $cond])            # b sub [cond]
258 #      cmd_stop()                           # Control-C
259 #      cmd_d($lineno)                       # d lineno (B)
260 #      The cmd_*() API returns FALSE on failure; in this case it outputs
261 #      the error message to the debugging output.
262 #   j) Low-level debugger API
263 #      break_on_load($filename)             # b load filename
264 #      @files = report_break_on_load()      # List files with load-breakpoints
265 #      breakable_line_in_filename($name, $from [, $to])
266 #                                           # First breakable line in the
267 #                                           # range $from .. $to.  $to defaults
268 #                                           # to $from, and may be less than $to
269 #      breakable_line($from [, $to])        # Same for the current file
270 #      break_on_filename_line($name, $lineno [, $cond])
271 #                                           # Set breakpoint,$cond defaults to 1
272 #      break_on_filename_line_range($name, $from, $to [, $cond])
273 #                                           # As above, on the first
274 #                                           # breakable line in range
275 #      break_on_line($lineno [, $cond])     # As above, in the current file
276 #      break_subroutine($sub [, $cond])     # break on the first breakable line
277 #      ($name, $from, $to) = subroutine_filename_lines($sub)
278 #                                           # The range of lines of the text
279 #      The low-level API returns TRUE on success, and die()s on failure.
280 #
281 # Changes: 1.10: May 23, 2001  Daniel Lewart <d-lewart@uiuc.edu>
282 #   BUG FIXES:
283 #   + Fixed warnings generated by "perl -dWe 42"
284 #   + Corrected spelling errors
285 #   + Squeezed Help (h) output into 80 columns
286 #
287 # Changes: 1.11: May 24, 2001  David Dyck <dcd@tc.fluke.com>
288 #   + Made "x @INC" work like it used to
289 #
290 # Changes: 1.12: May 24, 2001  Daniel Lewart <d-lewart@uiuc.edu>
291 #   + Fixed warnings generated by "O" (Show debugger options)
292 #   + Fixed warnings generated by "p 42" (Print expression)
293 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
294 #   + Added windowSize option 
295 # Changes: 1.14: Oct  9, 2001 multiple
296 #   + Clean up after itself on VMS (Charles Lane in 12385)
297 #   + Adding "@ file" syntax (Peter Scott in 12014)
298 #   + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
299 #   + $^S and other debugger fixes (Ilya Zakharevich in 11120)
300 #   + Forgot a my() declaration (Ilya Zakharevich in 11085)
301 # Changes: 1.15: Nov  6, 2001 Michael G Schwern <schwern@pobox.com>
302 #   + Updated 1.14 change log
303 #   + Added *dbline explainatory comments
304 #   + Mentioning perldebguts man page
305 # Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com>
306 #       + $onetimeDump improvements
307 # Changes: 1.17: Feb 20, 2002 Richard Foley <richard.foley@rfi.net>
308 #   Moved some code to cmd_[.]()'s for clarity and ease of handling,
309 #   rationalised the following commands and added cmd_wrapper() to 
310 #   enable switching between old and frighteningly consistent new 
311 #   behaviours for diehards: 'o CommandSet=pre580' (sigh...)
312 #     a(add),       A(del)            # action expr   (added del by line)
313 #   + b(add),       B(del)            # break  [line] (was b,D)
314 #   + w(add),       W(del)            # watch  expr   (was W,W) added del by expr
315 #   + h(summary), h h(long)           # help (hh)     (was h h,h)
316 #   + m(methods),   M(modules)        # ...           (was m,v)
317 #   + o(option)                       # lc            (was O)
318 #   + v(view code), V(view Variables) # ...           (was w,V)
319
320 ####################################################################
321
322 # Needed for the statement after exec():
323
324 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
325 local($^W) = 0;                 # Switch run-time warnings off during init.
326 warn (                  # Do not ;-)
327       $dumpvar::hashDepth,     
328       $dumpvar::arrayDepth,    
329       $dumpvar::dumpDBFiles,   
330       $dumpvar::dumpPackages,  
331       $dumpvar::quoteHighBit,  
332       $dumpvar::printUndef,    
333       $dumpvar::globPrint,     
334       $dumpvar::usageOnly,
335       @ARGS,
336       $Carp::CarpLevel,
337       $panic,
338       $second_time,
339      ) if 0;
340
341 # Command-line + PERLLIB:
342 @ini_INC = @INC;
343
344 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
345
346 $trace = $signal = $single = 0; # Uninitialized warning suppression
347                                 # (local $^W cannot help - other packages!).
348 $inhibit_exit = $option{PrintRet} = 1;
349
350 @options     = qw(hashDepth arrayDepth CommandSet dumpDepth
351                   DumpDBFiles DumpPackages DumpReused
352                   compactDump veryCompact quote HighBit undefPrint
353                   globPrint PrintRet UsageOnly frame AutoTrace
354                   TTY noTTY ReadLine NonStop LineInfo maxTraceLen
355                   recallCommand ShellBang pager tkRunning ornaments
356                   signalLevel warnLevel dieLevel inhibit_exit
357                   ImmediateStop bareStringify CreateTTY
358                   RemotePort windowSize);
359
360 %optionVars    = (
361                  hashDepth      => \$dumpvar::hashDepth,
362                  arrayDepth     => \$dumpvar::arrayDepth,
363                  CommandSet => \$CommandSet,
364                  DumpDBFiles    => \$dumpvar::dumpDBFiles,
365                  DumpPackages   => \$dumpvar::dumpPackages,
366                  DumpReused     => \$dumpvar::dumpReused,
367                  HighBit        => \$dumpvar::quoteHighBit,
368                  undefPrint     => \$dumpvar::printUndef,
369                  globPrint      => \$dumpvar::globPrint,
370                  UsageOnly      => \$dumpvar::usageOnly,
371                  CreateTTY      => \$CreateTTY,
372                  bareStringify  => \$dumpvar::bareStringify,
373                  frame          => \$frame,
374                  AutoTrace      => \$trace,
375                  inhibit_exit   => \$inhibit_exit,
376                  maxTraceLen    => \$maxtrace,
377                  ImmediateStop  => \$ImmediateStop,
378                  RemotePort     => \$remoteport,
379                  windowSize     => \$window,
380 );
381
382 %optionAction  = (
383                   compactDump   => \&dumpvar::compactDump,
384                   veryCompact   => \&dumpvar::veryCompact,
385                   quote         => \&dumpvar::quote,
386                   TTY           => \&TTY,
387                   noTTY         => \&noTTY,
388                   ReadLine      => \&ReadLine,
389                   NonStop       => \&NonStop,
390                   LineInfo      => \&LineInfo,
391                   recallCommand => \&recallCommand,
392                   ShellBang     => \&shellBang,
393                   pager         => \&pager,
394                   signalLevel   => \&signalLevel,
395                   warnLevel     => \&warnLevel,
396                   dieLevel      => \&dieLevel,
397                   tkRunning     => \&tkRunning,
398                   ornaments     => \&ornaments,
399                   RemotePort    => \&RemotePort,
400                  );
401
402 %optionRequire = (
403                   compactDump   => 'dumpvar.pl',
404                   veryCompact   => 'dumpvar.pl',
405                   quote         => 'dumpvar.pl',
406                  );
407
408 # These guys may be defined in $ENV{PERL5DB} :
409 $rl             = 1     unless defined $rl;
410 $warnLevel      = 1     unless defined $warnLevel;
411 $dieLevel       = 1     unless defined $dieLevel;
412 $signalLevel    = 1     unless defined $signalLevel;
413 $pre            = []    unless defined $pre;
414 $post           = []    unless defined $post;
415 $pretype        = []    unless defined $pretype;
416 $CreateTTY      = 3     unless defined $CreateTTY;
417 $CommandSet = '580'     unless defined $CommandSet;
418
419 warnLevel($warnLevel);
420 dieLevel($dieLevel);
421 signalLevel($signalLevel);
422
423 pager(
424       defined $ENV{PAGER}              ? $ENV{PAGER} :
425       eval { require Config } && 
426         defined $Config::Config{pager} ? $Config::Config{pager}
427                                        : 'more'
428      ) unless defined $pager;
429 setman();
430 &recallCommand("!") unless defined $prc;
431 &shellBang("!") unless defined $psh;
432 sethelp();
433 $maxtrace = 400 unless defined $maxtrace;
434 $ini_pids = $ENV{PERLDB_PIDS};
435 if (defined $ENV{PERLDB_PIDS}) {
436   $pids = "[$ENV{PERLDB_PIDS}]";
437   $ENV{PERLDB_PIDS} .= "->$$";
438   $term_pid = -1;
439 } else {
440   $ENV{PERLDB_PIDS} = "$$";
441   $pids = '';
442   $term_pid = $$;
443 }
444 $pidprompt = '';
445 *emacs = $slave_editor if $slave_editor;        # May be used in afterinit()...
446
447 if (-e "/dev/tty") {  # this is the wrong metric!
448   $rcfile=".perldb";
449 } else {
450   $rcfile="perldb.ini";
451 }
452
453 # This isn't really safe, because there's a race
454 # between checking and opening.  The solution is to
455 # open and fstat the handle, but then you have to read and
456 # eval the contents.  But then the silly thing gets
457 # your lexical scope, which is unfortunately at best.
458 sub safe_do { 
459     my $file = shift;
460
461     # Just exactly what part of the word "CORE::" don't you understand?
462     local $SIG{__WARN__};  
463     local $SIG{__DIE__};    
464
465     unless (is_safe_file($file)) {
466         CORE::warn <<EO_GRIPE;
467 perldb: Must not source insecure rcfile $file.
468         You or the superuser must be the owner, and it must not 
469         be writable by anyone but its owner.
470 EO_GRIPE
471         return;
472     } 
473
474     do $file;
475     CORE::warn("perldb: couldn't parse $file: $@") if $@;
476 }
477
478
479 # Verifies that owner is either real user or superuser and that no
480 # one but owner may write to it.  This function is of limited use
481 # when called on a path instead of upon a handle, because there are
482 # no guarantees that filename (by dirent) whose file (by ino) is
483 # eventually accessed is the same as the one tested. 
484 # Assumes that the file's existence is not in doubt.
485 sub is_safe_file {
486     my $path = shift;
487     stat($path) || return;      # mysteriously vaporized
488     my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
489
490     return 0 if $uid != 0 && $uid != $<;
491     return 0 if $mode & 022;
492     return 1;
493 }
494
495 if (-f $rcfile) {
496     safe_do("./$rcfile");
497
498 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
499     safe_do("$ENV{HOME}/$rcfile");
500 }
501 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
502     safe_do("$ENV{LOGDIR}/$rcfile");
503 }
504
505 if (defined $ENV{PERLDB_OPTS}) {
506   parse_options($ENV{PERLDB_OPTS});
507 }
508
509 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
510      and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
511     *get_fork_TTY = \&xterm_get_fork_TTY;
512 } elsif ($^O eq 'os2') {
513     *get_fork_TTY = \&os2_get_fork_TTY;
514 }
515
516 # Here begin the unreadable code.  It needs fixing.
517
518 if (exists $ENV{PERLDB_RESTART}) {
519   delete $ENV{PERLDB_RESTART};
520   # $restart = 1;
521   @hist = get_list('PERLDB_HIST');
522   %break_on_load = get_list("PERLDB_ON_LOAD");
523   %postponed = get_list("PERLDB_POSTPONE");
524   my @had_breakpoints= get_list("PERLDB_VISITED");
525   for (0 .. $#had_breakpoints) {
526     my %pf = get_list("PERLDB_FILE_$_");
527     $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
528   }
529   my %opt = get_list("PERLDB_OPT");
530   my ($opt,$val);
531   while (($opt,$val) = each %opt) {
532     $val =~ s/[\\\']/\\$1/g;
533     parse_options("$opt'$val'");
534   }
535   @INC = get_list("PERLDB_INC");
536   @ini_INC = @INC;
537   $pretype = [get_list("PERLDB_PRETYPE")];
538   $pre = [get_list("PERLDB_PRE")];
539   $post = [get_list("PERLDB_POST")];
540   @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
541 }
542
543 if ($notty) {
544   $runnonstop = 1;
545 } else {
546   # Is Perl being run from a slave editor or graphical debugger?
547   $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
548   $rl = 0, shift(@main::ARGV) if $slave_editor;
549
550   #require Term::ReadLine;
551
552   if ($^O eq 'cygwin') {
553     # /dev/tty is binary. use stdin for textmode
554     undef $console;
555   } elsif (-e "/dev/tty") {
556     $console = "/dev/tty";
557   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
558     $console = "con";
559   } elsif ($^O eq 'MacOS') {
560     if ($MacPerl::Version !~ /MPW/) {
561       $console = "Dev:Console:Perl Debug"; # Separate window for application
562     } else {
563       $console = "Dev:Console";
564     }
565   } else {
566     $console = "sys\$command";
567   }
568
569   if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
570     $console = undef;
571   }
572
573   if ($^O eq 'NetWare') {
574         $console = undef;
575   }
576
577   # Around a bug:
578   if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
579     $console = undef;
580   }
581
582   if ($^O eq 'epoc') {
583     $console = undef;
584   }
585
586   $console = $tty if defined $tty;
587
588   if (defined $remoteport) {
589     require IO::Socket;
590     $OUT = new IO::Socket::INET( Timeout  => '10',
591                                  PeerAddr => $remoteport,
592                                  Proto    => 'tcp',
593                                );
594     if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
595     $IN = $OUT;
596   } else {
597     create_IN_OUT(4) if $CreateTTY & 4;
598     if ($console) {
599       my ($i, $o) = split /,/, $console;
600       $o = $i unless defined $o;
601       open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
602       open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
603         || open(OUT,">&STDOUT");        # so we don't dongle stdout
604     } elsif (not defined $console) {
605       open(IN,"<&STDIN");
606       open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
607       $console = 'STDIN/OUT';
608     }
609     # so open("|more") can read from STDOUT and so we don't dingle stdin
610     $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
611   }
612   my $previous = select($OUT);
613   $| = 1;                       # for DB::OUT
614   select($previous);
615
616   $LINEINFO = $OUT unless defined $LINEINFO;
617   $lineinfo = $console unless defined $lineinfo;
618
619   $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
620   unless ($runnonstop) {
621     local $\ = '';
622     local $, = '';
623     if ($term_pid eq '-1') {
624       print $OUT "\nDaughter DB session started...\n";
625     } else {
626       print $OUT "\nLoading DB routines from $header\n";
627       print $OUT ("Editor support ",
628                   $slave_editor ? "enabled" : "available",
629                   ".\n");
630       print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
631     }
632   }
633 }
634
635 @ARGS = @ARGV;
636 for (@args) {
637     s/\'/\\\'/g;
638     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
639 }
640
641 if (defined &afterinit) {       # May be defined in $rcfile
642   &afterinit();
643 }
644
645 $I_m_init = 1;
646
647 ############################################################ Subroutines
648
649 sub DB {
650     # _After_ the perl program is compiled, $single is set to 1:
651     if ($single and not $second_time++) {
652       if ($runnonstop) {        # Disable until signal
653         for ($i=0; $i <= $stack_depth; ) {
654             $stack[$i++] &= ~1;
655         }
656         $single = 0;
657         # return;                       # Would not print trace!
658       } elsif ($ImmediateStop) {
659         $ImmediateStop = 0;
660         $signal = 1;
661       }
662     }
663     $runnonstop = 0 if $single or $signal; # Disable it if interactive.
664     &save;
665     ($package, $filename, $line) = caller;
666     $filename_ini = $filename;
667     $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
668       "package $package;";      # this won't let them modify, alas
669     local(*dbline) = $main::{'_<' . $filename};
670
671     # we need to check for pseudofiles on Mac OS (these are files
672     # not attached to a filename, but instead stored in Dev:Pseudo)
673     if ($^O eq 'MacOS' && $#dbline < 0) {
674         $filename_ini = $filename = 'Dev:Pseudo';
675         *dbline = $main::{'_<' . $filename};
676     }
677
678     $max = $#dbline;
679     if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
680                 if ($stop eq '1') {
681                         $signal |= 1;
682                 } elsif ($stop) {
683                         $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
684                         $dbline{$line} =~ s/;9($|\0)/$1/;
685                 }
686     }
687     my $was_signal = $signal;
688     if ($trace & 2) {
689       for (my $n = 0; $n <= $#to_watch; $n++) {
690                 $evalarg = $to_watch[$n];
691                 local $onetimeDump;     # Do not output results
692                 my ($val) = &eval;      # Fix context (&eval is doing array)?
693                 $val = ( (defined $val) ? "'$val'" : 'undef' );
694                 if ($val ne $old_watch[$n]) {
695                   $signal = 1;
696                   print $OUT <<EOP;
697 Watchpoint $n:\t$to_watch[$n] changed:
698         old value:\t$old_watch[$n]
699         new value:\t$val
700 EOP
701                   $old_watch[$n] = $val;
702                 }
703       }
704     }
705     if ($trace & 4) {           # User-installed watch
706       return if watchfunction($package, $filename, $line) 
707         and not $single and not $was_signal and not ($trace & ~4);
708     }
709     $was_signal = $signal;
710     $signal = 0;
711     if ($single || ($trace & 1) || $was_signal) {
712         if ($slave_editor) {
713             $position = "\032\032$filename:$line:0\n";
714             print_lineinfo($position);
715         } elsif ($package eq 'DB::fake') {
716           $term || &setterm;
717           print_help(<<EOP);
718 Debugged program terminated.  Use B<q> to quit or B<R> to restart,
719   use B<O> I<inhibit_exit> to avoid stopping after program termination,
720   B<h q>, B<h R> or B<h O> to get additional info.  
721 EOP
722           $package = 'main';
723           $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
724             "package $package;";        # this won't let them modify, alas
725         } else {
726             $sub =~ s/\'/::/;
727             $prefix = $sub =~ /::/ ? "" : "${'package'}::";
728             $prefix .= "$sub($filename:";
729             $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
730             if (length($prefix) > 30) {
731                 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
732                         $prefix = "";
733                         $infix = ":\t";
734             } else {
735                         $infix = "):\t";
736                         $position = "$prefix$line$infix$dbline[$line]$after";
737             }
738             if ($frame) {
739                         print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
740             } else {
741                         print_lineinfo($position);
742             }
743             for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
744                         last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
745                         last if $signal;
746                         $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
747                         $incr_pos = "$prefix$i$infix$dbline[$i]$after";
748                         $position .= $incr_pos;
749                         if ($frame) {
750                                 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
751                         } else {
752                                 print_lineinfo($incr_pos);
753                         }
754             }
755         }
756     }
757     $evalarg = $action, &eval if $action;
758     if ($single || $was_signal) {
759           local $level = $level + 1;
760           foreach $evalarg (@$pre) {
761             &eval;
762           }
763           print $OUT $stack_depth . " levels deep in subroutine calls!\n"
764               if $single & 4;
765                 $start = $line;
766                 $incr = -1;             # for backward motion.
767                 @typeahead = (@$pretype, @typeahead);
768     CMD:
769         while (($term || &setterm),
770                ($term_pid == $$ or resetterm(1)),
771                defined ($cmd=&readline("$pidprompt  DB" . ('<' x $level) .
772                                        ($#hist+1) . ('>' x $level) . " "))) 
773         {
774                 $single = 0;
775                 $signal = 0;
776                 $cmd =~ s/\\$/\n/ && do {
777                     $cmd .= &readline("  cont: ");
778                     redo CMD;
779                 };
780                 $cmd =~ /^$/ && ($cmd = $laststep);
781                 push(@hist,$cmd) if length($cmd) > 1;
782               PIPE: {
783                     $cmd =~ s/^\s+//s;   # trim annoying leading whitespace
784                     $cmd =~ s/\s+$//s;   # trim annoying trailing whitespace
785                     ($i) = split(/\s+/,$cmd);
786                     if ($alias{$i}) { 
787                                         # squelch the sigmangler
788                                         local $SIG{__DIE__};
789                                         local $SIG{__WARN__};
790                                         eval "\$cmd =~ $alias{$i}";
791                                         if ($@) {
792                                                 local $\ = '';
793                                                 print $OUT "Couldn't evaluate `$i' alias: $@";
794                                                 next CMD;
795                                         } 
796                     }
797                     $cmd =~ /^q$/ && do {
798                         $fall_off_end = 1;
799                         clean_ENV();
800                         exit $?;
801                     };
802                     $cmd =~ /^t$/ && do {
803                         $trace ^= 1;
804                         local $\ = '';
805                         print $OUT "Trace = " .
806                             (($trace & 1) ? "on" : "off" ) . "\n";
807                         next CMD; };
808                     $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
809                         $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
810                         local $\ = '';
811                         local $, = '';
812                         foreach $subname (sort(keys %sub)) {
813                             if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
814                                 print $OUT $subname,"\n";
815                             }
816                         }
817                         next CMD; };
818                     $cmd =~ s/^X\b/V $package/;
819                     $cmd =~ /^V$/ && do {
820                         $cmd = "V $package"; };
821                     $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
822                         local ($savout) = select($OUT);
823                         $packname = $1;
824                         @vars = split(' ',$2);
825                         do 'dumpvar.pl' unless defined &main::dumpvar;
826                         if (defined &main::dumpvar) {
827                             local $frame = 0;
828                             local $doret = -2;
829                             # must detect sigpipe failures
830                            eval { &main::dumpvar($packname,
831                                                  defined $option{dumpDepth}
832                                                   ? $option{dumpDepth} : -1,
833                                                  @vars) };
834                             if ($@) {
835                                 die unless $@ =~ /dumpvar print failed/;
836                             } 
837                         } else {
838                             print $OUT "dumpvar.pl not available.\n";
839                         }
840                         select ($savout);
841                         next CMD; };
842                     $cmd =~ s/^x\b/ / && do { # So that will be evaled
843                         $onetimeDump = 'dump'; 
844                         # handle special  "x 3 blah" syntax
845                         if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
846                           $onetimedumpDepth = $1;
847                         }
848                       };
849                     $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
850                         methods($1); next CMD};
851                     $cmd =~ s/^m\b/ / && do { # So this will be evaled
852                         $onetimeDump = 'methods'; };
853                     $cmd =~ /^f\b\s*(.*)/ && do {
854                         $file = $1;
855                         $file =~ s/\s+$//;
856                         if (!$file) {
857                             print $OUT "The old f command is now the r command.\n"; # hint
858                             print $OUT "The new f command switches filenames.\n";
859                             next CMD;
860                         }
861                         if (!defined $main::{'_<' . $file}) {
862                             if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
863                                               $try = substr($try,2);
864                                               print $OUT "Choosing $try matching `$file':\n";
865                                               $file = $try;
866                                           }}
867                         }
868                         if (!defined $main::{'_<' . $file}) {
869                             print $OUT "No file matching `$file' is loaded.\n";
870                             next CMD;
871                         } elsif ($file ne $filename) {
872                             *dbline = $main::{'_<' . $file};
873                             $max = $#dbline;
874                             $filename = $file;
875                             $start = 1;
876                             $cmd = "l";
877                           } else {
878                             print $OUT "Already in $file.\n";
879                             next CMD;
880                           }
881                       };
882                     $cmd =~ /^\.$/ && do {
883                         $incr = -1;             # for backward motion.
884                         $start = $line;
885                         $filename = $filename_ini;
886                         *dbline = $main::{'_<' . $filename};
887                         $max = $#dbline;
888                         print_lineinfo($position);
889                         next CMD };
890                     $cmd =~ /^-$/ && do {
891                         $start -= $incr + $window + 1;
892                         $start = 1 if $start <= 0;
893                         $incr = $window - 1;
894                         $cmd = 'l ' . ($start) . '+'; };
895                         # rjsf ->
896                   $cmd =~ /^([aAbBDhlLMoOvwW])\b\s*(.*)/s && do { 
897                                 &cmd_wrapper($1, $2, $line); 
898                                 next CMD; 
899                         };
900                         # <- rjsf
901                   $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
902                         push @$pre, action($1);
903                         next CMD; };
904                     $cmd =~ /^>>\s*(.*)/ && do {
905                         push @$post, action($1);
906                         next CMD; };
907                     $cmd =~ /^<\s*(.*)/ && do {
908                         unless ($1) {
909                             print $OUT "All < actions cleared.\n";
910                             $pre = [];
911                             next CMD;
912                         } 
913                         if ($1 eq '?') {
914                             unless (@$pre) {
915                                 print $OUT "No pre-prompt Perl actions.\n";
916                                 next CMD;
917                             } 
918                             print $OUT "Perl commands run before each prompt:\n";
919                             for my $action ( @$pre ) {
920                                 print $OUT "\t< -- $action\n";
921                             } 
922                             next CMD;
923                         } 
924                         $pre = [action($1)];
925                         next CMD; };
926                     $cmd =~ /^>\s*(.*)/ && do {
927                         unless ($1) {
928                             print $OUT "All > actions cleared.\n";
929                             $post = [];
930                             next CMD;
931                         }
932                         if ($1 eq '?') {
933                             unless (@$post) {
934                                 print $OUT "No post-prompt Perl actions.\n";
935                                 next CMD;
936                             } 
937                             print $OUT "Perl commands run after each prompt:\n";
938                             for my $action ( @$post ) {
939                                 print $OUT "\t> -- $action\n";
940                             } 
941                             next CMD;
942                         } 
943                         $post = [action($1)];
944                         next CMD; };
945                     $cmd =~ /^\{\{\s*(.*)/ && do {
946                         if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { 
947                             print $OUT "{{ is now a debugger command\n",
948                                 "use `;{{' if you mean Perl code\n";
949                             $cmd = "h {{";
950                             redo CMD;
951                         } 
952                         push @$pretype, $1;
953                         next CMD; };
954                     $cmd =~ /^\{\s*(.*)/ && do {
955                         unless ($1) {
956                             print $OUT "All { actions cleared.\n";
957                             $pretype = [];
958                             next CMD;
959                         }
960                         if ($1 eq '?') {
961                             unless (@$pretype) {
962                                 print $OUT "No pre-prompt debugger actions.\n";
963                                 next CMD;
964                             } 
965                             print $OUT "Debugger commands run before each prompt:\n";
966                             for my $action ( @$pretype ) {
967                                 print $OUT "\t{ -- $action\n";
968                             } 
969                             next CMD;
970                         } 
971                         if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { 
972                             print $OUT "{ is now a debugger command\n",
973                                 "use `;{' if you mean Perl code\n";
974                             $cmd = "h {";
975                             redo CMD;
976                         } 
977                         $pretype = [$1];
978                         next CMD; };
979             $cmd =~ /^n$/ && do {
980                         end_report(), next CMD if $finished and $level <= 1;
981                         $single = 2;
982                         $laststep = $cmd;
983                         last CMD; };
984                     $cmd =~ /^s$/ && do {
985                         end_report(), next CMD if $finished and $level <= 1;
986                         $single = 1;
987                         $laststep = $cmd;
988                         last CMD; };
989                     $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
990                         end_report(), next CMD if $finished and $level <= 1;
991                         $subname = $i = $1;
992                         #  Probably not needed, since we finish an interactive
993                         #  sub-session anyway...
994                         # local $filename = $filename;
995                         # local *dbline = *dbline;      # XXX Would this work?!
996                         if ($subname =~ /\D/) { # subroutine name
997                             $subname = $package."::".$subname 
998                                 unless $subname =~ /::/;
999                             ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1000                             $i += 0;
1001                             if ($i) {
1002                                 $filename = $file;
1003                                 *dbline = $main::{'_<' . $filename};
1004                                 $had_breakpoints{$filename} |= 1;
1005                                 $max = $#dbline;
1006                                 ++$i while $dbline[$i] == 0 && $i < $max;
1007                             } else {
1008                                 print $OUT "Subroutine $subname not found.\n";
1009                                 next CMD; 
1010                             }
1011                         }
1012                         if ($i) {
1013                             if ($dbline[$i] == 0) {
1014                                 print $OUT "Line $i not breakable.\n";
1015                                 next CMD;
1016                             }
1017                             $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1018                         }
1019                         for ($i=0; $i <= $stack_depth; ) {
1020                             $stack[$i++] &= ~1;
1021                         }
1022                         last CMD; };
1023                     $cmd =~ /^r$/ && do {
1024                         end_report(), next CMD if $finished and $level <= 1;
1025                         $stack[$stack_depth] |= 1;
1026                         $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1027                         last CMD; };
1028                     $cmd =~ /^R$/ && do {
1029                         print $OUT "Warning: some settings and command-line options may be lost!\n";
1030                         my (@script, @flags, $cl);
1031                         push @flags, '-w' if $ini_warn;
1032                         # Put all the old includes at the start to get
1033                         # the same debugger.
1034                         for (@ini_INC) {
1035                           push @flags, '-I', $_;
1036                         }
1037                         push @flags, '-T' if ${^TAINT};
1038                         # Arrange for setting the old INC:
1039                         set_list("PERLDB_INC", @ini_INC);
1040                         if ($0 eq '-e') {
1041                           for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1042                                 chomp ($cl =  ${'::_<-e'}[$_]);
1043                             push @script, '-e', $cl;
1044                           }
1045                         } else {
1046                           @script = $0;
1047                         }
1048                         set_list("PERLDB_HIST", 
1049                                  $term->Features->{getHistory} 
1050                                  ? $term->GetHistory : @hist);
1051                         my @had_breakpoints = keys %had_breakpoints;
1052                         set_list("PERLDB_VISITED", @had_breakpoints);
1053                         set_list("PERLDB_OPT", %option);
1054                         set_list("PERLDB_ON_LOAD", %break_on_load);
1055                         my @hard;
1056                         for (0 .. $#had_breakpoints) {
1057                           my $file = $had_breakpoints[$_];
1058                           *dbline = $main::{'_<' . $file};
1059                           next unless %dbline or $postponed_file{$file};
1060                           (push @hard, $file), next 
1061                             if $file =~ /^\(\w*eval/;
1062                           my @add;
1063                           @add = %{$postponed_file{$file}}
1064                             if $postponed_file{$file};
1065                           set_list("PERLDB_FILE_$_", %dbline, @add);
1066                         }
1067                         for (@hard) { # Yes, really-really...
1068                           # Find the subroutines in this eval
1069                           *dbline = $main::{'_<' . $_};
1070                           my ($quoted, $sub, %subs, $line) = quotemeta $_;
1071                           for $sub (keys %sub) {
1072                             next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1073                             $subs{$sub} = [$1, $2];
1074                           }
1075                           unless (%subs) {
1076                             print $OUT
1077                               "No subroutines in $_, ignoring breakpoints.\n";
1078                             next;
1079                           }
1080                         LINES: for $line (keys %dbline) {
1081                             # One breakpoint per sub only:
1082                             my ($offset, $sub, $found);
1083                           SUBS: for $sub (keys %subs) {
1084                               if ($subs{$sub}->[1] >= $line # Not after the subroutine
1085                                   and (not defined $offset # Not caught
1086                                        or $offset < 0 )) { # or badly caught
1087                                 $found = $sub;
1088                                 $offset = $line - $subs{$sub}->[0];
1089                                 $offset = "+$offset", last SUBS if $offset >= 0;
1090                               }
1091                             }
1092                             if (defined $offset) {
1093                               $postponed{$found} =
1094                                 "break $offset if $dbline{$line}";
1095                             } else {
1096                               print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1097                             }
1098                           }
1099                         }
1100                         set_list("PERLDB_POSTPONE", %postponed);
1101                         set_list("PERLDB_PRETYPE", @$pretype);
1102                         set_list("PERLDB_PRE", @$pre);
1103                         set_list("PERLDB_POST", @$post);
1104                         set_list("PERLDB_TYPEAHEAD", @typeahead);
1105                         $ENV{PERLDB_RESTART} = 1;
1106                         delete $ENV{PERLDB_PIDS}; # Restore ini state
1107                         $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1108                         #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1109                         exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1110                         print $OUT "exec failed: $!\n";
1111                         last CMD; };
1112                     $cmd =~ /^T$/ && do {
1113                         print_trace($OUT, 1); # skip DB
1114                         next CMD; };
1115                     $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w($1); next CMD; };
1116                     $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W($1); next CMD; };
1117                     $cmd =~ /^\/(.*)$/ && do {
1118                         $inpat = $1;
1119                         $inpat =~ s:([^\\])/$:$1:;
1120                         if ($inpat ne "") {
1121                             # squelch the sigmangler
1122                             local $SIG{__DIE__};
1123                             local $SIG{__WARN__};
1124                             eval '$inpat =~ m'."\a$inpat\a";    
1125                             if ($@ ne "") {
1126                                 print $OUT "$@";
1127                                 next CMD;
1128                             }
1129                             $pat = $inpat;
1130                         }
1131                         $end = $start;
1132                         $incr = -1;
1133                         eval '
1134                             for (;;) {
1135                                 ++$start;
1136                                 $start = 1 if ($start > $max);
1137                                 last if ($start == $end);
1138                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1139                                     if ($slave_editor) {
1140                                         print $OUT "\032\032$filename:$start:0\n";
1141                                     } else {
1142                                         print $OUT "$start:\t", $dbline[$start], "\n";
1143                                     }
1144                                     last;
1145                                 }
1146                             } ';
1147                         print $OUT "/$pat/: not found\n" if ($start == $end);
1148                         next CMD; };
1149                     $cmd =~ /^\?(.*)$/ && do {
1150                         $inpat = $1;
1151                         $inpat =~ s:([^\\])\?$:$1:;
1152                         if ($inpat ne "") {
1153                             # squelch the sigmangler
1154                             local $SIG{__DIE__};
1155                             local $SIG{__WARN__};
1156                             eval '$inpat =~ m'."\a$inpat\a";    
1157                             if ($@ ne "") {
1158                                 print $OUT $@;
1159                                 next CMD;
1160                             }
1161                             $pat = $inpat;
1162                         }
1163                         $end = $start;
1164                         $incr = -1;
1165                         eval '
1166                             for (;;) {
1167                                 --$start;
1168                                 $start = $max if ($start <= 0);
1169                                 last if ($start == $end);
1170                                 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1171                                     if ($slave_editor) {
1172                                         print $OUT "\032\032$filename:$start:0\n";
1173                                     } else {
1174                                         print $OUT "$start:\t", $dbline[$start], "\n";
1175                                     }
1176                                     last;
1177                                 }
1178                             } ';
1179                         print $OUT "?$pat?: not found\n" if ($start == $end);
1180                         next CMD; };
1181                     $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1182                         pop(@hist) if length($cmd) > 1;
1183                         $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1184                         $cmd = $hist[$i];
1185                         print $OUT $cmd, "\n";
1186                         redo CMD; };
1187                     $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1188                         &system($1);
1189                         next CMD; };
1190                     $cmd =~ /^$rc([^$rc].*)$/ && do {
1191                         $pat = "^$1";
1192                         pop(@hist) if length($cmd) > 1;
1193                         for ($i = $#hist; $i; --$i) {
1194                             last if $hist[$i] =~ /$pat/;
1195                         }
1196                         if (!$i) {
1197                             print $OUT "No such command!\n\n";
1198                             next CMD;
1199                         }
1200                         $cmd = $hist[$i];
1201                         print $OUT $cmd, "\n";
1202                         redo CMD; };
1203                     $cmd =~ /^$sh$/ && do {
1204                         &system($ENV{SHELL}||"/bin/sh");
1205                         next CMD; };
1206                     $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1207                         # XXX: using csh or tcsh destroys sigint retvals!
1208                         #&system($1);  # use this instead
1209                         &system($ENV{SHELL}||"/bin/sh","-c",$1);
1210                         next CMD; };
1211                     $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1212                         $end = $2 ? ($#hist-$2) : 0;
1213                         $hist = 0 if $hist < 0;
1214                         for ($i=$#hist; $i>$end; $i--) {
1215                             print $OUT "$i: ",$hist[$i],"\n"
1216                               unless $hist[$i] =~ /^.?$/;
1217                         };
1218                         next CMD; };
1219                     $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1220                         runman($1);
1221                         next CMD; };
1222                     $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1223                     $cmd =~ s/^p\b/print {\$DB::OUT} /;
1224                     $cmd =~ s/^=\s*// && do {
1225                         my @keys;
1226                         if (length $cmd == 0) {
1227                             @keys = sort keys %alias;
1228                         } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1229                             # can't use $_ or kill //g state
1230                             for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1231                             $alias{$k} = "s\a$k\a$v\a";
1232                             # squelch the sigmangler
1233                             local $SIG{__DIE__};
1234                             local $SIG{__WARN__};
1235                             unless (eval "sub { s\a$k\a$v\a }; 1") {
1236                                 print $OUT "Can't alias $k to $v: $@\n"; 
1237                                 delete $alias{$k};
1238                                 next CMD;
1239                             } 
1240                             @keys = ($k);
1241                         } else {
1242                             @keys = ($cmd);
1243                         } 
1244                         for my $k (@keys) {
1245                             if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
1246                                 print $OUT "$k\t= $1\n";
1247                             } 
1248                             elsif (defined $alias{$k}) {
1249                                     print $OUT "$k\t$alias{$k}\n";
1250                             } 
1251                             else {
1252                                 print "No alias for $k\n";
1253                             } 
1254                         }
1255                         next CMD; };
1256                     $cmd =~ /^\@\s*(.*\S)/ && do {
1257                       if (open my $fh, $1) {
1258                         push @cmdfhs, $fh;
1259                       } else {
1260                         &warn("Can't execute `$1': $!\n");
1261                       }
1262                       next CMD; };
1263                     $cmd =~ /^\|\|?\s*[^|]/ && do {
1264                         if ($pager =~ /^\|/) {
1265                             open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1266                             open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1267                         } else {
1268                             open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1269                         }
1270                         fix_less();
1271                         unless ($piped=open(OUT,$pager)) {
1272                             &warn("Can't pipe output to `$pager'");
1273                             if ($pager =~ /^\|/) {
1274                                 open(OUT,">&STDOUT") # XXX: lost message
1275                                     || &warn("Can't restore DB::OUT");
1276                                 open(STDOUT,">&SAVEOUT")
1277                                   || &warn("Can't restore STDOUT");
1278                                 close(SAVEOUT);
1279                             } else {
1280                                 open(OUT,">&STDOUT") # XXX: lost message
1281                                     || &warn("Can't restore DB::OUT");
1282                             }
1283                             next CMD;
1284                         }
1285                         $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1286                             && ("" eq $SIG{PIPE}  ||  "DEFAULT" eq $SIG{PIPE});
1287                         $selected= select(OUT);
1288                         $|= 1;
1289                         select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1290                         $cmd =~ s/^\|+\s*//;
1291                         redo PIPE; 
1292                     };
1293                     # XXX Local variants do not work!
1294                     $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1295                     $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1296                     $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1297                 }               # PIPE:
1298             $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1299             if ($onetimeDump) {
1300                 $onetimeDump = undef;
1301                 $onetimedumpDepth = undef;
1302             } elsif ($term_pid == $$) {
1303                 print $OUT "\n";
1304             }
1305         } continue {            # CMD:
1306             if ($piped) {
1307                 if ($pager =~ /^\|/) {
1308                     $? = 0;  
1309                     # we cannot warn here: the handle is missing --tchrist
1310                     close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1311
1312                     # most of the $? crud was coping with broken cshisms
1313                     if ($?) {
1314                         print SAVEOUT "Pager `$pager' failed: ";
1315                         if ($? == -1) {
1316                             print SAVEOUT "shell returned -1\n";
1317                         } elsif ($? >> 8) {
1318                             print SAVEOUT 
1319                               ( $? & 127 ) ? " (SIG#".($?&127).")" : "", 
1320                               ( $? & 128 ) ? " -- core dumped" : "", "\n";
1321                         } else {
1322                             print SAVEOUT "status ", ($? >> 8), "\n";
1323                         } 
1324                     } 
1325
1326                     open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1327                     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1328                     $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1329                     # Will stop ignoring SIGPIPE if done like nohup(1)
1330                     # does SIGINT but Perl doesn't give us a choice.
1331                 } else {
1332                     open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1333                 }
1334                 close(SAVEOUT);
1335                 select($selected), $selected= "" unless $selected eq "";
1336                 $piped= "";
1337             }
1338         }                       # CMD:
1339     $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1340         foreach $evalarg (@$post) {
1341           &eval;
1342         }
1343     }                           # if ($single || $signal)
1344     ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1345     ();
1346 }
1347
1348 # The following code may be executed now:
1349 # BEGIN {warn 4}
1350
1351 sub sub {
1352     my ($al, $ret, @ret) = "";
1353     if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1354         $al = " for $$sub";
1355     }
1356     local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1357     $#stack = $stack_depth;
1358     $stack[-1] = $single;
1359     $single &= 1;
1360     $single |= 4 if $stack_depth == $deep;
1361     ($frame & 4 
1362      ? ( print_lineinfo(' ' x ($stack_depth - 1), "in  "),
1363          # Why -1? But it works! :-(
1364          print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1365      : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1366     if (wantarray) {
1367         @ret = &$sub;
1368         $single |= $stack[$stack_depth--];
1369         ($frame & 4 
1370          ? ( print_lineinfo(' ' x $stack_depth, "out "), 
1371              print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1372          : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1373         if ($doret eq $stack_depth or $frame & 16) {
1374             local $\ = '';
1375             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1376             print $fh ' ' x $stack_depth if $frame & 16;
1377             print $fh "list context return from $sub:\n"; 
1378             dumpit($fh, \@ret );
1379             $doret = -2;
1380         }
1381         @ret;
1382     } else {
1383         if (defined wantarray) {
1384             $ret = &$sub;
1385         } else {
1386             &$sub; undef $ret;
1387         };
1388         $single |= $stack[$stack_depth--];
1389         ($frame & 4 
1390          ? (  print_lineinfo(' ' x $stack_depth, "out "),
1391               print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1392          : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1393         if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1394             local $\ = '';
1395             my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1396             print $fh (' ' x $stack_depth) if $frame & 16;
1397             print $fh (defined wantarray 
1398                          ? "scalar context return from $sub: " 
1399                          : "void context return from $sub\n");
1400             dumpit( $fh, $ret ) if defined wantarray;
1401             $doret = -2;
1402         }
1403         $ret;
1404     }
1405 }
1406
1407 ### The API section
1408
1409 ### Functions with multiple modes of failure die on error, the rest
1410 ### returns FALSE on error.
1411 ### User-interface functions cmd_* output error message.
1412
1413 ### Note all cmd_[a-zA-Z]'s require $line, $dblineno as first arguments
1414
1415 my %set = ( # 
1416         'pre580'        => {
1417                 'a'     => 'pre580_a', 
1418                 'A'     => 'pre580_null',
1419                 'b'     => 'pre580_b', 
1420                 'B'     => 'pre580_null',
1421                 'd'     => 'pre580_null',
1422                 'D'     => 'pre580_D',
1423                 'h'     => 'pre580_h',
1424                 'M'     => 'pre580_null',
1425                 'O'     => 'o',
1426                 'o'     => 'pre580_null',
1427                 'v'     => 'M',
1428                 'w'     => 'v',
1429                 'W'     => 'pre580_W',
1430         },
1431 );
1432
1433 sub cmd_wrapper {
1434         my $cmd      = shift;
1435         my $line     = shift;
1436         my $dblineno = shift;
1437
1438         # with this level of indirection we can wrap 
1439         # to old (pre580) or other command sets easily
1440         # 
1441         my $call = 'cmd_'.(
1442                 $set{$CommandSet}{$cmd} || $cmd
1443         );
1444         # print "rjsf: cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
1445
1446         return &$call($line, $dblineno);
1447 }
1448
1449 sub cmd_a {
1450         my $line   = shift || ''; # [.|line] expr
1451         my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
1452         if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
1453                 my ($lineno, $expr) = ($1, $2);
1454                 if (length $expr) {
1455                         if ($dbline[$lineno] == 0) {
1456                                 print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
1457                         } else {
1458                                 $had_breakpoints{$filename} |= 2;
1459                                 $dbline{$lineno} =~ s/\0[^\0]*//;
1460                                 $dbline{$lineno} .= "\0" . action($expr);
1461                         }
1462                 }
1463         } else {
1464                 print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
1465         }
1466 }
1467
1468 sub cmd_A {
1469         my $line   = shift || '';
1470         my $dbline = shift; $line =~ s/^\./$dbline/;
1471         if ($line eq '*') {
1472                 eval { &delete_action(); 1 } or print $OUT $@ and return;
1473         } elsif ($line =~ /^(\S.*)/) {
1474                 eval { &delete_action($1); 1 } or print $OUT $@ and return;
1475         } else {
1476                 print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
1477         }
1478 }
1479
1480 sub delete_action {
1481   my $i = shift;
1482   if (defined($i)) {
1483                 die "Line $i has no action .\n" if $dbline[$i] == 0;
1484                 $dbline{$i} =~ s/\0[^\0]*//; # \^a
1485                 delete $dbline{$i} if $dbline{$i} eq '';
1486         } else {
1487                 print $OUT "Deleting all actions...\n";
1488                 for my $file (keys %had_breakpoints) {
1489                         local *dbline = $main::{'_<' . $file};
1490                         my $max = $#dbline;
1491                         my $was;
1492                         for ($i = 1; $i <= $max ; $i++) {
1493                                         if (defined $dbline{$i}) {
1494                                                         $dbline{$i} =~ s/\0[^\0]*//;
1495                                                         delete $dbline{$i} if $dbline{$i} eq '';
1496                                         }
1497                                 unless ($had_breakpoints{$file} &= ~2) {
1498                                                 delete $had_breakpoints{$file};
1499                                 }
1500                         }
1501                 }
1502         }
1503 }
1504
1505 sub cmd_b {
1506         my $line   = shift; # [.|line] [cond]
1507         my $dbline = shift; $line =~ s/^\./$dbline/;
1508         if ($line =~ /^\s*$/) {
1509                 &cmd_b_line($dbline, 1);
1510         } elsif ($line =~ /^load\b\s*(.*)/) {
1511                 my $file = $1; $file =~ s/\s+$//;
1512                 &cmd_b_load($file);
1513         } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
1514                 my $cond = length $3 ? $3 : '1';
1515                 my ($subname, $break) = ($2, $1 eq 'postpone');
1516                 $subname =~ s/\'/::/g;
1517                 $subname = "${'package'}::" . $subname unless $subname =~ /::/;
1518                 $subname = "main".$subname if substr($subname,0,2) eq "::";
1519                 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
1520         } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) { 
1521                 $subname = $1;
1522                 $cond = length $2 ? $2 : '1';
1523                 &cmd_b_sub($subname, $cond);
1524         } elsif ($line =~ /^(\d*)\s*(.*)/) { 
1525                 $line = $1 || $dbline;
1526                 $cond = length $2 ? $2 : '1';
1527                 &cmd_b_line($line, $cond);
1528         } else {
1529                 print "confused by line($line)?\n";
1530         }
1531 }
1532
1533 sub break_on_load {
1534   my $file = shift;
1535   $break_on_load{$file} = 1;
1536   $had_breakpoints{$file} |= 1;
1537 }
1538
1539 sub report_break_on_load {
1540   sort keys %break_on_load;
1541 }
1542
1543 sub cmd_b_load {
1544   my $file = shift;
1545   my @files;
1546   {
1547     push @files, $file;
1548     push @files, $::INC{$file} if $::INC{$file};
1549     $file .= '.pm', redo unless $file =~ /\./;
1550   }
1551   break_on_load($_) for @files;
1552   @files = report_break_on_load;
1553   local $\ = '';
1554   local $" = ' ';
1555   print $OUT "Will stop on load of `@files'.\n";
1556 }
1557
1558 $filename_error = '';
1559
1560 sub breakable_line {
1561   my ($from, $to) = @_;
1562   my $i = $from;
1563   if (@_ >= 2) {
1564     my $delta = $from < $to ? +1 : -1;
1565     my $limit = $delta > 0 ? $#dbline : 1;
1566     $limit = $to if ($limit - $to) * $delta > 0;
1567     $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1568   }
1569   return $i unless $dbline[$i] == 0;
1570   my ($pl, $upto) = ('', '');
1571   ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1572   die "Line$pl $from$upto$filename_error not breakable\n";
1573 }
1574
1575 sub breakable_line_in_filename {
1576   my ($f) = shift;
1577   local *dbline = $main::{'_<' . $f};
1578   local $filename_error = " of `$f'";
1579   breakable_line(@_);
1580 }
1581
1582 sub break_on_line {
1583   my ($i, $cond) = @_;
1584   $cond = 1 unless @_ >= 2;
1585   my $inii = $i;
1586   my $after = '';
1587   my $pl = '';
1588   die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1589   $had_breakpoints{$filename} |= 1;
1590   if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1591   else { $dbline{$i} = $cond; }
1592 }
1593
1594 sub cmd_b_line {
1595   eval { break_on_line(@_); 1 } or do {
1596     local $\ = '';
1597     print $OUT $@ and return;
1598   };
1599 }
1600
1601 sub break_on_filename_line {
1602   my ($f, $i, $cond) = @_;
1603   $cond = 1 unless @_ >= 3;
1604   local *dbline = $main::{'_<' . $f};
1605   local $filename_error = " of `$f'";
1606   local $filename = $f;
1607   break_on_line($i, $cond);
1608 }
1609
1610 sub break_on_filename_line_range {
1611   my ($f, $from, $to, $cond) = @_;
1612   my $i = breakable_line_in_filename($f, $from, $to);
1613   $cond = 1 unless @_ >= 3;
1614   break_on_filename_line($f,$i,$cond);
1615 }
1616
1617 sub subroutine_filename_lines {
1618   my ($subname,$cond) = @_;
1619   # Filename below can contain ':'
1620   find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1621 }
1622
1623 sub break_subroutine {
1624   my $subname = shift;
1625   my ($file,$s,$e) = subroutine_filename_lines($subname) or
1626     die "Subroutine $subname not found.\n";
1627   $cond = 1 unless @_ >= 2;
1628   break_on_filename_line_range($file,$s,$e,@_);
1629 }
1630
1631 sub cmd_b_sub {
1632   my ($subname,$cond) = @_;
1633   $cond = 1 unless @_ >= 2;
1634   unless (ref $subname eq 'CODE') {
1635     $subname =~ s/\'/::/g;
1636     my $s = $subname;
1637     $subname = "${'package'}::" . $subname
1638       unless $subname =~ /::/;
1639     $subname = "CORE::GLOBAL::$s"
1640       if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1641     $subname = "main".$subname if substr($subname,0,2) eq "::";
1642   }
1643   eval { break_subroutine($subname,$cond); 1 } or do {
1644     local $\ = '';
1645     print $OUT $@ and return;
1646   }
1647 }
1648
1649 sub cmd_B {
1650         my $line   = ($_[0] =~ /^\./) ? $dbline : shift || ''; 
1651         my $dbline = shift; $line =~ s/^\./$dbline/;
1652         if ($line eq '*') {
1653                 eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
1654         } elsif ($line =~ /^(\S.*)/) {
1655                 eval { &delete_breakpoint($line || $dbline); 1 } or do {
1656                     local $\ = '';
1657                     print $OUT $@ and return;
1658                 };
1659         } else {
1660                 print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
1661         }
1662 }
1663
1664 sub delete_breakpoint {
1665   my $i = shift;
1666   if (defined($i)) {
1667           die "Line $i not breakable.\n" if $dbline[$i] == 0;
1668           $dbline{$i} =~ s/^[^\0]*//;
1669           delete $dbline{$i} if $dbline{$i} eq '';
1670   } else {
1671                   print $OUT "Deleting all breakpoints...\n";
1672                   for my $file (keys %had_breakpoints) {
1673                                         local *dbline = $main::{'_<' . $file};
1674                                         my $max = $#dbline;
1675                                         my $was;
1676                                         for ($i = 1; $i <= $max ; $i++) {
1677                                                         if (defined $dbline{$i}) {
1678                                                 $dbline{$i} =~ s/^[^\0]+//;
1679                                                 if ($dbline{$i} =~ s/^\0?$//) {
1680                                                                 delete $dbline{$i};
1681                                                 }
1682                                                         }
1683                                         }
1684                                         if (not $had_breakpoints{$file} &= ~1) {
1685                                                         delete $had_breakpoints{$file};
1686                                         }
1687                   }
1688                   undef %postponed;
1689                   undef %postponed_file;
1690                   undef %break_on_load;
1691         }
1692 }
1693
1694 sub cmd_stop {                  # As on ^C, but not signal-safy.
1695   $signal = 1;
1696 }
1697
1698 sub cmd_h {
1699         my $line   = shift || '';
1700         if ($line  =~ /^h\s*/) {
1701                 print_help($help);
1702         } elsif ($line =~ /^(\S.*)$/) { 
1703                         # support long commands; otherwise bogus errors
1704                         # happen when you ask for h on <CR> for example
1705                         my $asked = $1;                 # for proper errmsg
1706                         my $qasked = quotemeta($asked); # for searching
1707                         # XXX: finds CR but not <CR>
1708                         if ($help =~ /^<?(?:[IB]<)$qasked/m) {
1709                           while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
1710                             print_help($1);
1711                           }
1712                         } else {
1713                             print_help("B<$asked> is not a debugger command.\n");
1714                         }
1715         } else {
1716                         print_help($summary);
1717         }
1718 }
1719
1720 sub cmd_l {
1721         my $line = shift;
1722         $line =~ s/^-\s*$/-/;
1723         if ($line =~ /^(\$.*)/s) {
1724                 $evalarg = $2;
1725                 my ($s) = &eval;
1726                 print($OUT "Error: $@\n"), next CMD if $@;
1727                 $s = CvGV_name($s);
1728                 print($OUT "Interpreted as: $1 $s\n");
1729                 $line = "$1 $s";
1730                 &cmd_l($s);
1731         } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) { 
1732                 my $s = $subname = $1;
1733                 $subname =~ s/\'/::/;
1734                 $subname = $package."::".$subname 
1735                 unless $subname =~ /::/;
1736                 $subname = "CORE::GLOBAL::$s"
1737                 if not defined &$subname and $s !~ /::/
1738                          and defined &{"CORE::GLOBAL::$s"};
1739                 $subname = "main".$subname if substr($subname,0,2) eq "::";
1740                 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
1741                 $subrange = pop @pieces;
1742                 $file = join(':', @pieces);
1743                 if ($file ne $filename) {
1744                         print $OUT "Switching to file '$file'.\n"
1745                 unless $slave_editor;
1746                         *dbline = $main::{'_<' . $file};
1747                         $max = $#dbline;
1748                         $filename = $file;
1749                 }
1750                 if ($subrange) {
1751                         if (eval($subrange) < -$window) {
1752                 $subrange =~ s/-.*/+/;
1753                         }
1754                         $line = $subrange;
1755                         &cmd_l($subrange);
1756                 } else {
1757                         print $OUT "Subroutine $subname not found.\n";
1758                 }
1759         } elsif ($line =~ /^\s*$/) {
1760                 $incr = $window - 1;
1761                 $line = $start . '-' . ($start + $incr); 
1762                 &cmd_l($line);
1763         } elsif ($line =~ /^(\d*)\+(\d*)$/) { 
1764                 $start = $1 if $1;
1765                 $incr = $2;
1766                 $incr = $window - 1 unless $incr;
1767                 $line = $start . '-' . ($start + $incr); 
1768                 &cmd_l($line);  
1769         } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) { 
1770                 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
1771                 $end = $max if $end > $max;
1772                 $i = $2;
1773                 $i = $line if $i eq '.';
1774                 $i = 1 if $i < 1;
1775                 $incr = $end - $i;
1776                 if ($slave_editor) {
1777                         print $OUT "\032\032$filename:$i:0\n";
1778                         $i = $end;
1779                 } else {
1780                         for (; $i <= $end; $i++) {
1781                                 my ($stop,$action);
1782                                 ($stop,$action) = split(/\0/, $dbline{$i}) if
1783                                                 $dbline{$i};
1784                                                         $arrow = ($i==$line 
1785                                                 and $filename eq $filename_ini) 
1786                                         ?  '==>' 
1787                                                 : ($dbline[$i]+0 ? ':' : ' ') ;
1788                                 $arrow .= 'b' if $stop;
1789                                 $arrow .= 'a' if $action;
1790                                 print $OUT "$i$arrow\t", $dbline[$i];
1791                                 $i++, last if $signal;
1792                         }
1793                         print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
1794                 }
1795                 $start = $i; # remember in case they want more
1796                 $start = $max if $start > $max;
1797         }
1798 }
1799
1800 sub cmd_L {
1801         my $arg    = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
1802         my $action_wanted = ($arg =~ /a/) ? 1 : 0;
1803         my $break_wanted  = ($arg =~ /b/) ? 1 : 0;
1804         my $watch_wanted  = ($arg =~ /w/) ? 1 : 0;
1805
1806         if ($break_wanted or $action_wanted) {
1807                 for my $file (keys %had_breakpoints) {
1808                         local *dbline = $main::{'_<' . $file};
1809                         my $max = $#dbline;
1810                         my $was;
1811                         for ($i = 1; $i <= $max; $i++) {
1812                                 if (defined $dbline{$i}) {
1813                                         print $OUT "$file:\n" unless $was++;
1814                                         print $OUT " $i:\t", $dbline[$i];
1815                                         ($stop,$action) = split(/\0/, $dbline{$i});
1816                                         print $OUT "   break if (", $stop, ")\n"
1817                                                 if $stop and $break_wanted;
1818                                         print $OUT "   action:  ", $action, "\n"
1819                                                 if $action and $action_wanted;
1820                                         last if $signal;
1821                                 }
1822                         }
1823                 }
1824         }
1825         if (%postponed and $break_wanted) {
1826                 print $OUT "Postponed breakpoints in subroutines:\n";
1827                 my $subname;
1828                 for $subname (keys %postponed) {
1829                   print $OUT " $subname\t$postponed{$subname}\n";
1830                   last if $signal;
1831                 }
1832         }
1833         my @have = map { # Combined keys
1834                         keys %{$postponed_file{$_}}
1835         } keys %postponed_file;
1836         if (@have and ($break_wanted or $action_wanted)) {
1837                 print $OUT "Postponed breakpoints in files:\n";
1838                 my ($file, $line);
1839                 for $file (keys %postponed_file) {
1840                   my $db = $postponed_file{$file};
1841                   print $OUT " $file:\n";
1842                   for $line (sort {$a <=> $b} keys %$db) {
1843                         print $OUT "  $line:\n";
1844                         my ($stop,$action) = split(/\0/, $$db{$line});
1845                         print $OUT "    break if (", $stop, ")\n"
1846                           if $stop and $break_wanted;
1847                         print $OUT "    action:  ", $action, "\n"
1848                           if $action and $action_wanted;
1849                         last if $signal;
1850                   }
1851                   last if $signal;
1852                 }
1853         }
1854   if (%break_on_load and $break_wanted) {
1855                 print $OUT "Breakpoints on load:\n";
1856                 my $file;
1857                 for $file (keys %break_on_load) {
1858                   print $OUT " $file\n";
1859                   last if $signal;
1860                 }
1861   }
1862   if ($watch_wanted) {
1863         if ($trace & 2) {
1864                 print $OUT "Watch-expressions:\n" if @to_watch;
1865                 for my $expr (@to_watch) {
1866                         print $OUT " $expr\n";
1867                         last if $signal;
1868                 }
1869         }
1870   }
1871 }
1872
1873 sub cmd_M {
1874         &list_modules();
1875 }
1876
1877 sub cmd_o {
1878         my $opt      = shift || ''; # opt[=val]
1879         if ($opt =~ /^(\S.*)/) {
1880                 &parse_options($1);
1881         } else {
1882                 for (@options) {
1883                         &dump_option($_);
1884                 }
1885         }
1886 }
1887
1888 sub cmd_v {
1889         my $line = shift;
1890
1891         if ($line =~ /^(\d*)$/) {
1892                 $incr = $window - 1;
1893                 $start = $1 if $1;
1894                 $start -= $preview;
1895                 $line = $start . '-' . ($start + $incr);
1896                 &cmd_l($line);
1897         }
1898 }
1899
1900 sub cmd_w {
1901         my $expr     = shift || '';
1902         if ($expr =~ /^(\S.*)/) {
1903                 push @to_watch, $expr;
1904                 $evalarg = $expr;
1905                 my ($val) = &eval;
1906                 $val = (defined $val) ? "'$val'" : 'undef' ;
1907                 push @old_watch, $val;
1908                 $trace |= 2;
1909         } else {
1910                 print $OUT "Adding a watch-expression requires an expression\n"; # hint
1911         }
1912 }
1913
1914 sub cmd_W {
1915         my $expr     = shift || '';
1916         if ($expr eq '*') {
1917                 $trace &= ~2;
1918                 print $OUT "Deleting all watch expressions ...\n";
1919                 @to_watch = @old_watch = ();
1920         } elsif ($expr =~ /^(\S.*)/) {
1921                 my $i_cnt = 0;
1922                 foreach (@to_watch) {
1923                         my $val = $to_watch[$i_cnt];
1924                         if ($val eq $expr) { # =~ m/^\Q$i$/) {
1925                                 splice(@to_watch, $i_cnt, 1);
1926                         }
1927                         $i_cnt++;
1928                 }
1929         } else {
1930                 print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
1931         }
1932 }
1933
1934 ### END of the API section
1935
1936 sub save {
1937     @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1938     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1939 }
1940
1941 sub print_lineinfo {
1942   resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1943   local $\ = '';
1944   local $, = '';
1945   print $LINEINFO @_;
1946 }
1947
1948 # The following takes its argument via $evalarg to preserve current @_
1949
1950 sub postponed_sub {
1951   my $subname = shift;
1952   if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1953     my $offset = $1 || 0;
1954     # Filename below can contain ':'
1955     my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1956     if ($i) {
1957       $i += $offset;
1958       local *dbline = $main::{'_<' . $file};
1959       local $^W = 0;            # != 0 is magical below
1960       $had_breakpoints{$file} |= 1;
1961       my $max = $#dbline;
1962       ++$i until $dbline[$i] != 0 or $i >= $max;
1963       $dbline{$i} = delete $postponed{$subname};
1964     } else {
1965       local $\ = '';
1966       print $OUT "Subroutine $subname not found.\n";
1967     }
1968     return;
1969   }
1970   elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1971   #print $OUT "In postponed_sub for `$subname'.\n";
1972 }
1973
1974 sub postponed {
1975   if ($ImmediateStop) {
1976     $ImmediateStop = 0;
1977     $signal = 1;
1978   }
1979   return &postponed_sub
1980     unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1981   # Cannot be done before the file is compiled
1982   local *dbline = shift;
1983   my $filename = $dbline;
1984   $filename =~ s/^_<//;
1985   local $\ = '';
1986   $signal = 1, print $OUT "'$filename' loaded...\n"
1987     if $break_on_load{$filename};
1988   print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1989   return unless $postponed_file{$filename};
1990   $had_breakpoints{$filename} |= 1;
1991   #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1992   my $key;
1993   for $key (keys %{$postponed_file{$filename}}) {
1994     $dbline{$key} = ${$postponed_file{$filename}}{$key};
1995   }
1996   delete $postponed_file{$filename};
1997 }
1998
1999 sub dumpit {
2000     local ($savout) = select(shift);
2001     my $osingle = $single;
2002     my $otrace = $trace;
2003     $single = $trace = 0;
2004     local $frame = 0;
2005     local $doret = -2;
2006     unless (defined &main::dumpValue) {
2007         do 'dumpvar.pl';
2008     }
2009     if (defined &main::dumpValue) {
2010         local $\ = '';
2011         local $, = '';
2012         local $" = ' ';
2013         my $v = shift;
2014         my $maxdepth = shift || $option{dumpDepth};
2015         $maxdepth = -1 unless defined $maxdepth;   # -1 means infinite depth
2016         &main::dumpValue($v, $maxdepth);
2017     } else {
2018         local $\ = '';
2019         print $OUT "dumpvar.pl not available.\n";
2020     }
2021     $single = $osingle;
2022     $trace = $otrace;
2023     select ($savout);    
2024 }
2025
2026 # Tied method do not create a context, so may get wrong message:
2027
2028 sub print_trace {
2029   local $\ = '';
2030   my $fh = shift;
2031   resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
2032   my @sub = dump_trace($_[0] + 1, $_[1]);
2033   my $short = $_[2];            # Print short report, next one for sub name
2034   my $s;
2035   for ($i=0; $i <= $#sub; $i++) {
2036     last if $signal;
2037     local $" = ', ';
2038     my $args = defined $sub[$i]{args} 
2039     ? "(@{ $sub[$i]{args} })"
2040       : '' ;
2041     $args = (substr $args, 0, $maxtrace - 3) . '...' 
2042       if length $args > $maxtrace;
2043     my $file = $sub[$i]{file};
2044     $file = $file eq '-e' ? $file : "file `$file'" unless $short;
2045     $s = $sub[$i]{sub};
2046     $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;    
2047     if ($short) {
2048       my $sub = @_ >= 4 ? $_[3] : $s;
2049       print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
2050     } else {
2051       print $fh "$sub[$i]{context} = $s$args" .
2052         " called from $file" . 
2053           " line $sub[$i]{line}\n";
2054     }
2055   }
2056 }
2057
2058 sub dump_trace {
2059   my $skip = shift;
2060   my $count = shift || 1e9;
2061   $skip++;
2062   $count += $skip;
2063   my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
2064   my $nothard = not $frame & 8;
2065   local $frame = 0;             # Do not want to trace this.
2066   my $otrace = $trace;
2067   $trace = 0;
2068   for ($i = $skip; 
2069        $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); 
2070        $i++) {
2071     @a = ();
2072     for $arg (@args) {
2073       my $type;
2074       if (not defined $arg) {
2075         push @a, "undef";
2076       } elsif ($nothard and tied $arg) {
2077         push @a, "tied";
2078       } elsif ($nothard and $type = ref $arg) {
2079         push @a, "ref($type)";
2080       } else {
2081         local $_ = "$arg";      # Safe to stringify now - should not call f().
2082         s/([\'\\])/\\$1/g;
2083         s/(.*)/'$1'/s
2084           unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
2085         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
2086         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
2087         push(@a, $_);
2088       }
2089     }
2090     $context = $context ? '@' : (defined $context ? "\$" : '.');
2091     $args = $h ? [@a] : undef;
2092     $e =~ s/\n\s*\;\s*\Z// if $e;
2093     $e =~ s/([\\\'])/\\$1/g if $e;
2094     if ($r) {
2095       $sub = "require '$e'";
2096     } elsif (defined $r) {
2097       $sub = "eval '$e'";
2098     } elsif ($sub eq '(eval)') {
2099       $sub = "eval {...}";
2100     }
2101     push(@sub, {context => $context, sub => $sub, args => $args,
2102                 file => $file, line => $line});
2103     last if $signal;
2104   }
2105   $trace = $otrace;
2106   @sub;
2107 }
2108
2109 sub action {
2110     my $action = shift;
2111     while ($action =~ s/\\$//) {
2112         #print $OUT "+ ";
2113         #$action .= "\n";
2114         $action .= &gets;
2115     }
2116     $action;
2117 }
2118
2119 sub unbalanced { 
2120     # i hate using globals!
2121     $balanced_brace_re ||= qr{ 
2122         ^ \{
2123               (?:
2124                  (?> [^{}] + )              # Non-parens without backtracking
2125                |
2126                  (??{ $balanced_brace_re }) # Group with matching parens
2127               ) *
2128           \} $
2129    }x;
2130    return $_[0] !~ m/$balanced_brace_re/;
2131 }
2132
2133 sub gets {
2134     &readline("cont: ");
2135 }
2136
2137 sub system {
2138     # We save, change, then restore STDIN and STDOUT to avoid fork() since
2139     # some non-Unix systems can do system() but have problems with fork().
2140     open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
2141     open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
2142     open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
2143     open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
2144
2145     # XXX: using csh or tcsh destroys sigint retvals!
2146     system(@_);
2147     open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
2148     open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
2149     close(SAVEIN); 
2150     close(SAVEOUT);
2151
2152
2153     # most of the $? crud was coping with broken cshisms
2154     if ($? >> 8) {
2155         &warn("(Command exited ", ($? >> 8), ")\n");
2156     } elsif ($?) { 
2157         &warn( "(Command died of SIG#",  ($? & 127),
2158             (($? & 128) ? " -- core dumped" : "") , ")", "\n");
2159     } 
2160
2161     return $?;
2162
2163 }
2164
2165 sub setterm {
2166     local $frame = 0;
2167     local $doret = -2;
2168     eval { require Term::ReadLine } or die $@;
2169     if ($notty) {
2170         if ($tty) {
2171             my ($i, $o) = split $tty, /,/;
2172             $o = $i unless defined $o;
2173             open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
2174             open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
2175             $IN = \*IN;
2176             $OUT = \*OUT;
2177             my $sel = select($OUT);
2178             $| = 1;
2179             select($sel);
2180         } else {
2181             eval "require Term::Rendezvous;" or die;
2182             my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
2183             my $term_rv = new Term::Rendezvous $rv;
2184             $IN = $term_rv->IN;
2185             $OUT = $term_rv->OUT;
2186         }
2187     }
2188     if ($term_pid eq '-1') {            # In a TTY with another debugger
2189         resetterm(2);
2190     }
2191     if (!$rl) {
2192         $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2193     } else {
2194         $term = new Term::ReadLine 'perldb', $IN, $OUT;
2195
2196         $rl_attribs = $term->Attribs;
2197         $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' 
2198           if defined $rl_attribs->{basic_word_break_characters} 
2199             and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2200         $rl_attribs->{special_prefixes} = '$@&%';
2201         $rl_attribs->{completer_word_break_characters} .= '$@&%';
2202         $rl_attribs->{completion_function} = \&db_complete; 
2203     }
2204     $LINEINFO = $OUT unless defined $LINEINFO;
2205     $lineinfo = $console unless defined $lineinfo;
2206     $term->MinLine(2);
2207     if ($term->Features->{setHistory} and "@hist" ne "?") {
2208       $term->SetHistory(@hist);
2209     }
2210     ornaments($ornaments) if defined $ornaments;
2211     $term_pid = $$;
2212 }
2213
2214 # Example get_fork_TTY functions
2215 sub xterm_get_fork_TTY {
2216   (my $name = $0) =~ s,^.*[/\\],,s;
2217   open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2218  sleep 10000000' |];
2219   my $tty = <XT>;
2220   chomp $tty;
2221   $pidprompt = '';              # Shown anyway in titlebar
2222   return $tty;
2223 }
2224
2225 # This example function resets $IN, $OUT itself
2226 sub os2_get_fork_TTY {
2227   local $^F = 40;                       # XXXX Fixme!
2228   local $\ = '';
2229   my ($in1, $out1, $in2, $out2);
2230   # Having -d in PERL5OPT would lead to a disaster...
2231   local $ENV{PERL5OPT} = $ENV{PERL5OPT}    if $ENV{PERL5OPT};
2232   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b//  if $ENV{PERL5OPT};
2233   $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2234   print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2235   (my $name = $0) =~ s,^.*[/\\],,s;
2236   my @args;
2237   if ( pipe $in1, $out1 and pipe $in2, $out2
2238        # system P_SESSION will fail if there is another process
2239        # in the same session with a "dependent" asynchronous child session.
2240        and @args = ($rl, fileno $in1, fileno $out2,
2241                     "Daughter Perl debugger $pids $name") and
2242        (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2243 use OS2::Process;
2244
2245 my ($rl, $in) = (shift, shift);         # Read from $in and pass through
2246 set_title pop;
2247 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2248   open IN, '<&=$in' or die "open <&=$in: \$!";
2249   \$| = 1; print while sysread IN, \$_, 1<<16;
2250 EOS
2251
2252 my $out = shift;
2253 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2254 select OUT;    $| = 1;
2255 require Term::ReadKey if $rl;
2256 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd.  Pipe is automatically nodelay...
2257 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2258 ES
2259          or warn "system P_SESSION: $!, $^E" and 0)
2260         and close $in1 and close $out2 ) {
2261       $pidprompt = '';                  # Shown anyway in titlebar
2262       reset_IN_OUT($in2, $out1);
2263       $tty = '*reset*';
2264       return '';                        # Indicate that reset_IN_OUT is called
2265    }
2266    return;
2267 }
2268
2269 sub create_IN_OUT {     # Create a window with IN/OUT handles redirected there
2270     my $in = &get_fork_TTY if defined &get_fork_TTY;
2271     $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2272     if (not defined $in) {
2273       my $why = shift;
2274       print_help(<<EOP) if $why == 1;
2275 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2276 EOP
2277       print_help(<<EOP) if $why == 2;
2278 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2279   This may be an asynchronous session, so the parent debugger may be active.
2280 EOP
2281       print_help(<<EOP) if $why != 4;
2282   Since two debuggers fight for the same TTY, input is severely entangled.
2283
2284 EOP
2285       print_help(<<EOP);
2286   I know how to switch the output to a different window in xterms
2287   and OS/2 consoles only.  For a manual switch, put the name of the created I<TTY>
2288   in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2289
2290   On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2291   by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2292
2293 EOP
2294     } elsif ($in ne '') {
2295       TTY($in);
2296     } else {
2297       $console = '';            # Indicate no need to open-from-the-console 
2298     }
2299     undef $fork_TTY;
2300 }
2301
2302 sub resetterm {                 # We forked, so we need a different TTY
2303     my $in = shift;
2304     my $systemed = $in > 1 ? '-' : '';
2305     if ($pids) {
2306       $pids =~ s/\]/$systemed->$$]/;
2307     } else {
2308       $pids = "[$term_pid->$$]";
2309     }
2310     $pidprompt = $pids;
2311     $term_pid = $$;
2312     return unless $CreateTTY & $in;
2313     create_IN_OUT($in);
2314 }
2315
2316 sub readline {
2317   local $.;
2318   if (@typeahead) {
2319     my $left = @typeahead;
2320     my $got = shift @typeahead;
2321     local $\ = '';
2322     print $OUT "auto(-$left)", shift, $got, "\n";
2323     $term->AddHistory($got) 
2324       if length($got) > 1 and defined $term->Features->{addHistory};
2325     return $got;
2326   }
2327   local $frame = 0;
2328   local $doret = -2;
2329   while (@cmdfhs) {
2330     my $line = CORE::readline($cmdfhs[-1]);
2331     defined $line ? (print $OUT ">> $line" and return $line)
2332                   : close pop @cmdfhs;
2333   }
2334   if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2335     $OUT->write(join('', @_));
2336     my $stuff;
2337     $IN->recv( $stuff, 2048 );  # XXX: what's wrong with sysread?
2338     $stuff;
2339   }
2340   else {
2341     $term->readline(@_);
2342   }
2343 }
2344
2345 sub dump_option {
2346     my ($opt, $val)= @_;
2347     $val = option_val($opt,'N/A');
2348     $val =~ s/([\\\'])/\\$1/g;
2349     printf $OUT "%20s = '%s'\n", $opt, $val;
2350 }
2351
2352 sub option_val {
2353     my ($opt, $default)= @_;
2354     my $val;
2355     if (defined $optionVars{$opt}
2356         and defined ${$optionVars{$opt}}) {
2357         $val = ${$optionVars{$opt}};
2358     } elsif (defined $optionAction{$opt}
2359         and defined &{$optionAction{$opt}}) {
2360         $val = &{$optionAction{$opt}}();
2361     } elsif (defined $optionAction{$opt}
2362              and not defined $option{$opt}
2363              or defined $optionVars{$opt}
2364              and not defined ${$optionVars{$opt}}) {
2365         $val = $default;
2366     } else {
2367         $val = $option{$opt};
2368     }
2369     $val = $default unless defined $val;
2370     $val
2371 }
2372
2373 sub parse_options {
2374     local($_)= @_;
2375     local $\ = '';
2376     # too dangerous to let intuitive usage overwrite important things
2377     # defaultion should never be the default
2378     my %opt_needs_val = map { ( $_ => 1 ) } qw{
2379         dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2380         pager quote ReadLine recallCommand RemotePort ShellBang TTY
2381     };
2382     while (length) {
2383         my $val_defaulted;
2384         s/^\s+// && next;
2385         s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2386         my ($opt,$sep) = ($1,$2);
2387         my $val;
2388         if ("?" eq $sep) {
2389             print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2390               if /^\S/;
2391             #&dump_option($opt);
2392         } elsif ($sep !~ /\S/) {
2393             $val_defaulted = 1;
2394             $val = "1";  #  this is an evil default; make 'em set it!
2395         } elsif ($sep eq "=") {
2396             if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { 
2397                 my $quote = $1;
2398                 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2399             } else { 
2400                 s/^(\S*)//;
2401             $val = $1;
2402                 print OUT qq(Option better cleared using $opt=""\n)
2403                     unless length $val;
2404             }
2405
2406         } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2407             my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2408             s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2409               print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2410             ($val = $1) =~ s/\\([\\$end])/$1/g;
2411         }
2412
2413         my $option;
2414         my $matches = grep( /^\Q$opt/  && ($option = $_),  @options  )
2415                    || grep( /^\Q$opt/i && ($option = $_),  @options  );
2416
2417         print($OUT "Unknown option `$opt'\n"), next     unless $matches;
2418         print($OUT "Ambiguous option `$opt'\n"), next   if $matches > 1;
2419
2420        if ($opt_needs_val{$option} && $val_defaulted) {
2421                          my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
2422             print $OUT "Option `$opt' is non-boolean.  Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
2423             next;
2424         } 
2425
2426         $option{$option} = $val if defined $val;
2427
2428         eval qq{
2429                 local \$frame = 0; 
2430                 local \$doret = -2; 
2431                 require '$optionRequire{$option}';
2432                 1;
2433          } || die  # XXX: shouldn't happen
2434             if  defined $optionRequire{$option}     &&
2435                 defined $val;
2436
2437         ${$optionVars{$option}} = $val      
2438             if  defined $optionVars{$option}        &&
2439                 defined $val;
2440
2441         &{$optionAction{$option}} ($val)    
2442             if defined $optionAction{$option}       &&
2443                defined &{$optionAction{$option}}    &&
2444                defined $val;
2445
2446         # Not $rcfile
2447         dump_option($option)    unless $OUT eq \*STDERR; 
2448     }
2449 }
2450
2451 sub set_list {
2452   my ($stem,@list) = @_;
2453   my $val;
2454   $ENV{"${stem}_n"} = @list;
2455   for $i (0 .. $#list) {
2456     $val = $list[$i];
2457     $val =~ s/\\/\\\\/g;
2458     $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2459     $ENV{"${stem}_$i"} = $val;
2460   }
2461 }
2462
2463 sub get_list {
2464   my $stem = shift;
2465   my @list;
2466   my $n = delete $ENV{"${stem}_n"};
2467   my $val;
2468   for $i (0 .. $n - 1) {
2469     $val = delete $ENV{"${stem}_$i"};
2470     $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2471     push @list, $val;
2472   }
2473   @list;
2474 }
2475
2476 sub catch {
2477     $signal = 1;
2478     return;                     # Put nothing on the stack - malloc/free land!
2479 }
2480
2481 sub warn {
2482     my($msg)= join("",@_);
2483     $msg .= ": $!\n" unless $msg =~ /\n$/;
2484     local $\ = '';
2485     print $OUT $msg;
2486 }
2487
2488 sub reset_IN_OUT {
2489     my $switch_li = $LINEINFO eq $OUT;
2490     if ($term and $term->Features->{newTTY}) {
2491       ($IN, $OUT) = (shift, shift);
2492       $term->newTTY($IN, $OUT);
2493     } elsif ($term) {
2494         &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2495     } else {
2496       ($IN, $OUT) = (shift, shift);
2497     }
2498     my $o = select $OUT;
2499     $| = 1;
2500     select $o;
2501     $LINEINFO = $OUT if $switch_li;
2502 }
2503
2504 sub TTY {
2505     if (@_ and $term and $term->Features->{newTTY}) {
2506       my ($in, $out) = shift;
2507       if ($in =~ /,/) {
2508         ($in, $out) = split /,/, $in, 2;
2509       } else {
2510         $out = $in;
2511       }
2512       open IN, $in or die "cannot open `$in' for read: $!";
2513       open OUT, ">$out" or die "cannot open `$out' for write: $!";
2514       reset_IN_OUT(\*IN,\*OUT);
2515       return $tty = $in;
2516     }
2517     &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2518     # Useful if done through PERLDB_OPTS:
2519     $console = $tty = shift if @_;
2520     $tty or $console;
2521 }
2522
2523 sub noTTY {
2524     if ($term) {
2525         &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2526     }
2527     $notty = shift if @_;
2528     $notty;
2529 }
2530
2531 sub ReadLine {
2532     if ($term) {
2533         &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2534     }
2535     $rl = shift if @_;
2536     $rl;
2537 }
2538
2539 sub RemotePort {
2540     if ($term) {
2541         &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2542     }
2543     $remoteport = shift if @_;
2544     $remoteport;
2545 }
2546
2547 sub tkRunning {
2548     if (${$term->Features}{tkRunning}) {
2549         return $term->tkRunning(@_);
2550     } else {
2551         local $\ = '';
2552         print $OUT "tkRunning not supported by current ReadLine package.\n";
2553         0;
2554     }
2555 }
2556
2557 sub NonStop {
2558     if ($term) {
2559         &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2560     }
2561     $runnonstop = shift if @_;
2562     $runnonstop;
2563 }
2564
2565 sub pager {
2566     if (@_) {
2567         $pager = shift;
2568         $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2569     }
2570     $pager;
2571 }
2572
2573 sub shellBang {
2574     if (@_) {
2575         $sh = quotemeta shift;
2576         $sh .= "\\b" if $sh =~ /\w$/;
2577     }
2578     $psh = $sh;
2579     $psh =~ s/\\b$//;
2580     $psh =~ s/\\(.)/$1/g;
2581     $psh;
2582 }
2583
2584 sub ornaments {
2585   if (defined $term) {
2586     local ($warnLevel,$dieLevel) = (0, 1);
2587     return '' unless $term->Features->{ornaments};
2588     eval { $term->ornaments(@_) } || '';
2589   } else {
2590     $ornaments = shift;
2591   }
2592 }
2593
2594 sub recallCommand {
2595     if (@_) {
2596         $rc = quotemeta shift;
2597         $rc .= "\\b" if $rc =~ /\w$/;
2598     }
2599     $prc = $rc;
2600     $prc =~ s/\\b$//;
2601     $prc =~ s/\\(.)/$1/g;
2602     $prc;
2603 }
2604
2605 sub LineInfo {
2606     return $lineinfo unless @_;
2607     $lineinfo = shift;
2608     my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2609     $slave_editor = ($stream =~ /^\|/);
2610     open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2611     $LINEINFO = \*LINEINFO;
2612     my $save = select($LINEINFO);
2613     $| = 1;
2614     select($save);
2615     $lineinfo;
2616 }
2617
2618 sub list_modules { # versions
2619   my %version;
2620   my $file;
2621   for (keys %INC) {
2622     $file = $_;
2623     s,\.p[lm]$,,i ;
2624     s,/,::,g ;
2625     s/^perl5db$/DB/;
2626     s/^Term::ReadLine::readline$/readline/;
2627     if (defined ${ $_ . '::VERSION' }) {
2628       $version{$file} = "${ $_ . '::VERSION' } from ";
2629     } 
2630     $version{$file} .= $INC{$file};
2631   }
2632   dumpit($OUT,\%version);
2633 }
2634
2635 sub sethelp {
2636     # XXX: make sure there are tabs between the command and explanation,
2637     #      or print_help will screw up your formatting if you have
2638     #      eeevil ornaments enabled.  This is an insane mess.
2639
2640     $help = "
2641 Help is currently only available for the new 580 CommandSet, 
2642 if you really want old behaviour, presumably you know what 
2643 you're doing ?-)
2644
2645 B<T>            Stack trace.
2646 B<s> [I<expr>]  Single step [in I<expr>].
2647 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
2648 <B<CR>>         Repeat last B<n> or B<s> command.
2649 B<r>            Return from current subroutine.
2650 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
2651                 at the specified position.
2652 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
2653 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
2654 B<l> I<line>            List single I<line>.
2655 B<l> I<subname> List first window of lines from subroutine.
2656 B<l> I<\$var>           List first window of lines from subroutine referenced by I<\$var>.
2657 B<l>            List next window of lines.
2658 B<->            List previous window of lines.
2659 B<v> [I<line>]  View window around I<line>.
2660 B<.>            Return to the executed line.
2661 B<f> I<filename>        Switch to viewing I<filename>. File must be already loaded.
2662                 I<filename> may be either the full name of the file, or a regular
2663                 expression matching the full file name:
2664                 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2665                 Evals (with saved bodies) are considered to be filenames:
2666                 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2667                 (in the order of execution).
2668 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
2669 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
2670 B<L> [I<a|b|w>]         List actions and or breakpoints and or watch-expressions.
2671 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2672 B<t>            Toggle trace mode.
2673 B<t> I<expr>            Trace through execution of I<expr>.
2674 B<b>            Sets breakpoint on current line)
2675 B<b> [I<line>] [I<condition>]
2676                 Set breakpoint; I<line> defaults to the current execution line;
2677                 I<condition> breaks if it evaluates to true, defaults to '1'.
2678 B<b> I<subname> [I<condition>]
2679                 Set breakpoint at first line of subroutine.
2680 B<b> I<\$var>           Set breakpoint at first line of subroutine referenced by I<\$var>.
2681 B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
2682 B<b> B<postpone> I<subname> [I<condition>]
2683                 Set breakpoint at first line of subroutine after 
2684                 it is compiled.
2685 B<b> B<compile> I<subname>
2686                 Stop after the subroutine is compiled.
2687 B<B> [I<line>]  Delete the breakpoint for I<line>.
2688 B<B> I<*>             Delete all breakpoints.
2689 B<a> [I<line>] I<command>
2690                 Set an action to be done before the I<line> is executed;
2691                 I<line> defaults to the current execution line.
2692                 Sequence is: check for breakpoint/watchpoint, print line
2693                 if necessary, do action, prompt user if necessary,
2694                 execute line.
2695 B<a>            Does nothing
2696 B<A> [I<line>]  Delete the action for I<line>.
2697 B<A> I<*>             Delete all actions.
2698 B<w> I<expr>            Add a global watch-expression.
2699 B<w>                    Does nothing
2700 B<W> I<expr>            Delete a global watch-expression.
2701 B<W> I<*>             Delete all watch-expressions.
2702 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2703                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2704 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
2705 B<x> I<expr>            Evals expression in list context, dumps the result.
2706 B<m> I<expr>            Evals expression in list context, prints methods callable
2707                 on the first element of the result.
2708 B<m> I<class>           Prints methods callable via the given class.
2709 B<M>            Show versions of loaded modules.
2710
2711 B<<> ?                  List Perl commands to run before each prompt.
2712 B<<> I<expr>            Define Perl command to run before each prompt.
2713 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
2714 B<>> ?                  List Perl commands to run after each prompt.
2715 B<>> I<expr>            Define Perl command to run after each prompt.
2716 B<>>B<>> I<expr>                Add to the list of Perl commands to run after each prompt.
2717 B<{> I<db_command>      Define debugger command to run before each prompt.
2718 B<{> ?                  List debugger commands to run before each prompt.
2719 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
2720 B<$prc> I<number>       Redo a previous command (default previous command).
2721 B<$prc> I<-number>      Redo number'th-to-last command.
2722 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
2723                 See 'B<O> I<recallCommand>' too.
2724 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2725   . ( $rc eq $sh ? "" : "
2726 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2727                 See 'B<O> I<shellBang>' too.
2728 B<@>I<file>             Execute I<file> containing debugger commands (may nest).
2729 B<H> I<-number> Display last number commands (default all).
2730 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
2731 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
2732 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2733 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
2734 I<command>              Execute as a perl statement in current package.
2735 B<R>            Pure-man-restart of debugger, some of debugger state
2736                 and command-line options may be lost.
2737                 Currently the following settings are preserved:
2738                 history, breakpoints and actions, debugger B<O>ptions 
2739                 and the following command-line options: I<-w>, I<-I>, I<-e>.
2740
2741 B<o> [I<opt>] ...       Set boolean option to true
2742 B<o> [I<opt>B<?>]       Query options
2743 B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... 
2744                 Set options.  Use quotes in spaces in value.
2745     I<recallCommand>, I<ShellBang>      chars used to recall command or spawn shell;
2746     I<pager>                    program for output of \"|cmd\";
2747     I<tkRunning>                        run Tk while prompting (with ReadLine);
2748     I<signalLevel> I<warnLevel> I<dieLevel>     level of verbosity;
2749     I<inhibit_exit>             Allows stepping off the end of the script.
2750     I<ImmediateStop>            Debugger should stop as early as possible.
2751     I<RemotePort>                       Remote hostname:port for remote debugging
2752   The following options affect what happens with B<V>, B<X>, and B<x> commands:
2753     I<arrayDepth>, I<hashDepth>         print only first N elements ('' for all);
2754     I<compactDump>, I<veryCompact>      change style of array and hash dump;
2755     I<globPrint>                        whether to print contents of globs;
2756     I<DumpDBFiles>              dump arrays holding debugged files;
2757     I<DumpPackages>             dump symbol tables of packages;
2758     I<DumpReused>                       dump contents of \"reused\" addresses;
2759     I<quote>, I<HighBit>, I<undefPrint>         change style of string dump;
2760     I<bareStringify>            Do not print the overload-stringified value;
2761   Other options include:
2762     I<PrintRet>         affects printing of return value after B<r> command,
2763     I<frame>            affects printing messages on subroutine entry/exit.
2764     I<AutoTrace>        affects printing messages on possible breaking points.
2765     I<maxTraceLen>      gives max length of evals/args listed in stack trace.
2766     I<ornaments>        affects screen appearance of the command line.
2767     I<CreateTTY>        bits control attempts to create a new TTY on events:
2768                         1: on fork()    2: debugger is started inside debugger
2769                         4: on startup
2770         During startup options are initialized from \$ENV{PERLDB_OPTS}.
2771         You can put additional initialization options I<TTY>, I<noTTY>,
2772         I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2773         `B<R>' after you set them).
2774
2775 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
2776 B<h>            Summary of debugger commands.
2777 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
2778 B<h h>          Long help for debugger commands
2779 B<$doccmd> I<manpage>   Runs the external doc viewer B<$doccmd> command on the 
2780                 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2781                 Set B<\$DB::doccmd> to change viewer.
2782
2783 Type `|h h' for a paged display if this was too hard to read.
2784
2785 "; # Fix balance of vi % matching: }}}}
2786
2787     #  note: tabs in the following section are not-so-helpful
2788     $summary = <<"END_SUM";
2789 I<List/search source lines:>               I<Control script execution:>
2790   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
2791   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
2792   B<v> [I<line>]    View around line            B<n> [I<expr>]    Next, steps over subs
2793   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
2794   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
2795   B<M>           Show module versions        B<c> [I<ln>|I<sub>]  Continue until position
2796 I<Debugger controls:>                        B<L>           List break/watch/actions
2797   B<o> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
2798   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2799   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<B> I<ln|*>      Delete a/all breakpoints
2800   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
2801   B<=> [I<a> I<val>]   Define/list an alias        B<A> I<ln|*>      Delete a/all actions
2802   B<h> [I<db_cmd>]  Get help on command         B<w> I<expr>      Add a watch expression
2803   B<h h>         Complete help page          B<W> I<expr|*>    Delete a/all watch expressions
2804   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2805   B<q> or B<^D>     Quit                        B<R>           Attempt a restart
2806 I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2807   B<x>|B<m> I<expr>       Evals expr in list context, dumps the result or lists methods.
2808   B<p> I<expr>         Print expression (uses script's current package).
2809   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
2810   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
2811   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
2812 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2813 END_SUM
2814                                 # ')}}; # Fix balance of vi % matching
2815
2816         # and this is really numb...
2817         $pre580_help = "
2818 B<T>            Stack trace.
2819 B<s> [I<expr>]  Single step [in I<expr>].
2820 B<n> [I<expr>]  Next, steps over subroutine calls [in I<expr>].
2821 <B<CR>>         Repeat last B<n> or B<s> command.
2822 B<r>            Return from current subroutine.
2823 B<c> [I<line>|I<sub>]   Continue; optionally inserts a one-time-only breakpoint
2824                 at the specified position.
2825 B<l> I<min>B<+>I<incr>  List I<incr>+1 lines starting at I<min>.
2826 B<l> I<min>B<->I<max>   List lines I<min> through I<max>.
2827 B<l> I<line>            List single I<line>.
2828 B<l> I<subname> List first window of lines from subroutine.
2829 B<l> I<\$var>           List first window of lines from subroutine referenced by I<\$var>.
2830 B<l>            List next window of lines.
2831 B<->            List previous window of lines.
2832 B<w> [I<line>]  List window around I<line>.
2833 B<.>            Return to the executed line.
2834 B<f> I<filename>        Switch to viewing I<filename>. File must be already loaded.
2835                 I<filename> may be either the full name of the file, or a regular
2836                 expression matching the full file name:
2837                 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2838                 Evals (with saved bodies) are considered to be filenames:
2839                 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2840                 (in the order of execution).
2841 B</>I<pattern>B</>      Search forwards for I<pattern>; final B</> is optional.
2842 B<?>I<pattern>B<?>      Search backwards for I<pattern>; final B<?> is optional.
2843 B<L>            List all breakpoints and actions.
2844 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2845 B<t>            Toggle trace mode.
2846 B<t> I<expr>            Trace through execution of I<expr>.
2847 B<b> [I<line>] [I<condition>]
2848                 Set breakpoint; I<line> defaults to the current execution line;
2849                 I<condition> breaks if it evaluates to true, defaults to '1'.
2850 B<b> I<subname> [I<condition>]
2851                 Set breakpoint at first line of subroutine.
2852 B<b> I<\$var>           Set breakpoint at first line of subroutine referenced by I<\$var>.
2853 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2854 B<b> B<postpone> I<subname> [I<condition>]
2855                 Set breakpoint at first line of subroutine after 
2856                 it is compiled.
2857 B<b> B<compile> I<subname>
2858                 Stop after the subroutine is compiled.
2859 B<d> [I<line>]  Delete the breakpoint for I<line>.
2860 B<D>            Delete all breakpoints.
2861 B<a> [I<line>] I<command>
2862                 Set an action to be done before the I<line> is executed;
2863                 I<line> defaults to the current execution line.
2864                 Sequence is: check for breakpoint/watchpoint, print line
2865                 if necessary, do action, prompt user if necessary,
2866                 execute line.
2867 B<a> [I<line>]  Delete the action for I<line>.
2868 B<A>            Delete all actions.
2869 B<W> I<expr>            Add a global watch-expression.
2870 B<W>            Delete all watch-expressions.
2871 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2872                 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2873 B<X> [I<vars>]  Same as \"B<V> I<currentpackage> [I<vars>]\".
2874 B<x> I<expr>            Evals expression in list context, dumps the result.
2875 B<m> I<expr>            Evals expression in list context, prints methods callable
2876                 on the first element of the result.
2877 B<m> I<class>           Prints methods callable via the given class.
2878
2879 B<<> ?                  List Perl commands to run before each prompt.
2880 B<<> I<expr>            Define Perl command to run before each prompt.
2881 B<<<> I<expr>           Add to the list of Perl commands to run before each prompt.
2882 B<>> ?                  List Perl commands to run after each prompt.
2883 B<>> I<expr>            Define Perl command to run after each prompt.
2884 B<>>B<>> I<expr>                Add to the list of Perl commands to run after each prompt.
2885 B<{> I<db_command>      Define debugger command to run before each prompt.
2886 B<{> ?                  List debugger commands to run before each prompt.
2887 B<{{> I<db_command>     Add to the list of debugger commands to run before each prompt.
2888 B<$prc> I<number>       Redo a previous command (default previous command).
2889 B<$prc> I<-number>      Redo number'th-to-last command.
2890 B<$prc> I<pattern>      Redo last command that started with I<pattern>.
2891                 See 'B<O> I<recallCommand>' too.
2892 B<$psh$psh> I<cmd>      Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2893   . ( $rc eq $sh ? "" : "
2894 B<$psh> [I<cmd>]        Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2895                 See 'B<O> I<shellBang>' too.
2896 B<@>I<file>             Execute I<file> containing debugger commands (may nest).
2897 B<H> I<-number> Display last number commands (default all).
2898 B<p> I<expr>            Same as \"I<print {DB::OUT} expr>\" in current package.
2899 B<|>I<dbcmd>            Run debugger command, piping DB::OUT to current pager.
2900 B<||>I<dbcmd>           Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2901 B<\=> [I<alias> I<value>]       Define a command alias, or list current aliases.
2902 I<command>              Execute as a perl statement in current package.
2903 B<v>            Show versions of loaded modules.
2904 B<R>            Pure-man-restart of debugger, some of debugger state
2905                 and command-line options may be lost.
2906                 Currently the following settings are preserved:
2907                 history, breakpoints and actions, debugger B<O>ptions 
2908                 and the following command-line options: I<-w>, I<-I>, I<-e>.
2909
2910 B<O> [I<opt>] ...       Set boolean option to true
2911 B<O> [I<opt>B<?>]       Query options
2912 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... 
2913                 Set options.  Use quotes in spaces in value.
2914     I<recallCommand>, I<ShellBang>      chars used to recall command or spawn shell;
2915     I<pager>                    program for output of \"|cmd\";
2916     I<tkRunning>                        run Tk while prompting (with ReadLine);
2917     I<signalLevel> I<warnLevel> I<dieLevel>     level of verbosity;
2918     I<inhibit_exit>             Allows stepping off the end of the script.
2919     I<ImmediateStop>            Debugger should stop as early as possible.
2920     I<RemotePort>                       Remote hostname:port for remote debugging
2921   The following options affect what happens with B<V>, B<X>, and B<x> commands:
2922     I<arrayDepth>, I<hashDepth>         print only first N elements ('' for all);
2923     I<compactDump>, I<veryCompact>      change style of array and hash dump;
2924     I<globPrint>                        whether to print contents of globs;
2925     I<DumpDBFiles>              dump arrays holding debugged files;
2926     I<DumpPackages>             dump symbol tables of packages;
2927     I<DumpReused>                       dump contents of \"reused\" addresses;
2928     I<quote>, I<HighBit>, I<undefPrint>         change style of string dump;
2929     I<bareStringify>            Do not print the overload-stringified value;
2930   Other options include:
2931     I<PrintRet>         affects printing of return value after B<r> command,
2932     I<frame>            affects printing messages on subroutine entry/exit.
2933     I<AutoTrace>        affects printing messages on possible breaking points.
2934     I<maxTraceLen>      gives max length of evals/args listed in stack trace.
2935     I<ornaments>        affects screen appearance of the command line.
2936     I<CreateTTY>        bits control attempts to create a new TTY on events:
2937                         1: on fork()    2: debugger is started inside debugger
2938                         4: on startup
2939         During startup options are initialized from \$ENV{PERLDB_OPTS}.
2940         You can put additional initialization options I<TTY>, I<noTTY>,
2941         I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2942         `B<R>' after you set them).
2943
2944 B<q> or B<^D>           Quit. Set B<\$DB::finished = 0> to debug global destruction.
2945 B<h> [I<db_command>]    Get help [on a specific debugger command], enter B<|h> to page.
2946 B<h h>          Summary of debugger commands.
2947 B<$doccmd> I<manpage>   Runs the external doc viewer B<$doccmd> command on the 
2948                 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2949                 Set B<\$DB::doccmd> to change viewer.
2950
2951 Type `|h' for a paged display if this was too hard to read.
2952
2953 "; # Fix balance of vi % matching: }}}}
2954
2955     #  note: tabs in the following section are not-so-helpful
2956     $pre580_summary = <<"END_SUM";
2957 I<List/search source lines:>               I<Control script execution:>
2958   B<l> [I<ln>|I<sub>]  List source code            B<T>           Stack trace
2959   B<-> or B<.>      List previous/current line  B<s> [I<expr>]    Single step [in expr]
2960   B<w> [I<line>]    List around line            B<n> [I<expr>]    Next, steps over subs
2961   B<f> I<filename>  View source in file         <B<CR>/B<Enter>>  Repeat last B<n> or B<s>
2962   B</>I<pattern>B</> B<?>I<patt>B<?>   Search forw/backw    B<r>           Return from subroutine
2963   B<v>           Show versions of modules    B<c> [I<ln>|I<sub>]  Continue until position
2964 I<Debugger controls:>                        B<L>           List break/watch/actions
2965   B<O> [...]     Set debugger options        B<t> [I<expr>]    Toggle trace [trace expr]
2966   B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2967   B<$prc> [I<N>|I<pat>]   Redo a previous command     B<d> [I<ln>] or B<D> Delete a/all breakpoints
2968   B<H> [I<-num>]    Display last num commands   B<a> [I<ln>] I<cmd>  Do cmd before line
2969   B<=> [I<a> I<val>]   Define/list an alias        B<W> I<expr>      Add a watch expression
2970   B<h> [I<db_cmd>]  Get help on command         B<A> or B<W>      Delete all actions/watch
2971   B<|>[B<|>]I<db_cmd>  Send output to pager        B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2972   B<q> or B<^D>     Quit                        B<R>           Attempt a restart
2973 I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2974   B<x>|B<m> I<expr>       Evals expr in list context, dumps the result or lists methods.
2975   B<p> I<expr>         Print expression (uses script's current package).
2976   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
2977   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
2978   B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
2979 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2980 END_SUM
2981                                 # ')}}; # Fix balance of vi % matching
2982
2983 }
2984
2985 sub print_help {
2986     local $_ = shift;
2987
2988     # Restore proper alignment destroyed by eeevil I<> and B<>
2989     # ornaments: A pox on both their houses!
2990     #
2991     # A help command will have everything up to and including
2992     # the first tab sequence padded into a field 16 (or if indented 20)
2993     # wide.  If it's wider than that, an extra space will be added.
2994     s{
2995         ^                       # only matters at start of line
2996           ( \040{4} | \t )*     # some subcommands are indented
2997           ( < ?                 # so <CR> works
2998             [BI] < [^\t\n] + )  # find an eeevil ornament
2999           ( \t+ )               # original separation, discarded
3000           ( .* )                # this will now start (no earlier) than 
3001                                 # column 16
3002     } {
3003         my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
3004         my $clean = $command;
3005         $clean =~ s/[BI]<([^>]*)>/$1/g;  
3006     # replace with this whole string:
3007         ($leadwhite ? " " x 4 : "")
3008       . $command
3009       . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
3010       . $text;
3011
3012     }mgex;
3013
3014     s{                          # handle bold ornaments
3015         B < ( [^>] + | > ) >
3016     } {
3017           $Term::ReadLine::TermCap::rl_term_set[2] 
3018         . $1
3019         . $Term::ReadLine::TermCap::rl_term_set[3]
3020     }gex;
3021
3022     s{                          # handle italic ornaments
3023         I < ( [^>] + | > ) >
3024     } {
3025           $Term::ReadLine::TermCap::rl_term_set[0] 
3026         . $1
3027         . $Term::ReadLine::TermCap::rl_term_set[1]
3028     }gex;
3029
3030     local $\ = '';
3031     print $OUT $_;
3032 }
3033
3034 sub fix_less {
3035     return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
3036     my $is_less = $pager =~ /\bless\b/;
3037     if ($pager =~ /\bmore\b/) { 
3038         my @st_more = stat('/usr/bin/more');
3039         my @st_less = stat('/usr/bin/less');
3040         $is_less = @st_more    && @st_less 
3041                 && $st_more[0] == $st_less[0] 
3042                 && $st_more[1] == $st_less[1];
3043     }
3044     # changes environment!
3045     $ENV{LESS} .= 'r'   if $is_less;
3046 }
3047
3048 sub diesignal {
3049     local $frame = 0;
3050     local $doret = -2;
3051     $SIG{'ABRT'} = 'DEFAULT';
3052     kill 'ABRT', $$ if $panic++;
3053     if (defined &Carp::longmess) {
3054         local $SIG{__WARN__} = '';
3055         local $Carp::CarpLevel = 2;             # mydie + confess
3056         &warn(Carp::longmess("Signal @_"));
3057     }
3058     else {
3059         local $\ = '';
3060         print $DB::OUT "Got signal @_\n";
3061     }
3062     kill 'ABRT', $$;
3063 }
3064
3065 sub dbwarn { 
3066   local $frame = 0;
3067   local $doret = -2;
3068   local $SIG{__WARN__} = '';
3069   local $SIG{__DIE__} = '';
3070   eval { require Carp } if defined $^S; # If error/warning during compilation,
3071                                         # require may be broken.
3072   CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
3073     return unless defined &Carp::longmess;
3074   my ($mysingle,$mytrace) = ($single,$trace);
3075   $single = 0; $trace = 0;
3076   my $mess = Carp::longmess(@_);
3077   ($single,$trace) = ($mysingle,$mytrace);
3078   &warn($mess); 
3079 }
3080
3081 sub dbdie {
3082   local $frame = 0;
3083   local $doret = -2;
3084   local $SIG{__DIE__} = '';
3085   local $SIG{__WARN__} = '';
3086   my $i = 0; my $ineval = 0; my $sub;
3087   if ($dieLevel > 2) {
3088       local $SIG{__WARN__} = \&dbwarn;
3089       &warn(@_);                # Yell no matter what
3090       return;
3091   }
3092   if ($dieLevel < 2) {
3093     die @_ if $^S;              # in eval propagate
3094   }
3095   # No need to check $^S, eval is much more robust nowadays
3096   eval { require Carp }; #if defined $^S;# If error/warning during compilation,
3097                                         # require may be broken.
3098
3099   die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
3100     unless defined &Carp::longmess;
3101
3102   # We do not want to debug this chunk (automatic disabling works
3103   # inside DB::DB, but not in Carp).
3104   my ($mysingle,$mytrace) = ($single,$trace);
3105   $single = 0; $trace = 0;
3106   my $mess = "@_";
3107   { 
3108     package Carp;               # Do not include us in the list
3109     eval {
3110       $mess = Carp::longmess(@_);
3111     };
3112   }
3113   ($single,$trace) = ($mysingle,$mytrace);
3114   die $mess;
3115 }
3116
3117 sub warnLevel {
3118   if (@_) {
3119     $prevwarn = $SIG{__WARN__} unless $warnLevel;
3120     $warnLevel = shift;
3121     if ($warnLevel) {
3122       $SIG{__WARN__} = \&DB::dbwarn;
3123     } elsif ($prevwarn) {
3124       $SIG{__WARN__} = $prevwarn;
3125     }
3126   }
3127   $warnLevel;
3128 }
3129
3130 sub dieLevel {
3131   local $\ = '';
3132   if (@_) {
3133     $prevdie = $SIG{__DIE__} unless $dieLevel;
3134     $dieLevel = shift;
3135     if ($dieLevel) {
3136       $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
3137       #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
3138       print $OUT "Stack dump during die enabled", 
3139         ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
3140           if $I_m_init;
3141       print $OUT "Dump printed too.\n" if $dieLevel > 2;
3142     } elsif ($prevdie) {
3143       $SIG{__DIE__} = $prevdie;
3144       print $OUT "Default die handler restored.\n";
3145     }
3146   }
3147   $dieLevel;
3148 }
3149
3150 sub signalLevel {
3151   if (@_) {
3152     $prevsegv = $SIG{SEGV} unless $signalLevel;
3153     $prevbus = $SIG{BUS} unless $signalLevel;
3154     $signalLevel = shift;
3155     if ($signalLevel) {
3156       $SIG{SEGV} = \&DB::diesignal;
3157       $SIG{BUS} = \&DB::diesignal;
3158     } else {
3159       $SIG{SEGV} = $prevsegv;
3160       $SIG{BUS} = $prevbus;
3161     }
3162   }
3163   $signalLevel;
3164 }
3165
3166 sub CvGV_name {
3167   my $in = shift;
3168   my $name = CvGV_name_or_bust($in);
3169   defined $name ? $name : $in;
3170 }
3171
3172 sub CvGV_name_or_bust {
3173   my $in = shift;
3174   return if $skipCvGV;          # Backdoor to avoid problems if XS broken...
3175   return unless ref $in;
3176   $in = \&$in;                  # Hard reference...
3177   eval {require Devel::Peek; 1} or return;
3178   my $gv = Devel::Peek::CvGV($in) or return;
3179   *$gv{PACKAGE} . '::' . *$gv{NAME};
3180 }
3181
3182 sub find_sub {
3183   my $subr = shift;
3184   $sub{$subr} or do {
3185     return unless defined &$subr;
3186     my $name = CvGV_name_or_bust($subr);
3187     my $data;
3188     $data = $sub{$name} if defined $name;
3189     return $data if defined $data;
3190
3191     # Old stupid way...
3192     $subr = \&$subr;            # Hard reference
3193     my $s;
3194     for (keys %sub) {
3195       $s = $_, last if $subr eq \&$_;
3196     }
3197     $sub{$s} if $s;
3198   }
3199 }
3200
3201 sub methods {
3202   my $class = shift;
3203   $class = ref $class if ref $class;
3204   local %seen;
3205   local %packs;
3206   methods_via($class, '', 1);
3207   methods_via('UNIVERSAL', 'UNIVERSAL', 0);
3208 }
3209
3210 sub methods_via {
3211   my $class = shift;
3212   return if $packs{$class}++;
3213   my $prefix = shift;
3214   my $prepend = $prefix ? "via $prefix: " : '';
3215   my $name;
3216   for $name (grep {defined &{${"${class}::"}{$_}}} 
3217              sort keys %{"${class}::"}) {
3218     next if $seen{ $name }++;
3219     local $\ = '';
3220     local $, = '';
3221     print $DB::OUT "$prepend$name\n";
3222   }
3223   return unless shift;          # Recurse?
3224   for $name (@{"${class}::ISA"}) {
3225     $prepend = $prefix ? $prefix . " -> $name" : $name;
3226     methods_via($name, $prepend, 1);
3227   }
3228 }
3229
3230 sub setman { 
3231     $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
3232                 ? "man"             # O Happy Day!
3233                 : "perldoc";        # Alas, poor unfortunates
3234 }
3235
3236 sub runman {
3237     my $page = shift;
3238     unless ($page) {
3239         &system("$doccmd $doccmd");
3240         return;
3241     } 
3242     # this way user can override, like with $doccmd="man -Mwhatever"
3243     # or even just "man " to disable the path check.
3244     unless ($doccmd eq 'man') {
3245         &system("$doccmd $page");
3246         return;
3247     } 
3248
3249     $page = 'perl' if lc($page) eq 'help';
3250
3251     require Config;
3252     my $man1dir = $Config::Config{'man1dir'};
3253     my $man3dir = $Config::Config{'man3dir'};
3254     for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ } 
3255     my $manpath = '';
3256     $manpath .= "$man1dir:" if $man1dir =~ /\S/;
3257     $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
3258     chop $manpath if $manpath;
3259     # harmless if missing, I figure
3260     my $oldpath = $ENV{MANPATH};
3261     $ENV{MANPATH} = $manpath if $manpath;
3262     my $nopathopt = $^O =~ /dunno what goes here/;
3263     if (CORE::system($doccmd, 
3264                 # I just *know* there are men without -M
3265                 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),  
3266             split ' ', $page) )
3267     {
3268         unless ($page =~ /^perl\w/) {
3269             if (grep { $page eq $_ } qw{ 
3270                 5004delta 5005delta amiga api apio book boot bot call compile
3271                 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
3272                 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
3273                 form func guts hack hist hpux intern ipc lexwarn locale lol mod
3274                 modinstall modlib number obj op opentut os2 os390 pod port 
3275                 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
3276                 trap unicode var vms win32 xs xstut
3277               }) 
3278             {
3279                 $page =~ s/^/perl/;
3280                 CORE::system($doccmd, 
3281                         (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),  
3282                         $page);
3283             }
3284         }
3285     } 
3286     if (defined $oldpath) {
3287         $ENV{MANPATH} = $manpath;
3288     } else {
3289         delete $ENV{MANPATH};
3290     } 
3291
3292
3293 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
3294
3295 BEGIN {                 # This does not compile, alas.
3296   $IN = \*STDIN;                # For bugs before DB::OUT has been opened
3297   $OUT = \*STDERR;              # For errors before DB::OUT has been opened
3298   $sh = '!';
3299   $rc = ',';
3300   @hist = ('?');
3301   $deep = 100;                  # warning if stack gets this deep
3302   $window = 10;
3303   $preview = 3;
3304   $sub = '';
3305   $SIG{INT} = \&DB::catch;
3306   # This may be enabled to debug debugger:
3307   #$warnLevel = 1 unless defined $warnLevel;
3308   #$dieLevel = 1 unless defined $dieLevel;
3309   #$signalLevel = 1 unless defined $signalLevel;
3310
3311   $db_stop = 0;                 # Compiler warning
3312   $db_stop = 1 << 30;
3313   $level = 0;                   # Level of recursive debugging
3314   # @stack and $doret are needed in sub sub, which is called for DB::postponed.
3315   # Triggers bug (?) in perl is we postpone this until runtime:
3316   @postponed = @stack = (0);
3317   $stack_depth = 0;             # Localized $#stack
3318   $doret = -2;
3319   $frame = 0;
3320 }
3321
3322 BEGIN {$^W = $ini_warn;}        # Switch warnings back
3323
3324 #use Carp;                      # This did break, left for debugging
3325
3326 sub db_complete {
3327   # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
3328   my($text, $line, $start) = @_;
3329   my ($itext, $search, $prefix, $pack) =
3330     ($text, "^\Q${'package'}::\E([^:]+)\$");
3331   
3332   return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
3333                                (map { /$search/ ? ($1) : () } keys %sub)
3334     if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
3335   return sort grep /^\Q$text/, values %INC # files
3336     if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
3337   return sort map {($_, db_complete($_ . "::", "V ", 2))}
3338     grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
3339       if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
3340   return sort map {($_, db_complete($_ . "::", "V ", 2))}
3341     grep !/^main::/,
3342       grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
3343                                  # packages
3344         if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ 
3345           and $text =~ /^(.*[^:])::?(\w*)$/  and $prefix = $1;
3346   if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
3347     # We may want to complete to (eval 9), so $text may be wrong
3348     $prefix = length($1) - length($text);
3349     $text = $1;
3350     return sort 
3351         map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
3352   }
3353   if ((substr $text, 0, 1) eq '&') { # subroutines
3354     $text = substr $text, 1;
3355     $prefix = "&";
3356     return sort map "$prefix$_", 
3357                grep /^\Q$text/, 
3358                  (keys %sub),
3359                  (map { /$search/ ? ($1) : () } 
3360                     keys %sub);
3361   }
3362   if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
3363     $pack = ($1 eq 'main' ? '' : $1) . '::';
3364     $prefix = (substr $text, 0, 1) . $1 . '::';
3365     $text = $2;
3366     my @out 
3367       = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
3368     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3369       return db_complete($out[0], $line, $start);
3370     }
3371     return sort @out;
3372   }
3373   if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3374     $pack = ($package eq 'main' ? '' : $package) . '::';
3375     $prefix = substr $text, 0, 1;
3376     $text = substr $text, 1;
3377     my @out = map "$prefix$_", grep /^\Q$text/, 
3378        (grep /^_?[a-zA-Z]/, keys %$pack), 
3379        ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3380     if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3381       return db_complete($out[0], $line, $start);
3382     }
3383     return sort @out;
3384   }
3385   if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3386     my @out = grep /^\Q$text/, @options;
3387     my $val = option_val($out[0], undef);
3388     my $out = '? ';
3389     if (not defined $val or $val =~ /[\n\r]/) {
3390       # Can do nothing better
3391     } elsif ($val =~ /\s/) {
3392       my $found;
3393       foreach $l (split //, qq/\"\'\#\|/) {
3394         $out = "$l$val$l ", last if (index $val, $l) == -1;
3395       }
3396     } else {
3397       $out = "=$val ";
3398     }
3399     # Default to value if one completion, to question if many
3400     $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3401     return sort @out;
3402   }
3403   return $term->filename_list($text); # filenames
3404 }
3405
3406 sub end_report {
3407   local $\ = '';
3408   print $OUT "Use `q' to quit or `R' to restart.  `h q' for details.\n"
3409 }
3410
3411 sub clean_ENV {
3412     if (defined($ini_pids)) {
3413         $ENV{PERLDB_PIDS} = $ini_pids;
3414     } else {
3415         delete($ENV{PERLDB_PIDS});
3416     }
3417 }
3418
3419 END {
3420   $finished = 1 if $inhibit_exit;      # So that some keys may be disabled.
3421   $fall_off_end = 1 unless $inhibit_exit;
3422   # Do not stop in at_exit() and destructors on exit:
3423   $DB::single = !$fall_off_end && !$runnonstop;
3424   DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3425 }
3426
3427
3428 # ===================================== pre580 ================================
3429 # this is very sad below here...
3430 #
3431
3432 sub cmd_pre580_null {
3433         # do nothing...
3434 }
3435
3436 sub cmd_pre580_a {
3437         my $cmd = shift;
3438         if ($cmd =~ /^(\d*)\s*(.*)/) {
3439                 $i = $1 || $line; $j = $2;
3440                 if (length $j) {
3441                         if ($dbline[$i] == 0) {
3442                                 print $OUT "Line $i may not have an action.\n";
3443                         } else {
3444                                 $had_breakpoints{$filename} |= 2;
3445                                 $dbline{$i} =~ s/\0[^\0]*//;
3446                                 $dbline{$i} .= "\0" . action($j);
3447                         }
3448                 } else {
3449                         $dbline{$i} =~ s/\0[^\0]*//;
3450                         delete $dbline{$i} if $dbline{$i} eq '';
3451                 }
3452         }
3453 }
3454
3455 sub cmd_pre580_b {
3456         my $cmd    = shift;
3457         my $dbline = shift;
3458         if ($cmd =~ /^load\b\s*(.*)/) {
3459                 my $file = $1; $file =~ s/\s+$//;
3460                 &cmd_b_load($file);
3461         } elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
3462                 my $cond = length $3 ? $3 : '1';
3463                 my ($subname, $break) = ($2, $1 eq 'postpone');
3464                 $subname =~ s/\'/::/g;
3465                 $subname = "${'package'}::" . $subname
3466                 unless $subname =~ /::/;
3467                 $subname = "main".$subname if substr($subname,0,2) eq "::";
3468                 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
3469         } elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) { 
3470                 my $subname = $1;
3471                 my $cond = length $2 ? $2 : '1';
3472                 &cmd_b_sub($subname, $cond);
3473         } elsif ($cmd =~ /^(\d*)\s*(.*)/) {
3474                 my $i = $1 || $dbline;
3475                 my $cond = length $2 ? $2 : '1';
3476                 &cmd_b_line($i, $cond);
3477         }
3478 }
3479
3480 sub cmd_pre580_D {
3481         my $cmd = shift;
3482         if ($cmd =~ /^\s*$/) {
3483                 print $OUT "Deleting all breakpoints...\n";
3484                 my $file;
3485                 for $file (keys %had_breakpoints) {
3486                         local *dbline = $main::{'_<' . $file};
3487                         my $max = $#dbline;
3488                         my $was;
3489
3490                         for ($i = 1; $i <= $max ; $i++) {
3491                                 if (defined $dbline{$i}) {
3492                                         $dbline{$i} =~ s/^[^\0]+//;
3493                                         if ($dbline{$i} =~ s/^\0?$//) {
3494                                                 delete $dbline{$i};
3495                                         }
3496                                 }
3497                         }
3498
3499                         if (not $had_breakpoints{$file} &= ~1) {
3500                                 delete $had_breakpoints{$file};
3501                         }
3502                 }
3503                 undef %postponed;
3504                 undef %postponed_file;
3505                 undef %break_on_load;
3506         }
3507 }
3508
3509 sub cmd_pre580_h {
3510         my $cmd = shift;
3511         if ($cmd =~ /^\s*$/) {
3512                 print_help($pre580_help);
3513         } elsif ($cmd =~ /^h\s*/) {
3514                 print_help($pre580_summary);
3515         } elsif ($cmd =~ /^h\s+(\S.*)$/) { 
3516                 my $asked = $1;                 # for proper errmsg
3517                 my $qasked = quotemeta($asked); # for searching
3518                 # XXX: finds CR but not <CR>
3519                 if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) {
3520                         while ($pre580_help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
3521                                 print_help($1);
3522                         }
3523                 } else {
3524                         print_help("B<$asked> is not a debugger command.\n");
3525                 }
3526         }
3527 }
3528
3529 sub cmd_pre580_W {
3530         my $cmd = shift;
3531         if ($cmd =~ /^$/) { 
3532                 $trace &= ~2;
3533                 @to_watch = @old_watch = ();
3534         } elsif ($cmd =~ /^(.*)/s) {
3535                 push @to_watch, $1;
3536                 $evalarg = $1;
3537                 my ($val) = &eval;
3538                 $val = (defined $val) ? "'$val'" : 'undef' ;
3539                 push @old_watch, $val;
3540                 $trace |= 2;
3541         }
3542 }
3543
3544 package DB::fake;
3545
3546 sub at_exit {
3547   "Debugged program terminated.  Use `q' to quit or `R' to restart.";
3548 }
3549
3550 package DB;                     # Do not trace this 1; below!
3551
3552 1;
3553