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})) {
506 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
514 $console = $tty if defined $tty;
516 if (defined $remoteport) {
518 $OUT = new IO::Socket::INET( Timeout => '10',
519 PeerAddr => $remoteport,
522 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
524 } elsif ($CreateTTY & 4) {
527 if (defined $console) {
528 my ($i, $o) = split /,/, $console;
529 $o = $i unless defined $o;
530 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
531 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
532 || open(OUT,">&STDOUT"); # so we don't dongle stdout
535 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
536 $console = 'STDIN/OUT';
538 # so open("|more") can read from STDOUT and so we don't dingle stdin
543 my $previous = select($OUT);
544 $| = 1; # for DB::OUT
547 $LINEINFO = $OUT unless defined $LINEINFO;
548 $lineinfo = $console unless defined $lineinfo;
550 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
551 unless ($runnonstop) {
552 if ($term_pid eq '-1') {
553 print $OUT "\nDaughter DB session started...\n";
555 print $OUT "\nLoading DB routines from $header\n";
556 print $OUT ("Editor support ",
557 $slave_editor ? "enabled" : "available",
559 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
567 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
570 if (defined &afterinit) { # May be defined in $rcfile
576 ############################################################ Subroutines
579 # _After_ the perl program is compiled, $single is set to 1:
580 if ($single and not $second_time++) {
581 if ($runnonstop) { # Disable until signal
582 for ($i=0; $i <= $stack_depth; ) {
586 # return; # Would not print trace!
587 } elsif ($ImmediateStop) {
592 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
594 ($package, $filename, $line) = caller;
595 $filename_ini = $filename;
596 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
597 "package $package;"; # this won't let them modify, alas
598 local(*dbline) = $main::{'_<' . $filename};
600 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
604 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
605 $dbline{$line} =~ s/;9($|\0)/$1/;
608 my $was_signal = $signal;
610 for (my $n = 0; $n <= $#to_watch; $n++) {
611 $evalarg = $to_watch[$n];
612 local $onetimeDump; # Do not output results
613 my ($val) = &eval; # Fix context (&eval is doing array)?
614 $val = ( (defined $val) ? "'$val'" : 'undef' );
615 if ($val ne $old_watch[$n]) {
618 Watchpoint $n:\t$to_watch[$n] changed:
619 old value:\t$old_watch[$n]
622 $old_watch[$n] = $val;
626 if ($trace & 4) { # User-installed watch
627 return if watchfunction($package, $filename, $line)
628 and not $single and not $was_signal and not ($trace & ~4);
630 $was_signal = $signal;
632 if ($single || ($trace & 1) || $was_signal) {
634 $position = "\032\032$filename:$line:0\n";
635 print_lineinfo($position);
636 } elsif ($package eq 'DB::fake') {
639 Debugged program terminated. Use B<q> to quit or B<R> to restart,
640 use B<O> I<inhibit_exit> to avoid stopping after program termination,
641 B<h q>, B<h R> or B<h O> to get additional info.
644 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
645 "package $package;"; # this won't let them modify, alas
648 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
649 $prefix .= "$sub($filename:";
650 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
651 if (length($prefix) > 30) {
652 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
657 $position = "$prefix$line$infix$dbline[$line]$after";
660 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
662 print_lineinfo($position);
664 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
665 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
667 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
668 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
669 $position .= $incr_pos;
671 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
673 print_lineinfo($incr_pos);
678 $evalarg = $action, &eval if $action;
679 if ($single || $was_signal) {
680 local $level = $level + 1;
681 foreach $evalarg (@$pre) {
684 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
687 $incr = -1; # for backward motion.
688 @typeahead = (@$pretype, @typeahead);
690 while (($term || &setterm),
691 ($term_pid == $$ or resetterm(1)),
692 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
693 ($#hist+1) . ('>' x $level) .
698 $cmd =~ s/\\$/\n/ && do {
699 $cmd .= &readline(" cont: ");
702 $cmd =~ /^$/ && ($cmd = $laststep);
703 push(@hist,$cmd) if length($cmd) > 1;
705 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
706 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
707 ($i) = split(/\s+/,$cmd);
709 # squelch the sigmangler
711 local $SIG{__WARN__};
712 eval "\$cmd =~ $alias{$i}";
714 print $OUT "Couldn't evaluate `$i' alias: $@";
718 $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
719 $cmd =~ /^h$/ && do {
722 $cmd =~ /^h\s+h$/ && do {
723 print_help($summary);
725 # support long commands; otherwise bogus errors
726 # happen when you ask for h on <CR> for example
727 $cmd =~ /^h\s+(\S.*)$/ && do {
728 my $asked = $1; # for proper errmsg
729 my $qasked = quotemeta($asked); # for searching
730 # XXX: finds CR but not <CR>
731 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
732 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
736 print_help("B<$asked> is not a debugger command.\n");
739 $cmd =~ /^t$/ && do {
741 print $OUT "Trace = " .
742 (($trace & 1) ? "on" : "off" ) . "\n";
744 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
745 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
746 foreach $subname (sort(keys %sub)) {
747 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
748 print $OUT $subname,"\n";
752 $cmd =~ /^v$/ && do {
753 list_versions(); next CMD};
754 $cmd =~ s/^X\b/V $package/;
755 $cmd =~ /^V$/ && do {
756 $cmd = "V $package"; };
757 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
758 local ($savout) = select($OUT);
760 @vars = split(' ',$2);
761 do 'dumpvar.pl' unless defined &main::dumpvar;
762 if (defined &main::dumpvar) {
765 # must detect sigpipe failures
766 eval { &main::dumpvar($packname,@vars) };
768 die unless $@ =~ /dumpvar print failed/;
771 print $OUT "dumpvar.pl not available.\n";
775 $cmd =~ s/^x\b/ / && do { # So that will be evaled
776 $onetimeDump = 'dump'; };
777 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
778 methods($1); next CMD};
779 $cmd =~ s/^m\b/ / && do { # So this will be evaled
780 $onetimeDump = 'methods'; };
781 $cmd =~ /^f\b\s*(.*)/ && do {
785 print $OUT "The old f command is now the r command.\n";
786 print $OUT "The new f command switches filenames.\n";
789 if (!defined $main::{'_<' . $file}) {
790 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
791 $try = substr($try,2);
792 print $OUT "Choosing $try matching `$file':\n";
796 if (!defined $main::{'_<' . $file}) {
797 print $OUT "No file matching `$file' is loaded.\n";
799 } elsif ($file ne $filename) {
800 *dbline = $main::{'_<' . $file};
806 print $OUT "Already in $file.\n";
810 $cmd =~ s/^l\s+-\s*$/-/;
811 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
814 print($OUT "Error: $@\n"), next CMD if $@;
816 print($OUT "Interpreted as: $1 $s\n");
819 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
820 my $s = $subname = $1;
821 $subname =~ s/\'/::/;
822 $subname = $package."::".$subname
823 unless $subname =~ /::/;
824 $subname = "CORE::GLOBAL::$s"
825 if not defined &$subname and $s !~ /::/
826 and defined &{"CORE::GLOBAL::$s"};
827 $subname = "main".$subname if substr($subname,0,2) eq "::";
828 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
829 $subrange = pop @pieces;
830 $file = join(':', @pieces);
831 if ($file ne $filename) {
832 print $OUT "Switching to file '$file'.\n"
833 unless $slave_editor;
834 *dbline = $main::{'_<' . $file};
839 if (eval($subrange) < -$window) {
840 $subrange =~ s/-.*/+/;
842 $cmd = "l $subrange";
844 print $OUT "Subroutine $subname not found.\n";
847 $cmd =~ /^\.$/ && do {
848 $incr = -1; # for backward motion.
850 $filename = $filename_ini;
851 *dbline = $main::{'_<' . $filename};
853 print_lineinfo($position);
855 $cmd =~ /^w\b\s*(\d*)$/ && do {
859 #print $OUT 'l ' . $start . '-' . ($start + $incr);
860 $cmd = 'l ' . $start . '-' . ($start + $incr); };
861 $cmd =~ /^-$/ && do {
862 $start -= $incr + $window + 1;
863 $start = 1 if $start <= 0;
865 $cmd = 'l ' . ($start) . '+'; };
866 $cmd =~ /^l$/ && do {
868 $cmd = 'l ' . $start . '-' . ($start + $incr); };
869 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
872 $incr = $window - 1 unless $incr;
873 $cmd = 'l ' . $start . '-' . ($start + $incr); };
874 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
875 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
876 $end = $max if $end > $max;
878 $i = $line if $i eq '.';
882 print $OUT "\032\032$filename:$i:0\n";
885 for (; $i <= $end; $i++) {
886 ($stop,$action) = split(/\0/, $dbline{$i}) if
889 and $filename eq $filename_ini)
891 : ($dbline[$i]+0 ? ':' : ' ') ;
892 $arrow .= 'b' if $stop;
893 $arrow .= 'a' if $action;
894 print $OUT "$i$arrow\t", $dbline[$i];
895 $i++, last if $signal;
897 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
899 $start = $i; # remember in case they want more
900 $start = $max if $start > $max;
902 $cmd =~ /^D$/ && do {
903 print $OUT "Deleting all breakpoints...\n";
905 for $file (keys %had_breakpoints) {
906 local *dbline = $main::{'_<' . $file};
910 for ($i = 1; $i <= $max ; $i++) {
911 if (defined $dbline{$i}) {
912 $dbline{$i} =~ s/^[^\0]+//;
913 if ($dbline{$i} =~ s/^\0?$//) {
919 if (not $had_breakpoints{$file} &= ~1) {
920 delete $had_breakpoints{$file};
924 undef %postponed_file;
925 undef %break_on_load;
927 $cmd =~ /^L$/ && do {
929 for $file (keys %had_breakpoints) {
930 local *dbline = $main::{'_<' . $file};
934 for ($i = 1; $i <= $max; $i++) {
935 if (defined $dbline{$i}) {
936 print $OUT "$file:\n" unless $was++;
937 print $OUT " $i:\t", $dbline[$i];
938 ($stop,$action) = split(/\0/, $dbline{$i});
939 print $OUT " break if (", $stop, ")\n"
941 print $OUT " action: ", $action, "\n"
948 print $OUT "Postponed breakpoints in subroutines:\n";
950 for $subname (keys %postponed) {
951 print $OUT " $subname\t$postponed{$subname}\n";
955 my @have = map { # Combined keys
956 keys %{$postponed_file{$_}}
957 } keys %postponed_file;
959 print $OUT "Postponed breakpoints in files:\n";
961 for $file (keys %postponed_file) {
962 my $db = $postponed_file{$file};
963 print $OUT " $file:\n";
964 for $line (sort {$a <=> $b} keys %$db) {
965 print $OUT " $line:\n";
966 my ($stop,$action) = split(/\0/, $$db{$line});
967 print $OUT " break if (", $stop, ")\n"
969 print $OUT " action: ", $action, "\n"
976 if (%break_on_load) {
977 print $OUT "Breakpoints on load:\n";
979 for $file (keys %break_on_load) {
980 print $OUT " $file\n";
985 print $OUT "Watch-expressions:\n";
987 for $expr (@to_watch) {
988 print $OUT " $expr\n";
993 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
994 my $file = $1; $file =~ s/\s+$//;
997 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
998 my $cond = length $3 ? $3 : '1';
999 my ($subname, $break) = ($2, $1 eq 'postpone');
1000 $subname =~ s/\'/::/g;
1001 $subname = "${'package'}::" . $subname
1002 unless $subname =~ /::/;
1003 $subname = "main".$subname if substr($subname,0,2) eq "::";
1004 $postponed{$subname} = $break
1005 ? "break +0 if $cond" : "compile";
1007 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1009 $cond = length $2 ? $2 : '1';
1010 cmd_b_sub($subname, $cond);
1012 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1014 $cond = length $2 ? $2 : '1';
1015 cmd_b_line($i, $cond);
1017 $cmd =~ /^d\b\s*(\d*)/ && do {
1020 $cmd =~ /^A$/ && do {
1021 print $OUT "Deleting all actions...\n";
1023 for $file (keys %had_breakpoints) {
1024 local *dbline = $main::{'_<' . $file};
1028 for ($i = 1; $i <= $max ; $i++) {
1029 if (defined $dbline{$i}) {
1030 $dbline{$i} =~ s/\0[^\0]*//;
1031 delete $dbline{$i} if $dbline{$i} eq '';
1035 unless ($had_breakpoints{$file} &= ~2) {
1036 delete $had_breakpoints{$file};
1040 $cmd =~ /^O\s*$/ && do {
1045 $cmd =~ /^O\s*(\S.*)/ && do {
1048 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1049 push @$pre, action($1);
1051 $cmd =~ /^>>\s*(.*)/ && do {
1052 push @$post, action($1);
1054 $cmd =~ /^<\s*(.*)/ && do {
1056 print $OUT "All < actions cleared.\n";
1062 print $OUT "No pre-prompt Perl actions.\n";
1065 print $OUT "Perl commands run before each prompt:\n";
1066 for my $action ( @$pre ) {
1067 print $OUT "\t< -- $action\n";
1071 $pre = [action($1)];
1073 $cmd =~ /^>\s*(.*)/ && do {
1075 print $OUT "All > actions cleared.\n";
1081 print $OUT "No post-prompt Perl actions.\n";
1084 print $OUT "Perl commands run after each prompt:\n";
1085 for my $action ( @$post ) {
1086 print $OUT "\t> -- $action\n";
1090 $post = [action($1)];
1092 $cmd =~ /^\{\{\s*(.*)/ && do {
1093 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1094 print $OUT "{{ is now a debugger command\n",
1095 "use `;{{' if you mean Perl code\n";
1101 $cmd =~ /^\{\s*(.*)/ && do {
1103 print $OUT "All { actions cleared.\n";
1108 unless (@$pretype) {
1109 print $OUT "No pre-prompt debugger actions.\n";
1112 print $OUT "Debugger commands run before each prompt:\n";
1113 for my $action ( @$pretype ) {
1114 print $OUT "\t{ -- $action\n";
1118 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1119 print $OUT "{ is now a debugger command\n",
1120 "use `;{' if you mean Perl code\n";
1126 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1127 $i = $1 || $line; $j = $2;
1129 if ($dbline[$i] == 0) {
1130 print $OUT "Line $i may not have an action.\n";
1132 $had_breakpoints{$filename} |= 2;
1133 $dbline{$i} =~ s/\0[^\0]*//;
1134 $dbline{$i} .= "\0" . action($j);
1137 $dbline{$i} =~ s/\0[^\0]*//;
1138 delete $dbline{$i} if $dbline{$i} eq '';
1141 $cmd =~ /^n$/ && do {
1142 end_report(), next CMD if $finished and $level <= 1;
1146 $cmd =~ /^s$/ && do {
1147 end_report(), next CMD if $finished and $level <= 1;
1151 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1152 end_report(), next CMD if $finished and $level <= 1;
1154 # Probably not needed, since we finish an interactive
1155 # sub-session anyway...
1156 # local $filename = $filename;
1157 # local *dbline = *dbline; # XXX Would this work?!
1158 if ($i =~ /\D/) { # subroutine name
1159 $subname = $package."::".$subname
1160 unless $subname =~ /::/;
1161 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1165 *dbline = $main::{'_<' . $filename};
1166 $had_breakpoints{$filename} |= 1;
1168 ++$i while $dbline[$i] == 0 && $i < $max;
1170 print $OUT "Subroutine $subname not found.\n";
1175 if ($dbline[$i] == 0) {
1176 print $OUT "Line $i not breakable.\n";
1179 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1181 for ($i=0; $i <= $stack_depth; ) {
1185 $cmd =~ /^r$/ && do {
1186 end_report(), next CMD if $finished and $level <= 1;
1187 $stack[$stack_depth] |= 1;
1188 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1190 $cmd =~ /^R$/ && do {
1191 print $OUT "Warning: some settings and command-line options may be lost!\n";
1192 my (@script, @flags, $cl);
1193 push @flags, '-w' if $ini_warn;
1194 # Put all the old includes at the start to get
1195 # the same debugger.
1197 push @flags, '-I', $_;
1199 # Arrange for setting the old INC:
1200 set_list("PERLDB_INC", @ini_INC);
1202 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1203 chomp ($cl = ${'::_<-e'}[$_]);
1204 push @script, '-e', $cl;
1209 set_list("PERLDB_HIST",
1210 $term->Features->{getHistory}
1211 ? $term->GetHistory : @hist);
1212 my @had_breakpoints = keys %had_breakpoints;
1213 set_list("PERLDB_VISITED", @had_breakpoints);
1214 set_list("PERLDB_OPT", %option);
1215 set_list("PERLDB_ON_LOAD", %break_on_load);
1217 for (0 .. $#had_breakpoints) {
1218 my $file = $had_breakpoints[$_];
1219 *dbline = $main::{'_<' . $file};
1220 next unless %dbline or $postponed_file{$file};
1221 (push @hard, $file), next
1222 if $file =~ /^\(eval \d+\)$/;
1224 @add = %{$postponed_file{$file}}
1225 if $postponed_file{$file};
1226 set_list("PERLDB_FILE_$_", %dbline, @add);
1228 for (@hard) { # Yes, really-really...
1229 # Find the subroutines in this eval
1230 *dbline = $main::{'_<' . $_};
1231 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1232 for $sub (keys %sub) {
1233 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1234 $subs{$sub} = [$1, $2];
1238 "No subroutines in $_, ignoring breakpoints.\n";
1241 LINES: for $line (keys %dbline) {
1242 # One breakpoint per sub only:
1243 my ($offset, $sub, $found);
1244 SUBS: for $sub (keys %subs) {
1245 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1246 and (not defined $offset # Not caught
1247 or $offset < 0 )) { # or badly caught
1249 $offset = $line - $subs{$sub}->[0];
1250 $offset = "+$offset", last SUBS if $offset >= 0;
1253 if (defined $offset) {
1254 $postponed{$found} =
1255 "break $offset if $dbline{$line}";
1257 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1261 set_list("PERLDB_POSTPONE", %postponed);
1262 set_list("PERLDB_PRETYPE", @$pretype);
1263 set_list("PERLDB_PRE", @$pre);
1264 set_list("PERLDB_POST", @$post);
1265 set_list("PERLDB_TYPEAHEAD", @typeahead);
1266 $ENV{PERLDB_RESTART} = 1;
1267 delete $ENV{PERLDB_PIDS}; # Restore ini state
1268 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1269 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1270 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1271 print $OUT "exec failed: $!\n";
1273 $cmd =~ /^T$/ && do {
1274 print_trace($OUT, 1); # skip DB
1276 $cmd =~ /^W\s*$/ && do {
1278 @to_watch = @old_watch = ();
1280 $cmd =~ /^W\b\s*(.*)/s && do {
1284 $val = (defined $val) ? "'$val'" : 'undef' ;
1285 push @old_watch, $val;
1288 $cmd =~ /^\/(.*)$/ && do {
1290 $inpat =~ s:([^\\])/$:$1:;
1292 # squelch the sigmangler
1293 local $SIG{__DIE__};
1294 local $SIG{__WARN__};
1295 eval '$inpat =~ m'."\a$inpat\a";
1307 $start = 1 if ($start > $max);
1308 last if ($start == $end);
1309 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1310 if ($slave_editor) {
1311 print $OUT "\032\032$filename:$start:0\n";
1313 print $OUT "$start:\t", $dbline[$start], "\n";
1318 print $OUT "/$pat/: not found\n" if ($start == $end);
1320 $cmd =~ /^\?(.*)$/ && do {
1322 $inpat =~ s:([^\\])\?$:$1:;
1324 # squelch the sigmangler
1325 local $SIG{__DIE__};
1326 local $SIG{__WARN__};
1327 eval '$inpat =~ m'."\a$inpat\a";
1339 $start = $max if ($start <= 0);
1340 last if ($start == $end);
1341 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1342 if ($slave_editor) {
1343 print $OUT "\032\032$filename:$start:0\n";
1345 print $OUT "$start:\t", $dbline[$start], "\n";
1350 print $OUT "?$pat?: not found\n" if ($start == $end);
1352 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1353 pop(@hist) if length($cmd) > 1;
1354 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1356 print $OUT $cmd, "\n";
1358 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1361 $cmd =~ /^$rc([^$rc].*)$/ && do {
1363 pop(@hist) if length($cmd) > 1;
1364 for ($i = $#hist; $i; --$i) {
1365 last if $hist[$i] =~ /$pat/;
1368 print $OUT "No such command!\n\n";
1372 print $OUT $cmd, "\n";
1374 $cmd =~ /^$sh$/ && do {
1375 &system($ENV{SHELL}||"/bin/sh");
1377 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1378 # XXX: using csh or tcsh destroys sigint retvals!
1379 #&system($1); # use this instead
1380 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1382 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1383 $end = $2 ? ($#hist-$2) : 0;
1384 $hist = 0 if $hist < 0;
1385 for ($i=$#hist; $i>$end; $i--) {
1386 print $OUT "$i: ",$hist[$i],"\n"
1387 unless $hist[$i] =~ /^.?$/;
1390 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1393 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1394 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1395 $cmd =~ s/^=\s*// && do {
1397 if (length $cmd == 0) {
1398 @keys = sort keys %alias;
1400 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1401 # can't use $_ or kill //g state
1402 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1403 $alias{$k} = "s\a$k\a$v\a";
1404 # squelch the sigmangler
1405 local $SIG{__DIE__};
1406 local $SIG{__WARN__};
1407 unless (eval "sub { s\a$k\a$v\a }; 1") {
1408 print $OUT "Can't alias $k to $v: $@\n";
1418 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1419 print $OUT "$k\t= $1\n";
1421 elsif (defined $alias{$k}) {
1422 print $OUT "$k\t$alias{$k}\n";
1425 print "No alias for $k\n";
1429 $cmd =~ /^\|\|?\s*[^|]/ && do {
1430 if ($pager =~ /^\|/) {
1431 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1432 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1434 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1437 unless ($piped=open(OUT,$pager)) {
1438 &warn("Can't pipe output to `$pager'");
1439 if ($pager =~ /^\|/) {
1440 open(OUT,">&STDOUT") # XXX: lost message
1441 || &warn("Can't restore DB::OUT");
1442 open(STDOUT,">&SAVEOUT")
1443 || &warn("Can't restore STDOUT");
1446 open(OUT,">&STDOUT") # XXX: lost message
1447 || &warn("Can't restore DB::OUT");
1451 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1452 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1453 $selected= select(OUT);
1455 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1456 $cmd =~ s/^\|+\s*//;
1459 # XXX Local variants do not work!
1460 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1461 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1462 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1464 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1466 $onetimeDump = undef;
1467 } elsif ($term_pid == $$) {
1472 if ($pager =~ /^\|/) {
1474 # we cannot warn here: the handle is missing --tchrist
1475 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1477 # most of the $? crud was coping with broken cshisms
1479 print SAVEOUT "Pager `$pager' failed: ";
1481 print SAVEOUT "shell returned -1\n";
1484 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1485 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1487 print SAVEOUT "status ", ($? >> 8), "\n";
1491 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1492 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1493 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1494 # Will stop ignoring SIGPIPE if done like nohup(1)
1495 # does SIGINT but Perl doesn't give us a choice.
1497 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1500 select($selected), $selected= "" unless $selected eq "";
1504 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1505 foreach $evalarg (@$post) {
1508 } # if ($single || $signal)
1509 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1513 # The following code may be executed now:
1517 my ($al, $ret, @ret) = "";
1518 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1521 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1522 $#stack = $stack_depth;
1523 $stack[-1] = $single;
1525 $single |= 4 if $stack_depth == $deep;
1527 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1528 # Why -1? But it works! :-(
1529 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1530 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1533 $single |= $stack[$stack_depth--];
1535 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1536 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1537 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1538 if ($doret eq $stack_depth or $frame & 16) {
1539 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1540 print $fh ' ' x $stack_depth if $frame & 16;
1541 print $fh "list context return from $sub:\n";
1542 dumpit($fh, \@ret );
1547 if (defined wantarray) {
1552 $single |= $stack[$stack_depth--];
1554 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1555 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1556 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1557 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1558 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1559 print $fh (' ' x $stack_depth) if $frame & 16;
1560 print $fh (defined wantarray
1561 ? "scalar context return from $sub: "
1562 : "void context return from $sub\n");
1563 dumpit( $fh, $ret ) if defined wantarray;
1572 ### Functions with multiple modes of failure die on error, the rest
1573 ### returns FALSE on error.
1574 ### User-interface functions cmd_* output error message.
1578 $break_on_load{$file} = 1;
1579 $had_breakpoints{$file} |= 1;
1582 sub report_break_on_load {
1583 sort keys %break_on_load;
1591 push @files, $::INC{$file} if $::INC{$file};
1592 $file .= '.pm', redo unless $file =~ /\./;
1594 break_on_load($_) for @files;
1595 @files = report_break_on_load;
1596 print $OUT "Will stop on load of `@files'.\n";
1599 $filename_error = '';
1601 sub breakable_line {
1602 my ($from, $to) = @_;
1605 my $delta = $from < $to ? +1 : -1;
1606 my $limit = $delta > 0 ? $#dbline : 1;
1607 $limit = $to if ($limit - $to) * $delta > 0;
1608 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1610 return $i unless $dbline[$i] == 0;
1611 my ($pl, $upto) = ('', '');
1612 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1613 die "Line$pl $from$upto$filename_error not breakable\n";
1616 sub breakable_line_in_filename {
1618 local *dbline = $main::{'_<' . $f};
1619 local $filename_error = " of `$f'";
1624 my ($i, $cond) = @_;
1625 $cond = 1 unless @_ >= 2;
1629 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1630 $had_breakpoints{$filename} |= 1;
1631 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1632 else { $dbline{$i} = $cond; }
1636 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1639 sub break_on_filename_line {
1640 my ($f, $i, $cond) = @_;
1641 $cond = 1 unless @_ >= 3;
1642 local *dbline = $main::{'_<' . $f};
1643 local $filename_error = " of `$f'";
1644 local $filename = $f;
1645 break_on_line($i, $cond);
1648 sub break_on_filename_line_range {
1649 my ($f, $from, $to, $cond) = @_;
1650 my $i = breakable_line_in_filename($f, $from, $to);
1651 $cond = 1 unless @_ >= 3;
1652 break_on_filename_line($f,$i,$cond);
1655 sub subroutine_filename_lines {
1656 my ($subname,$cond) = @_;
1657 # Filename below can contain ':'
1658 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1661 sub break_subroutine {
1662 my $subname = shift;
1663 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1664 die "Subroutine $subname not found.\n";
1665 $cond = 1 unless @_ >= 2;
1666 break_on_filename_line_range($file,$s,$e,@_);
1670 my ($subname,$cond) = @_;
1671 $cond = 1 unless @_ >= 2;
1672 unless (ref $subname eq 'CODE') {
1673 $subname =~ s/\'/::/g;
1675 $subname = "${'package'}::" . $subname
1676 unless $subname =~ /::/;
1677 $subname = "CORE::GLOBAL::$s"
1678 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1679 $subname = "main".$subname if substr($subname,0,2) eq "::";
1681 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1684 sub cmd_stop { # As on ^C, but not signal-safy.
1688 sub delete_breakpoint {
1690 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1691 $dbline{$i} =~ s/^[^\0]*//;
1692 delete $dbline{$i} if $dbline{$i} eq '';
1697 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1700 ### END of the API section
1703 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1704 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1707 sub print_lineinfo {
1708 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1712 # The following takes its argument via $evalarg to preserve current @_
1715 # 'my' would make it visible from user code
1716 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1719 local $otrace = $trace;
1720 local $osingle = $single;
1722 { ($evalarg) = $evalarg =~ /(.*)/s; }
1723 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1729 local $saved[0]; # Preserve the old value of $@
1733 } elsif ($onetimeDump) {
1734 dumpit($OUT, \@res) if $onetimeDump eq 'dump';
1735 methods($res[0]) if $onetimeDump eq 'methods';
1741 my $subname = shift;
1742 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1743 my $offset = $1 || 0;
1744 # Filename below can contain ':'
1745 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1748 local *dbline = $main::{'_<' . $file};
1749 local $^W = 0; # != 0 is magical below
1750 $had_breakpoints{$file} |= 1;
1752 ++$i until $dbline[$i] != 0 or $i >= $max;
1753 $dbline{$i} = delete $postponed{$subname};
1755 print $OUT "Subroutine $subname not found.\n";
1759 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1760 #print $OUT "In postponed_sub for `$subname'.\n";
1764 if ($ImmediateStop) {
1768 return &postponed_sub
1769 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1770 # Cannot be done before the file is compiled
1771 local *dbline = shift;
1772 my $filename = $dbline;
1773 $filename =~ s/^_<//;
1774 $signal = 1, print $OUT "'$filename' loaded...\n"
1775 if $break_on_load{$filename};
1776 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1777 return unless $postponed_file{$filename};
1778 $had_breakpoints{$filename} |= 1;
1779 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1781 for $key (keys %{$postponed_file{$filename}}) {
1782 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1784 delete $postponed_file{$filename};
1788 local ($savout) = select(shift);
1789 my $osingle = $single;
1790 my $otrace = $trace;
1791 $single = $trace = 0;
1794 unless (defined &main::dumpValue) {
1797 if (defined &main::dumpValue) {
1798 &main::dumpValue(shift);
1800 print $OUT "dumpvar.pl not available.\n";
1807 # Tied method do not create a context, so may get wrong message:
1811 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1812 my @sub = dump_trace($_[0] + 1, $_[1]);
1813 my $short = $_[2]; # Print short report, next one for sub name
1815 for ($i=0; $i <= $#sub; $i++) {
1818 my $args = defined $sub[$i]{args}
1819 ? "(@{ $sub[$i]{args} })"
1821 $args = (substr $args, 0, $maxtrace - 3) . '...'
1822 if length $args > $maxtrace;
1823 my $file = $sub[$i]{file};
1824 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1826 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1828 my $sub = @_ >= 4 ? $_[3] : $s;
1829 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1831 print $fh "$sub[$i]{context} = $s$args" .
1832 " called from $file" .
1833 " line $sub[$i]{line}\n";
1840 my $count = shift || 1e9;
1843 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1844 my $nothard = not $frame & 8;
1845 local $frame = 0; # Do not want to trace this.
1846 my $otrace = $trace;
1849 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1854 if (not defined $arg) {
1856 } elsif ($nothard and tied $arg) {
1858 } elsif ($nothard and $type = ref $arg) {
1859 push @a, "ref($type)";
1861 local $_ = "$arg"; # Safe to stringify now - should not call f().
1864 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1865 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1866 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1870 $context = $context ? '@' : (defined $context ? "\$" : '.');
1871 $args = $h ? [@a] : undef;
1872 $e =~ s/\n\s*\;\s*\Z// if $e;
1873 $e =~ s/([\\\'])/\\$1/g if $e;
1875 $sub = "require '$e'";
1876 } elsif (defined $r) {
1878 } elsif ($sub eq '(eval)') {
1879 $sub = "eval {...}";
1881 push(@sub, {context => $context, sub => $sub, args => $args,
1882 file => $file, line => $line});
1891 while ($action =~ s/\\$//) {
1900 # i hate using globals!
1901 $balanced_brace_re ||= qr{
1904 (?> [^{}] + ) # Non-parens without backtracking
1906 (??{ $balanced_brace_re }) # Group with matching parens
1910 return $_[0] !~ m/$balanced_brace_re/;
1914 &readline("cont: ");
1918 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1919 # some non-Unix systems can do system() but have problems with fork().
1920 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1921 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1922 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1923 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1925 # XXX: using csh or tcsh destroys sigint retvals!
1927 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1928 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1933 # most of the $? crud was coping with broken cshisms
1935 &warn("(Command exited ", ($? >> 8), ")\n");
1937 &warn( "(Command died of SIG#", ($? & 127),
1938 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1948 eval { require Term::ReadLine } or die $@;
1951 my ($i, $o) = split $tty, /,/;
1952 $o = $i unless defined $o;
1953 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1954 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1957 my $sel = select($OUT);
1961 eval "require Term::Rendezvous;" or die;
1962 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1963 my $term_rv = new Term::Rendezvous $rv;
1965 $OUT = $term_rv->OUT;
1968 if ($term_pid eq '-1') { # In a TTY with another debugger
1972 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1974 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1976 $rl_attribs = $term->Attribs;
1977 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1978 if defined $rl_attribs->{basic_word_break_characters}
1979 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1980 $rl_attribs->{special_prefixes} = '$@&%';
1981 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1982 $rl_attribs->{completion_function} = \&db_complete;
1984 $LINEINFO = $OUT unless defined $LINEINFO;
1985 $lineinfo = $console unless defined $lineinfo;
1987 if ($term->Features->{setHistory} and "@hist" ne "?") {
1988 $term->SetHistory(@hist);
1990 ornaments($ornaments) if defined $ornaments;
1994 # Example get_fork_TTY functions
1995 sub xterm_get_fork_TTY {
1996 (my $name = $0) =~ s,^.*[/\\],,s;
1997 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2001 $pidprompt = ''; # Shown anyway in titlebar
2005 # This one resets $IN, $OUT itself
2006 sub os2_get_fork_TTY {
2007 $^F = 40; # XXXX Fixme!
2008 my ($in1, $out1, $in2, $out2);
2009 # Having -d in PERL5OPT would lead to a disaster...
2010 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2011 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2012 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2013 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2014 (my $name = $0) =~ s,^.*[/\\],,s;
2015 if ( pipe $in1, $out1 and pipe $in2, $out2 and
2016 # system P_SESSION will fail if there is another process
2017 # in the same session with a "dependent" asynchronous child session.
2018 (($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
2022 my $in = shift; # Read from here and pass through
2024 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2025 open IN, '<&=$in' or die "open <&=$in: \$!";
2026 \$| = 1; print while sysread IN, \$_, 1<<16;
2030 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2032 ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
2033 print while sysread STDIN, $_, 1<<16;
2035 and close $in1 and close $out2 ) {
2036 $pidprompt = ''; # Shown anyway in titlebar
2037 reset_IN_OUT($in2, $out1);
2039 return ''; # Indicate that reset_IN_OUT is called
2044 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2045 my $in = &get_fork_TTY if defined &get_fork_TTY;
2046 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2047 if (not defined $in) {
2049 print_help(<<EOP) if $why == 1;
2050 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2052 print_help(<<EOP) if $why == 2;
2053 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2054 This may be an asynchronous session, so the parent debugger may be active.
2056 print_help(<<EOP) if $why != 4;
2057 Since two debuggers fight for the same TTY, input is severely entangled.
2061 I know how to switch the output to a different window in xterms
2062 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2063 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2065 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2066 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2069 } elsif ($in ne '') {
2075 sub resetterm { # We forked, so we need a different TTY
2077 my $systemed = $in > 1 ? '-' : '';
2079 $pids =~ s/\]/$systemed->$$]/;
2081 $pids = "[$term_pid->$$]";
2085 return unless $CreateTTY & $in;
2092 my $left = @typeahead;
2093 my $got = shift @typeahead;
2094 print $OUT "auto(-$left)", shift, $got, "\n";
2095 $term->AddHistory($got)
2096 if length($got) > 1 and defined $term->Features->{addHistory};
2101 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2102 $OUT->write(join('', @_));
2104 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2108 $term->readline(@_);
2113 my ($opt, $val)= @_;
2114 $val = option_val($opt,'N/A');
2115 $val =~ s/([\\\'])/\\$1/g;
2116 printf $OUT "%20s = '%s'\n", $opt, $val;
2120 my ($opt, $default)= @_;
2122 if (defined $optionVars{$opt}
2123 and defined ${$optionVars{$opt}}) {
2124 $val = ${$optionVars{$opt}};
2125 } elsif (defined $optionAction{$opt}
2126 and defined &{$optionAction{$opt}}) {
2127 $val = &{$optionAction{$opt}}();
2128 } elsif (defined $optionAction{$opt}
2129 and not defined $option{$opt}
2130 or defined $optionVars{$opt}
2131 and not defined ${$optionVars{$opt}}) {
2134 $val = $option{$opt};
2136 $val = $default unless defined $val;
2142 # too dangerous to let intuitive usage overwrite important things
2143 # defaultion should never be the default
2144 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2145 arrayDepth hashDepth LineInfo maxTraceLen ornaments
2146 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2151 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2152 my ($opt,$sep) = ($1,$2);
2155 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2157 #&dump_option($opt);
2158 } elsif ($sep !~ /\S/) {
2160 $val = "1"; # this is an evil default; make 'em set it!
2161 } elsif ($sep eq "=") {
2163 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2165 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2169 print OUT qq(Option better cleared using $opt=""\n)
2173 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2174 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2175 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2176 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2177 ($val = $1) =~ s/\\([\\$end])/$1/g;
2181 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2182 || grep( /^\Q$opt/i && ($option = $_), @options );
2184 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2185 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2187 if ($opt_needs_val{$option} && $val_defaulted) {
2188 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2192 $option{$option} = $val if defined $val;
2197 require '$optionRequire{$option}';
2199 } || die # XXX: shouldn't happen
2200 if defined $optionRequire{$option} &&
2203 ${$optionVars{$option}} = $val
2204 if defined $optionVars{$option} &&
2207 &{$optionAction{$option}} ($val)
2208 if defined $optionAction{$option} &&
2209 defined &{$optionAction{$option}} &&
2213 dump_option($option) unless $OUT eq \*STDERR;
2218 my ($stem,@list) = @_;
2220 $ENV{"${stem}_n"} = @list;
2221 for $i (0 .. $#list) {
2223 $val =~ s/\\/\\\\/g;
2224 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2225 $ENV{"${stem}_$i"} = $val;
2232 my $n = delete $ENV{"${stem}_n"};
2234 for $i (0 .. $n - 1) {
2235 $val = delete $ENV{"${stem}_$i"};
2236 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2244 return; # Put nothing on the stack - malloc/free land!
2248 my($msg)= join("",@_);
2249 $msg .= ": $!\n" unless $msg =~ /\n$/;
2254 my $switch_li = $LINEINFO eq $OUT;
2255 if ($term and $term->Features->{newTTY}) {
2256 ($IN, $OUT) = (shift, shift);
2257 $term->newTTY($IN, $OUT);
2259 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2261 ($IN, $OUT) = (shift, shift);
2263 my $o = select $OUT;
2266 $LINEINFO = $OUT if $switch_li;
2270 if (@_ and $term and $term->Features->{newTTY}) {
2271 my ($in, $out) = shift;
2273 ($in, $out) = split /,/, $in, 2;
2277 open IN, $in or die "cannot open `$in' for read: $!";
2278 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2279 reset_IN_OUT(\*IN,\*OUT);
2282 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2283 # Useful if done through PERLDB_OPTS:
2290 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2292 $notty = shift if @_;
2298 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2306 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2308 $remoteport = shift if @_;
2313 if (${$term->Features}{tkRunning}) {
2314 return $term->tkRunning(@_);
2316 print $OUT "tkRunning not supported by current ReadLine package.\n";
2323 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2325 $runnonstop = shift if @_;
2332 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2339 $sh = quotemeta shift;
2340 $sh .= "\\b" if $sh =~ /\w$/;
2344 $psh =~ s/\\(.)/$1/g;
2349 if (defined $term) {
2350 local ($warnLevel,$dieLevel) = (0, 1);
2351 return '' unless $term->Features->{ornaments};
2352 eval { $term->ornaments(@_) } || '';
2360 $rc = quotemeta shift;
2361 $rc .= "\\b" if $rc =~ /\w$/;
2365 $prc =~ s/\\(.)/$1/g;
2370 return $lineinfo unless @_;
2372 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2373 $slave_editor = ($stream =~ /^\|/);
2374 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2375 $LINEINFO = \*LINEINFO;
2376 my $save = select($LINEINFO);
2390 s/^Term::ReadLine::readline$/readline/;
2391 if (defined ${ $_ . '::VERSION' }) {
2392 $version{$file} = "${ $_ . '::VERSION' } from ";
2394 $version{$file} .= $INC{$file};
2396 dumpit($OUT,\%version);
2400 # XXX: make sure there are tabs between the command and explanation,
2401 # or print_help will screw up your formatting if you have
2402 # eeevil ornaments enabled. This is an insane mess.
2406 B<s> [I<expr>] Single step [in I<expr>].
2407 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2408 <B<CR>> Repeat last B<n> or B<s> command.
2409 B<r> Return from current subroutine.
2410 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2411 at the specified position.
2412 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2413 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2414 B<l> I<line> List single I<line>.
2415 B<l> I<subname> List first window of lines from subroutine.
2416 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2417 B<l> List next window of lines.
2418 B<-> List previous window of lines.
2419 B<w> [I<line>] List window around I<line>.
2420 B<.> Return to the executed line.
2421 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2422 I<filename> may be either the full name of the file, or a regular
2423 expression matching the full file name:
2424 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2425 Evals (with saved bodies) are considered to be filenames:
2426 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2427 (in the order of execution).
2428 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2429 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2430 B<L> List all breakpoints and actions.
2431 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2432 B<t> Toggle trace mode.
2433 B<t> I<expr> Trace through execution of I<expr>.
2434 B<b> [I<line>] [I<condition>]
2435 Set breakpoint; I<line> defaults to the current execution line;
2436 I<condition> breaks if it evaluates to true, defaults to '1'.
2437 B<b> I<subname> [I<condition>]
2438 Set breakpoint at first line of subroutine.
2439 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2440 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2441 B<b> B<postpone> I<subname> [I<condition>]
2442 Set breakpoint at first line of subroutine after
2444 B<b> B<compile> I<subname>
2445 Stop after the subroutine is compiled.
2446 B<d> [I<line>] Delete the breakpoint for I<line>.
2447 B<D> Delete all breakpoints.
2448 B<a> [I<line>] I<command>
2449 Set an action to be done before the I<line> is executed;
2450 I<line> defaults to the current execution line.
2451 Sequence is: check for breakpoint/watchpoint, print line
2452 if necessary, do action, prompt user if necessary,
2454 B<a> [I<line>] Delete the action for I<line>.
2455 B<A> Delete all actions.
2456 B<W> I<expr> Add a global watch-expression.
2457 B<W> Delete all watch-expressions.
2458 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2459 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2460 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2461 B<x> I<expr> Evals expression in list context, dumps the result.
2462 B<m> I<expr> Evals expression in list context, prints methods callable
2463 on the first element of the result.
2464 B<m> I<class> Prints methods callable via the given class.
2466 B<<> ? List Perl commands to run before each prompt.
2467 B<<> I<expr> Define Perl command to run before each prompt.
2468 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2469 B<>> ? List Perl commands to run after each prompt.
2470 B<>> I<expr> Define Perl command to run after each prompt.
2471 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2472 B<{> I<db_command> Define debugger command to run before each prompt.
2473 B<{> ? List debugger commands to run before each prompt.
2474 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2475 B<$prc> I<number> Redo a previous command (default previous command).
2476 B<$prc> I<-number> Redo number'th-to-last command.
2477 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2478 See 'B<O> I<recallCommand>' too.
2479 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2480 . ( $rc eq $sh ? "" : "
2481 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2482 See 'B<O> I<shellBang>' too.
2483 B<H> I<-number> Display last number commands (default all).
2484 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2485 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2486 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2487 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2488 I<command> Execute as a perl statement in current package.
2489 B<v> Show versions of loaded modules.
2490 B<R> Pure-man-restart of debugger, some of debugger state
2491 and command-line options may be lost.
2492 Currently the following settings are preserved:
2493 history, breakpoints and actions, debugger B<O>ptions
2494 and the following command-line options: I<-w>, I<-I>, I<-e>.
2496 B<O> [I<opt>] ... Set boolean option to true
2497 B<O> [I<opt>B<?>] Query options
2498 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2499 Set options. Use quotes in spaces in value.
2500 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2501 I<pager> program for output of \"|cmd\";
2502 I<tkRunning> run Tk while prompting (with ReadLine);
2503 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2504 I<inhibit_exit> Allows stepping off the end of the script.
2505 I<ImmediateStop> Debugger should stop as early as possible.
2506 I<RemotePort> Remote hostname:port for remote debugging
2507 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2508 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2509 I<compactDump>, I<veryCompact> change style of array and hash dump;
2510 I<globPrint> whether to print contents of globs;
2511 I<DumpDBFiles> dump arrays holding debugged files;
2512 I<DumpPackages> dump symbol tables of packages;
2513 I<DumpReused> dump contents of \"reused\" addresses;
2514 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2515 I<bareStringify> Do not print the overload-stringified value;
2516 Other options include:
2517 I<PrintRet> affects printing of return value after B<r> command,
2518 I<frame> affects printing messages on subroutine entry/exit.
2519 I<AutoTrace> affects printing messages on possible breaking points.
2520 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2521 I<ornaments> affects screen appearance of the command line.
2522 I<CreateTTY> bits control attempts to create a new TTY on events:
2523 1: on fork() 2: debugger is started inside debugger
2525 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2526 You can put additional initialization options I<TTY>, I<noTTY>,
2527 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2528 `B<R>' after you set them).
2530 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2531 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2532 B<h h> Summary of debugger commands.
2533 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2534 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2535 Set B<\$DB::doccmd> to change viewer.
2537 Type `|h' for a paged display if this was too hard to read.
2539 "; # Fix balance of vi % matching: }}}}
2541 # note: tabs in the following section are not-so-helpful
2542 $summary = <<"END_SUM";
2543 I<List/search source lines:> I<Control script execution:>
2544 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2545 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2546 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2547 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2548 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2549 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2550 I<Debugger controls:> B<L> List break/watch/actions
2551 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2552 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2553 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2554 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2555 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2556 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2557 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2558 B<q> or B<^D> Quit B<R> Attempt a restart
2559 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2560 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2561 B<p> I<expr> Print expression (uses script's current package).
2562 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2563 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2564 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2565 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2567 # ')}}; # Fix balance of vi % matching
2573 # Restore proper alignment destroyed by eeevil I<> and B<>
2574 # ornaments: A pox on both their houses!
2576 # A help command will have everything up to and including
2577 # the first tab sequence padded into a field 16 (or if indented 20)
2578 # wide. If it's wider than that, an extra space will be added.
2580 ^ # only matters at start of line
2581 ( \040{4} | \t )* # some subcommands are indented
2582 ( < ? # so <CR> works
2583 [BI] < [^\t\n] + ) # find an eeevil ornament
2584 ( \t+ ) # original separation, discarded
2585 ( .* ) # this will now start (no earlier) than
2588 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2589 my $clean = $command;
2590 $clean =~ s/[BI]<([^>]*)>/$1/g;
2591 # replace with this whole string:
2592 ($leadwhite ? " " x 4 : "")
2594 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2599 s{ # handle bold ornaments
2600 B < ( [^>] + | > ) >
2602 $Term::ReadLine::TermCap::rl_term_set[2]
2604 . $Term::ReadLine::TermCap::rl_term_set[3]
2607 s{ # handle italic ornaments
2608 I < ( [^>] + | > ) >
2610 $Term::ReadLine::TermCap::rl_term_set[0]
2612 . $Term::ReadLine::TermCap::rl_term_set[1]
2619 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2620 my $is_less = $pager =~ /\bless\b/;
2621 if ($pager =~ /\bmore\b/) {
2622 my @st_more = stat('/usr/bin/more');
2623 my @st_less = stat('/usr/bin/less');
2624 $is_less = @st_more && @st_less
2625 && $st_more[0] == $st_less[0]
2626 && $st_more[1] == $st_less[1];
2628 # changes environment!
2629 $ENV{LESS} .= 'r' if $is_less;
2635 $SIG{'ABRT'} = 'DEFAULT';
2636 kill 'ABRT', $$ if $panic++;
2637 if (defined &Carp::longmess) {
2638 local $SIG{__WARN__} = '';
2639 local $Carp::CarpLevel = 2; # mydie + confess
2640 &warn(Carp::longmess("Signal @_"));
2643 print $DB::OUT "Got signal @_\n";
2651 local $SIG{__WARN__} = '';
2652 local $SIG{__DIE__} = '';
2653 eval { require Carp } if defined $^S; # If error/warning during compilation,
2654 # require may be broken.
2655 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2656 return unless defined &Carp::longmess;
2657 my ($mysingle,$mytrace) = ($single,$trace);
2658 $single = 0; $trace = 0;
2659 my $mess = Carp::longmess(@_);
2660 ($single,$trace) = ($mysingle,$mytrace);
2667 local $SIG{__DIE__} = '';
2668 local $SIG{__WARN__} = '';
2669 my $i = 0; my $ineval = 0; my $sub;
2670 if ($dieLevel > 2) {
2671 local $SIG{__WARN__} = \&dbwarn;
2672 &warn(@_); # Yell no matter what
2675 if ($dieLevel < 2) {
2676 die @_ if $^S; # in eval propagate
2678 eval { require Carp } if defined $^S; # If error/warning during compilation,
2679 # require may be broken.
2681 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2682 unless defined &Carp::longmess;
2684 # We do not want to debug this chunk (automatic disabling works
2685 # inside DB::DB, but not in Carp).
2686 my ($mysingle,$mytrace) = ($single,$trace);
2687 $single = 0; $trace = 0;
2688 my $mess = Carp::longmess(@_);
2689 ($single,$trace) = ($mysingle,$mytrace);
2695 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2698 $SIG{__WARN__} = \&DB::dbwarn;
2699 } elsif ($prevwarn) {
2700 $SIG{__WARN__} = $prevwarn;
2708 $prevdie = $SIG{__DIE__} unless $dieLevel;
2711 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2712 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2713 print $OUT "Stack dump during die enabled",
2714 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2716 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2717 } elsif ($prevdie) {
2718 $SIG{__DIE__} = $prevdie;
2719 print $OUT "Default die handler restored.\n";
2727 $prevsegv = $SIG{SEGV} unless $signalLevel;
2728 $prevbus = $SIG{BUS} unless $signalLevel;
2729 $signalLevel = shift;
2731 $SIG{SEGV} = \&DB::diesignal;
2732 $SIG{BUS} = \&DB::diesignal;
2734 $SIG{SEGV} = $prevsegv;
2735 $SIG{BUS} = $prevbus;
2743 my $name = CvGV_name_or_bust($in);
2744 defined $name ? $name : $in;
2747 sub CvGV_name_or_bust {
2749 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2750 return unless ref $in;
2751 $in = \&$in; # Hard reference...
2752 eval {require Devel::Peek; 1} or return;
2753 my $gv = Devel::Peek::CvGV($in) or return;
2754 *$gv{PACKAGE} . '::' . *$gv{NAME};
2760 return unless defined &$subr;
2761 my $name = CvGV_name_or_bust($subr);
2763 $data = $sub{$name} if defined $name;
2764 return $data if defined $data;
2767 $subr = \&$subr; # Hard reference
2770 $s = $_, last if $subr eq \&$_;
2778 $class = ref $class if ref $class;
2781 methods_via($class, '', 1);
2782 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2787 return if $packs{$class}++;
2789 my $prepend = $prefix ? "via $prefix: " : '';
2791 for $name (grep {defined &{${"${class}::"}{$_}}}
2792 sort keys %{"${class}::"}) {
2793 next if $seen{ $name }++;
2794 print $DB::OUT "$prepend$name\n";
2796 return unless shift; # Recurse?
2797 for $name (@{"${class}::ISA"}) {
2798 $prepend = $prefix ? $prefix . " -> $name" : $name;
2799 methods_via($name, $prepend, 1);
2804 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
2805 ? "man" # O Happy Day!
2806 : "perldoc"; # Alas, poor unfortunates
2812 &system("$doccmd $doccmd");
2815 # this way user can override, like with $doccmd="man -Mwhatever"
2816 # or even just "man " to disable the path check.
2817 unless ($doccmd eq 'man') {
2818 &system("$doccmd $page");
2822 $page = 'perl' if lc($page) eq 'help';
2825 my $man1dir = $Config::Config{'man1dir'};
2826 my $man3dir = $Config::Config{'man3dir'};
2827 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2829 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2830 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2831 chop $manpath if $manpath;
2832 # harmless if missing, I figure
2833 my $oldpath = $ENV{MANPATH};
2834 $ENV{MANPATH} = $manpath if $manpath;
2835 my $nopathopt = $^O =~ /dunno what goes here/;
2836 if (CORE::system($doccmd,
2837 # I just *know* there are men without -M
2838 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2841 unless ($page =~ /^perl\w/) {
2842 if (grep { $page eq $_ } qw{
2843 5004delta 5005delta amiga api apio book boot bot call compile
2844 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2845 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2846 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2847 modinstall modlib number obj op opentut os2 os390 pod port
2848 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2849 trap unicode var vms win32 xs xstut
2853 CORE::system($doccmd,
2854 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2859 if (defined $oldpath) {
2860 $ENV{MANPATH} = $manpath;
2862 delete $ENV{MANPATH};
2866 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2868 BEGIN { # This does not compile, alas.
2869 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2870 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2874 $deep = 100; # warning if stack gets this deep
2878 $SIG{INT} = \&DB::catch;
2879 # This may be enabled to debug debugger:
2880 #$warnLevel = 1 unless defined $warnLevel;
2881 #$dieLevel = 1 unless defined $dieLevel;
2882 #$signalLevel = 1 unless defined $signalLevel;
2884 $db_stop = 0; # Compiler warning
2886 $level = 0; # Level of recursive debugging
2887 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2888 # Triggers bug (?) in perl is we postpone this until runtime:
2889 @postponed = @stack = (0);
2890 $stack_depth = 0; # Localized $#stack
2895 BEGIN {$^W = $ini_warn;} # Switch warnings back
2897 #use Carp; # This did break, left for debugging
2900 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2901 my($text, $line, $start) = @_;
2902 my ($itext, $search, $prefix, $pack) =
2903 ($text, "^\Q${'package'}::\E([^:]+)\$");
2905 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2906 (map { /$search/ ? ($1) : () } keys %sub)
2907 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2908 return sort grep /^\Q$text/, values %INC # files
2909 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2910 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2911 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2912 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2913 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2915 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2917 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2918 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2919 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2920 # We may want to complete to (eval 9), so $text may be wrong
2921 $prefix = length($1) - length($text);
2924 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2926 if ((substr $text, 0, 1) eq '&') { # subroutines
2927 $text = substr $text, 1;
2929 return sort map "$prefix$_",
2932 (map { /$search/ ? ($1) : () }
2935 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2936 $pack = ($1 eq 'main' ? '' : $1) . '::';
2937 $prefix = (substr $text, 0, 1) . $1 . '::';
2940 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2941 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2942 return db_complete($out[0], $line, $start);
2946 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2947 $pack = ($package eq 'main' ? '' : $package) . '::';
2948 $prefix = substr $text, 0, 1;
2949 $text = substr $text, 1;
2950 my @out = map "$prefix$_", grep /^\Q$text/,
2951 (grep /^_?[a-zA-Z]/, keys %$pack),
2952 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2953 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2954 return db_complete($out[0], $line, $start);
2958 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2959 my @out = grep /^\Q$text/, @options;
2960 my $val = option_val($out[0], undef);
2962 if (not defined $val or $val =~ /[\n\r]/) {
2963 # Can do nothing better
2964 } elsif ($val =~ /\s/) {
2966 foreach $l (split //, qq/\"\'\#\|/) {
2967 $out = "$l$val$l ", last if (index $val, $l) == -1;
2972 # Default to value if one completion, to question if many
2973 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2976 return $term->filename_list($text); # filenames
2980 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2984 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
2985 $fall_off_end = 1 unless $inhibit_exit;
2986 # Do not stop in at_exit() and destructors on exit:
2987 $DB::single = !$fall_off_end && !$runnonstop;
2988 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
2994 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2997 package DB; # Do not trace this 1; below!