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 ####################################################################
251 # Needed for the statement after exec():
253 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
254 local($^W) = 0; # Switch run-time warnings off during init.
257 $dumpvar::arrayDepth,
258 $dumpvar::dumpDBFiles,
259 $dumpvar::dumpPackages,
260 $dumpvar::quoteHighBit,
261 $dumpvar::printUndef,
270 # Command-line + PERLLIB:
273 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
275 $trace = $signal = $single = 0; # Uninitialized warning suppression
276 # (local $^W cannot help - other packages!).
277 $inhibit_exit = $option{PrintRet} = 1;
279 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
280 compactDump veryCompact quote HighBit undefPrint
281 globPrint PrintRet UsageOnly frame AutoTrace
282 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
283 recallCommand ShellBang pager tkRunning ornaments
284 signalLevel warnLevel dieLevel inhibit_exit
285 ImmediateStop bareStringify CreateTTY
289 hashDepth => \$dumpvar::hashDepth,
290 arrayDepth => \$dumpvar::arrayDepth,
291 DumpDBFiles => \$dumpvar::dumpDBFiles,
292 DumpPackages => \$dumpvar::dumpPackages,
293 DumpReused => \$dumpvar::dumpReused,
294 HighBit => \$dumpvar::quoteHighBit,
295 undefPrint => \$dumpvar::printUndef,
296 globPrint => \$dumpvar::globPrint,
297 UsageOnly => \$dumpvar::usageOnly,
298 CreateTTY => \$CreateTTY,
299 bareStringify => \$dumpvar::bareStringify,
301 AutoTrace => \$trace,
302 inhibit_exit => \$inhibit_exit,
303 maxTraceLen => \$maxtrace,
304 ImmediateStop => \$ImmediateStop,
305 RemotePort => \$remoteport,
309 compactDump => \&dumpvar::compactDump,
310 veryCompact => \&dumpvar::veryCompact,
311 quote => \&dumpvar::quote,
314 ReadLine => \&ReadLine,
315 NonStop => \&NonStop,
316 LineInfo => \&LineInfo,
317 recallCommand => \&recallCommand,
318 ShellBang => \&shellBang,
320 signalLevel => \&signalLevel,
321 warnLevel => \&warnLevel,
322 dieLevel => \&dieLevel,
323 tkRunning => \&tkRunning,
324 ornaments => \&ornaments,
325 RemotePort => \&RemotePort,
329 compactDump => 'dumpvar.pl',
330 veryCompact => 'dumpvar.pl',
331 quote => 'dumpvar.pl',
334 # These guys may be defined in $ENV{PERL5DB} :
335 $rl = 1 unless defined $rl;
336 $warnLevel = 0 unless defined $warnLevel;
337 $dieLevel = 0 unless defined $dieLevel;
338 $signalLevel = 1 unless defined $signalLevel;
339 $pre = [] unless defined $pre;
340 $post = [] unless defined $post;
341 $pretype = [] unless defined $pretype;
342 $CreateTTY = 3 unless defined $CreateTTY;
344 warnLevel($warnLevel);
346 signalLevel($signalLevel);
349 (defined($ENV{PAGER})
353 : 'more'))) unless defined $pager;
355 &recallCommand("!") unless defined $prc;
356 &shellBang("!") unless defined $psh;
358 $maxtrace = 400 unless defined $maxtrace;
359 $ini_pids = $ENV{PERLDB_PIDS};
360 if (defined $ENV{PERLDB_PIDS}) {
361 $pids = "[$ENV{PERLDB_PIDS}]";
362 $ENV{PERLDB_PIDS} .= "->$$";
365 $ENV{PERLDB_PIDS} = "$$";
370 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
372 if (-e "/dev/tty") { # this is the wrong metric!
375 $rcfile="perldb.ini";
378 # This isn't really safe, because there's a race
379 # between checking and opening. The solution is to
380 # open and fstat the handle, but then you have to read and
381 # eval the contents. But then the silly thing gets
382 # your lexical scope, which is unfortunately at best.
386 # Just exactly what part of the word "CORE::" don't you understand?
387 local $SIG{__WARN__};
390 unless (is_safe_file($file)) {
391 CORE::warn <<EO_GRIPE;
392 perldb: Must not source insecure rcfile $file.
393 You or the superuser must be the owner, and it must not
394 be writable by anyone but its owner.
400 CORE::warn("perldb: couldn't parse $file: $@") if $@;
404 # Verifies that owner is either real user or superuser and that no
405 # one but owner may write to it. This function is of limited use
406 # when called on a path instead of upon a handle, because there are
407 # no guarantees that filename (by dirent) whose file (by ino) is
408 # eventually accessed is the same as the one tested.
409 # Assumes that the file's existence is not in doubt.
412 stat($path) || return; # mysteriously vaporized
413 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
415 return 0 if $uid != 0 && $uid != $<;
416 return 0 if $mode & 022;
421 safe_do("./$rcfile");
423 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
424 safe_do("$ENV{HOME}/$rcfile");
426 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
427 safe_do("$ENV{LOGDIR}/$rcfile");
430 if (defined $ENV{PERLDB_OPTS}) {
431 parse_options($ENV{PERLDB_OPTS});
434 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
435 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
436 *get_fork_TTY = \&xterm_get_fork_TTY;
437 } elsif ($^O eq 'os2') {
438 *get_fork_TTY = \&os2_get_fork_TTY;
441 # Here begin the unreadable code. It needs fixing.
443 if (exists $ENV{PERLDB_RESTART}) {
444 delete $ENV{PERLDB_RESTART};
446 @hist = get_list('PERLDB_HIST');
447 %break_on_load = get_list("PERLDB_ON_LOAD");
448 %postponed = get_list("PERLDB_POSTPONE");
449 my @had_breakpoints= get_list("PERLDB_VISITED");
450 for (0 .. $#had_breakpoints) {
451 my %pf = get_list("PERLDB_FILE_$_");
452 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
454 my %opt = get_list("PERLDB_OPT");
456 while (($opt,$val) = each %opt) {
457 $val =~ s/[\\\']/\\$1/g;
458 parse_options("$opt'$val'");
460 @INC = get_list("PERLDB_INC");
462 $pretype = [get_list("PERLDB_PRETYPE")];
463 $pre = [get_list("PERLDB_PRE")];
464 $post = [get_list("PERLDB_POST")];
465 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
471 # Is Perl being run from a slave editor or graphical debugger?
472 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
473 $rl = 0, shift(@main::ARGV) if $slave_editor;
475 #require Term::ReadLine;
477 if ($^O eq 'cygwin') {
478 # /dev/tty is binary. use stdin for textmode
480 } elsif (-e "/dev/tty") {
481 $console = "/dev/tty";
482 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
484 } elsif ($^O eq 'MacOS') {
485 if ($MacPerl::Version !~ /MPW/) {
486 $console = "Dev:Console:Perl Debug"; # Separate window for application
488 $console = "Dev:Console";
491 $console = "sys\$command";
494 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
499 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
507 $console = $tty if defined $tty;
509 if (defined $remoteport) {
511 $OUT = new IO::Socket::INET( Timeout => '10',
512 PeerAddr => $remoteport,
515 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
517 } elsif ($CreateTTY & 4) {
520 if (defined $console) {
521 my ($i, $o) = split /,/, $console;
522 $o = $i unless defined $o;
523 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
524 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
525 || open(OUT,">&STDOUT"); # so we don't dongle stdout
528 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
529 $console = 'STDIN/OUT';
531 # so open("|more") can read from STDOUT and so we don't dingle stdin
537 $| = 1; # for DB::OUT
540 $LINEINFO = $OUT unless defined $LINEINFO;
541 $lineinfo = $console unless defined $lineinfo;
543 $| = 1; # for real STDOUT
545 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
546 unless ($runnonstop) {
547 if ($term_pid eq '-1') {
548 print $OUT "\nDaughter DB session started...\n";
550 print $OUT "\nLoading DB routines from $header\n";
551 print $OUT ("Editor support ",
552 $slave_editor ? "enabled" : "available",
554 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
562 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
565 if (defined &afterinit) { # May be defined in $rcfile
571 ############################################################ Subroutines
574 # _After_ the perl program is compiled, $single is set to 1:
575 if ($single and not $second_time++) {
576 if ($runnonstop) { # Disable until signal
577 for ($i=0; $i <= $stack_depth; ) {
581 # return; # Would not print trace!
582 } elsif ($ImmediateStop) {
587 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
589 ($package, $filename, $line) = caller;
590 $filename_ini = $filename;
591 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
592 "package $package;"; # this won't let them modify, alas
593 local(*dbline) = $main::{'_<' . $filename};
595 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
599 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
600 $dbline{$line} =~ s/;9($|\0)/$1/;
603 my $was_signal = $signal;
605 for (my $n = 0; $n <= $#to_watch; $n++) {
606 $evalarg = $to_watch[$n];
607 local $onetimeDump; # Do not output results
608 my ($val) = &eval; # Fix context (&eval is doing array)?
609 $val = ( (defined $val) ? "'$val'" : 'undef' );
610 if ($val ne $old_watch[$n]) {
613 Watchpoint $n:\t$to_watch[$n] changed:
614 old value:\t$old_watch[$n]
617 $old_watch[$n] = $val;
621 if ($trace & 4) { # User-installed watch
622 return if watchfunction($package, $filename, $line)
623 and not $single and not $was_signal and not ($trace & ~4);
625 $was_signal = $signal;
627 if ($single || ($trace & 1) || $was_signal) {
629 $position = "\032\032$filename:$line:0\n";
630 print_lineinfo($position);
631 } elsif ($package eq 'DB::fake') {
634 Debugged program terminated. Use B<q> to quit or B<R> to restart,
635 use B<O> I<inhibit_exit> to avoid stopping after program termination,
636 B<h q>, B<h R> or B<h O> to get additional info.
639 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
640 "package $package;"; # this won't let them modify, alas
643 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
644 $prefix .= "$sub($filename:";
645 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
646 if (length($prefix) > 30) {
647 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
652 $position = "$prefix$line$infix$dbline[$line]$after";
655 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
657 print_lineinfo($position);
659 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
660 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
662 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
663 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
664 $position .= $incr_pos;
666 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
668 print_lineinfo($incr_pos);
673 $evalarg = $action, &eval if $action;
674 if ($single || $was_signal) {
675 local $level = $level + 1;
676 foreach $evalarg (@$pre) {
679 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
682 $incr = -1; # for backward motion.
683 @typeahead = (@$pretype, @typeahead);
685 while (($term || &setterm),
686 ($term_pid == $$ or resetterm(1)),
687 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
688 ($#hist+1) . ('>' x $level) .
693 $cmd =~ s/\\$/\n/ && do {
694 $cmd .= &readline(" cont: ");
697 $cmd =~ /^$/ && ($cmd = $laststep);
698 push(@hist,$cmd) if length($cmd) > 1;
700 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
701 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
702 ($i) = split(/\s+/,$cmd);
704 # squelch the sigmangler
706 local $SIG{__WARN__};
707 eval "\$cmd =~ $alias{$i}";
709 print $OUT "Couldn't evaluate `$i' alias: $@";
713 $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
714 $cmd =~ /^h$/ && do {
717 $cmd =~ /^h\s+h$/ && do {
718 print_help($summary);
720 # support long commands; otherwise bogus errors
721 # happen when you ask for h on <CR> for example
722 $cmd =~ /^h\s+(\S.*)$/ && do {
723 my $asked = $1; # for proper errmsg
724 my $qasked = quotemeta($asked); # for searching
725 # XXX: finds CR but not <CR>
726 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
727 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
731 print_help("B<$asked> is not a debugger command.\n");
734 $cmd =~ /^t$/ && do {
736 print $OUT "Trace = " .
737 (($trace & 1) ? "on" : "off" ) . "\n";
739 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
740 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
741 foreach $subname (sort(keys %sub)) {
742 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
743 print $OUT $subname,"\n";
747 $cmd =~ /^v$/ && do {
748 list_versions(); next CMD};
749 $cmd =~ s/^X\b/V $package/;
750 $cmd =~ /^V$/ && do {
751 $cmd = "V $package"; };
752 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
753 local ($savout) = select($OUT);
755 @vars = split(' ',$2);
756 do 'dumpvar.pl' unless defined &main::dumpvar;
757 if (defined &main::dumpvar) {
760 # must detect sigpipe failures
761 eval { &main::dumpvar($packname,@vars) };
763 die unless $@ =~ /dumpvar print failed/;
766 print $OUT "dumpvar.pl not available.\n";
770 $cmd =~ s/^x\b/ / && do { # So that will be evaled
771 $onetimeDump = 'dump'; };
772 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
773 methods($1); next CMD};
774 $cmd =~ s/^m\b/ / && do { # So this will be evaled
775 $onetimeDump = 'methods'; };
776 $cmd =~ /^f\b\s*(.*)/ && do {
780 print $OUT "The old f command is now the r command.\n";
781 print $OUT "The new f command switches filenames.\n";
784 if (!defined $main::{'_<' . $file}) {
785 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
786 $try = substr($try,2);
787 print $OUT "Choosing $try matching `$file':\n";
791 if (!defined $main::{'_<' . $file}) {
792 print $OUT "No file matching `$file' is loaded.\n";
794 } elsif ($file ne $filename) {
795 *dbline = $main::{'_<' . $file};
801 print $OUT "Already in $file.\n";
805 $cmd =~ s/^l\s+-\s*$/-/;
806 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
809 print($OUT "Error: $@\n"), next CMD if $@;
811 print($OUT "Interpreted as: $1 $s\n");
814 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
815 my $s = $subname = $1;
816 $subname =~ s/\'/::/;
817 $subname = $package."::".$subname
818 unless $subname =~ /::/;
819 $subname = "CORE::GLOBAL::$s"
820 if not defined &$subname and $s !~ /::/
821 and defined &{"CORE::GLOBAL::$s"};
822 $subname = "main".$subname if substr($subname,0,2) eq "::";
823 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
824 $subrange = pop @pieces;
825 $file = join(':', @pieces);
826 if ($file ne $filename) {
827 print $OUT "Switching to file '$file'.\n"
828 unless $slave_editor;
829 *dbline = $main::{'_<' . $file};
834 if (eval($subrange) < -$window) {
835 $subrange =~ s/-.*/+/;
837 $cmd = "l $subrange";
839 print $OUT "Subroutine $subname not found.\n";
842 $cmd =~ /^\.$/ && do {
843 $incr = -1; # for backward motion.
845 $filename = $filename_ini;
846 *dbline = $main::{'_<' . $filename};
848 print_lineinfo($position);
850 $cmd =~ /^w\b\s*(\d*)$/ && do {
854 #print $OUT 'l ' . $start . '-' . ($start + $incr);
855 $cmd = 'l ' . $start . '-' . ($start + $incr); };
856 $cmd =~ /^-$/ && do {
857 $start -= $incr + $window + 1;
858 $start = 1 if $start <= 0;
860 $cmd = 'l ' . ($start) . '+'; };
861 $cmd =~ /^l$/ && do {
863 $cmd = 'l ' . $start . '-' . ($start + $incr); };
864 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
867 $incr = $window - 1 unless $incr;
868 $cmd = 'l ' . $start . '-' . ($start + $incr); };
869 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
870 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
871 $end = $max if $end > $max;
873 $i = $line if $i eq '.';
877 print $OUT "\032\032$filename:$i:0\n";
880 for (; $i <= $end; $i++) {
881 ($stop,$action) = split(/\0/, $dbline{$i}) if
884 and $filename eq $filename_ini)
886 : ($dbline[$i]+0 ? ':' : ' ') ;
887 $arrow .= 'b' if $stop;
888 $arrow .= 'a' if $action;
889 print $OUT "$i$arrow\t", $dbline[$i];
890 $i++, last if $signal;
892 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
894 $start = $i; # remember in case they want more
895 $start = $max if $start > $max;
897 $cmd =~ /^D$/ && do {
898 print $OUT "Deleting all breakpoints...\n";
900 for $file (keys %had_breakpoints) {
901 local *dbline = $main::{'_<' . $file};
905 for ($i = 1; $i <= $max ; $i++) {
906 if (defined $dbline{$i}) {
907 $dbline{$i} =~ s/^[^\0]+//;
908 if ($dbline{$i} =~ s/^\0?$//) {
914 if (not $had_breakpoints{$file} &= ~1) {
915 delete $had_breakpoints{$file};
919 undef %postponed_file;
920 undef %break_on_load;
922 $cmd =~ /^L$/ && do {
924 for $file (keys %had_breakpoints) {
925 local *dbline = $main::{'_<' . $file};
929 for ($i = 1; $i <= $max; $i++) {
930 if (defined $dbline{$i}) {
931 print $OUT "$file:\n" unless $was++;
932 print $OUT " $i:\t", $dbline[$i];
933 ($stop,$action) = split(/\0/, $dbline{$i});
934 print $OUT " break if (", $stop, ")\n"
936 print $OUT " action: ", $action, "\n"
943 print $OUT "Postponed breakpoints in subroutines:\n";
945 for $subname (keys %postponed) {
946 print $OUT " $subname\t$postponed{$subname}\n";
950 my @have = map { # Combined keys
951 keys %{$postponed_file{$_}}
952 } keys %postponed_file;
954 print $OUT "Postponed breakpoints in files:\n";
956 for $file (keys %postponed_file) {
957 my $db = $postponed_file{$file};
958 print $OUT " $file:\n";
959 for $line (sort {$a <=> $b} keys %$db) {
960 print $OUT " $line:\n";
961 my ($stop,$action) = split(/\0/, $$db{$line});
962 print $OUT " break if (", $stop, ")\n"
964 print $OUT " action: ", $action, "\n"
971 if (%break_on_load) {
972 print $OUT "Breakpoints on load:\n";
974 for $file (keys %break_on_load) {
975 print $OUT " $file\n";
980 print $OUT "Watch-expressions:\n";
982 for $expr (@to_watch) {
983 print $OUT " $expr\n";
988 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
989 my $file = $1; $file =~ s/\s+$//;
992 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
993 my $cond = length $3 ? $3 : '1';
994 my ($subname, $break) = ($2, $1 eq 'postpone');
995 $subname =~ s/\'/::/g;
996 $subname = "${'package'}::" . $subname
997 unless $subname =~ /::/;
998 $subname = "main".$subname if substr($subname,0,2) eq "::";
999 $postponed{$subname} = $break
1000 ? "break +0 if $cond" : "compile";
1002 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1004 $cond = length $2 ? $2 : '1';
1005 cmd_b_sub($subname, $cond);
1007 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1009 $cond = length $2 ? $2 : '1';
1010 cmd_b_line($i, $cond);
1012 $cmd =~ /^d\b\s*(\d*)/ && do {
1015 $cmd =~ /^A$/ && do {
1016 print $OUT "Deleting all actions...\n";
1018 for $file (keys %had_breakpoints) {
1019 local *dbline = $main::{'_<' . $file};
1023 for ($i = 1; $i <= $max ; $i++) {
1024 if (defined $dbline{$i}) {
1025 $dbline{$i} =~ s/\0[^\0]*//;
1026 delete $dbline{$i} if $dbline{$i} eq '';
1030 unless ($had_breakpoints{$file} &= ~2) {
1031 delete $had_breakpoints{$file};
1035 $cmd =~ /^O\s*$/ && do {
1040 $cmd =~ /^O\s*(\S.*)/ && do {
1043 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1044 push @$pre, action($1);
1046 $cmd =~ /^>>\s*(.*)/ && do {
1047 push @$post, action($1);
1049 $cmd =~ /^<\s*(.*)/ && do {
1051 print $OUT "All < actions cleared.\n";
1057 print $OUT "No pre-prompt Perl actions.\n";
1060 print $OUT "Perl commands run before each prompt:\n";
1061 for my $action ( @$pre ) {
1062 print $OUT "\t< -- $action\n";
1066 $pre = [action($1)];
1068 $cmd =~ /^>\s*(.*)/ && do {
1070 print $OUT "All > actions cleared.\n";
1076 print $OUT "No post-prompt Perl actions.\n";
1079 print $OUT "Perl commands run after each prompt:\n";
1080 for my $action ( @$post ) {
1081 print $OUT "\t> -- $action\n";
1085 $post = [action($1)];
1087 $cmd =~ /^\{\{\s*(.*)/ && do {
1088 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1089 print $OUT "{{ is now a debugger command\n",
1090 "use `;{{' if you mean Perl code\n";
1096 $cmd =~ /^\{\s*(.*)/ && do {
1098 print $OUT "All { actions cleared.\n";
1103 unless (@$pretype) {
1104 print $OUT "No pre-prompt debugger actions.\n";
1107 print $OUT "Debugger commands run before each prompt:\n";
1108 for my $action ( @$pretype ) {
1109 print $OUT "\t{ -- $action\n";
1113 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1114 print $OUT "{ is now a debugger command\n",
1115 "use `;{' if you mean Perl code\n";
1121 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1122 $i = $1 || $line; $j = $2;
1124 if ($dbline[$i] == 0) {
1125 print $OUT "Line $i may not have an action.\n";
1127 $had_breakpoints{$filename} |= 2;
1128 $dbline{$i} =~ s/\0[^\0]*//;
1129 $dbline{$i} .= "\0" . action($j);
1132 $dbline{$i} =~ s/\0[^\0]*//;
1133 delete $dbline{$i} if $dbline{$i} eq '';
1136 $cmd =~ /^n$/ && do {
1137 end_report(), next CMD if $finished and $level <= 1;
1141 $cmd =~ /^s$/ && do {
1142 end_report(), next CMD if $finished and $level <= 1;
1146 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1147 end_report(), next CMD if $finished and $level <= 1;
1149 # Probably not needed, since we finish an interactive
1150 # sub-session anyway...
1151 # local $filename = $filename;
1152 # local *dbline = *dbline; # XXX Would this work?!
1153 if ($i =~ /\D/) { # subroutine name
1154 $subname = $package."::".$subname
1155 unless $subname =~ /::/;
1156 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1160 *dbline = $main::{'_<' . $filename};
1161 $had_breakpoints{$filename} |= 1;
1163 ++$i while $dbline[$i] == 0 && $i < $max;
1165 print $OUT "Subroutine $subname not found.\n";
1170 if ($dbline[$i] == 0) {
1171 print $OUT "Line $i not breakable.\n";
1174 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1176 for ($i=0; $i <= $stack_depth; ) {
1180 $cmd =~ /^r$/ && do {
1181 end_report(), next CMD if $finished and $level <= 1;
1182 $stack[$stack_depth] |= 1;
1183 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1185 $cmd =~ /^R$/ && do {
1186 print $OUT "Warning: some settings and command-line options may be lost!\n";
1187 my (@script, @flags, $cl);
1188 push @flags, '-w' if $ini_warn;
1189 # Put all the old includes at the start to get
1190 # the same debugger.
1192 push @flags, '-I', $_;
1194 # Arrange for setting the old INC:
1195 set_list("PERLDB_INC", @ini_INC);
1197 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1198 chomp ($cl = ${'::_<-e'}[$_]);
1199 push @script, '-e', $cl;
1204 set_list("PERLDB_HIST",
1205 $term->Features->{getHistory}
1206 ? $term->GetHistory : @hist);
1207 my @had_breakpoints = keys %had_breakpoints;
1208 set_list("PERLDB_VISITED", @had_breakpoints);
1209 set_list("PERLDB_OPT", %option);
1210 set_list("PERLDB_ON_LOAD", %break_on_load);
1212 for (0 .. $#had_breakpoints) {
1213 my $file = $had_breakpoints[$_];
1214 *dbline = $main::{'_<' . $file};
1215 next unless %dbline or $postponed_file{$file};
1216 (push @hard, $file), next
1217 if $file =~ /^\(eval \d+\)$/;
1219 @add = %{$postponed_file{$file}}
1220 if $postponed_file{$file};
1221 set_list("PERLDB_FILE_$_", %dbline, @add);
1223 for (@hard) { # Yes, really-really...
1224 # Find the subroutines in this eval
1225 *dbline = $main::{'_<' . $_};
1226 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1227 for $sub (keys %sub) {
1228 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1229 $subs{$sub} = [$1, $2];
1233 "No subroutines in $_, ignoring breakpoints.\n";
1236 LINES: for $line (keys %dbline) {
1237 # One breakpoint per sub only:
1238 my ($offset, $sub, $found);
1239 SUBS: for $sub (keys %subs) {
1240 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1241 and (not defined $offset # Not caught
1242 or $offset < 0 )) { # or badly caught
1244 $offset = $line - $subs{$sub}->[0];
1245 $offset = "+$offset", last SUBS if $offset >= 0;
1248 if (defined $offset) {
1249 $postponed{$found} =
1250 "break $offset if $dbline{$line}";
1252 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1256 set_list("PERLDB_POSTPONE", %postponed);
1257 set_list("PERLDB_PRETYPE", @$pretype);
1258 set_list("PERLDB_PRE", @$pre);
1259 set_list("PERLDB_POST", @$post);
1260 set_list("PERLDB_TYPEAHEAD", @typeahead);
1261 $ENV{PERLDB_RESTART} = 1;
1262 delete $ENV{PERLDB_PIDS}; # Restore ini state
1263 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1264 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1265 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1266 print $OUT "exec failed: $!\n";
1268 $cmd =~ /^T$/ && do {
1269 print_trace($OUT, 1); # skip DB
1271 $cmd =~ /^W\s*$/ && do {
1273 @to_watch = @old_watch = ();
1275 $cmd =~ /^W\b\s*(.*)/s && do {
1279 $val = (defined $val) ? "'$val'" : 'undef' ;
1280 push @old_watch, $val;
1283 $cmd =~ /^\/(.*)$/ && do {
1285 $inpat =~ s:([^\\])/$:$1:;
1287 # squelch the sigmangler
1288 local $SIG{__DIE__};
1289 local $SIG{__WARN__};
1290 eval '$inpat =~ m'."\a$inpat\a";
1302 $start = 1 if ($start > $max);
1303 last if ($start == $end);
1304 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1305 if ($slave_editor) {
1306 print $OUT "\032\032$filename:$start:0\n";
1308 print $OUT "$start:\t", $dbline[$start], "\n";
1313 print $OUT "/$pat/: not found\n" if ($start == $end);
1315 $cmd =~ /^\?(.*)$/ && do {
1317 $inpat =~ s:([^\\])\?$:$1:;
1319 # squelch the sigmangler
1320 local $SIG{__DIE__};
1321 local $SIG{__WARN__};
1322 eval '$inpat =~ m'."\a$inpat\a";
1334 $start = $max if ($start <= 0);
1335 last if ($start == $end);
1336 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1337 if ($slave_editor) {
1338 print $OUT "\032\032$filename:$start:0\n";
1340 print $OUT "$start:\t", $dbline[$start], "\n";
1345 print $OUT "?$pat?: not found\n" if ($start == $end);
1347 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1348 pop(@hist) if length($cmd) > 1;
1349 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1351 print $OUT $cmd, "\n";
1353 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1356 $cmd =~ /^$rc([^$rc].*)$/ && do {
1358 pop(@hist) if length($cmd) > 1;
1359 for ($i = $#hist; $i; --$i) {
1360 last if $hist[$i] =~ /$pat/;
1363 print $OUT "No such command!\n\n";
1367 print $OUT $cmd, "\n";
1369 $cmd =~ /^$sh$/ && do {
1370 &system($ENV{SHELL}||"/bin/sh");
1372 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1373 # XXX: using csh or tcsh destroys sigint retvals!
1374 #&system($1); # use this instead
1375 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1377 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1378 $end = $2 ? ($#hist-$2) : 0;
1379 $hist = 0 if $hist < 0;
1380 for ($i=$#hist; $i>$end; $i--) {
1381 print $OUT "$i: ",$hist[$i],"\n"
1382 unless $hist[$i] =~ /^.?$/;
1385 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1388 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1389 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1390 $cmd =~ s/^=\s*// && do {
1392 if (length $cmd == 0) {
1393 @keys = sort keys %alias;
1395 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1396 # can't use $_ or kill //g state
1397 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1398 $alias{$k} = "s\a$k\a$v\a";
1399 # squelch the sigmangler
1400 local $SIG{__DIE__};
1401 local $SIG{__WARN__};
1402 unless (eval "sub { s\a$k\a$v\a }; 1") {
1403 print $OUT "Can't alias $k to $v: $@\n";
1413 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1414 print $OUT "$k\t= $1\n";
1416 elsif (defined $alias{$k}) {
1417 print $OUT "$k\t$alias{$k}\n";
1420 print "No alias for $k\n";
1424 $cmd =~ /^\|\|?\s*[^|]/ && do {
1425 if ($pager =~ /^\|/) {
1426 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1427 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1429 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1432 unless ($piped=open(OUT,$pager)) {
1433 &warn("Can't pipe output to `$pager'");
1434 if ($pager =~ /^\|/) {
1435 open(OUT,">&STDOUT") # XXX: lost message
1436 || &warn("Can't restore DB::OUT");
1437 open(STDOUT,">&SAVEOUT")
1438 || &warn("Can't restore STDOUT");
1441 open(OUT,">&STDOUT") # XXX: lost message
1442 || &warn("Can't restore DB::OUT");
1446 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1447 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1448 $selected= select(OUT);
1450 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1451 $cmd =~ s/^\|+\s*//;
1454 # XXX Local variants do not work!
1455 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1456 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1457 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1459 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1461 $onetimeDump = undef;
1462 } elsif ($term_pid == $$) {
1467 if ($pager =~ /^\|/) {
1469 # we cannot warn here: the handle is missing --tchrist
1470 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1472 # most of the $? crud was coping with broken cshisms
1474 print SAVEOUT "Pager `$pager' failed: ";
1476 print SAVEOUT "shell returned -1\n";
1479 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1480 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1482 print SAVEOUT "status ", ($? >> 8), "\n";
1486 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1487 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1488 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1489 # Will stop ignoring SIGPIPE if done like nohup(1)
1490 # does SIGINT but Perl doesn't give us a choice.
1492 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1495 select($selected), $selected= "" unless $selected eq "";
1499 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1500 foreach $evalarg (@$post) {
1503 } # if ($single || $signal)
1504 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1508 # The following code may be executed now:
1512 my ($al, $ret, @ret) = "";
1513 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1516 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1517 $#stack = $stack_depth;
1518 $stack[-1] = $single;
1520 $single |= 4 if $stack_depth == $deep;
1522 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1523 # Why -1? But it works! :-(
1524 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1525 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1528 $single |= $stack[$stack_depth--];
1530 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1531 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1532 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1533 if ($doret eq $stack_depth or $frame & 16) {
1534 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1535 print $fh ' ' x $stack_depth if $frame & 16;
1536 print $fh "list context return from $sub:\n";
1537 dumpit($fh, \@ret );
1542 if (defined wantarray) {
1547 $single |= $stack[$stack_depth--];
1549 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1550 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1551 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1552 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1553 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1554 print $fh (' ' x $stack_depth) if $frame & 16;
1555 print $fh (defined wantarray
1556 ? "scalar context return from $sub: "
1557 : "void context return from $sub\n");
1558 dumpit( $fh, $ret ) if defined wantarray;
1567 ### Functions with multiple modes of failure die on error, the rest
1568 ### returns FALSE on error.
1569 ### User-interface functions cmd_* output error message.
1573 $break_on_load{$file} = 1;
1574 $had_breakpoints{$file} |= 1;
1577 sub report_break_on_load {
1578 sort keys %break_on_load;
1586 push @files, $::INC{$file} if $::INC{$file};
1587 $file .= '.pm', redo unless $file =~ /\./;
1589 break_on_load($_) for @files;
1590 @files = report_break_on_load;
1591 print $OUT "Will stop on load of `@files'.\n";
1594 $filename_error = '';
1596 sub breakable_line {
1597 my ($from, $to) = @_;
1600 my $delta = $from < $to ? +1 : -1;
1601 my $limit = $delta > 0 ? $#dbline : 1;
1602 $limit = $to if ($limit - $to) * $delta > 0;
1603 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1605 return $i unless $dbline[$i] == 0;
1606 my ($pl, $upto) = ('', '');
1607 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1608 die "Line$pl $from$upto$filename_error not breakable\n";
1611 sub breakable_line_in_filename {
1613 local *dbline = $main::{'_<' . $f};
1614 local $filename_error = " of `$f'";
1619 my ($i, $cond) = @_;
1620 $cond = 1 unless @_ >= 2;
1624 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1625 $had_breakpoints{$filename} |= 1;
1626 $dbline{$i} =~ s/^[^\0]*/$cond/ if $dbline{$i};
1630 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1633 sub break_on_filename_line {
1634 my ($f, $i, $cond) = @_;
1635 $cond = 1 unless @_ >= 3;
1636 local *dbline = $main::{'_<' . $f};
1637 local $filename_error = " of `$f'";
1638 local $filename = $f;
1639 break_on_line($i, $cond);
1642 sub break_on_filename_line_range {
1643 my ($f, $from, $to, $cond) = @_;
1644 my $i = breakable_line_in_filename($f, $from, $to);
1645 $cond = 1 unless @_ >= 3;
1646 break_on_filename_line($f,$i,$cond);
1649 sub subroutine_filename_lines {
1650 my ($subname,$cond) = @_;
1651 # Filename below can contain ':'
1652 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1655 sub break_subroutine {
1656 my $subname = shift;
1657 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1658 die "Subroutine $subname not found.\n";
1659 $cond = 1 unless @_ >= 2;
1660 break_on_filename_line_range($file,$s,$e,@_);
1664 my ($subname,$cond) = @_;
1665 $cond = 1 unless @_ >= 2;
1666 unless (ref $subname eq 'CODE') {
1667 $subname =~ s/\'/::/g;
1669 $subname = "${'package'}::" . $subname
1670 unless $subname =~ /::/;
1671 $subname = "CORE::GLOBAL::$s"
1672 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1673 $subname = "main".$subname if substr($subname,0,2) eq "::";
1675 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1678 sub cmd_stop { # As on ^C, but not signal-safy.
1682 sub delete_breakpoint {
1684 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1685 $dbline{$i} =~ s/^[^\0]*//;
1686 delete $dbline{$i} if $dbline{$i} eq '';
1691 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1694 ### END of the API section
1697 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1698 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1701 sub print_lineinfo {
1702 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1706 # The following takes its argument via $evalarg to preserve current @_
1709 # 'my' would make it visible from user code
1710 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1713 local $otrace = $trace;
1714 local $osingle = $single;
1716 { ($evalarg) = $evalarg =~ /(.*)/s; }
1717 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1723 local $saved[0]; # Preserve the old value of $@
1727 } elsif ($onetimeDump eq 'dump') {
1728 dumpit($OUT, \@res);
1729 } elsif ($onetimeDump eq 'methods') {
1736 my $subname = shift;
1737 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1738 my $offset = $1 || 0;
1739 # Filename below can contain ':'
1740 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1743 local *dbline = $main::{'_<' . $file};
1744 local $^W = 0; # != 0 is magical below
1745 $had_breakpoints{$file} |= 1;
1747 ++$i until $dbline[$i] != 0 or $i >= $max;
1748 $dbline{$i} = delete $postponed{$subname};
1750 print $OUT "Subroutine $subname not found.\n";
1754 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1755 #print $OUT "In postponed_sub for `$subname'.\n";
1759 if ($ImmediateStop) {
1763 return &postponed_sub
1764 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1765 # Cannot be done before the file is compiled
1766 local *dbline = shift;
1767 my $filename = $dbline;
1768 $filename =~ s/^_<//;
1769 $signal = 1, print $OUT "'$filename' loaded...\n"
1770 if $break_on_load{$filename};
1771 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1772 return unless $postponed_file{$filename};
1773 $had_breakpoints{$filename} |= 1;
1774 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1776 for $key (keys %{$postponed_file{$filename}}) {
1777 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1779 delete $postponed_file{$filename};
1783 local ($savout) = select(shift);
1784 my $osingle = $single;
1785 my $otrace = $trace;
1786 $single = $trace = 0;
1789 unless (defined &main::dumpValue) {
1792 if (defined &main::dumpValue) {
1793 &main::dumpValue(shift);
1795 print $OUT "dumpvar.pl not available.\n";
1802 # Tied method do not create a context, so may get wrong message:
1806 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1807 my @sub = dump_trace($_[0] + 1, $_[1]);
1808 my $short = $_[2]; # Print short report, next one for sub name
1810 for ($i=0; $i <= $#sub; $i++) {
1813 my $args = defined $sub[$i]{args}
1814 ? "(@{ $sub[$i]{args} })"
1816 $args = (substr $args, 0, $maxtrace - 3) . '...'
1817 if length $args > $maxtrace;
1818 my $file = $sub[$i]{file};
1819 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1821 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1823 my $sub = @_ >= 4 ? $_[3] : $s;
1824 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1826 print $fh "$sub[$i]{context} = $s$args" .
1827 " called from $file" .
1828 " line $sub[$i]{line}\n";
1835 my $count = shift || 1e9;
1838 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1839 my $nothard = not $frame & 8;
1840 local $frame = 0; # Do not want to trace this.
1841 my $otrace = $trace;
1844 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1849 if (not defined $arg) {
1851 } elsif ($nothard and tied $arg) {
1853 } elsif ($nothard and $type = ref $arg) {
1854 push @a, "ref($type)";
1856 local $_ = "$arg"; # Safe to stringify now - should not call f().
1859 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1860 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1861 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1865 $context = $context ? '@' : (defined $context ? "\$" : '.');
1866 $args = $h ? [@a] : undef;
1867 $e =~ s/\n\s*\;\s*\Z// if $e;
1868 $e =~ s/([\\\'])/\\$1/g if $e;
1870 $sub = "require '$e'";
1871 } elsif (defined $r) {
1873 } elsif ($sub eq '(eval)') {
1874 $sub = "eval {...}";
1876 push(@sub, {context => $context, sub => $sub, args => $args,
1877 file => $file, line => $line});
1886 while ($action =~ s/\\$//) {
1895 # i hate using globals!
1896 $balanced_brace_re ||= qr{
1899 (?> [^{}] + ) # Non-parens without backtracking
1901 (??{ $balanced_brace_re }) # Group with matching parens
1905 return $_[0] !~ m/$balanced_brace_re/;
1909 &readline("cont: ");
1913 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1914 # some non-Unix systems can do system() but have problems with fork().
1915 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1916 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1917 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1918 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1920 # XXX: using csh or tcsh destroys sigint retvals!
1922 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1923 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1928 # most of the $? crud was coping with broken cshisms
1930 &warn("(Command exited ", ($? >> 8), ")\n");
1932 &warn( "(Command died of SIG#", ($? & 127),
1933 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1943 eval { require Term::ReadLine } or die $@;
1946 my ($i, $o) = split $tty, /,/;
1947 $o = $i unless defined $o;
1948 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1949 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1952 my $sel = select($OUT);
1956 eval "require Term::Rendezvous;" or die;
1957 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1958 my $term_rv = new Term::Rendezvous $rv;
1960 $OUT = $term_rv->OUT;
1963 if ($term_pid eq '-1') { # In a TTY with another debugger
1967 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1969 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1971 $rl_attribs = $term->Attribs;
1972 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1973 if defined $rl_attribs->{basic_word_break_characters}
1974 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1975 $rl_attribs->{special_prefixes} = '$@&%';
1976 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1977 $rl_attribs->{completion_function} = \&db_complete;
1979 $LINEINFO = $OUT unless defined $LINEINFO;
1980 $lineinfo = $console unless defined $lineinfo;
1982 if ($term->Features->{setHistory} and "@hist" ne "?") {
1983 $term->SetHistory(@hist);
1985 ornaments($ornaments) if defined $ornaments;
1989 # Example get_fork_TTY functions
1990 sub xterm_get_fork_TTY {
1991 (my $name = $0) =~ s,^.*[/\\],,s;
1992 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
1996 $pidprompt = ''; # Shown anyway in titlebar
2000 # This one resets $IN, $OUT itself
2001 sub os2_get_fork_TTY {
2002 $^F = 40; # XXXX Fixme!
2003 my ($in1, $out1, $in2, $out2);
2004 # Having -d in PERL5OPT would lead to a disaster...
2005 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2006 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2007 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2008 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2009 (my $name = $0) =~ s,^.*[/\\],,s;
2010 if ( pipe $in1, $out1 and pipe $in2, $out2 and
2011 # system P_SESSION will fail if there is another process
2012 # in the same session with a "dependent" asynchronous child session.
2013 (($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
2017 my $in = shift; # Read from here and pass through
2019 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2020 open IN, '<&=$in' or die "open <&=$in: \$!";
2021 \$| = 1; print while sysread IN, \$_, 1<<16;
2025 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2027 ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
2028 print while sysread STDIN, $_, 1<<16;
2030 and close $in1 and close $out2 ) {
2031 $pidprompt = ''; # Shown anyway in titlebar
2032 reset_IN_OUT($in2, $out1);
2034 return ''; # Indicate that reset_IN_OUT is called
2039 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2040 my $in = &get_fork_TTY if defined &get_fork_TTY;
2041 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2042 if (not defined $in) {
2044 print_help(<<EOP) if $why == 1;
2045 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2047 print_help(<<EOP) if $why == 2;
2048 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2049 This may be an asynchronous session, so the parent debugger may be active.
2051 print_help(<<EOP) if $why != 4;
2052 Since two debuggers fight for the same TTY, input is severely entangled.
2056 I know how to switch the output to a different window in xterms
2057 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2058 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2060 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2061 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2064 } elsif ($in ne '') {
2070 sub resetterm { # We forked, so we need a different TTY
2072 my $systemed = $in > 1 ? '-' : '';
2074 $pids =~ s/\]/$systemed->$$]/;
2076 $pids = "[$term_pid->$$]";
2080 return unless $CreateTTY & $in;
2087 my $left = @typeahead;
2088 my $got = shift @typeahead;
2089 print $OUT "auto(-$left)", shift, $got, "\n";
2090 $term->AddHistory($got)
2091 if length($got) > 1 and defined $term->Features->{addHistory};
2096 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2097 $OUT->write(join('', @_));
2099 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2103 $term->readline(@_);
2108 my ($opt, $val)= @_;
2109 $val = option_val($opt,'N/A');
2110 $val =~ s/([\\\'])/\\$1/g;
2111 printf $OUT "%20s = '%s'\n", $opt, $val;
2115 my ($opt, $default)= @_;
2117 if (defined $optionVars{$opt}
2118 and defined ${$optionVars{$opt}}) {
2119 $val = ${$optionVars{$opt}};
2120 } elsif (defined $optionAction{$opt}
2121 and defined &{$optionAction{$opt}}) {
2122 $val = &{$optionAction{$opt}}();
2123 } elsif (defined $optionAction{$opt}
2124 and not defined $option{$opt}
2125 or defined $optionVars{$opt}
2126 and not defined ${$optionVars{$opt}}) {
2129 $val = $option{$opt};
2136 # too dangerous to let intuitive usage overwrite important things
2137 # defaultion should never be the default
2138 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2139 arrayDepth hashDepth LineInfo maxTraceLen ornaments
2140 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2145 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2146 my ($opt,$sep) = ($1,$2);
2149 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2151 #&dump_option($opt);
2152 } elsif ($sep !~ /\S/) {
2154 $val = "1"; # this is an evil default; make 'em set it!
2155 } elsif ($sep eq "=") {
2157 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2159 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2163 print OUT qq(Option better cleared using $opt=""\n)
2167 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2168 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2169 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2170 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2171 ($val = $1) =~ s/\\([\\$end])/$1/g;
2175 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2176 || grep( /^\Q$opt/i && ($option = $_), @options );
2178 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2179 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2181 if ($opt_needs_val{$option} && $val_defaulted) {
2182 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2186 $option{$option} = $val if defined $val;
2191 require '$optionRequire{$option}';
2193 } || die # XXX: shouldn't happen
2194 if defined $optionRequire{$option} &&
2197 ${$optionVars{$option}} = $val
2198 if defined $optionVars{$option} &&
2201 &{$optionAction{$option}} ($val)
2202 if defined $optionAction{$option} &&
2203 defined &{$optionAction{$option}} &&
2207 dump_option($option) unless $OUT eq \*STDERR;
2212 my ($stem,@list) = @_;
2214 $ENV{"${stem}_n"} = @list;
2215 for $i (0 .. $#list) {
2217 $val =~ s/\\/\\\\/g;
2218 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2219 $ENV{"${stem}_$i"} = $val;
2226 my $n = delete $ENV{"${stem}_n"};
2228 for $i (0 .. $n - 1) {
2229 $val = delete $ENV{"${stem}_$i"};
2230 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2238 return; # Put nothing on the stack - malloc/free land!
2242 my($msg)= join("",@_);
2243 $msg .= ": $!\n" unless $msg =~ /\n$/;
2248 my $switch_li = $LINEINFO eq $OUT;
2249 if ($term and $term->Features->{newTTY}) {
2250 ($IN, $OUT) = (shift, shift);
2251 $term->newTTY($IN, $OUT);
2253 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2255 ($IN, $OUT) = (shift, shift);
2257 my $o = select $OUT;
2260 $LINEINFO = $OUT if $switch_li;
2264 if (@_ and $term and $term->Features->{newTTY}) {
2265 my ($in, $out) = shift;
2267 ($in, $out) = split /,/, $in, 2;
2271 open IN, $in or die "cannot open `$in' for read: $!";
2272 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2273 reset_IN_OUT(\*IN,\*OUT);
2276 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2277 # Useful if done through PERLDB_OPTS:
2284 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2286 $notty = shift if @_;
2292 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2300 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2302 $remoteport = shift if @_;
2307 if (${$term->Features}{tkRunning}) {
2308 return $term->tkRunning(@_);
2310 print $OUT "tkRunning not supported by current ReadLine package.\n";
2317 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2319 $runnonstop = shift if @_;
2326 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2333 $sh = quotemeta shift;
2334 $sh .= "\\b" if $sh =~ /\w$/;
2338 $psh =~ s/\\(.)/$1/g;
2343 if (defined $term) {
2344 local ($warnLevel,$dieLevel) = (0, 1);
2345 return '' unless $term->Features->{ornaments};
2346 eval { $term->ornaments(@_) } || '';
2354 $rc = quotemeta shift;
2355 $rc .= "\\b" if $rc =~ /\w$/;
2359 $prc =~ s/\\(.)/$1/g;
2364 return $lineinfo unless @_;
2366 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2367 $slave_editor = ($stream =~ /^\|/);
2368 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2369 $LINEINFO = \*LINEINFO;
2370 my $save = select($LINEINFO);
2384 s/^Term::ReadLine::readline$/readline/;
2385 if (defined ${ $_ . '::VERSION' }) {
2386 $version{$file} = "${ $_ . '::VERSION' } from ";
2388 $version{$file} .= $INC{$file};
2390 dumpit($OUT,\%version);
2394 # XXX: make sure there are tabs between the command and explanation,
2395 # or print_help will screw up your formatting if you have
2396 # eeevil ornaments enabled. This is an insane mess.
2400 B<s> [I<expr>] Single step [in I<expr>].
2401 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2402 <B<CR>> Repeat last B<n> or B<s> command.
2403 B<r> Return from current subroutine.
2404 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2405 at the specified position.
2406 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2407 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2408 B<l> I<line> List single I<line>.
2409 B<l> I<subname> List first window of lines from subroutine.
2410 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2411 B<l> List next window of lines.
2412 B<-> List previous window of lines.
2413 B<w> [I<line>] List window around I<line>.
2414 B<.> Return to the executed line.
2415 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2416 I<filename> may be either the full name of the file, or a regular
2417 expression matching the full file name:
2418 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2419 Evals (with saved bodies) are considered to be filenames:
2420 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2421 (in the order of execution).
2422 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2423 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2424 B<L> List all breakpoints and actions.
2425 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2426 B<t> Toggle trace mode.
2427 B<t> I<expr> Trace through execution of I<expr>.
2428 B<b> [I<line>] [I<condition>]
2429 Set breakpoint; I<line> defaults to the current execution line;
2430 I<condition> breaks if it evaluates to true, defaults to '1'.
2431 B<b> I<subname> [I<condition>]
2432 Set breakpoint at first line of subroutine.
2433 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2434 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2435 B<b> B<postpone> I<subname> [I<condition>]
2436 Set breakpoint at first line of subroutine after
2438 B<b> B<compile> I<subname>
2439 Stop after the subroutine is compiled.
2440 B<d> [I<line>] Delete the breakpoint for I<line>.
2441 B<D> Delete all breakpoints.
2442 B<a> [I<line>] I<command>
2443 Set an action to be done before the I<line> is executed;
2444 I<line> defaults to the current execution line.
2445 Sequence is: check for breakpoint/watchpoint, print line
2446 if necessary, do action, prompt user if necessary,
2448 B<a> [I<line>] Delete the action for I<line>.
2449 B<A> Delete all actions.
2450 B<W> I<expr> Add a global watch-expression.
2451 B<W> Delete all watch-expressions.
2452 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2453 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2454 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2455 B<x> I<expr> Evals expression in list context, dumps the result.
2456 B<m> I<expr> Evals expression in list context, prints methods callable
2457 on the first element of the result.
2458 B<m> I<class> Prints methods callable via the given class.
2460 B<<> ? List Perl commands to run before each prompt.
2461 B<<> I<expr> Define Perl command to run before each prompt.
2462 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2463 B<>> ? List Perl commands to run after each prompt.
2464 B<>> I<expr> Define Perl command to run after each prompt.
2465 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2466 B<{> I<db_command> Define debugger command to run before each prompt.
2467 B<{> ? List debugger commands to run before each prompt.
2468 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2469 B<$prc> I<number> Redo a previous command (default previous command).
2470 B<$prc> I<-number> Redo number'th-to-last command.
2471 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2472 See 'B<O> I<recallCommand>' too.
2473 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2474 . ( $rc eq $sh ? "" : "
2475 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2476 See 'B<O> I<shellBang>' too.
2477 B<H> I<-number> Display last number commands (default all).
2478 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2479 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2480 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2481 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2482 I<command> Execute as a perl statement in current package.
2483 B<v> Show versions of loaded modules.
2484 B<R> Pure-man-restart of debugger, some of debugger state
2485 and command-line options may be lost.
2486 Currently the following settings are preserved:
2487 history, breakpoints and actions, debugger B<O>ptions
2488 and the following command-line options: I<-w>, I<-I>, I<-e>.
2490 B<O> [I<opt>] ... Set boolean option to true
2491 B<O> [I<opt>B<?>] Query options
2492 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2493 Set options. Use quotes in spaces in value.
2494 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2495 I<pager> program for output of \"|cmd\";
2496 I<tkRunning> run Tk while prompting (with ReadLine);
2497 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2498 I<inhibit_exit> Allows stepping off the end of the script.
2499 I<ImmediateStop> Debugger should stop as early as possible.
2500 I<RemotePort> Remote hostname:port for remote debugging
2501 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2502 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2503 I<compactDump>, I<veryCompact> change style of array and hash dump;
2504 I<globPrint> whether to print contents of globs;
2505 I<DumpDBFiles> dump arrays holding debugged files;
2506 I<DumpPackages> dump symbol tables of packages;
2507 I<DumpReused> dump contents of \"reused\" addresses;
2508 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2509 I<bareStringify> Do not print the overload-stringified value;
2510 Other options include:
2511 I<PrintRet> affects printing of return value after B<r> command,
2512 I<frame> affects printing messages on subroutine entry/exit.
2513 I<AutoTrace> affects printing messages on possible breaking points.
2514 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2515 I<ornaments> affects screen appearance of the command line.
2516 I<CreateTTY> bits control attempts to create a new TTY on events:
2517 1: on fork() 2: debugger is started inside debugger
2519 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2520 You can put additional initialization options I<TTY>, I<noTTY>,
2521 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2522 `B<R>' after you set them).
2524 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2525 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2526 B<h h> Summary of debugger commands.
2527 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2528 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2529 Set B<\$DB::doccmd> to change viewer.
2531 Type `|h' for a paged display if this was too hard to read.
2533 "; # Fix balance of vi % matching: }}}}
2535 # note: tabs in the following section are not-so-helpful
2536 $summary = <<"END_SUM";
2537 I<List/search source lines:> I<Control script execution:>
2538 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2539 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2540 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2541 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2542 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2543 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2544 I<Debugger controls:> B<L> List break/watch/actions
2545 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2546 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2547 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2548 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2549 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2550 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2551 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2552 B<q> or B<^D> Quit B<R> Attempt a restart
2553 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2554 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2555 B<p> I<expr> Print expression (uses script's current package).
2556 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2557 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2558 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2559 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2561 # ')}}; # Fix balance of vi % matching
2567 # Restore proper alignment destroyed by eeevil I<> and B<>
2568 # ornaments: A pox on both their houses!
2570 # A help command will have everything up to and including
2571 # the first tab sequence padded into a field 16 (or if indented 20)
2572 # wide. If it's wider than that, an extra space will be added.
2574 ^ # only matters at start of line
2575 ( \040{4} | \t )* # some subcommands are indented
2576 ( < ? # so <CR> works
2577 [BI] < [^\t\n] + ) # find an eeevil ornament
2578 ( \t+ ) # original separation, discarded
2579 ( .* ) # this will now start (no earlier) than
2582 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2583 my $clean = $command;
2584 $clean =~ s/[BI]<([^>]*)>/$1/g;
2585 # replace with this whole string:
2586 ($leadwhite ? " " x 4 : "")
2588 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2593 s{ # handle bold ornaments
2594 B < ( [^>] + | > ) >
2596 $Term::ReadLine::TermCap::rl_term_set[2]
2598 . $Term::ReadLine::TermCap::rl_term_set[3]
2601 s{ # handle italic ornaments
2602 I < ( [^>] + | > ) >
2604 $Term::ReadLine::TermCap::rl_term_set[0]
2606 . $Term::ReadLine::TermCap::rl_term_set[1]
2613 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2614 my $is_less = $pager =~ /\bless\b/;
2615 if ($pager =~ /\bmore\b/) {
2616 my @st_more = stat('/usr/bin/more');
2617 my @st_less = stat('/usr/bin/less');
2618 $is_less = @st_more && @st_less
2619 && $st_more[0] == $st_less[0]
2620 && $st_more[1] == $st_less[1];
2622 # changes environment!
2623 $ENV{LESS} .= 'r' if $is_less;
2629 $SIG{'ABRT'} = 'DEFAULT';
2630 kill 'ABRT', $$ if $panic++;
2631 if (defined &Carp::longmess) {
2632 local $SIG{__WARN__} = '';
2633 local $Carp::CarpLevel = 2; # mydie + confess
2634 &warn(Carp::longmess("Signal @_"));
2637 print $DB::OUT "Got signal @_\n";
2645 local $SIG{__WARN__} = '';
2646 local $SIG{__DIE__} = '';
2647 eval { require Carp } if defined $^S; # If error/warning during compilation,
2648 # require may be broken.
2649 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2650 return unless defined &Carp::longmess;
2651 my ($mysingle,$mytrace) = ($single,$trace);
2652 $single = 0; $trace = 0;
2653 my $mess = Carp::longmess(@_);
2654 ($single,$trace) = ($mysingle,$mytrace);
2661 local $SIG{__DIE__} = '';
2662 local $SIG{__WARN__} = '';
2663 my $i = 0; my $ineval = 0; my $sub;
2664 if ($dieLevel > 2) {
2665 local $SIG{__WARN__} = \&dbwarn;
2666 &warn(@_); # Yell no matter what
2669 if ($dieLevel < 2) {
2670 die @_ if $^S; # in eval propagate
2672 eval { require Carp } if defined $^S; # If error/warning during compilation,
2673 # require may be broken.
2675 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2676 unless defined &Carp::longmess;
2678 # We do not want to debug this chunk (automatic disabling works
2679 # inside DB::DB, but not in Carp).
2680 my ($mysingle,$mytrace) = ($single,$trace);
2681 $single = 0; $trace = 0;
2682 my $mess = Carp::longmess(@_);
2683 ($single,$trace) = ($mysingle,$mytrace);
2689 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2692 $SIG{__WARN__} = \&DB::dbwarn;
2693 } elsif ($prevwarn) {
2694 $SIG{__WARN__} = $prevwarn;
2702 $prevdie = $SIG{__DIE__} unless $dieLevel;
2705 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2706 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2707 print $OUT "Stack dump during die enabled",
2708 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2710 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2711 } elsif ($prevdie) {
2712 $SIG{__DIE__} = $prevdie;
2713 print $OUT "Default die handler restored.\n";
2721 $prevsegv = $SIG{SEGV} unless $signalLevel;
2722 $prevbus = $SIG{BUS} unless $signalLevel;
2723 $signalLevel = shift;
2725 $SIG{SEGV} = \&DB::diesignal;
2726 $SIG{BUS} = \&DB::diesignal;
2728 $SIG{SEGV} = $prevsegv;
2729 $SIG{BUS} = $prevbus;
2737 my $name = CvGV_name_or_bust($in);
2738 defined $name ? $name : $in;
2741 sub CvGV_name_or_bust {
2743 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2744 $in = \&$in; # Hard reference...
2745 eval {require Devel::Peek; 1} or return;
2746 my $gv = Devel::Peek::CvGV($in) or return;
2747 *$gv{PACKAGE} . '::' . *$gv{NAME};
2753 return unless defined &$subr;
2754 my $name = CvGV_name_or_bust($subr);
2756 $data = $sub{$name} if defined $name;
2757 return $data if defined $data;
2760 $subr = \&$subr; # Hard reference
2763 $s = $_, last if $subr eq \&$_;
2771 $class = ref $class if ref $class;
2774 methods_via($class, '', 1);
2775 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2780 return if $packs{$class}++;
2782 my $prepend = $prefix ? "via $prefix: " : '';
2784 for $name (grep {defined &{${"${class}::"}{$_}}}
2785 sort keys %{"${class}::"}) {
2786 next if $seen{ $name }++;
2787 print $DB::OUT "$prepend$name\n";
2789 return unless shift; # Recurse?
2790 for $name (@{"${class}::ISA"}) {
2791 $prepend = $prefix ? $prefix . " -> $name" : $name;
2792 methods_via($name, $prepend, 1);
2797 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
2798 ? "man" # O Happy Day!
2799 : "perldoc"; # Alas, poor unfortunates
2805 &system("$doccmd $doccmd");
2808 # this way user can override, like with $doccmd="man -Mwhatever"
2809 # or even just "man " to disable the path check.
2810 unless ($doccmd eq 'man') {
2811 &system("$doccmd $page");
2815 $page = 'perl' if lc($page) eq 'help';
2818 my $man1dir = $Config::Config{'man1dir'};
2819 my $man3dir = $Config::Config{'man3dir'};
2820 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2822 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2823 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2824 chop $manpath if $manpath;
2825 # harmless if missing, I figure
2826 my $oldpath = $ENV{MANPATH};
2827 $ENV{MANPATH} = $manpath if $manpath;
2828 my $nopathopt = $^O =~ /dunno what goes here/;
2829 if (CORE::system($doccmd,
2830 # I just *know* there are men without -M
2831 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2834 unless ($page =~ /^perl\w/) {
2835 if (grep { $page eq $_ } qw{
2836 5004delta 5005delta amiga api apio book boot bot call compile
2837 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2838 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2839 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2840 modinstall modlib number obj op opentut os2 os390 pod port
2841 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2842 trap unicode var vms win32 xs xstut
2846 CORE::system($doccmd,
2847 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2852 if (defined $oldpath) {
2853 $ENV{MANPATH} = $manpath;
2855 delete $ENV{MANPATH};
2859 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2861 BEGIN { # This does not compile, alas.
2862 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2863 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2867 $deep = 100; # warning if stack gets this deep
2871 $SIG{INT} = \&DB::catch;
2872 # This may be enabled to debug debugger:
2873 #$warnLevel = 1 unless defined $warnLevel;
2874 #$dieLevel = 1 unless defined $dieLevel;
2875 #$signalLevel = 1 unless defined $signalLevel;
2877 $db_stop = 0; # Compiler warning
2879 $level = 0; # Level of recursive debugging
2880 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2881 # Triggers bug (?) in perl is we postpone this until runtime:
2882 @postponed = @stack = (0);
2883 $stack_depth = 0; # Localized $#stack
2888 BEGIN {$^W = $ini_warn;} # Switch warnings back
2890 #use Carp; # This did break, left for debugging
2893 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2894 my($text, $line, $start) = @_;
2895 my ($itext, $search, $prefix, $pack) =
2896 ($text, "^\Q${'package'}::\E([^:]+)\$");
2898 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2899 (map { /$search/ ? ($1) : () } keys %sub)
2900 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2901 return sort grep /^\Q$text/, values %INC # files
2902 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2903 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2904 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2905 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2906 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2908 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2910 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2911 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2912 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2913 # We may want to complete to (eval 9), so $text may be wrong
2914 $prefix = length($1) - length($text);
2917 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2919 if ((substr $text, 0, 1) eq '&') { # subroutines
2920 $text = substr $text, 1;
2922 return sort map "$prefix$_",
2925 (map { /$search/ ? ($1) : () }
2928 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2929 $pack = ($1 eq 'main' ? '' : $1) . '::';
2930 $prefix = (substr $text, 0, 1) . $1 . '::';
2933 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2934 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2935 return db_complete($out[0], $line, $start);
2939 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2940 $pack = ($package eq 'main' ? '' : $package) . '::';
2941 $prefix = substr $text, 0, 1;
2942 $text = substr $text, 1;
2943 my @out = map "$prefix$_", grep /^\Q$text/,
2944 (grep /^_?[a-zA-Z]/, keys %$pack),
2945 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2946 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2947 return db_complete($out[0], $line, $start);
2951 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2952 my @out = grep /^\Q$text/, @options;
2953 my $val = option_val($out[0], undef);
2955 if (not defined $val or $val =~ /[\n\r]/) {
2956 # Can do nothing better
2957 } elsif ($val =~ /\s/) {
2959 foreach $l (split //, qq/\"\'\#\|/) {
2960 $out = "$l$val$l ", last if (index $val, $l) == -1;
2965 # Default to value if one completion, to question if many
2966 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2969 return $term->filename_list($text); # filenames
2973 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2977 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
2978 $fall_off_end = 1 unless $inhibit_exit;
2979 # Do not stop in at_exit() and destructors on exit:
2980 $DB::single = !$fall_off_end && !$runnonstop;
2981 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
2987 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2990 package DB; # Do not trace this 1; below!