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)
256 ####################################################################
258 # Needed for the statement after exec():
260 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
261 local($^W) = 0; # Switch run-time warnings off during init.
264 $dumpvar::arrayDepth,
265 $dumpvar::dumpDBFiles,
266 $dumpvar::dumpPackages,
267 $dumpvar::quoteHighBit,
268 $dumpvar::printUndef,
277 # Command-line + PERLLIB:
280 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
282 $trace = $signal = $single = 0; # Uninitialized warning suppression
283 # (local $^W cannot help - other packages!).
284 $inhibit_exit = $option{PrintRet} = 1;
286 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
287 compactDump veryCompact quote HighBit undefPrint
288 globPrint PrintRet UsageOnly frame AutoTrace
289 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
290 recallCommand ShellBang pager tkRunning ornaments
291 signalLevel warnLevel dieLevel inhibit_exit
292 ImmediateStop bareStringify CreateTTY
296 hashDepth => \$dumpvar::hashDepth,
297 arrayDepth => \$dumpvar::arrayDepth,
298 DumpDBFiles => \$dumpvar::dumpDBFiles,
299 DumpPackages => \$dumpvar::dumpPackages,
300 DumpReused => \$dumpvar::dumpReused,
301 HighBit => \$dumpvar::quoteHighBit,
302 undefPrint => \$dumpvar::printUndef,
303 globPrint => \$dumpvar::globPrint,
304 UsageOnly => \$dumpvar::usageOnly,
305 CreateTTY => \$CreateTTY,
306 bareStringify => \$dumpvar::bareStringify,
308 AutoTrace => \$trace,
309 inhibit_exit => \$inhibit_exit,
310 maxTraceLen => \$maxtrace,
311 ImmediateStop => \$ImmediateStop,
312 RemotePort => \$remoteport,
316 compactDump => \&dumpvar::compactDump,
317 veryCompact => \&dumpvar::veryCompact,
318 quote => \&dumpvar::quote,
321 ReadLine => \&ReadLine,
322 NonStop => \&NonStop,
323 LineInfo => \&LineInfo,
324 recallCommand => \&recallCommand,
325 ShellBang => \&shellBang,
327 signalLevel => \&signalLevel,
328 warnLevel => \&warnLevel,
329 dieLevel => \&dieLevel,
330 tkRunning => \&tkRunning,
331 ornaments => \&ornaments,
332 RemotePort => \&RemotePort,
336 compactDump => 'dumpvar.pl',
337 veryCompact => 'dumpvar.pl',
338 quote => 'dumpvar.pl',
341 # These guys may be defined in $ENV{PERL5DB} :
342 $rl = 1 unless defined $rl;
343 $warnLevel = 0 unless defined $warnLevel;
344 $dieLevel = 0 unless defined $dieLevel;
345 $signalLevel = 1 unless defined $signalLevel;
346 $pre = [] unless defined $pre;
347 $post = [] unless defined $post;
348 $pretype = [] unless defined $pretype;
349 $CreateTTY = 3 unless defined $CreateTTY;
351 warnLevel($warnLevel);
353 signalLevel($signalLevel);
356 (defined($ENV{PAGER})
360 : 'more'))) unless defined $pager;
362 &recallCommand("!") unless defined $prc;
363 &shellBang("!") unless defined $psh;
365 $maxtrace = 400 unless defined $maxtrace;
366 $ini_pids = $ENV{PERLDB_PIDS};
367 if (defined $ENV{PERLDB_PIDS}) {
368 $pids = "[$ENV{PERLDB_PIDS}]";
369 $ENV{PERLDB_PIDS} .= "->$$";
372 $ENV{PERLDB_PIDS} = "$$";
377 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
379 if (-e "/dev/tty") { # this is the wrong metric!
382 $rcfile="perldb.ini";
385 # This isn't really safe, because there's a race
386 # between checking and opening. The solution is to
387 # open and fstat the handle, but then you have to read and
388 # eval the contents. But then the silly thing gets
389 # your lexical scope, which is unfortunately at best.
393 # Just exactly what part of the word "CORE::" don't you understand?
394 local $SIG{__WARN__};
397 unless (is_safe_file($file)) {
398 CORE::warn <<EO_GRIPE;
399 perldb: Must not source insecure rcfile $file.
400 You or the superuser must be the owner, and it must not
401 be writable by anyone but its owner.
407 CORE::warn("perldb: couldn't parse $file: $@") if $@;
411 # Verifies that owner is either real user or superuser and that no
412 # one but owner may write to it. This function is of limited use
413 # when called on a path instead of upon a handle, because there are
414 # no guarantees that filename (by dirent) whose file (by ino) is
415 # eventually accessed is the same as the one tested.
416 # Assumes that the file's existence is not in doubt.
419 stat($path) || return; # mysteriously vaporized
420 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
422 return 0 if $uid != 0 && $uid != $<;
423 return 0 if $mode & 022;
428 safe_do("./$rcfile");
430 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
431 safe_do("$ENV{HOME}/$rcfile");
433 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
434 safe_do("$ENV{LOGDIR}/$rcfile");
437 if (defined $ENV{PERLDB_OPTS}) {
438 parse_options($ENV{PERLDB_OPTS});
441 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
442 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
443 *get_fork_TTY = \&xterm_get_fork_TTY;
444 } elsif ($^O eq 'os2') {
445 *get_fork_TTY = \&os2_get_fork_TTY;
448 # Here begin the unreadable code. It needs fixing.
450 if (exists $ENV{PERLDB_RESTART}) {
451 delete $ENV{PERLDB_RESTART};
453 @hist = get_list('PERLDB_HIST');
454 %break_on_load = get_list("PERLDB_ON_LOAD");
455 %postponed = get_list("PERLDB_POSTPONE");
456 my @had_breakpoints= get_list("PERLDB_VISITED");
457 for (0 .. $#had_breakpoints) {
458 my %pf = get_list("PERLDB_FILE_$_");
459 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
461 my %opt = get_list("PERLDB_OPT");
463 while (($opt,$val) = each %opt) {
464 $val =~ s/[\\\']/\\$1/g;
465 parse_options("$opt'$val'");
467 @INC = get_list("PERLDB_INC");
469 $pretype = [get_list("PERLDB_PRETYPE")];
470 $pre = [get_list("PERLDB_PRE")];
471 $post = [get_list("PERLDB_POST")];
472 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
478 # Is Perl being run from a slave editor or graphical debugger?
479 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
480 $rl = 0, shift(@main::ARGV) if $slave_editor;
482 #require Term::ReadLine;
484 if ($^O eq 'cygwin') {
485 # /dev/tty is binary. use stdin for textmode
487 } elsif (-e "/dev/tty") {
488 $console = "/dev/tty";
489 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
491 } elsif ($^O eq 'MacOS') {
492 if ($MacPerl::Version !~ /MPW/) {
493 $console = "Dev:Console:Perl Debug"; # Separate window for application
495 $console = "Dev:Console";
498 $console = "sys\$command";
501 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
505 if ($^O eq 'NetWare') {
510 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
518 $console = $tty if defined $tty;
520 if (defined $remoteport) {
522 $OUT = new IO::Socket::INET( Timeout => '10',
523 PeerAddr => $remoteport,
526 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
528 } elsif ($CreateTTY & 4) {
531 if (defined $console) {
532 my ($i, $o) = split /,/, $console;
533 $o = $i unless defined $o;
534 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
535 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
536 || open(OUT,">&STDOUT"); # so we don't dongle stdout
539 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
540 $console = 'STDIN/OUT';
542 # so open("|more") can read from STDOUT and so we don't dingle stdin
547 my $previous = select($OUT);
548 $| = 1; # for DB::OUT
551 $LINEINFO = $OUT unless defined $LINEINFO;
552 $lineinfo = $console unless defined $lineinfo;
554 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
555 unless ($runnonstop) {
556 if ($term_pid eq '-1') {
557 print $OUT "\nDaughter DB session started...\n";
559 print $OUT "\nLoading DB routines from $header\n";
560 print $OUT ("Editor support ",
561 $slave_editor ? "enabled" : "available",
563 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
571 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
574 if (defined &afterinit) { # May be defined in $rcfile
580 ############################################################ Subroutines
583 # _After_ the perl program is compiled, $single is set to 1:
584 if ($single and not $second_time++) {
585 if ($runnonstop) { # Disable until signal
586 for ($i=0; $i <= $stack_depth; ) {
590 # return; # Would not print trace!
591 } elsif ($ImmediateStop) {
596 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
598 ($package, $filename, $line) = caller;
599 $filename_ini = $filename;
600 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
601 "package $package;"; # this won't let them modify, alas
602 local(*dbline) = $main::{'_<' . $filename};
604 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
608 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
609 $dbline{$line} =~ s/;9($|\0)/$1/;
612 my $was_signal = $signal;
614 for (my $n = 0; $n <= $#to_watch; $n++) {
615 $evalarg = $to_watch[$n];
616 local $onetimeDump; # Do not output results
617 my ($val) = &eval; # Fix context (&eval is doing array)?
618 $val = ( (defined $val) ? "'$val'" : 'undef' );
619 if ($val ne $old_watch[$n]) {
622 Watchpoint $n:\t$to_watch[$n] changed:
623 old value:\t$old_watch[$n]
626 $old_watch[$n] = $val;
630 if ($trace & 4) { # User-installed watch
631 return if watchfunction($package, $filename, $line)
632 and not $single and not $was_signal and not ($trace & ~4);
634 $was_signal = $signal;
636 if ($single || ($trace & 1) || $was_signal) {
638 $position = "\032\032$filename:$line:0\n";
639 print_lineinfo($position);
640 } elsif ($package eq 'DB::fake') {
643 Debugged program terminated. Use B<q> to quit or B<R> to restart,
644 use B<O> I<inhibit_exit> to avoid stopping after program termination,
645 B<h q>, B<h R> or B<h O> to get additional info.
648 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
649 "package $package;"; # this won't let them modify, alas
652 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
653 $prefix .= "$sub($filename:";
654 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
655 if (length($prefix) > 30) {
656 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
661 $position = "$prefix$line$infix$dbline[$line]$after";
664 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
666 print_lineinfo($position);
668 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
669 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
671 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
672 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
673 $position .= $incr_pos;
675 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
677 print_lineinfo($incr_pos);
682 $evalarg = $action, &eval if $action;
683 if ($single || $was_signal) {
684 local $level = $level + 1;
685 foreach $evalarg (@$pre) {
688 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
691 $incr = -1; # for backward motion.
692 @typeahead = (@$pretype, @typeahead);
694 while (($term || &setterm),
695 ($term_pid == $$ or resetterm(1)),
696 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
697 ($#hist+1) . ('>' x $level) .
702 $cmd =~ s/\\$/\n/ && do {
703 $cmd .= &readline(" cont: ");
706 $cmd =~ /^$/ && ($cmd = $laststep);
707 push(@hist,$cmd) if length($cmd) > 1;
709 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
710 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
711 ($i) = split(/\s+/,$cmd);
713 # squelch the sigmangler
715 local $SIG{__WARN__};
716 eval "\$cmd =~ $alias{$i}";
718 print $OUT "Couldn't evaluate `$i' alias: $@";
722 $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
723 $cmd =~ /^h$/ && do {
726 $cmd =~ /^h\s+h$/ && do {
727 print_help($summary);
729 # support long commands; otherwise bogus errors
730 # happen when you ask for h on <CR> for example
731 $cmd =~ /^h\s+(\S.*)$/ && do {
732 my $asked = $1; # for proper errmsg
733 my $qasked = quotemeta($asked); # for searching
734 # XXX: finds CR but not <CR>
735 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
736 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
740 print_help("B<$asked> is not a debugger command.\n");
743 $cmd =~ /^t$/ && do {
745 print $OUT "Trace = " .
746 (($trace & 1) ? "on" : "off" ) . "\n";
748 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
749 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
750 foreach $subname (sort(keys %sub)) {
751 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
752 print $OUT $subname,"\n";
756 $cmd =~ /^v$/ && do {
757 list_versions(); next CMD};
758 $cmd =~ s/^X\b/V $package/;
759 $cmd =~ /^V$/ && do {
760 $cmd = "V $package"; };
761 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
762 local ($savout) = select($OUT);
764 @vars = split(' ',$2);
765 do 'dumpvar.pl' unless defined &main::dumpvar;
766 if (defined &main::dumpvar) {
769 # must detect sigpipe failures
770 eval { &main::dumpvar($packname,@vars) };
772 die unless $@ =~ /dumpvar print failed/;
775 print $OUT "dumpvar.pl not available.\n";
779 $cmd =~ s/^x\b/ / && do { # So that will be evaled
780 $onetimeDump = 'dump'; };
781 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
782 methods($1); next CMD};
783 $cmd =~ s/^m\b/ / && do { # So this will be evaled
784 $onetimeDump = 'methods'; };
785 $cmd =~ /^f\b\s*(.*)/ && do {
789 print $OUT "The old f command is now the r command.\n";
790 print $OUT "The new f command switches filenames.\n";
793 if (!defined $main::{'_<' . $file}) {
794 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
795 $try = substr($try,2);
796 print $OUT "Choosing $try matching `$file':\n";
800 if (!defined $main::{'_<' . $file}) {
801 print $OUT "No file matching `$file' is loaded.\n";
803 } elsif ($file ne $filename) {
804 *dbline = $main::{'_<' . $file};
810 print $OUT "Already in $file.\n";
814 $cmd =~ s/^l\s+-\s*$/-/;
815 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
818 print($OUT "Error: $@\n"), next CMD if $@;
820 print($OUT "Interpreted as: $1 $s\n");
823 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
824 my $s = $subname = $1;
825 $subname =~ s/\'/::/;
826 $subname = $package."::".$subname
827 unless $subname =~ /::/;
828 $subname = "CORE::GLOBAL::$s"
829 if not defined &$subname and $s !~ /::/
830 and defined &{"CORE::GLOBAL::$s"};
831 $subname = "main".$subname if substr($subname,0,2) eq "::";
832 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
833 $subrange = pop @pieces;
834 $file = join(':', @pieces);
835 if ($file ne $filename) {
836 print $OUT "Switching to file '$file'.\n"
837 unless $slave_editor;
838 *dbline = $main::{'_<' . $file};
843 if (eval($subrange) < -$window) {
844 $subrange =~ s/-.*/+/;
846 $cmd = "l $subrange";
848 print $OUT "Subroutine $subname not found.\n";
851 $cmd =~ /^\.$/ && do {
852 $incr = -1; # for backward motion.
854 $filename = $filename_ini;
855 *dbline = $main::{'_<' . $filename};
857 print_lineinfo($position);
859 $cmd =~ /^w\b\s*(\d*)$/ && do {
863 #print $OUT 'l ' . $start . '-' . ($start + $incr);
864 $cmd = 'l ' . $start . '-' . ($start + $incr); };
865 $cmd =~ /^-$/ && do {
866 $start -= $incr + $window + 1;
867 $start = 1 if $start <= 0;
869 $cmd = 'l ' . ($start) . '+'; };
870 $cmd =~ /^l$/ && do {
872 $cmd = 'l ' . $start . '-' . ($start + $incr); };
873 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
876 $incr = $window - 1 unless $incr;
877 $cmd = 'l ' . $start . '-' . ($start + $incr); };
878 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
879 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
880 $end = $max if $end > $max;
882 $i = $line if $i eq '.';
886 print $OUT "\032\032$filename:$i:0\n";
889 for (; $i <= $end; $i++) {
890 ($stop,$action) = split(/\0/, $dbline{$i}) if
893 and $filename eq $filename_ini)
895 : ($dbline[$i]+0 ? ':' : ' ') ;
896 $arrow .= 'b' if $stop;
897 $arrow .= 'a' if $action;
898 print $OUT "$i$arrow\t", $dbline[$i];
899 $i++, last if $signal;
901 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
903 $start = $i; # remember in case they want more
904 $start = $max if $start > $max;
906 $cmd =~ /^D$/ && do {
907 print $OUT "Deleting all breakpoints...\n";
909 for $file (keys %had_breakpoints) {
910 local *dbline = $main::{'_<' . $file};
914 for ($i = 1; $i <= $max ; $i++) {
915 if (defined $dbline{$i}) {
916 $dbline{$i} =~ s/^[^\0]+//;
917 if ($dbline{$i} =~ s/^\0?$//) {
923 if (not $had_breakpoints{$file} &= ~1) {
924 delete $had_breakpoints{$file};
928 undef %postponed_file;
929 undef %break_on_load;
931 $cmd =~ /^L$/ && do {
933 for $file (keys %had_breakpoints) {
934 local *dbline = $main::{'_<' . $file};
938 for ($i = 1; $i <= $max; $i++) {
939 if (defined $dbline{$i}) {
940 print $OUT "$file:\n" unless $was++;
941 print $OUT " $i:\t", $dbline[$i];
942 ($stop,$action) = split(/\0/, $dbline{$i});
943 print $OUT " break if (", $stop, ")\n"
945 print $OUT " action: ", $action, "\n"
952 print $OUT "Postponed breakpoints in subroutines:\n";
954 for $subname (keys %postponed) {
955 print $OUT " $subname\t$postponed{$subname}\n";
959 my @have = map { # Combined keys
960 keys %{$postponed_file{$_}}
961 } keys %postponed_file;
963 print $OUT "Postponed breakpoints in files:\n";
965 for $file (keys %postponed_file) {
966 my $db = $postponed_file{$file};
967 print $OUT " $file:\n";
968 for $line (sort {$a <=> $b} keys %$db) {
969 print $OUT " $line:\n";
970 my ($stop,$action) = split(/\0/, $$db{$line});
971 print $OUT " break if (", $stop, ")\n"
973 print $OUT " action: ", $action, "\n"
980 if (%break_on_load) {
981 print $OUT "Breakpoints on load:\n";
983 for $file (keys %break_on_load) {
984 print $OUT " $file\n";
989 print $OUT "Watch-expressions:\n";
991 for $expr (@to_watch) {
992 print $OUT " $expr\n";
997 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
998 my $file = $1; $file =~ s/\s+$//;
1001 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
1002 my $cond = length $3 ? $3 : '1';
1003 my ($subname, $break) = ($2, $1 eq 'postpone');
1004 $subname =~ s/\'/::/g;
1005 $subname = "${'package'}::" . $subname
1006 unless $subname =~ /::/;
1007 $subname = "main".$subname if substr($subname,0,2) eq "::";
1008 $postponed{$subname} = $break
1009 ? "break +0 if $cond" : "compile";
1011 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1013 $cond = length $2 ? $2 : '1';
1014 cmd_b_sub($subname, $cond);
1016 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1018 $cond = length $2 ? $2 : '1';
1019 cmd_b_line($i, $cond);
1021 $cmd =~ /^d\b\s*(\d*)/ && do {
1024 $cmd =~ /^A$/ && do {
1025 print $OUT "Deleting all actions...\n";
1027 for $file (keys %had_breakpoints) {
1028 local *dbline = $main::{'_<' . $file};
1032 for ($i = 1; $i <= $max ; $i++) {
1033 if (defined $dbline{$i}) {
1034 $dbline{$i} =~ s/\0[^\0]*//;
1035 delete $dbline{$i} if $dbline{$i} eq '';
1039 unless ($had_breakpoints{$file} &= ~2) {
1040 delete $had_breakpoints{$file};
1044 $cmd =~ /^O\s*$/ && do {
1049 $cmd =~ /^O\s*(\S.*)/ && do {
1052 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1053 push @$pre, action($1);
1055 $cmd =~ /^>>\s*(.*)/ && do {
1056 push @$post, action($1);
1058 $cmd =~ /^<\s*(.*)/ && do {
1060 print $OUT "All < actions cleared.\n";
1066 print $OUT "No pre-prompt Perl actions.\n";
1069 print $OUT "Perl commands run before each prompt:\n";
1070 for my $action ( @$pre ) {
1071 print $OUT "\t< -- $action\n";
1075 $pre = [action($1)];
1077 $cmd =~ /^>\s*(.*)/ && do {
1079 print $OUT "All > actions cleared.\n";
1085 print $OUT "No post-prompt Perl actions.\n";
1088 print $OUT "Perl commands run after each prompt:\n";
1089 for my $action ( @$post ) {
1090 print $OUT "\t> -- $action\n";
1094 $post = [action($1)];
1096 $cmd =~ /^\{\{\s*(.*)/ && do {
1097 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1098 print $OUT "{{ is now a debugger command\n",
1099 "use `;{{' if you mean Perl code\n";
1105 $cmd =~ /^\{\s*(.*)/ && do {
1107 print $OUT "All { actions cleared.\n";
1112 unless (@$pretype) {
1113 print $OUT "No pre-prompt debugger actions.\n";
1116 print $OUT "Debugger commands run before each prompt:\n";
1117 for my $action ( @$pretype ) {
1118 print $OUT "\t{ -- $action\n";
1122 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1123 print $OUT "{ is now a debugger command\n",
1124 "use `;{' if you mean Perl code\n";
1130 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1131 $i = $1 || $line; $j = $2;
1133 if ($dbline[$i] == 0) {
1134 print $OUT "Line $i may not have an action.\n";
1136 $had_breakpoints{$filename} |= 2;
1137 $dbline{$i} =~ s/\0[^\0]*//;
1138 $dbline{$i} .= "\0" . action($j);
1141 $dbline{$i} =~ s/\0[^\0]*//;
1142 delete $dbline{$i} if $dbline{$i} eq '';
1145 $cmd =~ /^n$/ && do {
1146 end_report(), next CMD if $finished and $level <= 1;
1150 $cmd =~ /^s$/ && do {
1151 end_report(), next CMD if $finished and $level <= 1;
1155 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1156 end_report(), next CMD if $finished and $level <= 1;
1158 # Probably not needed, since we finish an interactive
1159 # sub-session anyway...
1160 # local $filename = $filename;
1161 # local *dbline = *dbline; # XXX Would this work?!
1162 if ($i =~ /\D/) { # subroutine name
1163 $subname = $package."::".$subname
1164 unless $subname =~ /::/;
1165 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1169 *dbline = $main::{'_<' . $filename};
1170 $had_breakpoints{$filename} |= 1;
1172 ++$i while $dbline[$i] == 0 && $i < $max;
1174 print $OUT "Subroutine $subname not found.\n";
1179 if ($dbline[$i] == 0) {
1180 print $OUT "Line $i not breakable.\n";
1183 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1185 for ($i=0; $i <= $stack_depth; ) {
1189 $cmd =~ /^r$/ && do {
1190 end_report(), next CMD if $finished and $level <= 1;
1191 $stack[$stack_depth] |= 1;
1192 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1194 $cmd =~ /^R$/ && do {
1195 print $OUT "Warning: some settings and command-line options may be lost!\n";
1196 my (@script, @flags, $cl);
1197 push @flags, '-w' if $ini_warn;
1198 # Put all the old includes at the start to get
1199 # the same debugger.
1201 push @flags, '-I', $_;
1203 # Arrange for setting the old INC:
1204 set_list("PERLDB_INC", @ini_INC);
1206 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1207 chomp ($cl = ${'::_<-e'}[$_]);
1208 push @script, '-e', $cl;
1213 set_list("PERLDB_HIST",
1214 $term->Features->{getHistory}
1215 ? $term->GetHistory : @hist);
1216 my @had_breakpoints = keys %had_breakpoints;
1217 set_list("PERLDB_VISITED", @had_breakpoints);
1218 set_list("PERLDB_OPT", %option);
1219 set_list("PERLDB_ON_LOAD", %break_on_load);
1221 for (0 .. $#had_breakpoints) {
1222 my $file = $had_breakpoints[$_];
1223 *dbline = $main::{'_<' . $file};
1224 next unless %dbline or $postponed_file{$file};
1225 (push @hard, $file), next
1226 if $file =~ /^\(eval \d+\)$/;
1228 @add = %{$postponed_file{$file}}
1229 if $postponed_file{$file};
1230 set_list("PERLDB_FILE_$_", %dbline, @add);
1232 for (@hard) { # Yes, really-really...
1233 # Find the subroutines in this eval
1234 *dbline = $main::{'_<' . $_};
1235 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1236 for $sub (keys %sub) {
1237 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1238 $subs{$sub} = [$1, $2];
1242 "No subroutines in $_, ignoring breakpoints.\n";
1245 LINES: for $line (keys %dbline) {
1246 # One breakpoint per sub only:
1247 my ($offset, $sub, $found);
1248 SUBS: for $sub (keys %subs) {
1249 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1250 and (not defined $offset # Not caught
1251 or $offset < 0 )) { # or badly caught
1253 $offset = $line - $subs{$sub}->[0];
1254 $offset = "+$offset", last SUBS if $offset >= 0;
1257 if (defined $offset) {
1258 $postponed{$found} =
1259 "break $offset if $dbline{$line}";
1261 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1265 set_list("PERLDB_POSTPONE", %postponed);
1266 set_list("PERLDB_PRETYPE", @$pretype);
1267 set_list("PERLDB_PRE", @$pre);
1268 set_list("PERLDB_POST", @$post);
1269 set_list("PERLDB_TYPEAHEAD", @typeahead);
1270 $ENV{PERLDB_RESTART} = 1;
1271 delete $ENV{PERLDB_PIDS}; # Restore ini state
1272 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1273 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1274 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1275 print $OUT "exec failed: $!\n";
1277 $cmd =~ /^T$/ && do {
1278 print_trace($OUT, 1); # skip DB
1280 $cmd =~ /^W\s*$/ && do {
1282 @to_watch = @old_watch = ();
1284 $cmd =~ /^W\b\s*(.*)/s && do {
1288 $val = (defined $val) ? "'$val'" : 'undef' ;
1289 push @old_watch, $val;
1292 $cmd =~ /^\/(.*)$/ && do {
1294 $inpat =~ s:([^\\])/$:$1:;
1296 # squelch the sigmangler
1297 local $SIG{__DIE__};
1298 local $SIG{__WARN__};
1299 eval '$inpat =~ m'."\a$inpat\a";
1311 $start = 1 if ($start > $max);
1312 last if ($start == $end);
1313 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1314 if ($slave_editor) {
1315 print $OUT "\032\032$filename:$start:0\n";
1317 print $OUT "$start:\t", $dbline[$start], "\n";
1322 print $OUT "/$pat/: not found\n" if ($start == $end);
1324 $cmd =~ /^\?(.*)$/ && do {
1326 $inpat =~ s:([^\\])\?$:$1:;
1328 # squelch the sigmangler
1329 local $SIG{__DIE__};
1330 local $SIG{__WARN__};
1331 eval '$inpat =~ m'."\a$inpat\a";
1343 $start = $max if ($start <= 0);
1344 last if ($start == $end);
1345 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1346 if ($slave_editor) {
1347 print $OUT "\032\032$filename:$start:0\n";
1349 print $OUT "$start:\t", $dbline[$start], "\n";
1354 print $OUT "?$pat?: not found\n" if ($start == $end);
1356 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1357 pop(@hist) if length($cmd) > 1;
1358 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1360 print $OUT $cmd, "\n";
1362 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1365 $cmd =~ /^$rc([^$rc].*)$/ && do {
1367 pop(@hist) if length($cmd) > 1;
1368 for ($i = $#hist; $i; --$i) {
1369 last if $hist[$i] =~ /$pat/;
1372 print $OUT "No such command!\n\n";
1376 print $OUT $cmd, "\n";
1378 $cmd =~ /^$sh$/ && do {
1379 &system($ENV{SHELL}||"/bin/sh");
1381 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1382 # XXX: using csh or tcsh destroys sigint retvals!
1383 #&system($1); # use this instead
1384 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1386 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1387 $end = $2 ? ($#hist-$2) : 0;
1388 $hist = 0 if $hist < 0;
1389 for ($i=$#hist; $i>$end; $i--) {
1390 print $OUT "$i: ",$hist[$i],"\n"
1391 unless $hist[$i] =~ /^.?$/;
1394 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1397 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1398 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1399 $cmd =~ s/^=\s*// && do {
1401 if (length $cmd == 0) {
1402 @keys = sort keys %alias;
1404 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1405 # can't use $_ or kill //g state
1406 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1407 $alias{$k} = "s\a$k\a$v\a";
1408 # squelch the sigmangler
1409 local $SIG{__DIE__};
1410 local $SIG{__WARN__};
1411 unless (eval "sub { s\a$k\a$v\a }; 1") {
1412 print $OUT "Can't alias $k to $v: $@\n";
1422 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1423 print $OUT "$k\t= $1\n";
1425 elsif (defined $alias{$k}) {
1426 print $OUT "$k\t$alias{$k}\n";
1429 print "No alias for $k\n";
1433 $cmd =~ /^\|\|?\s*[^|]/ && do {
1434 if ($pager =~ /^\|/) {
1435 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1436 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1438 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1441 unless ($piped=open(OUT,$pager)) {
1442 &warn("Can't pipe output to `$pager'");
1443 if ($pager =~ /^\|/) {
1444 open(OUT,">&STDOUT") # XXX: lost message
1445 || &warn("Can't restore DB::OUT");
1446 open(STDOUT,">&SAVEOUT")
1447 || &warn("Can't restore STDOUT");
1450 open(OUT,">&STDOUT") # XXX: lost message
1451 || &warn("Can't restore DB::OUT");
1455 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1456 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1457 $selected= select(OUT);
1459 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1460 $cmd =~ s/^\|+\s*//;
1463 # XXX Local variants do not work!
1464 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1465 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1466 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1468 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1470 $onetimeDump = undef;
1471 } elsif ($term_pid == $$) {
1476 if ($pager =~ /^\|/) {
1478 # we cannot warn here: the handle is missing --tchrist
1479 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1481 # most of the $? crud was coping with broken cshisms
1483 print SAVEOUT "Pager `$pager' failed: ";
1485 print SAVEOUT "shell returned -1\n";
1488 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1489 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1491 print SAVEOUT "status ", ($? >> 8), "\n";
1495 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1496 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1497 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1498 # Will stop ignoring SIGPIPE if done like nohup(1)
1499 # does SIGINT but Perl doesn't give us a choice.
1501 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1504 select($selected), $selected= "" unless $selected eq "";
1508 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1509 foreach $evalarg (@$post) {
1512 } # if ($single || $signal)
1513 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1517 # The following code may be executed now:
1521 my ($al, $ret, @ret) = "";
1522 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1525 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1526 $#stack = $stack_depth;
1527 $stack[-1] = $single;
1529 $single |= 4 if $stack_depth == $deep;
1531 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1532 # Why -1? But it works! :-(
1533 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1534 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1537 $single |= $stack[$stack_depth--];
1539 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1540 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1541 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1542 if ($doret eq $stack_depth or $frame & 16) {
1543 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1544 print $fh ' ' x $stack_depth if $frame & 16;
1545 print $fh "list context return from $sub:\n";
1546 dumpit($fh, \@ret );
1551 if (defined wantarray) {
1556 $single |= $stack[$stack_depth--];
1558 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1559 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1560 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1561 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1562 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1563 print $fh (' ' x $stack_depth) if $frame & 16;
1564 print $fh (defined wantarray
1565 ? "scalar context return from $sub: "
1566 : "void context return from $sub\n");
1567 dumpit( $fh, $ret ) if defined wantarray;
1576 ### Functions with multiple modes of failure die on error, the rest
1577 ### returns FALSE on error.
1578 ### User-interface functions cmd_* output error message.
1582 $break_on_load{$file} = 1;
1583 $had_breakpoints{$file} |= 1;
1586 sub report_break_on_load {
1587 sort keys %break_on_load;
1595 push @files, $::INC{$file} if $::INC{$file};
1596 $file .= '.pm', redo unless $file =~ /\./;
1598 break_on_load($_) for @files;
1599 @files = report_break_on_load;
1600 print $OUT "Will stop on load of `@files'.\n";
1603 $filename_error = '';
1605 sub breakable_line {
1606 my ($from, $to) = @_;
1609 my $delta = $from < $to ? +1 : -1;
1610 my $limit = $delta > 0 ? $#dbline : 1;
1611 $limit = $to if ($limit - $to) * $delta > 0;
1612 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1614 return $i unless $dbline[$i] == 0;
1615 my ($pl, $upto) = ('', '');
1616 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1617 die "Line$pl $from$upto$filename_error not breakable\n";
1620 sub breakable_line_in_filename {
1622 local *dbline = $main::{'_<' . $f};
1623 local $filename_error = " of `$f'";
1628 my ($i, $cond) = @_;
1629 $cond = 1 unless @_ >= 2;
1633 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1634 $had_breakpoints{$filename} |= 1;
1635 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1636 else { $dbline{$i} = $cond; }
1640 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1643 sub break_on_filename_line {
1644 my ($f, $i, $cond) = @_;
1645 $cond = 1 unless @_ >= 3;
1646 local *dbline = $main::{'_<' . $f};
1647 local $filename_error = " of `$f'";
1648 local $filename = $f;
1649 break_on_line($i, $cond);
1652 sub break_on_filename_line_range {
1653 my ($f, $from, $to, $cond) = @_;
1654 my $i = breakable_line_in_filename($f, $from, $to);
1655 $cond = 1 unless @_ >= 3;
1656 break_on_filename_line($f,$i,$cond);
1659 sub subroutine_filename_lines {
1660 my ($subname,$cond) = @_;
1661 # Filename below can contain ':'
1662 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1665 sub break_subroutine {
1666 my $subname = shift;
1667 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1668 die "Subroutine $subname not found.\n";
1669 $cond = 1 unless @_ >= 2;
1670 break_on_filename_line_range($file,$s,$e,@_);
1674 my ($subname,$cond) = @_;
1675 $cond = 1 unless @_ >= 2;
1676 unless (ref $subname eq 'CODE') {
1677 $subname =~ s/\'/::/g;
1679 $subname = "${'package'}::" . $subname
1680 unless $subname =~ /::/;
1681 $subname = "CORE::GLOBAL::$s"
1682 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1683 $subname = "main".$subname if substr($subname,0,2) eq "::";
1685 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1688 sub cmd_stop { # As on ^C, but not signal-safy.
1692 sub delete_breakpoint {
1694 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1695 $dbline{$i} =~ s/^[^\0]*//;
1696 delete $dbline{$i} if $dbline{$i} eq '';
1701 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1704 ### END of the API section
1707 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1708 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1711 sub print_lineinfo {
1712 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1716 # The following takes its argument via $evalarg to preserve current @_
1719 # 'my' would make it visible from user code
1720 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1723 local $otrace = $trace;
1724 local $osingle = $single;
1726 { ($evalarg) = $evalarg =~ /(.*)/s; }
1727 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1733 local $saved[0]; # Preserve the old value of $@
1737 } elsif ($onetimeDump) {
1738 dumpit($OUT, \@res) if $onetimeDump eq 'dump';
1739 methods($res[0]) if $onetimeDump eq 'methods';
1745 my $subname = shift;
1746 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1747 my $offset = $1 || 0;
1748 # Filename below can contain ':'
1749 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1752 local *dbline = $main::{'_<' . $file};
1753 local $^W = 0; # != 0 is magical below
1754 $had_breakpoints{$file} |= 1;
1756 ++$i until $dbline[$i] != 0 or $i >= $max;
1757 $dbline{$i} = delete $postponed{$subname};
1759 print $OUT "Subroutine $subname not found.\n";
1763 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1764 #print $OUT "In postponed_sub for `$subname'.\n";
1768 if ($ImmediateStop) {
1772 return &postponed_sub
1773 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1774 # Cannot be done before the file is compiled
1775 local *dbline = shift;
1776 my $filename = $dbline;
1777 $filename =~ s/^_<//;
1778 $signal = 1, print $OUT "'$filename' loaded...\n"
1779 if $break_on_load{$filename};
1780 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1781 return unless $postponed_file{$filename};
1782 $had_breakpoints{$filename} |= 1;
1783 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1785 for $key (keys %{$postponed_file{$filename}}) {
1786 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1788 delete $postponed_file{$filename};
1792 local ($savout) = select(shift);
1793 my $osingle = $single;
1794 my $otrace = $trace;
1795 $single = $trace = 0;
1798 unless (defined &main::dumpValue) {
1801 if (defined &main::dumpValue) {
1802 &main::dumpValue(shift);
1804 print $OUT "dumpvar.pl not available.\n";
1811 # Tied method do not create a context, so may get wrong message:
1815 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1816 my @sub = dump_trace($_[0] + 1, $_[1]);
1817 my $short = $_[2]; # Print short report, next one for sub name
1819 for ($i=0; $i <= $#sub; $i++) {
1822 my $args = defined $sub[$i]{args}
1823 ? "(@{ $sub[$i]{args} })"
1825 $args = (substr $args, 0, $maxtrace - 3) . '...'
1826 if length $args > $maxtrace;
1827 my $file = $sub[$i]{file};
1828 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1830 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1832 my $sub = @_ >= 4 ? $_[3] : $s;
1833 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1835 print $fh "$sub[$i]{context} = $s$args" .
1836 " called from $file" .
1837 " line $sub[$i]{line}\n";
1844 my $count = shift || 1e9;
1847 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1848 my $nothard = not $frame & 8;
1849 local $frame = 0; # Do not want to trace this.
1850 my $otrace = $trace;
1853 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1858 if (not defined $arg) {
1860 } elsif ($nothard and tied $arg) {
1862 } elsif ($nothard and $type = ref $arg) {
1863 push @a, "ref($type)";
1865 local $_ = "$arg"; # Safe to stringify now - should not call f().
1868 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1869 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1870 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1874 $context = $context ? '@' : (defined $context ? "\$" : '.');
1875 $args = $h ? [@a] : undef;
1876 $e =~ s/\n\s*\;\s*\Z// if $e;
1877 $e =~ s/([\\\'])/\\$1/g if $e;
1879 $sub = "require '$e'";
1880 } elsif (defined $r) {
1882 } elsif ($sub eq '(eval)') {
1883 $sub = "eval {...}";
1885 push(@sub, {context => $context, sub => $sub, args => $args,
1886 file => $file, line => $line});
1895 while ($action =~ s/\\$//) {
1904 # i hate using globals!
1905 $balanced_brace_re ||= qr{
1908 (?> [^{}] + ) # Non-parens without backtracking
1910 (??{ $balanced_brace_re }) # Group with matching parens
1914 return $_[0] !~ m/$balanced_brace_re/;
1918 &readline("cont: ");
1922 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1923 # some non-Unix systems can do system() but have problems with fork().
1924 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1925 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1926 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1927 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1929 # XXX: using csh or tcsh destroys sigint retvals!
1931 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1932 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1937 # most of the $? crud was coping with broken cshisms
1939 &warn("(Command exited ", ($? >> 8), ")\n");
1941 &warn( "(Command died of SIG#", ($? & 127),
1942 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1952 eval { require Term::ReadLine } or die $@;
1955 my ($i, $o) = split $tty, /,/;
1956 $o = $i unless defined $o;
1957 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1958 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1961 my $sel = select($OUT);
1965 eval "require Term::Rendezvous;" or die;
1966 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1967 my $term_rv = new Term::Rendezvous $rv;
1969 $OUT = $term_rv->OUT;
1972 if ($term_pid eq '-1') { # In a TTY with another debugger
1976 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1978 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1980 $rl_attribs = $term->Attribs;
1981 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1982 if defined $rl_attribs->{basic_word_break_characters}
1983 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1984 $rl_attribs->{special_prefixes} = '$@&%';
1985 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1986 $rl_attribs->{completion_function} = \&db_complete;
1988 $LINEINFO = $OUT unless defined $LINEINFO;
1989 $lineinfo = $console unless defined $lineinfo;
1991 if ($term->Features->{setHistory} and "@hist" ne "?") {
1992 $term->SetHistory(@hist);
1994 ornaments($ornaments) if defined $ornaments;
1998 # Example get_fork_TTY functions
1999 sub xterm_get_fork_TTY {
2000 (my $name = $0) =~ s,^.*[/\\],,s;
2001 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2005 $pidprompt = ''; # Shown anyway in titlebar
2009 # This one resets $IN, $OUT itself
2010 sub os2_get_fork_TTY {
2011 $^F = 40; # XXXX Fixme!
2012 my ($in1, $out1, $in2, $out2);
2013 # Having -d in PERL5OPT would lead to a disaster...
2014 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2015 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2016 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2017 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2018 (my $name = $0) =~ s,^.*[/\\],,s;
2019 if ( pipe $in1, $out1 and pipe $in2, $out2 and
2020 # system P_SESSION will fail if there is another process
2021 # in the same session with a "dependent" asynchronous child session.
2022 (($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
2026 my $in = shift; # Read from here and pass through
2028 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2029 open IN, '<&=$in' or die "open <&=$in: \$!";
2030 \$| = 1; print while sysread IN, \$_, 1<<16;
2034 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2036 ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
2037 print while sysread STDIN, $_, 1<<16;
2039 and close $in1 and close $out2 ) {
2040 $pidprompt = ''; # Shown anyway in titlebar
2041 reset_IN_OUT($in2, $out1);
2043 return ''; # Indicate that reset_IN_OUT is called
2048 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2049 my $in = &get_fork_TTY if defined &get_fork_TTY;
2050 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2051 if (not defined $in) {
2053 print_help(<<EOP) if $why == 1;
2054 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2056 print_help(<<EOP) if $why == 2;
2057 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2058 This may be an asynchronous session, so the parent debugger may be active.
2060 print_help(<<EOP) if $why != 4;
2061 Since two debuggers fight for the same TTY, input is severely entangled.
2065 I know how to switch the output to a different window in xterms
2066 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2067 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2069 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2070 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2073 } elsif ($in ne '') {
2079 sub resetterm { # We forked, so we need a different TTY
2081 my $systemed = $in > 1 ? '-' : '';
2083 $pids =~ s/\]/$systemed->$$]/;
2085 $pids = "[$term_pid->$$]";
2089 return unless $CreateTTY & $in;
2096 my $left = @typeahead;
2097 my $got = shift @typeahead;
2098 print $OUT "auto(-$left)", shift, $got, "\n";
2099 $term->AddHistory($got)
2100 if length($got) > 1 and defined $term->Features->{addHistory};
2105 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2106 $OUT->write(join('', @_));
2108 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2112 $term->readline(@_);
2117 my ($opt, $val)= @_;
2118 $val = option_val($opt,'N/A');
2119 $val =~ s/([\\\'])/\\$1/g;
2120 printf $OUT "%20s = '%s'\n", $opt, $val;
2124 my ($opt, $default)= @_;
2126 if (defined $optionVars{$opt}
2127 and defined ${$optionVars{$opt}}) {
2128 $val = ${$optionVars{$opt}};
2129 } elsif (defined $optionAction{$opt}
2130 and defined &{$optionAction{$opt}}) {
2131 $val = &{$optionAction{$opt}}();
2132 } elsif (defined $optionAction{$opt}
2133 and not defined $option{$opt}
2134 or defined $optionVars{$opt}
2135 and not defined ${$optionVars{$opt}}) {
2138 $val = $option{$opt};
2140 $val = $default unless defined $val;
2146 # too dangerous to let intuitive usage overwrite important things
2147 # defaultion should never be the default
2148 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2149 arrayDepth hashDepth LineInfo maxTraceLen ornaments
2150 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2155 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2156 my ($opt,$sep) = ($1,$2);
2159 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2161 #&dump_option($opt);
2162 } elsif ($sep !~ /\S/) {
2164 $val = "1"; # this is an evil default; make 'em set it!
2165 } elsif ($sep eq "=") {
2167 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2169 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2173 print OUT qq(Option better cleared using $opt=""\n)
2177 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2178 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2179 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2180 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2181 ($val = $1) =~ s/\\([\\$end])/$1/g;
2185 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2186 || grep( /^\Q$opt/i && ($option = $_), @options );
2188 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2189 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2191 if ($opt_needs_val{$option} && $val_defaulted) {
2192 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2196 $option{$option} = $val if defined $val;
2201 require '$optionRequire{$option}';
2203 } || die # XXX: shouldn't happen
2204 if defined $optionRequire{$option} &&
2207 ${$optionVars{$option}} = $val
2208 if defined $optionVars{$option} &&
2211 &{$optionAction{$option}} ($val)
2212 if defined $optionAction{$option} &&
2213 defined &{$optionAction{$option}} &&
2217 dump_option($option) unless $OUT eq \*STDERR;
2222 my ($stem,@list) = @_;
2224 $ENV{"${stem}_n"} = @list;
2225 for $i (0 .. $#list) {
2227 $val =~ s/\\/\\\\/g;
2228 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2229 $ENV{"${stem}_$i"} = $val;
2236 my $n = delete $ENV{"${stem}_n"};
2238 for $i (0 .. $n - 1) {
2239 $val = delete $ENV{"${stem}_$i"};
2240 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2248 return; # Put nothing on the stack - malloc/free land!
2252 my($msg)= join("",@_);
2253 $msg .= ": $!\n" unless $msg =~ /\n$/;
2258 my $switch_li = $LINEINFO eq $OUT;
2259 if ($term and $term->Features->{newTTY}) {
2260 ($IN, $OUT) = (shift, shift);
2261 $term->newTTY($IN, $OUT);
2263 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2265 ($IN, $OUT) = (shift, shift);
2267 my $o = select $OUT;
2270 $LINEINFO = $OUT if $switch_li;
2274 if (@_ and $term and $term->Features->{newTTY}) {
2275 my ($in, $out) = shift;
2277 ($in, $out) = split /,/, $in, 2;
2281 open IN, $in or die "cannot open `$in' for read: $!";
2282 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2283 reset_IN_OUT(\*IN,\*OUT);
2286 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2287 # Useful if done through PERLDB_OPTS:
2294 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2296 $notty = shift if @_;
2302 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2310 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2312 $remoteport = shift if @_;
2317 if (${$term->Features}{tkRunning}) {
2318 return $term->tkRunning(@_);
2320 print $OUT "tkRunning not supported by current ReadLine package.\n";
2327 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2329 $runnonstop = shift if @_;
2336 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2343 $sh = quotemeta shift;
2344 $sh .= "\\b" if $sh =~ /\w$/;
2348 $psh =~ s/\\(.)/$1/g;
2353 if (defined $term) {
2354 local ($warnLevel,$dieLevel) = (0, 1);
2355 return '' unless $term->Features->{ornaments};
2356 eval { $term->ornaments(@_) } || '';
2364 $rc = quotemeta shift;
2365 $rc .= "\\b" if $rc =~ /\w$/;
2369 $prc =~ s/\\(.)/$1/g;
2374 return $lineinfo unless @_;
2376 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2377 $slave_editor = ($stream =~ /^\|/);
2378 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2379 $LINEINFO = \*LINEINFO;
2380 my $save = select($LINEINFO);
2394 s/^Term::ReadLine::readline$/readline/;
2395 if (defined ${ $_ . '::VERSION' }) {
2396 $version{$file} = "${ $_ . '::VERSION' } from ";
2398 $version{$file} .= $INC{$file};
2400 dumpit($OUT,\%version);
2404 # XXX: make sure there are tabs between the command and explanation,
2405 # or print_help will screw up your formatting if you have
2406 # eeevil ornaments enabled. This is an insane mess.
2410 B<s> [I<expr>] Single step [in I<expr>].
2411 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2412 <B<CR>> Repeat last B<n> or B<s> command.
2413 B<r> Return from current subroutine.
2414 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2415 at the specified position.
2416 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2417 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2418 B<l> I<line> List single I<line>.
2419 B<l> I<subname> List first window of lines from subroutine.
2420 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2421 B<l> List next window of lines.
2422 B<-> List previous window of lines.
2423 B<w> [I<line>] List window around I<line>.
2424 B<.> Return to the executed line.
2425 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2426 I<filename> may be either the full name of the file, or a regular
2427 expression matching the full file name:
2428 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2429 Evals (with saved bodies) are considered to be filenames:
2430 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2431 (in the order of execution).
2432 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2433 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2434 B<L> List all breakpoints and actions.
2435 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2436 B<t> Toggle trace mode.
2437 B<t> I<expr> Trace through execution of I<expr>.
2438 B<b> [I<line>] [I<condition>]
2439 Set breakpoint; I<line> defaults to the current execution line;
2440 I<condition> breaks if it evaluates to true, defaults to '1'.
2441 B<b> I<subname> [I<condition>]
2442 Set breakpoint at first line of subroutine.
2443 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2444 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2445 B<b> B<postpone> I<subname> [I<condition>]
2446 Set breakpoint at first line of subroutine after
2448 B<b> B<compile> I<subname>
2449 Stop after the subroutine is compiled.
2450 B<d> [I<line>] Delete the breakpoint for I<line>.
2451 B<D> Delete all breakpoints.
2452 B<a> [I<line>] I<command>
2453 Set an action to be done before the I<line> is executed;
2454 I<line> defaults to the current execution line.
2455 Sequence is: check for breakpoint/watchpoint, print line
2456 if necessary, do action, prompt user if necessary,
2458 B<a> [I<line>] Delete the action for I<line>.
2459 B<A> Delete all actions.
2460 B<W> I<expr> Add a global watch-expression.
2461 B<W> Delete all watch-expressions.
2462 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2463 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2464 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2465 B<x> I<expr> Evals expression in list context, dumps the result.
2466 B<m> I<expr> Evals expression in list context, prints methods callable
2467 on the first element of the result.
2468 B<m> I<class> Prints methods callable via the given class.
2470 B<<> ? List Perl commands to run before each prompt.
2471 B<<> I<expr> Define Perl command to run before each prompt.
2472 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2473 B<>> ? List Perl commands to run after each prompt.
2474 B<>> I<expr> Define Perl command to run after each prompt.
2475 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2476 B<{> I<db_command> Define debugger command to run before each prompt.
2477 B<{> ? List debugger commands to run before each prompt.
2478 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2479 B<$prc> I<number> Redo a previous command (default previous command).
2480 B<$prc> I<-number> Redo number'th-to-last command.
2481 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2482 See 'B<O> I<recallCommand>' too.
2483 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2484 . ( $rc eq $sh ? "" : "
2485 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2486 See 'B<O> I<shellBang>' too.
2487 B<H> I<-number> Display last number commands (default all).
2488 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2489 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2490 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2491 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2492 I<command> Execute as a perl statement in current package.
2493 B<v> Show versions of loaded modules.
2494 B<R> Pure-man-restart of debugger, some of debugger state
2495 and command-line options may be lost.
2496 Currently the following settings are preserved:
2497 history, breakpoints and actions, debugger B<O>ptions
2498 and the following command-line options: I<-w>, I<-I>, I<-e>.
2500 B<O> [I<opt>] ... Set boolean option to true
2501 B<O> [I<opt>B<?>] Query options
2502 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2503 Set options. Use quotes in spaces in value.
2504 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2505 I<pager> program for output of \"|cmd\";
2506 I<tkRunning> run Tk while prompting (with ReadLine);
2507 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2508 I<inhibit_exit> Allows stepping off the end of the script.
2509 I<ImmediateStop> Debugger should stop as early as possible.
2510 I<RemotePort> Remote hostname:port for remote debugging
2511 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2512 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2513 I<compactDump>, I<veryCompact> change style of array and hash dump;
2514 I<globPrint> whether to print contents of globs;
2515 I<DumpDBFiles> dump arrays holding debugged files;
2516 I<DumpPackages> dump symbol tables of packages;
2517 I<DumpReused> dump contents of \"reused\" addresses;
2518 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2519 I<bareStringify> Do not print the overload-stringified value;
2520 Other options include:
2521 I<PrintRet> affects printing of return value after B<r> command,
2522 I<frame> affects printing messages on subroutine entry/exit.
2523 I<AutoTrace> affects printing messages on possible breaking points.
2524 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2525 I<ornaments> affects screen appearance of the command line.
2526 I<CreateTTY> bits control attempts to create a new TTY on events:
2527 1: on fork() 2: debugger is started inside debugger
2529 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2530 You can put additional initialization options I<TTY>, I<noTTY>,
2531 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2532 `B<R>' after you set them).
2534 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2535 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2536 B<h h> Summary of debugger commands.
2537 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2538 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2539 Set B<\$DB::doccmd> to change viewer.
2541 Type `|h' for a paged display if this was too hard to read.
2543 "; # Fix balance of vi % matching: }}}}
2545 # note: tabs in the following section are not-so-helpful
2546 $summary = <<"END_SUM";
2547 I<List/search source lines:> I<Control script execution:>
2548 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2549 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2550 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2551 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2552 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2553 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2554 I<Debugger controls:> B<L> List break/watch/actions
2555 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2556 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2557 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2558 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2559 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2560 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2561 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2562 B<q> or B<^D> Quit B<R> Attempt a restart
2563 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2564 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2565 B<p> I<expr> Print expression (uses script's current package).
2566 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2567 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2568 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2569 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2571 # ')}}; # Fix balance of vi % matching
2577 # Restore proper alignment destroyed by eeevil I<> and B<>
2578 # ornaments: A pox on both their houses!
2580 # A help command will have everything up to and including
2581 # the first tab sequence padded into a field 16 (or if indented 20)
2582 # wide. If it's wider than that, an extra space will be added.
2584 ^ # only matters at start of line
2585 ( \040{4} | \t )* # some subcommands are indented
2586 ( < ? # so <CR> works
2587 [BI] < [^\t\n] + ) # find an eeevil ornament
2588 ( \t+ ) # original separation, discarded
2589 ( .* ) # this will now start (no earlier) than
2592 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2593 my $clean = $command;
2594 $clean =~ s/[BI]<([^>]*)>/$1/g;
2595 # replace with this whole string:
2596 ($leadwhite ? " " x 4 : "")
2598 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2603 s{ # handle bold ornaments
2604 B < ( [^>] + | > ) >
2606 $Term::ReadLine::TermCap::rl_term_set[2]
2608 . $Term::ReadLine::TermCap::rl_term_set[3]
2611 s{ # handle italic ornaments
2612 I < ( [^>] + | > ) >
2614 $Term::ReadLine::TermCap::rl_term_set[0]
2616 . $Term::ReadLine::TermCap::rl_term_set[1]
2623 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2624 my $is_less = $pager =~ /\bless\b/;
2625 if ($pager =~ /\bmore\b/) {
2626 my @st_more = stat('/usr/bin/more');
2627 my @st_less = stat('/usr/bin/less');
2628 $is_less = @st_more && @st_less
2629 && $st_more[0] == $st_less[0]
2630 && $st_more[1] == $st_less[1];
2632 # changes environment!
2633 $ENV{LESS} .= 'r' if $is_less;
2639 $SIG{'ABRT'} = 'DEFAULT';
2640 kill 'ABRT', $$ if $panic++;
2641 if (defined &Carp::longmess) {
2642 local $SIG{__WARN__} = '';
2643 local $Carp::CarpLevel = 2; # mydie + confess
2644 &warn(Carp::longmess("Signal @_"));
2647 print $DB::OUT "Got signal @_\n";
2655 local $SIG{__WARN__} = '';
2656 local $SIG{__DIE__} = '';
2657 eval { require Carp } if defined $^S; # If error/warning during compilation,
2658 # require may be broken.
2659 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2660 return unless defined &Carp::longmess;
2661 my ($mysingle,$mytrace) = ($single,$trace);
2662 $single = 0; $trace = 0;
2663 my $mess = Carp::longmess(@_);
2664 ($single,$trace) = ($mysingle,$mytrace);
2671 local $SIG{__DIE__} = '';
2672 local $SIG{__WARN__} = '';
2673 my $i = 0; my $ineval = 0; my $sub;
2674 if ($dieLevel > 2) {
2675 local $SIG{__WARN__} = \&dbwarn;
2676 &warn(@_); # Yell no matter what
2679 if ($dieLevel < 2) {
2680 die @_ if $^S; # in eval propagate
2682 eval { require Carp } if defined $^S; # If error/warning during compilation,
2683 # require may be broken.
2685 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2686 unless defined &Carp::longmess;
2688 # We do not want to debug this chunk (automatic disabling works
2689 # inside DB::DB, but not in Carp).
2690 my ($mysingle,$mytrace) = ($single,$trace);
2691 $single = 0; $trace = 0;
2692 my $mess = Carp::longmess(@_);
2693 ($single,$trace) = ($mysingle,$mytrace);
2699 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2702 $SIG{__WARN__} = \&DB::dbwarn;
2703 } elsif ($prevwarn) {
2704 $SIG{__WARN__} = $prevwarn;
2712 $prevdie = $SIG{__DIE__} unless $dieLevel;
2715 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2716 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2717 print $OUT "Stack dump during die enabled",
2718 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2720 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2721 } elsif ($prevdie) {
2722 $SIG{__DIE__} = $prevdie;
2723 print $OUT "Default die handler restored.\n";
2731 $prevsegv = $SIG{SEGV} unless $signalLevel;
2732 $prevbus = $SIG{BUS} unless $signalLevel;
2733 $signalLevel = shift;
2735 $SIG{SEGV} = \&DB::diesignal;
2736 $SIG{BUS} = \&DB::diesignal;
2738 $SIG{SEGV} = $prevsegv;
2739 $SIG{BUS} = $prevbus;
2747 my $name = CvGV_name_or_bust($in);
2748 defined $name ? $name : $in;
2751 sub CvGV_name_or_bust {
2753 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2754 return unless ref $in;
2755 $in = \&$in; # Hard reference...
2756 eval {require Devel::Peek; 1} or return;
2757 my $gv = Devel::Peek::CvGV($in) or return;
2758 *$gv{PACKAGE} . '::' . *$gv{NAME};
2764 return unless defined &$subr;
2765 my $name = CvGV_name_or_bust($subr);
2767 $data = $sub{$name} if defined $name;
2768 return $data if defined $data;
2771 $subr = \&$subr; # Hard reference
2774 $s = $_, last if $subr eq \&$_;
2782 $class = ref $class if ref $class;
2785 methods_via($class, '', 1);
2786 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2791 return if $packs{$class}++;
2793 my $prepend = $prefix ? "via $prefix: " : '';
2795 for $name (grep {defined &{${"${class}::"}{$_}}}
2796 sort keys %{"${class}::"}) {
2797 next if $seen{ $name }++;
2798 print $DB::OUT "$prepend$name\n";
2800 return unless shift; # Recurse?
2801 for $name (@{"${class}::ISA"}) {
2802 $prepend = $prefix ? $prefix . " -> $name" : $name;
2803 methods_via($name, $prepend, 1);
2808 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2809 ? "man" # O Happy Day!
2810 : "perldoc"; # Alas, poor unfortunates
2816 &system("$doccmd $doccmd");
2819 # this way user can override, like with $doccmd="man -Mwhatever"
2820 # or even just "man " to disable the path check.
2821 unless ($doccmd eq 'man') {
2822 &system("$doccmd $page");
2826 $page = 'perl' if lc($page) eq 'help';
2829 my $man1dir = $Config::Config{'man1dir'};
2830 my $man3dir = $Config::Config{'man3dir'};
2831 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2833 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2834 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2835 chop $manpath if $manpath;
2836 # harmless if missing, I figure
2837 my $oldpath = $ENV{MANPATH};
2838 $ENV{MANPATH} = $manpath if $manpath;
2839 my $nopathopt = $^O =~ /dunno what goes here/;
2840 if (CORE::system($doccmd,
2841 # I just *know* there are men without -M
2842 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2845 unless ($page =~ /^perl\w/) {
2846 if (grep { $page eq $_ } qw{
2847 5004delta 5005delta amiga api apio book boot bot call compile
2848 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2849 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2850 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2851 modinstall modlib number obj op opentut os2 os390 pod port
2852 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2853 trap unicode var vms win32 xs xstut
2857 CORE::system($doccmd,
2858 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2863 if (defined $oldpath) {
2864 $ENV{MANPATH} = $manpath;
2866 delete $ENV{MANPATH};
2870 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2872 BEGIN { # This does not compile, alas.
2873 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2874 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2878 $deep = 100; # warning if stack gets this deep
2882 $SIG{INT} = \&DB::catch;
2883 # This may be enabled to debug debugger:
2884 #$warnLevel = 1 unless defined $warnLevel;
2885 #$dieLevel = 1 unless defined $dieLevel;
2886 #$signalLevel = 1 unless defined $signalLevel;
2888 $db_stop = 0; # Compiler warning
2890 $level = 0; # Level of recursive debugging
2891 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2892 # Triggers bug (?) in perl is we postpone this until runtime:
2893 @postponed = @stack = (0);
2894 $stack_depth = 0; # Localized $#stack
2899 BEGIN {$^W = $ini_warn;} # Switch warnings back
2901 #use Carp; # This did break, left for debugging
2904 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2905 my($text, $line, $start) = @_;
2906 my ($itext, $search, $prefix, $pack) =
2907 ($text, "^\Q${'package'}::\E([^:]+)\$");
2909 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2910 (map { /$search/ ? ($1) : () } keys %sub)
2911 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2912 return sort grep /^\Q$text/, values %INC # files
2913 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2914 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2915 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2916 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2917 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2919 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2921 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2922 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2923 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2924 # We may want to complete to (eval 9), so $text may be wrong
2925 $prefix = length($1) - length($text);
2928 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2930 if ((substr $text, 0, 1) eq '&') { # subroutines
2931 $text = substr $text, 1;
2933 return sort map "$prefix$_",
2936 (map { /$search/ ? ($1) : () }
2939 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2940 $pack = ($1 eq 'main' ? '' : $1) . '::';
2941 $prefix = (substr $text, 0, 1) . $1 . '::';
2944 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2945 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2946 return db_complete($out[0], $line, $start);
2950 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2951 $pack = ($package eq 'main' ? '' : $package) . '::';
2952 $prefix = substr $text, 0, 1;
2953 $text = substr $text, 1;
2954 my @out = map "$prefix$_", grep /^\Q$text/,
2955 (grep /^_?[a-zA-Z]/, keys %$pack),
2956 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2957 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2958 return db_complete($out[0], $line, $start);
2962 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2963 my @out = grep /^\Q$text/, @options;
2964 my $val = option_val($out[0], undef);
2966 if (not defined $val or $val =~ /[\n\r]/) {
2967 # Can do nothing better
2968 } elsif ($val =~ /\s/) {
2970 foreach $l (split //, qq/\"\'\#\|/) {
2971 $out = "$l$val$l ", last if (index $val, $l) == -1;
2976 # Default to value if one completion, to question if many
2977 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2980 return $term->filename_list($text); # filenames
2984 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2988 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
2989 $fall_off_end = 1 unless $inhibit_exit;
2990 # Do not stop in at_exit() and destructors on exit:
2991 $DB::single = !$fall_off_end && !$runnonstop;
2992 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
2998 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3001 package DB; # Do not trace this 1; below!