3 # Debugger for Perl 5.00x; perl5db.pl patch level:
6 $header = "perl5db.pl version $VERSION";
9 # This file is automatically included if you do perl -d.
10 # It's probably not useful to include this yourself.
12 # Perl supplies the values for %sub. It effectively inserts
13 # a &DB'DB(); in front of every place that can have a
14 # breakpoint. Instead of a subroutine call it calls &DB::sub with
15 # $DB::sub being the called subroutine. It also inserts a BEGIN
16 # {require 'perl5db.pl'} before the first line.
18 # After each `require'd file is compiled, but before it is executed, a
19 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
20 # $filename is the expanded name of the `require'd file (as found as
23 # Additional services from Perl interpreter:
25 # if caller() is called from the package DB, it provides some
28 # The array @{$main::{'_<'.$filename}} is the line-by-line contents of
31 # The hash %{'_<'.$filename} contains breakpoints and action (it is
32 # keyed by line number), and individual entries are settable (as
33 # opposed to the whole hash). Only true/false is important to the
34 # interpreter, though the values used by perl5db.pl have the form
35 # "$break_condition\0$action". Values are magical in numeric context.
37 # The scalar ${'_<'.$filename} contains $filename.
39 # Note that no subroutine call is possible until &DB::sub is defined
40 # (for subroutines defined outside of the package DB). In fact the same is
41 # true if $deep is not defined.
46 # At start reads $rcfile that may set important options. This file
47 # may define a subroutine &afterinit that will be executed after the
48 # debugger is initialized.
50 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
51 # it as a rest of `O ...' line in debugger prompt.
53 # The options that can be specified only at startup:
54 # [To set in $rcfile, call &parse_options("optionName=new_value").]
56 # TTY - the TTY to use for debugging i/o.
58 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
59 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
60 # Term::Rendezvous. Current variant is to have the name of TTY in this
63 # ReadLine - If false, dummy ReadLine is used, so you can debug
64 # ReadLine applications.
66 # NonStop - if true, no i/o is performed until interrupt.
68 # LineInfo - file or pipe to print line number info to. If it is a
69 # pipe, a short "emacs like" message is used.
71 # RemotePort - host:port to connect to on remote host for remote debugging.
73 # Example $rcfile: (delete leading hashes!)
75 # &parse_options("NonStop=1 LineInfo=db.out");
76 # sub afterinit { $trace = 1; }
78 # The script will run without human intervention, putting trace
79 # information into db.out. (If you interrupt it, you would better
80 # reset LineInfo to something "interactive"!)
82 ##################################################################
84 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
86 # modified Perl debugger, to be run from Emacs in perldb-mode
87 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
88 # Johan Vromans -- upgrade to 4.0 pl 10
89 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
93 # A lot of things changed after 0.94. First of all, core now informs
94 # debugger about entry into XSUBs, overloaded operators, tied operations,
95 # BEGIN and END. Handy with `O f=2'.
97 # This can make debugger a little bit too verbose, please be patient
98 # and report your problems promptly.
100 # Now the option frame has 3 values: 0,1,2.
102 # Note that if DESTROY returns a reference to the object (or object),
103 # the deletion of data may be postponed until the next function call,
104 # due to the need to examine the return value.
106 # Changes: 0.95: `v' command shows versions.
107 # Changes: 0.96: `v' command shows version of readline.
108 # primitive completion works (dynamic variables, subs for `b' and `l',
109 # options). Can `p %var'
110 # Better help (`h <' now works). New commands <<, >>, {, {{.
111 # {dump|print}_trace() coded (to be able to do it from <<cmd).
112 # `c sub' documented.
113 # At last enough magic combined to stop after the end of debuggee.
114 # !! should work now (thanks to Emacs bracket matching an extra
115 # `]' in a regexp is caught).
116 # `L', `D' and `A' span files now (as documented).
117 # Breakpoints in `require'd code are possible (used in `R').
118 # Some additional words on internal work of debugger.
119 # `b load filename' implemented.
120 # `b postpone subr' implemented.
121 # now only `q' exits debugger (overwritable on $inhibit_exit).
122 # When restarting debugger breakpoints/actions persist.
123 # Buglet: When restarting debugger only one breakpoint/action per
124 # autoloaded function persists.
125 # Changes: 0.97: NonStop will not stop in at_exit().
126 # Option AutoTrace implemented.
127 # Trace printed differently if frames are printed too.
128 # new `inhibitExit' option.
129 # printing of a very long statement interruptible.
130 # Changes: 0.98: New command `m' for printing possible methods
131 # 'l -' is a synonym for `-'.
132 # Cosmetic bugs in printing stack trace.
133 # `frame' & 8 to print "expanded args" in stack trace.
134 # Can list/break in imported subs.
135 # new `maxTraceLen' option.
136 # frame & 4 and frame & 8 granted.
138 # nonstoppable lines do not have `:' near the line number.
139 # `b compile subname' implemented.
140 # Will not use $` any more.
141 # `-' behaves sane now.
142 # Changes: 0.99: Completion for `f', `m'.
143 # `m' will remove duplicate names instead of duplicate functions.
144 # `b load' strips trailing whitespace.
145 # completion ignores leading `|'; takes into account current package
146 # when completing a subroutine name (same for `l').
147 # Changes: 1.07: Many fixed by tchrist 13-March-2000
149 # + Added bare minimal security checks on perldb rc files, plus
150 # comments on what else is needed.
151 # + Fixed the ornaments that made "|h" completely unusable.
152 # They are not used in print_help if they will hurt. Strip pod
153 # if we're paging to less.
154 # + Fixed mis-formatting of help messages caused by ornaments
155 # to restore Larry's original formatting.
156 # + Fixed many other formatting errors. The code is still suboptimal,
157 # and needs a lot of work at restructuring. It's also misindented
159 # + Fixed bug where trying to look at an option like your pager
161 # + Fixed some $? processing. Note: if you use csh or tcsh, you will
162 # lose. You should consider shell escapes not using their shell,
163 # or else not caring about detailed status. This should really be
164 # unified into one place, too.
165 # + Fixed bug where invisible trailing whitespace on commands hoses you,
166 # tricking Perl into thinking you weren't calling a debugger command!
167 # + Fixed bug where leading whitespace on commands hoses you. (One
168 # suggests a leading semicolon or any other irrelevant non-whitespace
169 # to indicate literal Perl code.)
170 # + Fixed bugs that ate warnings due to wrong selected handle.
171 # + Fixed a precedence bug on signal stuff.
172 # + Fixed some unseemly wording.
173 # + Fixed bug in help command trying to call perl method code.
174 # + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
176 # + Added some comments. This code is still nasty spaghetti.
177 # + Added message if you clear your pre/post command stacks which was
178 # very easy to do if you just typed a bare >, <, or {. (A command
179 # without an argument should *never* be a destructive action; this
180 # API is fundamentally screwed up; likewise option setting, which
181 # is equally buggered.)
182 # + Added command stack dump on argument of "?" for >, <, or {.
183 # + Added a semi-built-in doc viewer command that calls man with the
184 # proper %Config::Config path (and thus gets caching, man -k, etc),
185 # or else perldoc on obstreperous platforms.
186 # + Added to and rearranged the help information.
187 # + Detected apparent misuse of { ... } to declare a block; this used
188 # to work but now is a command, and mysteriously gave no complaint.
190 # Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
192 # + This patch to perl5db.pl cleans up formatting issues on the help
193 # summary (h h) screen in the debugger. Mostly columnar alignment
194 # issues, plus converted the printed text to use all spaces, since
195 # tabs don't seem to help much here.
197 # Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
198 # 0) Minor bugs corrected;
199 # a) Support for auto-creation of new TTY window on startup, either
200 # unconditionally, or if started as a kid of another debugger session;
201 # b) New `O'ption CreateTTY
202 # I<CreateTTY> bits control attempts to create a new TTY on events:
203 # 1: on fork() 2: debugger is started inside debugger
205 # c) Code to auto-create a new TTY window on OS/2 (currently one one
206 # extra window per session - need named pipes to have more...);
207 # d) Simplified interface for custom createTTY functions (with a backward
208 # compatibility hack); now returns the TTY name to use; return of ''
209 # means that the function reset the I/O handles itself;
210 # d') Better message on the semantic of custom createTTY function;
211 # e) Convert the existing code to create a TTY into a custom createTTY
213 # f) Consistent support for TTY names of the form "TTYin,TTYout";
214 # g) Switch line-tracing output too to the created TTY window;
215 # h) make `b fork' DWIM with CORE::GLOBAL::fork;
216 # i) High-level debugger API cmd_*():
217 # cmd_b_load($filenamepart) # b load filenamepart
218 # cmd_b_line($lineno [, $cond]) # b lineno [cond]
219 # cmd_b_sub($sub [, $cond]) # b sub [cond]
220 # cmd_stop() # Control-C
221 # cmd_d($lineno) # d lineno
222 # The cmd_*() API returns FALSE on failure; in this case it outputs
223 # the error message to the debugging output.
224 # j) Low-level debugger API
225 # break_on_load($filename) # b load filename
226 # @files = report_break_on_load() # List files with load-breakpoints
227 # breakable_line_in_filename($name, $from [, $to])
228 # # First breakable line in the
229 # # range $from .. $to. $to defaults
230 # # to $from, and may be less than $to
231 # breakable_line($from [, $to]) # Same for the current file
232 # break_on_filename_line($name, $lineno [, $cond])
233 # # Set breakpoint,$cond defaults to 1
234 # break_on_filename_line_range($name, $from, $to [, $cond])
235 # # As above, on the first
236 # # breakable line in range
237 # break_on_line($lineno [, $cond]) # As above, in the current file
238 # break_subroutine($sub [, $cond]) # break on the first breakable line
239 # ($name, $from, $to) = subroutine_filename_lines($sub)
240 # # The range of lines of the text
241 # The low-level API returns TRUE on success, and die()s on failure.
243 # Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
245 # + Fixed warnings generated by "perl -dWe 42"
246 # + Corrected spelling errors
247 # + Squeezed Help (h) output into 80 columns
249 # Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
250 # + Made "x @INC" work like it used to
252 # Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
253 # + Fixed warnings generated by "O" (Show debugger options)
254 # + Fixed warnings generated by "p 42" (Print expression)
255 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
256 # + Added windowSize option
257 ####################################################################
259 # Needed for the statement after exec():
261 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
262 local($^W) = 0; # Switch run-time warnings off during init.
265 $dumpvar::arrayDepth,
266 $dumpvar::dumpDBFiles,
267 $dumpvar::dumpPackages,
268 $dumpvar::quoteHighBit,
269 $dumpvar::printUndef,
278 # Command-line + PERLLIB:
281 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
283 $trace = $signal = $single = 0; # Uninitialized warning suppression
284 # (local $^W cannot help - other packages!).
285 $inhibit_exit = $option{PrintRet} = 1;
287 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
288 compactDump veryCompact quote HighBit undefPrint
289 globPrint PrintRet UsageOnly frame AutoTrace
290 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
291 recallCommand ShellBang pager tkRunning ornaments
292 signalLevel warnLevel dieLevel inhibit_exit
293 ImmediateStop bareStringify CreateTTY
294 RemotePort windowSize);
297 hashDepth => \$dumpvar::hashDepth,
298 arrayDepth => \$dumpvar::arrayDepth,
299 DumpDBFiles => \$dumpvar::dumpDBFiles,
300 DumpPackages => \$dumpvar::dumpPackages,
301 DumpReused => \$dumpvar::dumpReused,
302 HighBit => \$dumpvar::quoteHighBit,
303 undefPrint => \$dumpvar::printUndef,
304 globPrint => \$dumpvar::globPrint,
305 UsageOnly => \$dumpvar::usageOnly,
306 CreateTTY => \$CreateTTY,
307 bareStringify => \$dumpvar::bareStringify,
309 AutoTrace => \$trace,
310 inhibit_exit => \$inhibit_exit,
311 maxTraceLen => \$maxtrace,
312 ImmediateStop => \$ImmediateStop,
313 RemotePort => \$remoteport,
314 windowSize => \$window,
318 compactDump => \&dumpvar::compactDump,
319 veryCompact => \&dumpvar::veryCompact,
320 quote => \&dumpvar::quote,
323 ReadLine => \&ReadLine,
324 NonStop => \&NonStop,
325 LineInfo => \&LineInfo,
326 recallCommand => \&recallCommand,
327 ShellBang => \&shellBang,
329 signalLevel => \&signalLevel,
330 warnLevel => \&warnLevel,
331 dieLevel => \&dieLevel,
332 tkRunning => \&tkRunning,
333 ornaments => \&ornaments,
334 RemotePort => \&RemotePort,
338 compactDump => 'dumpvar.pl',
339 veryCompact => 'dumpvar.pl',
340 quote => 'dumpvar.pl',
343 # These guys may be defined in $ENV{PERL5DB} :
344 $rl = 1 unless defined $rl;
345 $warnLevel = 0 unless defined $warnLevel;
346 $dieLevel = 0 unless defined $dieLevel;
347 $signalLevel = 1 unless defined $signalLevel;
348 $pre = [] unless defined $pre;
349 $post = [] unless defined $post;
350 $pretype = [] unless defined $pretype;
351 $CreateTTY = 3 unless defined $CreateTTY;
353 warnLevel($warnLevel);
355 signalLevel($signalLevel);
358 (defined($ENV{PAGER})
362 : 'more'))) unless defined $pager;
364 &recallCommand("!") unless defined $prc;
365 &shellBang("!") unless defined $psh;
367 $maxtrace = 400 unless defined $maxtrace;
368 $ini_pids = $ENV{PERLDB_PIDS};
369 if (defined $ENV{PERLDB_PIDS}) {
370 $pids = "[$ENV{PERLDB_PIDS}]";
371 $ENV{PERLDB_PIDS} .= "->$$";
374 $ENV{PERLDB_PIDS} = "$$";
379 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
381 if (-e "/dev/tty") { # this is the wrong metric!
384 $rcfile="perldb.ini";
387 # This isn't really safe, because there's a race
388 # between checking and opening. The solution is to
389 # open and fstat the handle, but then you have to read and
390 # eval the contents. But then the silly thing gets
391 # your lexical scope, which is unfortunately at best.
395 # Just exactly what part of the word "CORE::" don't you understand?
396 local $SIG{__WARN__};
399 unless (is_safe_file($file)) {
400 CORE::warn <<EO_GRIPE;
401 perldb: Must not source insecure rcfile $file.
402 You or the superuser must be the owner, and it must not
403 be writable by anyone but its owner.
409 CORE::warn("perldb: couldn't parse $file: $@") if $@;
413 # Verifies that owner is either real user or superuser and that no
414 # one but owner may write to it. This function is of limited use
415 # when called on a path instead of upon a handle, because there are
416 # no guarantees that filename (by dirent) whose file (by ino) is
417 # eventually accessed is the same as the one tested.
418 # Assumes that the file's existence is not in doubt.
421 stat($path) || return; # mysteriously vaporized
422 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
424 return 0 if $uid != 0 && $uid != $<;
425 return 0 if $mode & 022;
430 safe_do("./$rcfile");
432 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
433 safe_do("$ENV{HOME}/$rcfile");
435 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
436 safe_do("$ENV{LOGDIR}/$rcfile");
439 if (defined $ENV{PERLDB_OPTS}) {
440 parse_options($ENV{PERLDB_OPTS});
443 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
444 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
445 *get_fork_TTY = \&xterm_get_fork_TTY;
446 } elsif ($^O eq 'os2') {
447 *get_fork_TTY = \&os2_get_fork_TTY;
450 # Here begin the unreadable code. It needs fixing.
452 if (exists $ENV{PERLDB_RESTART}) {
453 delete $ENV{PERLDB_RESTART};
455 @hist = get_list('PERLDB_HIST');
456 %break_on_load = get_list("PERLDB_ON_LOAD");
457 %postponed = get_list("PERLDB_POSTPONE");
458 my @had_breakpoints= get_list("PERLDB_VISITED");
459 for (0 .. $#had_breakpoints) {
460 my %pf = get_list("PERLDB_FILE_$_");
461 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
463 my %opt = get_list("PERLDB_OPT");
465 while (($opt,$val) = each %opt) {
466 $val =~ s/[\\\']/\\$1/g;
467 parse_options("$opt'$val'");
469 @INC = get_list("PERLDB_INC");
471 $pretype = [get_list("PERLDB_PRETYPE")];
472 $pre = [get_list("PERLDB_PRE")];
473 $post = [get_list("PERLDB_POST")];
474 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
480 # Is Perl being run from a slave editor or graphical debugger?
481 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
482 $rl = 0, shift(@main::ARGV) if $slave_editor;
484 #require Term::ReadLine;
486 if ($^O eq 'cygwin') {
487 # /dev/tty is binary. use stdin for textmode
489 } elsif (-e "/dev/tty") {
490 $console = "/dev/tty";
491 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
493 } elsif ($^O eq 'MacOS') {
494 if ($MacPerl::Version !~ /MPW/) {
495 $console = "Dev:Console:Perl Debug"; # Separate window for application
497 $console = "Dev:Console";
500 $console = "sys\$command";
503 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
507 if ($^O eq 'NetWare') {
512 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
520 $console = $tty if defined $tty;
522 if (defined $remoteport) {
524 $OUT = new IO::Socket::INET( Timeout => '10',
525 PeerAddr => $remoteport,
528 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
530 } elsif ($CreateTTY & 4) {
533 if (defined $console) {
534 my ($i, $o) = split /,/, $console;
535 $o = $i unless defined $o;
536 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
537 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
538 || open(OUT,">&STDOUT"); # so we don't dongle stdout
541 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
542 $console = 'STDIN/OUT';
544 # so open("|more") can read from STDOUT and so we don't dingle stdin
549 my $previous = select($OUT);
550 $| = 1; # for DB::OUT
553 $LINEINFO = $OUT unless defined $LINEINFO;
554 $lineinfo = $console unless defined $lineinfo;
556 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
557 unless ($runnonstop) {
558 if ($term_pid eq '-1') {
559 print $OUT "\nDaughter DB session started...\n";
561 print $OUT "\nLoading DB routines from $header\n";
562 print $OUT ("Editor support ",
563 $slave_editor ? "enabled" : "available",
565 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
573 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
576 if (defined &afterinit) { # May be defined in $rcfile
582 ############################################################ Subroutines
585 # _After_ the perl program is compiled, $single is set to 1:
586 if ($single and not $second_time++) {
587 if ($runnonstop) { # Disable until signal
588 for ($i=0; $i <= $stack_depth; ) {
592 # return; # Would not print trace!
593 } elsif ($ImmediateStop) {
598 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
600 ($package, $filename, $line) = caller;
601 $filename_ini = $filename;
602 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
603 "package $package;"; # this won't let them modify, alas
604 local(*dbline) = $main::{'_<' . $filename};
606 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
610 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
611 $dbline{$line} =~ s/;9($|\0)/$1/;
614 my $was_signal = $signal;
616 for (my $n = 0; $n <= $#to_watch; $n++) {
617 $evalarg = $to_watch[$n];
618 local $onetimeDump; # Do not output results
619 my ($val) = &eval; # Fix context (&eval is doing array)?
620 $val = ( (defined $val) ? "'$val'" : 'undef' );
621 if ($val ne $old_watch[$n]) {
624 Watchpoint $n:\t$to_watch[$n] changed:
625 old value:\t$old_watch[$n]
628 $old_watch[$n] = $val;
632 if ($trace & 4) { # User-installed watch
633 return if watchfunction($package, $filename, $line)
634 and not $single and not $was_signal and not ($trace & ~4);
636 $was_signal = $signal;
638 if ($single || ($trace & 1) || $was_signal) {
640 $position = "\032\032$filename:$line:0\n";
641 print_lineinfo($position);
642 } elsif ($package eq 'DB::fake') {
645 Debugged program terminated. Use B<q> to quit or B<R> to restart,
646 use B<O> I<inhibit_exit> to avoid stopping after program termination,
647 B<h q>, B<h R> or B<h O> to get additional info.
650 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
651 "package $package;"; # this won't let them modify, alas
654 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
655 $prefix .= "$sub($filename:";
656 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
657 if (length($prefix) > 30) {
658 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
663 $position = "$prefix$line$infix$dbline[$line]$after";
666 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
668 print_lineinfo($position);
670 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
671 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
673 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
674 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
675 $position .= $incr_pos;
677 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
679 print_lineinfo($incr_pos);
684 $evalarg = $action, &eval if $action;
685 if ($single || $was_signal) {
686 local $level = $level + 1;
687 foreach $evalarg (@$pre) {
690 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
693 $incr = -1; # for backward motion.
694 @typeahead = (@$pretype, @typeahead);
696 while (($term || &setterm),
697 ($term_pid == $$ or resetterm(1)),
698 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
699 ($#hist+1) . ('>' x $level) .
704 $cmd =~ s/\\$/\n/ && do {
705 $cmd .= &readline(" cont: ");
708 $cmd =~ /^$/ && ($cmd = $laststep);
709 push(@hist,$cmd) if length($cmd) > 1;
711 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
712 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
713 ($i) = split(/\s+/,$cmd);
715 # squelch the sigmangler
717 local $SIG{__WARN__};
718 eval "\$cmd =~ $alias{$i}";
720 print $OUT "Couldn't evaluate `$i' alias: $@";
724 $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
725 $cmd =~ /^h$/ && do {
728 $cmd =~ /^h\s+h$/ && do {
729 print_help($summary);
731 # support long commands; otherwise bogus errors
732 # happen when you ask for h on <CR> for example
733 $cmd =~ /^h\s+(\S.*)$/ && do {
734 my $asked = $1; # for proper errmsg
735 my $qasked = quotemeta($asked); # for searching
736 # XXX: finds CR but not <CR>
737 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
738 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
742 print_help("B<$asked> is not a debugger command.\n");
745 $cmd =~ /^t$/ && do {
747 print $OUT "Trace = " .
748 (($trace & 1) ? "on" : "off" ) . "\n";
750 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
751 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
752 foreach $subname (sort(keys %sub)) {
753 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
754 print $OUT $subname,"\n";
758 $cmd =~ /^v$/ && do {
759 list_versions(); next CMD};
760 $cmd =~ s/^X\b/V $package/;
761 $cmd =~ /^V$/ && do {
762 $cmd = "V $package"; };
763 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
764 local ($savout) = select($OUT);
766 @vars = split(' ',$2);
767 do 'dumpvar.pl' unless defined &main::dumpvar;
768 if (defined &main::dumpvar) {
771 # must detect sigpipe failures
772 eval { &main::dumpvar($packname,@vars) };
774 die unless $@ =~ /dumpvar print failed/;
777 print $OUT "dumpvar.pl not available.\n";
781 $cmd =~ s/^x\b/ / && do { # So that will be evaled
782 $onetimeDump = 'dump'; };
783 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
784 methods($1); next CMD};
785 $cmd =~ s/^m\b/ / && do { # So this will be evaled
786 $onetimeDump = 'methods'; };
787 $cmd =~ /^f\b\s*(.*)/ && do {
791 print $OUT "The old f command is now the r command.\n";
792 print $OUT "The new f command switches filenames.\n";
795 if (!defined $main::{'_<' . $file}) {
796 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
797 $try = substr($try,2);
798 print $OUT "Choosing $try matching `$file':\n";
802 if (!defined $main::{'_<' . $file}) {
803 print $OUT "No file matching `$file' is loaded.\n";
805 } elsif ($file ne $filename) {
806 *dbline = $main::{'_<' . $file};
812 print $OUT "Already in $file.\n";
816 $cmd =~ s/^l\s+-\s*$/-/;
817 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
820 print($OUT "Error: $@\n"), next CMD if $@;
822 print($OUT "Interpreted as: $1 $s\n");
825 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
826 my $s = $subname = $1;
827 $subname =~ s/\'/::/;
828 $subname = $package."::".$subname
829 unless $subname =~ /::/;
830 $subname = "CORE::GLOBAL::$s"
831 if not defined &$subname and $s !~ /::/
832 and defined &{"CORE::GLOBAL::$s"};
833 $subname = "main".$subname if substr($subname,0,2) eq "::";
834 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
835 $subrange = pop @pieces;
836 $file = join(':', @pieces);
837 if ($file ne $filename) {
838 print $OUT "Switching to file '$file'.\n"
839 unless $slave_editor;
840 *dbline = $main::{'_<' . $file};
845 if (eval($subrange) < -$window) {
846 $subrange =~ s/-.*/+/;
848 $cmd = "l $subrange";
850 print $OUT "Subroutine $subname not found.\n";
853 $cmd =~ /^\.$/ && do {
854 $incr = -1; # for backward motion.
856 $filename = $filename_ini;
857 *dbline = $main::{'_<' . $filename};
859 print_lineinfo($position);
861 $cmd =~ /^w\b\s*(\d*)$/ && do {
865 #print $OUT 'l ' . $start . '-' . ($start + $incr);
866 $cmd = 'l ' . $start . '-' . ($start + $incr); };
867 $cmd =~ /^-$/ && do {
868 $start -= $incr + $window + 1;
869 $start = 1 if $start <= 0;
871 $cmd = 'l ' . ($start) . '+'; };
872 $cmd =~ /^l$/ && do {
874 $cmd = 'l ' . $start . '-' . ($start + $incr); };
875 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
878 $incr = $window - 1 unless $incr;
879 $cmd = 'l ' . $start . '-' . ($start + $incr); };
880 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
881 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
882 $end = $max if $end > $max;
884 $i = $line if $i eq '.';
888 print $OUT "\032\032$filename:$i:0\n";
891 for (; $i <= $end; $i++) {
892 ($stop,$action) = split(/\0/, $dbline{$i}) if
895 and $filename eq $filename_ini)
897 : ($dbline[$i]+0 ? ':' : ' ') ;
898 $arrow .= 'b' if $stop;
899 $arrow .= 'a' if $action;
900 print $OUT "$i$arrow\t", $dbline[$i];
901 $i++, last if $signal;
903 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
905 $start = $i; # remember in case they want more
906 $start = $max if $start > $max;
908 $cmd =~ /^D$/ && do {
909 print $OUT "Deleting all breakpoints...\n";
911 for $file (keys %had_breakpoints) {
912 local *dbline = $main::{'_<' . $file};
916 for ($i = 1; $i <= $max ; $i++) {
917 if (defined $dbline{$i}) {
918 $dbline{$i} =~ s/^[^\0]+//;
919 if ($dbline{$i} =~ s/^\0?$//) {
925 if (not $had_breakpoints{$file} &= ~1) {
926 delete $had_breakpoints{$file};
930 undef %postponed_file;
931 undef %break_on_load;
933 $cmd =~ /^L$/ && do {
935 for $file (keys %had_breakpoints) {
936 local *dbline = $main::{'_<' . $file};
940 for ($i = 1; $i <= $max; $i++) {
941 if (defined $dbline{$i}) {
942 print $OUT "$file:\n" unless $was++;
943 print $OUT " $i:\t", $dbline[$i];
944 ($stop,$action) = split(/\0/, $dbline{$i});
945 print $OUT " break if (", $stop, ")\n"
947 print $OUT " action: ", $action, "\n"
954 print $OUT "Postponed breakpoints in subroutines:\n";
956 for $subname (keys %postponed) {
957 print $OUT " $subname\t$postponed{$subname}\n";
961 my @have = map { # Combined keys
962 keys %{$postponed_file{$_}}
963 } keys %postponed_file;
965 print $OUT "Postponed breakpoints in files:\n";
967 for $file (keys %postponed_file) {
968 my $db = $postponed_file{$file};
969 print $OUT " $file:\n";
970 for $line (sort {$a <=> $b} keys %$db) {
971 print $OUT " $line:\n";
972 my ($stop,$action) = split(/\0/, $$db{$line});
973 print $OUT " break if (", $stop, ")\n"
975 print $OUT " action: ", $action, "\n"
982 if (%break_on_load) {
983 print $OUT "Breakpoints on load:\n";
985 for $file (keys %break_on_load) {
986 print $OUT " $file\n";
991 print $OUT "Watch-expressions:\n";
993 for $expr (@to_watch) {
994 print $OUT " $expr\n";
999 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
1000 my $file = $1; $file =~ s/\s+$//;
1003 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
1004 my $cond = length $3 ? $3 : '1';
1005 my ($subname, $break) = ($2, $1 eq 'postpone');
1006 $subname =~ s/\'/::/g;
1007 $subname = "${'package'}::" . $subname
1008 unless $subname =~ /::/;
1009 $subname = "main".$subname if substr($subname,0,2) eq "::";
1010 $postponed{$subname} = $break
1011 ? "break +0 if $cond" : "compile";
1013 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1015 $cond = length $2 ? $2 : '1';
1016 cmd_b_sub($subname, $cond);
1018 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1020 $cond = length $2 ? $2 : '1';
1021 cmd_b_line($i, $cond);
1023 $cmd =~ /^d\b\s*(\d*)/ && do {
1026 $cmd =~ /^A$/ && do {
1027 print $OUT "Deleting all actions...\n";
1029 for $file (keys %had_breakpoints) {
1030 local *dbline = $main::{'_<' . $file};
1034 for ($i = 1; $i <= $max ; $i++) {
1035 if (defined $dbline{$i}) {
1036 $dbline{$i} =~ s/\0[^\0]*//;
1037 delete $dbline{$i} if $dbline{$i} eq '';
1041 unless ($had_breakpoints{$file} &= ~2) {
1042 delete $had_breakpoints{$file};
1046 $cmd =~ /^O\s*$/ && do {
1051 $cmd =~ /^O\s*(\S.*)/ && do {
1054 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1055 push @$pre, action($1);
1057 $cmd =~ /^>>\s*(.*)/ && do {
1058 push @$post, action($1);
1060 $cmd =~ /^<\s*(.*)/ && do {
1062 print $OUT "All < actions cleared.\n";
1068 print $OUT "No pre-prompt Perl actions.\n";
1071 print $OUT "Perl commands run before each prompt:\n";
1072 for my $action ( @$pre ) {
1073 print $OUT "\t< -- $action\n";
1077 $pre = [action($1)];
1079 $cmd =~ /^>\s*(.*)/ && do {
1081 print $OUT "All > actions cleared.\n";
1087 print $OUT "No post-prompt Perl actions.\n";
1090 print $OUT "Perl commands run after each prompt:\n";
1091 for my $action ( @$post ) {
1092 print $OUT "\t> -- $action\n";
1096 $post = [action($1)];
1098 $cmd =~ /^\{\{\s*(.*)/ && do {
1099 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1100 print $OUT "{{ is now a debugger command\n",
1101 "use `;{{' if you mean Perl code\n";
1107 $cmd =~ /^\{\s*(.*)/ && do {
1109 print $OUT "All { actions cleared.\n";
1114 unless (@$pretype) {
1115 print $OUT "No pre-prompt debugger actions.\n";
1118 print $OUT "Debugger commands run before each prompt:\n";
1119 for my $action ( @$pretype ) {
1120 print $OUT "\t{ -- $action\n";
1124 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1125 print $OUT "{ is now a debugger command\n",
1126 "use `;{' if you mean Perl code\n";
1132 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1133 $i = $1 || $line; $j = $2;
1135 if ($dbline[$i] == 0) {
1136 print $OUT "Line $i may not have an action.\n";
1138 $had_breakpoints{$filename} |= 2;
1139 $dbline{$i} =~ s/\0[^\0]*//;
1140 $dbline{$i} .= "\0" . action($j);
1143 $dbline{$i} =~ s/\0[^\0]*//;
1144 delete $dbline{$i} if $dbline{$i} eq '';
1147 $cmd =~ /^n$/ && do {
1148 end_report(), next CMD if $finished and $level <= 1;
1152 $cmd =~ /^s$/ && do {
1153 end_report(), next CMD if $finished and $level <= 1;
1157 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1158 end_report(), next CMD if $finished and $level <= 1;
1160 # Probably not needed, since we finish an interactive
1161 # sub-session anyway...
1162 # local $filename = $filename;
1163 # local *dbline = *dbline; # XXX Would this work?!
1164 if ($i =~ /\D/) { # subroutine name
1165 $subname = $package."::".$subname
1166 unless $subname =~ /::/;
1167 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1171 *dbline = $main::{'_<' . $filename};
1172 $had_breakpoints{$filename} |= 1;
1174 ++$i while $dbline[$i] == 0 && $i < $max;
1176 print $OUT "Subroutine $subname not found.\n";
1181 if ($dbline[$i] == 0) {
1182 print $OUT "Line $i not breakable.\n";
1185 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1187 for ($i=0; $i <= $stack_depth; ) {
1191 $cmd =~ /^r$/ && do {
1192 end_report(), next CMD if $finished and $level <= 1;
1193 $stack[$stack_depth] |= 1;
1194 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1196 $cmd =~ /^R$/ && do {
1197 print $OUT "Warning: some settings and command-line options may be lost!\n";
1198 my (@script, @flags, $cl);
1199 push @flags, '-w' if $ini_warn;
1200 # Put all the old includes at the start to get
1201 # the same debugger.
1203 push @flags, '-I', $_;
1205 # Arrange for setting the old INC:
1206 set_list("PERLDB_INC", @ini_INC);
1208 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1209 chomp ($cl = ${'::_<-e'}[$_]);
1210 push @script, '-e', $cl;
1215 set_list("PERLDB_HIST",
1216 $term->Features->{getHistory}
1217 ? $term->GetHistory : @hist);
1218 my @had_breakpoints = keys %had_breakpoints;
1219 set_list("PERLDB_VISITED", @had_breakpoints);
1220 set_list("PERLDB_OPT", %option);
1221 set_list("PERLDB_ON_LOAD", %break_on_load);
1223 for (0 .. $#had_breakpoints) {
1224 my $file = $had_breakpoints[$_];
1225 *dbline = $main::{'_<' . $file};
1226 next unless %dbline or $postponed_file{$file};
1227 (push @hard, $file), next
1228 if $file =~ /^\(eval \d+\)$/;
1230 @add = %{$postponed_file{$file}}
1231 if $postponed_file{$file};
1232 set_list("PERLDB_FILE_$_", %dbline, @add);
1234 for (@hard) { # Yes, really-really...
1235 # Find the subroutines in this eval
1236 *dbline = $main::{'_<' . $_};
1237 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1238 for $sub (keys %sub) {
1239 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1240 $subs{$sub} = [$1, $2];
1244 "No subroutines in $_, ignoring breakpoints.\n";
1247 LINES: for $line (keys %dbline) {
1248 # One breakpoint per sub only:
1249 my ($offset, $sub, $found);
1250 SUBS: for $sub (keys %subs) {
1251 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1252 and (not defined $offset # Not caught
1253 or $offset < 0 )) { # or badly caught
1255 $offset = $line - $subs{$sub}->[0];
1256 $offset = "+$offset", last SUBS if $offset >= 0;
1259 if (defined $offset) {
1260 $postponed{$found} =
1261 "break $offset if $dbline{$line}";
1263 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1267 set_list("PERLDB_POSTPONE", %postponed);
1268 set_list("PERLDB_PRETYPE", @$pretype);
1269 set_list("PERLDB_PRE", @$pre);
1270 set_list("PERLDB_POST", @$post);
1271 set_list("PERLDB_TYPEAHEAD", @typeahead);
1272 $ENV{PERLDB_RESTART} = 1;
1273 delete $ENV{PERLDB_PIDS}; # Restore ini state
1274 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1275 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1276 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1277 print $OUT "exec failed: $!\n";
1279 $cmd =~ /^T$/ && do {
1280 print_trace($OUT, 1); # skip DB
1282 $cmd =~ /^W\s*$/ && do {
1284 @to_watch = @old_watch = ();
1286 $cmd =~ /^W\b\s*(.*)/s && do {
1290 $val = (defined $val) ? "'$val'" : 'undef' ;
1291 push @old_watch, $val;
1294 $cmd =~ /^\/(.*)$/ && do {
1296 $inpat =~ s:([^\\])/$:$1:;
1298 # squelch the sigmangler
1299 local $SIG{__DIE__};
1300 local $SIG{__WARN__};
1301 eval '$inpat =~ m'."\a$inpat\a";
1313 $start = 1 if ($start > $max);
1314 last if ($start == $end);
1315 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1316 if ($slave_editor) {
1317 print $OUT "\032\032$filename:$start:0\n";
1319 print $OUT "$start:\t", $dbline[$start], "\n";
1324 print $OUT "/$pat/: not found\n" if ($start == $end);
1326 $cmd =~ /^\?(.*)$/ && do {
1328 $inpat =~ s:([^\\])\?$:$1:;
1330 # squelch the sigmangler
1331 local $SIG{__DIE__};
1332 local $SIG{__WARN__};
1333 eval '$inpat =~ m'."\a$inpat\a";
1345 $start = $max if ($start <= 0);
1346 last if ($start == $end);
1347 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1348 if ($slave_editor) {
1349 print $OUT "\032\032$filename:$start:0\n";
1351 print $OUT "$start:\t", $dbline[$start], "\n";
1356 print $OUT "?$pat?: not found\n" if ($start == $end);
1358 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1359 pop(@hist) if length($cmd) > 1;
1360 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1362 print $OUT $cmd, "\n";
1364 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1367 $cmd =~ /^$rc([^$rc].*)$/ && do {
1369 pop(@hist) if length($cmd) > 1;
1370 for ($i = $#hist; $i; --$i) {
1371 last if $hist[$i] =~ /$pat/;
1374 print $OUT "No such command!\n\n";
1378 print $OUT $cmd, "\n";
1380 $cmd =~ /^$sh$/ && do {
1381 &system($ENV{SHELL}||"/bin/sh");
1383 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1384 # XXX: using csh or tcsh destroys sigint retvals!
1385 #&system($1); # use this instead
1386 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1388 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1389 $end = $2 ? ($#hist-$2) : 0;
1390 $hist = 0 if $hist < 0;
1391 for ($i=$#hist; $i>$end; $i--) {
1392 print $OUT "$i: ",$hist[$i],"\n"
1393 unless $hist[$i] =~ /^.?$/;
1396 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1399 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1400 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1401 $cmd =~ s/^=\s*// && do {
1403 if (length $cmd == 0) {
1404 @keys = sort keys %alias;
1406 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1407 # can't use $_ or kill //g state
1408 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1409 $alias{$k} = "s\a$k\a$v\a";
1410 # squelch the sigmangler
1411 local $SIG{__DIE__};
1412 local $SIG{__WARN__};
1413 unless (eval "sub { s\a$k\a$v\a }; 1") {
1414 print $OUT "Can't alias $k to $v: $@\n";
1424 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1425 print $OUT "$k\t= $1\n";
1427 elsif (defined $alias{$k}) {
1428 print $OUT "$k\t$alias{$k}\n";
1431 print "No alias for $k\n";
1435 $cmd =~ /^\|\|?\s*[^|]/ && do {
1436 if ($pager =~ /^\|/) {
1437 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1438 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1440 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1443 unless ($piped=open(OUT,$pager)) {
1444 &warn("Can't pipe output to `$pager'");
1445 if ($pager =~ /^\|/) {
1446 open(OUT,">&STDOUT") # XXX: lost message
1447 || &warn("Can't restore DB::OUT");
1448 open(STDOUT,">&SAVEOUT")
1449 || &warn("Can't restore STDOUT");
1452 open(OUT,">&STDOUT") # XXX: lost message
1453 || &warn("Can't restore DB::OUT");
1457 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1458 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1459 $selected= select(OUT);
1461 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1462 $cmd =~ s/^\|+\s*//;
1465 # XXX Local variants do not work!
1466 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1467 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1468 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1470 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1472 $onetimeDump = undef;
1473 } elsif ($term_pid == $$) {
1478 if ($pager =~ /^\|/) {
1480 # we cannot warn here: the handle is missing --tchrist
1481 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1483 # most of the $? crud was coping with broken cshisms
1485 print SAVEOUT "Pager `$pager' failed: ";
1487 print SAVEOUT "shell returned -1\n";
1490 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1491 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1493 print SAVEOUT "status ", ($? >> 8), "\n";
1497 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1498 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1499 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1500 # Will stop ignoring SIGPIPE if done like nohup(1)
1501 # does SIGINT but Perl doesn't give us a choice.
1503 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1506 select($selected), $selected= "" unless $selected eq "";
1510 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1511 foreach $evalarg (@$post) {
1514 } # if ($single || $signal)
1515 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1519 # The following code may be executed now:
1523 my ($al, $ret, @ret) = "";
1524 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1527 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1528 $#stack = $stack_depth;
1529 $stack[-1] = $single;
1531 $single |= 4 if $stack_depth == $deep;
1533 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1534 # Why -1? But it works! :-(
1535 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1536 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1539 $single |= $stack[$stack_depth--];
1541 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1542 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1543 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1544 if ($doret eq $stack_depth or $frame & 16) {
1545 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1546 print $fh ' ' x $stack_depth if $frame & 16;
1547 print $fh "list context return from $sub:\n";
1548 dumpit($fh, \@ret );
1553 if (defined wantarray) {
1558 $single |= $stack[$stack_depth--];
1560 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1561 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1562 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1563 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1564 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1565 print $fh (' ' x $stack_depth) if $frame & 16;
1566 print $fh (defined wantarray
1567 ? "scalar context return from $sub: "
1568 : "void context return from $sub\n");
1569 dumpit( $fh, $ret ) if defined wantarray;
1578 ### Functions with multiple modes of failure die on error, the rest
1579 ### returns FALSE on error.
1580 ### User-interface functions cmd_* output error message.
1584 $break_on_load{$file} = 1;
1585 $had_breakpoints{$file} |= 1;
1588 sub report_break_on_load {
1589 sort keys %break_on_load;
1597 push @files, $::INC{$file} if $::INC{$file};
1598 $file .= '.pm', redo unless $file =~ /\./;
1600 break_on_load($_) for @files;
1601 @files = report_break_on_load;
1602 print $OUT "Will stop on load of `@files'.\n";
1605 $filename_error = '';
1607 sub breakable_line {
1608 my ($from, $to) = @_;
1611 my $delta = $from < $to ? +1 : -1;
1612 my $limit = $delta > 0 ? $#dbline : 1;
1613 $limit = $to if ($limit - $to) * $delta > 0;
1614 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1616 return $i unless $dbline[$i] == 0;
1617 my ($pl, $upto) = ('', '');
1618 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1619 die "Line$pl $from$upto$filename_error not breakable\n";
1622 sub breakable_line_in_filename {
1624 local *dbline = $main::{'_<' . $f};
1625 local $filename_error = " of `$f'";
1630 my ($i, $cond) = @_;
1631 $cond = 1 unless @_ >= 2;
1635 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1636 $had_breakpoints{$filename} |= 1;
1637 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1638 else { $dbline{$i} = $cond; }
1642 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1645 sub break_on_filename_line {
1646 my ($f, $i, $cond) = @_;
1647 $cond = 1 unless @_ >= 3;
1648 local *dbline = $main::{'_<' . $f};
1649 local $filename_error = " of `$f'";
1650 local $filename = $f;
1651 break_on_line($i, $cond);
1654 sub break_on_filename_line_range {
1655 my ($f, $from, $to, $cond) = @_;
1656 my $i = breakable_line_in_filename($f, $from, $to);
1657 $cond = 1 unless @_ >= 3;
1658 break_on_filename_line($f,$i,$cond);
1661 sub subroutine_filename_lines {
1662 my ($subname,$cond) = @_;
1663 # Filename below can contain ':'
1664 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1667 sub break_subroutine {
1668 my $subname = shift;
1669 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1670 die "Subroutine $subname not found.\n";
1671 $cond = 1 unless @_ >= 2;
1672 break_on_filename_line_range($file,$s,$e,@_);
1676 my ($subname,$cond) = @_;
1677 $cond = 1 unless @_ >= 2;
1678 unless (ref $subname eq 'CODE') {
1679 $subname =~ s/\'/::/g;
1681 $subname = "${'package'}::" . $subname
1682 unless $subname =~ /::/;
1683 $subname = "CORE::GLOBAL::$s"
1684 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1685 $subname = "main".$subname if substr($subname,0,2) eq "::";
1687 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1690 sub cmd_stop { # As on ^C, but not signal-safy.
1694 sub delete_breakpoint {
1696 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1697 $dbline{$i} =~ s/^[^\0]*//;
1698 delete $dbline{$i} if $dbline{$i} eq '';
1703 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1706 ### END of the API section
1709 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1710 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1713 sub print_lineinfo {
1714 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1718 # The following takes its argument via $evalarg to preserve current @_
1721 # 'my' would make it visible from user code
1722 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1725 local $otrace = $trace;
1726 local $osingle = $single;
1728 { ($evalarg) = $evalarg =~ /(.*)/s; }
1729 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1735 local $saved[0]; # Preserve the old value of $@
1739 } elsif ($onetimeDump) {
1740 dumpit($OUT, \@res) if $onetimeDump eq 'dump';
1741 methods($res[0]) if $onetimeDump eq 'methods';
1747 my $subname = shift;
1748 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1749 my $offset = $1 || 0;
1750 # Filename below can contain ':'
1751 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1754 local *dbline = $main::{'_<' . $file};
1755 local $^W = 0; # != 0 is magical below
1756 $had_breakpoints{$file} |= 1;
1758 ++$i until $dbline[$i] != 0 or $i >= $max;
1759 $dbline{$i} = delete $postponed{$subname};
1761 print $OUT "Subroutine $subname not found.\n";
1765 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1766 #print $OUT "In postponed_sub for `$subname'.\n";
1770 if ($ImmediateStop) {
1774 return &postponed_sub
1775 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1776 # Cannot be done before the file is compiled
1777 local *dbline = shift;
1778 my $filename = $dbline;
1779 $filename =~ s/^_<//;
1780 $signal = 1, print $OUT "'$filename' loaded...\n"
1781 if $break_on_load{$filename};
1782 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1783 return unless $postponed_file{$filename};
1784 $had_breakpoints{$filename} |= 1;
1785 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1787 for $key (keys %{$postponed_file{$filename}}) {
1788 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1790 delete $postponed_file{$filename};
1794 local ($savout) = select(shift);
1795 my $osingle = $single;
1796 my $otrace = $trace;
1797 $single = $trace = 0;
1800 unless (defined &main::dumpValue) {
1803 if (defined &main::dumpValue) {
1804 &main::dumpValue(shift);
1806 print $OUT "dumpvar.pl not available.\n";
1813 # Tied method do not create a context, so may get wrong message:
1817 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1818 my @sub = dump_trace($_[0] + 1, $_[1]);
1819 my $short = $_[2]; # Print short report, next one for sub name
1821 for ($i=0; $i <= $#sub; $i++) {
1824 my $args = defined $sub[$i]{args}
1825 ? "(@{ $sub[$i]{args} })"
1827 $args = (substr $args, 0, $maxtrace - 3) . '...'
1828 if length $args > $maxtrace;
1829 my $file = $sub[$i]{file};
1830 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1832 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1834 my $sub = @_ >= 4 ? $_[3] : $s;
1835 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1837 print $fh "$sub[$i]{context} = $s$args" .
1838 " called from $file" .
1839 " line $sub[$i]{line}\n";
1846 my $count = shift || 1e9;
1849 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1850 my $nothard = not $frame & 8;
1851 local $frame = 0; # Do not want to trace this.
1852 my $otrace = $trace;
1855 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1860 if (not defined $arg) {
1862 } elsif ($nothard and tied $arg) {
1864 } elsif ($nothard and $type = ref $arg) {
1865 push @a, "ref($type)";
1867 local $_ = "$arg"; # Safe to stringify now - should not call f().
1870 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1871 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1872 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1876 $context = $context ? '@' : (defined $context ? "\$" : '.');
1877 $args = $h ? [@a] : undef;
1878 $e =~ s/\n\s*\;\s*\Z// if $e;
1879 $e =~ s/([\\\'])/\\$1/g if $e;
1881 $sub = "require '$e'";
1882 } elsif (defined $r) {
1884 } elsif ($sub eq '(eval)') {
1885 $sub = "eval {...}";
1887 push(@sub, {context => $context, sub => $sub, args => $args,
1888 file => $file, line => $line});
1897 while ($action =~ s/\\$//) {
1906 # i hate using globals!
1907 $balanced_brace_re ||= qr{
1910 (?> [^{}] + ) # Non-parens without backtracking
1912 (??{ $balanced_brace_re }) # Group with matching parens
1916 return $_[0] !~ m/$balanced_brace_re/;
1920 &readline("cont: ");
1924 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1925 # some non-Unix systems can do system() but have problems with fork().
1926 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1927 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1928 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1929 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1931 # XXX: using csh or tcsh destroys sigint retvals!
1933 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1934 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1939 # most of the $? crud was coping with broken cshisms
1941 &warn("(Command exited ", ($? >> 8), ")\n");
1943 &warn( "(Command died of SIG#", ($? & 127),
1944 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1954 eval { require Term::ReadLine } or die $@;
1957 my ($i, $o) = split $tty, /,/;
1958 $o = $i unless defined $o;
1959 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1960 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1963 my $sel = select($OUT);
1967 eval "require Term::Rendezvous;" or die;
1968 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1969 my $term_rv = new Term::Rendezvous $rv;
1971 $OUT = $term_rv->OUT;
1974 if ($term_pid eq '-1') { # In a TTY with another debugger
1978 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1980 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1982 $rl_attribs = $term->Attribs;
1983 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1984 if defined $rl_attribs->{basic_word_break_characters}
1985 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1986 $rl_attribs->{special_prefixes} = '$@&%';
1987 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1988 $rl_attribs->{completion_function} = \&db_complete;
1990 $LINEINFO = $OUT unless defined $LINEINFO;
1991 $lineinfo = $console unless defined $lineinfo;
1993 if ($term->Features->{setHistory} and "@hist" ne "?") {
1994 $term->SetHistory(@hist);
1996 ornaments($ornaments) if defined $ornaments;
2000 # Example get_fork_TTY functions
2001 sub xterm_get_fork_TTY {
2002 (my $name = $0) =~ s,^.*[/\\],,s;
2003 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2007 $pidprompt = ''; # Shown anyway in titlebar
2011 # This one resets $IN, $OUT itself
2012 sub os2_get_fork_TTY {
2013 $^F = 40; # XXXX Fixme!
2014 my ($in1, $out1, $in2, $out2);
2015 # Having -d in PERL5OPT would lead to a disaster...
2016 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2017 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2018 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2019 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2020 (my $name = $0) =~ s,^.*[/\\],,s;
2021 if ( pipe $in1, $out1 and pipe $in2, $out2 and
2022 # system P_SESSION will fail if there is another process
2023 # in the same session with a "dependent" asynchronous child session.
2024 (($kpid = CORE::system 4, $^X, '-we', <<'ES', fileno $in1, fileno $out2, "Daughter Perl debugger $pids $name") >= 0 or warn "system P_SESSION: $!, $^E" and 0) # P_SESSION
2028 my $in = shift; # Read from here and pass through
2030 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2031 open IN, '<&=$in' or die "open <&=$in: \$!";
2032 \$| = 1; print while sysread IN, \$_, 1<<16;
2036 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2038 ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
2039 print while sysread STDIN, $_, 1<<16;
2041 and close $in1 and close $out2 ) {
2042 $pidprompt = ''; # Shown anyway in titlebar
2043 reset_IN_OUT($in2, $out1);
2045 return ''; # Indicate that reset_IN_OUT is called
2050 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2051 my $in = &get_fork_TTY if defined &get_fork_TTY;
2052 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2053 if (not defined $in) {
2055 print_help(<<EOP) if $why == 1;
2056 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2058 print_help(<<EOP) if $why == 2;
2059 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2060 This may be an asynchronous session, so the parent debugger may be active.
2062 print_help(<<EOP) if $why != 4;
2063 Since two debuggers fight for the same TTY, input is severely entangled.
2067 I know how to switch the output to a different window in xterms
2068 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2069 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2071 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2072 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2075 } elsif ($in ne '') {
2081 sub resetterm { # We forked, so we need a different TTY
2083 my $systemed = $in > 1 ? '-' : '';
2085 $pids =~ s/\]/$systemed->$$]/;
2087 $pids = "[$term_pid->$$]";
2091 return unless $CreateTTY & $in;
2098 my $left = @typeahead;
2099 my $got = shift @typeahead;
2100 print $OUT "auto(-$left)", shift, $got, "\n";
2101 $term->AddHistory($got)
2102 if length($got) > 1 and defined $term->Features->{addHistory};
2107 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2108 $OUT->write(join('', @_));
2110 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2114 $term->readline(@_);
2119 my ($opt, $val)= @_;
2120 $val = option_val($opt,'N/A');
2121 $val =~ s/([\\\'])/\\$1/g;
2122 printf $OUT "%20s = '%s'\n", $opt, $val;
2126 my ($opt, $default)= @_;
2128 if (defined $optionVars{$opt}
2129 and defined ${$optionVars{$opt}}) {
2130 $val = ${$optionVars{$opt}};
2131 } elsif (defined $optionAction{$opt}
2132 and defined &{$optionAction{$opt}}) {
2133 $val = &{$optionAction{$opt}}();
2134 } elsif (defined $optionAction{$opt}
2135 and not defined $option{$opt}
2136 or defined $optionVars{$opt}
2137 and not defined ${$optionVars{$opt}}) {
2140 $val = $option{$opt};
2142 $val = $default unless defined $val;
2148 # too dangerous to let intuitive usage overwrite important things
2149 # defaultion should never be the default
2150 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2151 arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2152 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2157 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2158 my ($opt,$sep) = ($1,$2);
2161 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2163 #&dump_option($opt);
2164 } elsif ($sep !~ /\S/) {
2166 $val = "1"; # this is an evil default; make 'em set it!
2167 } elsif ($sep eq "=") {
2169 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2171 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2175 print OUT qq(Option better cleared using $opt=""\n)
2179 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2180 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2181 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2182 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2183 ($val = $1) =~ s/\\([\\$end])/$1/g;
2187 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2188 || grep( /^\Q$opt/i && ($option = $_), @options );
2190 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2191 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2193 if ($opt_needs_val{$option} && $val_defaulted) {
2194 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2198 $option{$option} = $val if defined $val;
2203 require '$optionRequire{$option}';
2205 } || die # XXX: shouldn't happen
2206 if defined $optionRequire{$option} &&
2209 ${$optionVars{$option}} = $val
2210 if defined $optionVars{$option} &&
2213 &{$optionAction{$option}} ($val)
2214 if defined $optionAction{$option} &&
2215 defined &{$optionAction{$option}} &&
2219 dump_option($option) unless $OUT eq \*STDERR;
2224 my ($stem,@list) = @_;
2226 $ENV{"${stem}_n"} = @list;
2227 for $i (0 .. $#list) {
2229 $val =~ s/\\/\\\\/g;
2230 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2231 $ENV{"${stem}_$i"} = $val;
2238 my $n = delete $ENV{"${stem}_n"};
2240 for $i (0 .. $n - 1) {
2241 $val = delete $ENV{"${stem}_$i"};
2242 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2250 return; # Put nothing on the stack - malloc/free land!
2254 my($msg)= join("",@_);
2255 $msg .= ": $!\n" unless $msg =~ /\n$/;
2260 my $switch_li = $LINEINFO eq $OUT;
2261 if ($term and $term->Features->{newTTY}) {
2262 ($IN, $OUT) = (shift, shift);
2263 $term->newTTY($IN, $OUT);
2265 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2267 ($IN, $OUT) = (shift, shift);
2269 my $o = select $OUT;
2272 $LINEINFO = $OUT if $switch_li;
2276 if (@_ and $term and $term->Features->{newTTY}) {
2277 my ($in, $out) = shift;
2279 ($in, $out) = split /,/, $in, 2;
2283 open IN, $in or die "cannot open `$in' for read: $!";
2284 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2285 reset_IN_OUT(\*IN,\*OUT);
2288 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2289 # Useful if done through PERLDB_OPTS:
2296 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2298 $notty = shift if @_;
2304 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2312 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2314 $remoteport = shift if @_;
2319 if (${$term->Features}{tkRunning}) {
2320 return $term->tkRunning(@_);
2322 print $OUT "tkRunning not supported by current ReadLine package.\n";
2329 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2331 $runnonstop = shift if @_;
2338 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2345 $sh = quotemeta shift;
2346 $sh .= "\\b" if $sh =~ /\w$/;
2350 $psh =~ s/\\(.)/$1/g;
2355 if (defined $term) {
2356 local ($warnLevel,$dieLevel) = (0, 1);
2357 return '' unless $term->Features->{ornaments};
2358 eval { $term->ornaments(@_) } || '';
2366 $rc = quotemeta shift;
2367 $rc .= "\\b" if $rc =~ /\w$/;
2371 $prc =~ s/\\(.)/$1/g;
2376 return $lineinfo unless @_;
2378 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2379 $slave_editor = ($stream =~ /^\|/);
2380 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2381 $LINEINFO = \*LINEINFO;
2382 my $save = select($LINEINFO);
2396 s/^Term::ReadLine::readline$/readline/;
2397 if (defined ${ $_ . '::VERSION' }) {
2398 $version{$file} = "${ $_ . '::VERSION' } from ";
2400 $version{$file} .= $INC{$file};
2402 dumpit($OUT,\%version);
2406 # XXX: make sure there are tabs between the command and explanation,
2407 # or print_help will screw up your formatting if you have
2408 # eeevil ornaments enabled. This is an insane mess.
2412 B<s> [I<expr>] Single step [in I<expr>].
2413 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2414 <B<CR>> Repeat last B<n> or B<s> command.
2415 B<r> Return from current subroutine.
2416 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2417 at the specified position.
2418 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2419 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2420 B<l> I<line> List single I<line>.
2421 B<l> I<subname> List first window of lines from subroutine.
2422 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2423 B<l> List next window of lines.
2424 B<-> List previous window of lines.
2425 B<w> [I<line>] List window around I<line>.
2426 B<.> Return to the executed line.
2427 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2428 I<filename> may be either the full name of the file, or a regular
2429 expression matching the full file name:
2430 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2431 Evals (with saved bodies) are considered to be filenames:
2432 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2433 (in the order of execution).
2434 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2435 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2436 B<L> List all breakpoints and actions.
2437 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2438 B<t> Toggle trace mode.
2439 B<t> I<expr> Trace through execution of I<expr>.
2440 B<b> [I<line>] [I<condition>]
2441 Set breakpoint; I<line> defaults to the current execution line;
2442 I<condition> breaks if it evaluates to true, defaults to '1'.
2443 B<b> I<subname> [I<condition>]
2444 Set breakpoint at first line of subroutine.
2445 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2446 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2447 B<b> B<postpone> I<subname> [I<condition>]
2448 Set breakpoint at first line of subroutine after
2450 B<b> B<compile> I<subname>
2451 Stop after the subroutine is compiled.
2452 B<d> [I<line>] Delete the breakpoint for I<line>.
2453 B<D> Delete all breakpoints.
2454 B<a> [I<line>] I<command>
2455 Set an action to be done before the I<line> is executed;
2456 I<line> defaults to the current execution line.
2457 Sequence is: check for breakpoint/watchpoint, print line
2458 if necessary, do action, prompt user if necessary,
2460 B<a> [I<line>] Delete the action for I<line>.
2461 B<A> Delete all actions.
2462 B<W> I<expr> Add a global watch-expression.
2463 B<W> Delete all watch-expressions.
2464 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2465 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2466 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2467 B<x> I<expr> Evals expression in list context, dumps the result.
2468 B<m> I<expr> Evals expression in list context, prints methods callable
2469 on the first element of the result.
2470 B<m> I<class> Prints methods callable via the given class.
2472 B<<> ? List Perl commands to run before each prompt.
2473 B<<> I<expr> Define Perl command to run before each prompt.
2474 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2475 B<>> ? List Perl commands to run after each prompt.
2476 B<>> I<expr> Define Perl command to run after each prompt.
2477 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2478 B<{> I<db_command> Define debugger command to run before each prompt.
2479 B<{> ? List debugger commands to run before each prompt.
2480 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2481 B<$prc> I<number> Redo a previous command (default previous command).
2482 B<$prc> I<-number> Redo number'th-to-last command.
2483 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2484 See 'B<O> I<recallCommand>' too.
2485 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2486 . ( $rc eq $sh ? "" : "
2487 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2488 See 'B<O> I<shellBang>' too.
2489 B<H> I<-number> Display last number commands (default all).
2490 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2491 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2492 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2493 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2494 I<command> Execute as a perl statement in current package.
2495 B<v> Show versions of loaded modules.
2496 B<R> Pure-man-restart of debugger, some of debugger state
2497 and command-line options may be lost.
2498 Currently the following settings are preserved:
2499 history, breakpoints and actions, debugger B<O>ptions
2500 and the following command-line options: I<-w>, I<-I>, I<-e>.
2502 B<O> [I<opt>] ... Set boolean option to true
2503 B<O> [I<opt>B<?>] Query options
2504 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2505 Set options. Use quotes in spaces in value.
2506 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2507 I<pager> program for output of \"|cmd\";
2508 I<tkRunning> run Tk while prompting (with ReadLine);
2509 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2510 I<inhibit_exit> Allows stepping off the end of the script.
2511 I<ImmediateStop> Debugger should stop as early as possible.
2512 I<RemotePort> Remote hostname:port for remote debugging
2513 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2514 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2515 I<compactDump>, I<veryCompact> change style of array and hash dump;
2516 I<globPrint> whether to print contents of globs;
2517 I<DumpDBFiles> dump arrays holding debugged files;
2518 I<DumpPackages> dump symbol tables of packages;
2519 I<DumpReused> dump contents of \"reused\" addresses;
2520 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2521 I<bareStringify> Do not print the overload-stringified value;
2522 Other options include:
2523 I<PrintRet> affects printing of return value after B<r> command,
2524 I<frame> affects printing messages on subroutine entry/exit.
2525 I<AutoTrace> affects printing messages on possible breaking points.
2526 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2527 I<ornaments> affects screen appearance of the command line.
2528 I<CreateTTY> bits control attempts to create a new TTY on events:
2529 1: on fork() 2: debugger is started inside debugger
2531 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2532 You can put additional initialization options I<TTY>, I<noTTY>,
2533 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2534 `B<R>' after you set them).
2536 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2537 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2538 B<h h> Summary of debugger commands.
2539 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2540 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2541 Set B<\$DB::doccmd> to change viewer.
2543 Type `|h' for a paged display if this was too hard to read.
2545 "; # Fix balance of vi % matching: }}}}
2547 # note: tabs in the following section are not-so-helpful
2548 $summary = <<"END_SUM";
2549 I<List/search source lines:> I<Control script execution:>
2550 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2551 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2552 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2553 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2554 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2555 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2556 I<Debugger controls:> B<L> List break/watch/actions
2557 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2558 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2559 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2560 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2561 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2562 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2563 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2564 B<q> or B<^D> Quit B<R> Attempt a restart
2565 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2566 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2567 B<p> I<expr> Print expression (uses script's current package).
2568 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2569 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2570 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2571 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2573 # ')}}; # Fix balance of vi % matching
2579 # Restore proper alignment destroyed by eeevil I<> and B<>
2580 # ornaments: A pox on both their houses!
2582 # A help command will have everything up to and including
2583 # the first tab sequence padded into a field 16 (or if indented 20)
2584 # wide. If it's wider than that, an extra space will be added.
2586 ^ # only matters at start of line
2587 ( \040{4} | \t )* # some subcommands are indented
2588 ( < ? # so <CR> works
2589 [BI] < [^\t\n] + ) # find an eeevil ornament
2590 ( \t+ ) # original separation, discarded
2591 ( .* ) # this will now start (no earlier) than
2594 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2595 my $clean = $command;
2596 $clean =~ s/[BI]<([^>]*)>/$1/g;
2597 # replace with this whole string:
2598 ($leadwhite ? " " x 4 : "")
2600 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2605 s{ # handle bold ornaments
2606 B < ( [^>] + | > ) >
2608 $Term::ReadLine::TermCap::rl_term_set[2]
2610 . $Term::ReadLine::TermCap::rl_term_set[3]
2613 s{ # handle italic ornaments
2614 I < ( [^>] + | > ) >
2616 $Term::ReadLine::TermCap::rl_term_set[0]
2618 . $Term::ReadLine::TermCap::rl_term_set[1]
2625 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2626 my $is_less = $pager =~ /\bless\b/;
2627 if ($pager =~ /\bmore\b/) {
2628 my @st_more = stat('/usr/bin/more');
2629 my @st_less = stat('/usr/bin/less');
2630 $is_less = @st_more && @st_less
2631 && $st_more[0] == $st_less[0]
2632 && $st_more[1] == $st_less[1];
2634 # changes environment!
2635 $ENV{LESS} .= 'r' if $is_less;
2641 $SIG{'ABRT'} = 'DEFAULT';
2642 kill 'ABRT', $$ if $panic++;
2643 if (defined &Carp::longmess) {
2644 local $SIG{__WARN__} = '';
2645 local $Carp::CarpLevel = 2; # mydie + confess
2646 &warn(Carp::longmess("Signal @_"));
2649 print $DB::OUT "Got signal @_\n";
2657 local $SIG{__WARN__} = '';
2658 local $SIG{__DIE__} = '';
2659 eval { require Carp } if defined $^S; # If error/warning during compilation,
2660 # require may be broken.
2661 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2662 return unless defined &Carp::longmess;
2663 my ($mysingle,$mytrace) = ($single,$trace);
2664 $single = 0; $trace = 0;
2665 my $mess = Carp::longmess(@_);
2666 ($single,$trace) = ($mysingle,$mytrace);
2673 local $SIG{__DIE__} = '';
2674 local $SIG{__WARN__} = '';
2675 my $i = 0; my $ineval = 0; my $sub;
2676 if ($dieLevel > 2) {
2677 local $SIG{__WARN__} = \&dbwarn;
2678 &warn(@_); # Yell no matter what
2681 if ($dieLevel < 2) {
2682 die @_ if $^S; # in eval propagate
2684 eval { require Carp } if defined $^S; # If error/warning during compilation,
2685 # require may be broken.
2687 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2688 unless defined &Carp::longmess;
2690 # We do not want to debug this chunk (automatic disabling works
2691 # inside DB::DB, but not in Carp).
2692 my ($mysingle,$mytrace) = ($single,$trace);
2693 $single = 0; $trace = 0;
2694 my $mess = Carp::longmess(@_);
2695 ($single,$trace) = ($mysingle,$mytrace);
2701 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2704 $SIG{__WARN__} = \&DB::dbwarn;
2705 } elsif ($prevwarn) {
2706 $SIG{__WARN__} = $prevwarn;
2714 $prevdie = $SIG{__DIE__} unless $dieLevel;
2717 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2718 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2719 print $OUT "Stack dump during die enabled",
2720 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2722 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2723 } elsif ($prevdie) {
2724 $SIG{__DIE__} = $prevdie;
2725 print $OUT "Default die handler restored.\n";
2733 $prevsegv = $SIG{SEGV} unless $signalLevel;
2734 $prevbus = $SIG{BUS} unless $signalLevel;
2735 $signalLevel = shift;
2737 $SIG{SEGV} = \&DB::diesignal;
2738 $SIG{BUS} = \&DB::diesignal;
2740 $SIG{SEGV} = $prevsegv;
2741 $SIG{BUS} = $prevbus;
2749 my $name = CvGV_name_or_bust($in);
2750 defined $name ? $name : $in;
2753 sub CvGV_name_or_bust {
2755 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2756 return unless ref $in;
2757 $in = \&$in; # Hard reference...
2758 eval {require Devel::Peek; 1} or return;
2759 my $gv = Devel::Peek::CvGV($in) or return;
2760 *$gv{PACKAGE} . '::' . *$gv{NAME};
2766 return unless defined &$subr;
2767 my $name = CvGV_name_or_bust($subr);
2769 $data = $sub{$name} if defined $name;
2770 return $data if defined $data;
2773 $subr = \&$subr; # Hard reference
2776 $s = $_, last if $subr eq \&$_;
2784 $class = ref $class if ref $class;
2787 methods_via($class, '', 1);
2788 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2793 return if $packs{$class}++;
2795 my $prepend = $prefix ? "via $prefix: " : '';
2797 for $name (grep {defined &{${"${class}::"}{$_}}}
2798 sort keys %{"${class}::"}) {
2799 next if $seen{ $name }++;
2800 print $DB::OUT "$prepend$name\n";
2802 return unless shift; # Recurse?
2803 for $name (@{"${class}::ISA"}) {
2804 $prepend = $prefix ? $prefix . " -> $name" : $name;
2805 methods_via($name, $prepend, 1);
2810 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2811 ? "man" # O Happy Day!
2812 : "perldoc"; # Alas, poor unfortunates
2818 &system("$doccmd $doccmd");
2821 # this way user can override, like with $doccmd="man -Mwhatever"
2822 # or even just "man " to disable the path check.
2823 unless ($doccmd eq 'man') {
2824 &system("$doccmd $page");
2828 $page = 'perl' if lc($page) eq 'help';
2831 my $man1dir = $Config::Config{'man1dir'};
2832 my $man3dir = $Config::Config{'man3dir'};
2833 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2835 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2836 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2837 chop $manpath if $manpath;
2838 # harmless if missing, I figure
2839 my $oldpath = $ENV{MANPATH};
2840 $ENV{MANPATH} = $manpath if $manpath;
2841 my $nopathopt = $^O =~ /dunno what goes here/;
2842 if (CORE::system($doccmd,
2843 # I just *know* there are men without -M
2844 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2847 unless ($page =~ /^perl\w/) {
2848 if (grep { $page eq $_ } qw{
2849 5004delta 5005delta amiga api apio book boot bot call compile
2850 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2851 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2852 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2853 modinstall modlib number obj op opentut os2 os390 pod port
2854 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2855 trap unicode var vms win32 xs xstut
2859 CORE::system($doccmd,
2860 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2865 if (defined $oldpath) {
2866 $ENV{MANPATH} = $manpath;
2868 delete $ENV{MANPATH};
2872 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2874 BEGIN { # This does not compile, alas.
2875 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2876 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2880 $deep = 100; # warning if stack gets this deep
2884 $SIG{INT} = \&DB::catch;
2885 # This may be enabled to debug debugger:
2886 #$warnLevel = 1 unless defined $warnLevel;
2887 #$dieLevel = 1 unless defined $dieLevel;
2888 #$signalLevel = 1 unless defined $signalLevel;
2890 $db_stop = 0; # Compiler warning
2892 $level = 0; # Level of recursive debugging
2893 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2894 # Triggers bug (?) in perl is we postpone this until runtime:
2895 @postponed = @stack = (0);
2896 $stack_depth = 0; # Localized $#stack
2901 BEGIN {$^W = $ini_warn;} # Switch warnings back
2903 #use Carp; # This did break, left for debugging
2906 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2907 my($text, $line, $start) = @_;
2908 my ($itext, $search, $prefix, $pack) =
2909 ($text, "^\Q${'package'}::\E([^:]+)\$");
2911 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2912 (map { /$search/ ? ($1) : () } keys %sub)
2913 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2914 return sort grep /^\Q$text/, values %INC # files
2915 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2916 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2917 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2918 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2919 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2921 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2923 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2924 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2925 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2926 # We may want to complete to (eval 9), so $text may be wrong
2927 $prefix = length($1) - length($text);
2930 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2932 if ((substr $text, 0, 1) eq '&') { # subroutines
2933 $text = substr $text, 1;
2935 return sort map "$prefix$_",
2938 (map { /$search/ ? ($1) : () }
2941 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2942 $pack = ($1 eq 'main' ? '' : $1) . '::';
2943 $prefix = (substr $text, 0, 1) . $1 . '::';
2946 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2947 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2948 return db_complete($out[0], $line, $start);
2952 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2953 $pack = ($package eq 'main' ? '' : $package) . '::';
2954 $prefix = substr $text, 0, 1;
2955 $text = substr $text, 1;
2956 my @out = map "$prefix$_", grep /^\Q$text/,
2957 (grep /^_?[a-zA-Z]/, keys %$pack),
2958 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2959 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2960 return db_complete($out[0], $line, $start);
2964 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2965 my @out = grep /^\Q$text/, @options;
2966 my $val = option_val($out[0], undef);
2968 if (not defined $val or $val =~ /[\n\r]/) {
2969 # Can do nothing better
2970 } elsif ($val =~ /\s/) {
2972 foreach $l (split //, qq/\"\'\#\|/) {
2973 $out = "$l$val$l ", last if (index $val, $l) == -1;
2978 # Default to value if one completion, to question if many
2979 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2982 return $term->filename_list($text); # filenames
2986 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2990 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
2991 $fall_off_end = 1 unless $inhibit_exit;
2992 # Do not stop in at_exit() and destructors on exit:
2993 $DB::single = !$fall_off_end && !$runnonstop;
2994 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3000 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3003 package DB; # Do not trace this 1; below!