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
544 $| = 1; # for DB::OUT
547 $LINEINFO = $OUT unless defined $LINEINFO;
548 $lineinfo = $console unless defined $lineinfo;
550 $| = 1; # for real STDOUT
552 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
553 unless ($runnonstop) {
554 if ($term_pid eq '-1') {
555 print $OUT "\nDaughter DB session started...\n";
557 print $OUT "\nLoading DB routines from $header\n";
558 print $OUT ("Editor support ",
559 $slave_editor ? "enabled" : "available",
561 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
569 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
572 if (defined &afterinit) { # May be defined in $rcfile
578 ############################################################ Subroutines
581 # _After_ the perl program is compiled, $single is set to 1:
582 if ($single and not $second_time++) {
583 if ($runnonstop) { # Disable until signal
584 for ($i=0; $i <= $stack_depth; ) {
588 # return; # Would not print trace!
589 } elsif ($ImmediateStop) {
594 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
596 ($package, $filename, $line) = caller;
597 $filename_ini = $filename;
598 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
599 "package $package;"; # this won't let them modify, alas
600 local(*dbline) = $main::{'_<' . $filename};
602 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
606 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
607 $dbline{$line} =~ s/;9($|\0)/$1/;
610 my $was_signal = $signal;
612 for (my $n = 0; $n <= $#to_watch; $n++) {
613 $evalarg = $to_watch[$n];
614 local $onetimeDump; # Do not output results
615 my ($val) = &eval; # Fix context (&eval is doing array)?
616 $val = ( (defined $val) ? "'$val'" : 'undef' );
617 if ($val ne $old_watch[$n]) {
620 Watchpoint $n:\t$to_watch[$n] changed:
621 old value:\t$old_watch[$n]
624 $old_watch[$n] = $val;
628 if ($trace & 4) { # User-installed watch
629 return if watchfunction($package, $filename, $line)
630 and not $single and not $was_signal and not ($trace & ~4);
632 $was_signal = $signal;
634 if ($single || ($trace & 1) || $was_signal) {
636 $position = "\032\032$filename:$line:0\n";
637 print_lineinfo($position);
638 } elsif ($package eq 'DB::fake') {
641 Debugged program terminated. Use B<q> to quit or B<R> to restart,
642 use B<O> I<inhibit_exit> to avoid stopping after program termination,
643 B<h q>, B<h R> or B<h O> to get additional info.
646 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
647 "package $package;"; # this won't let them modify, alas
650 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
651 $prefix .= "$sub($filename:";
652 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
653 if (length($prefix) > 30) {
654 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
659 $position = "$prefix$line$infix$dbline[$line]$after";
662 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
664 print_lineinfo($position);
666 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
667 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
669 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
670 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
671 $position .= $incr_pos;
673 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
675 print_lineinfo($incr_pos);
680 $evalarg = $action, &eval if $action;
681 if ($single || $was_signal) {
682 local $level = $level + 1;
683 foreach $evalarg (@$pre) {
686 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
689 $incr = -1; # for backward motion.
690 @typeahead = (@$pretype, @typeahead);
692 while (($term || &setterm),
693 ($term_pid == $$ or resetterm(1)),
694 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
695 ($#hist+1) . ('>' x $level) .
700 $cmd =~ s/\\$/\n/ && do {
701 $cmd .= &readline(" cont: ");
704 $cmd =~ /^$/ && ($cmd = $laststep);
705 push(@hist,$cmd) if length($cmd) > 1;
707 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
708 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
709 ($i) = split(/\s+/,$cmd);
711 # squelch the sigmangler
713 local $SIG{__WARN__};
714 eval "\$cmd =~ $alias{$i}";
716 print $OUT "Couldn't evaluate `$i' alias: $@";
720 $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
721 $cmd =~ /^h$/ && do {
724 $cmd =~ /^h\s+h$/ && do {
725 print_help($summary);
727 # support long commands; otherwise bogus errors
728 # happen when you ask for h on <CR> for example
729 $cmd =~ /^h\s+(\S.*)$/ && do {
730 my $asked = $1; # for proper errmsg
731 my $qasked = quotemeta($asked); # for searching
732 # XXX: finds CR but not <CR>
733 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
734 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
738 print_help("B<$asked> is not a debugger command.\n");
741 $cmd =~ /^t$/ && do {
743 print $OUT "Trace = " .
744 (($trace & 1) ? "on" : "off" ) . "\n";
746 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
747 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
748 foreach $subname (sort(keys %sub)) {
749 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
750 print $OUT $subname,"\n";
754 $cmd =~ /^v$/ && do {
755 list_versions(); next CMD};
756 $cmd =~ s/^X\b/V $package/;
757 $cmd =~ /^V$/ && do {
758 $cmd = "V $package"; };
759 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
760 local ($savout) = select($OUT);
762 @vars = split(' ',$2);
763 do 'dumpvar.pl' unless defined &main::dumpvar;
764 if (defined &main::dumpvar) {
767 # must detect sigpipe failures
768 eval { &main::dumpvar($packname,@vars) };
770 die unless $@ =~ /dumpvar print failed/;
773 print $OUT "dumpvar.pl not available.\n";
777 $cmd =~ s/^x\b/ / && do { # So that will be evaled
778 $onetimeDump = 'dump'; };
779 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
780 methods($1); next CMD};
781 $cmd =~ s/^m\b/ / && do { # So this will be evaled
782 $onetimeDump = 'methods'; };
783 $cmd =~ /^f\b\s*(.*)/ && do {
787 print $OUT "The old f command is now the r command.\n";
788 print $OUT "The new f command switches filenames.\n";
791 if (!defined $main::{'_<' . $file}) {
792 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
793 $try = substr($try,2);
794 print $OUT "Choosing $try matching `$file':\n";
798 if (!defined $main::{'_<' . $file}) {
799 print $OUT "No file matching `$file' is loaded.\n";
801 } elsif ($file ne $filename) {
802 *dbline = $main::{'_<' . $file};
808 print $OUT "Already in $file.\n";
812 $cmd =~ s/^l\s+-\s*$/-/;
813 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
816 print($OUT "Error: $@\n"), next CMD if $@;
818 print($OUT "Interpreted as: $1 $s\n");
821 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
822 my $s = $subname = $1;
823 $subname =~ s/\'/::/;
824 $subname = $package."::".$subname
825 unless $subname =~ /::/;
826 $subname = "CORE::GLOBAL::$s"
827 if not defined &$subname and $s !~ /::/
828 and defined &{"CORE::GLOBAL::$s"};
829 $subname = "main".$subname if substr($subname,0,2) eq "::";
830 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
831 $subrange = pop @pieces;
832 $file = join(':', @pieces);
833 if ($file ne $filename) {
834 print $OUT "Switching to file '$file'.\n"
835 unless $slave_editor;
836 *dbline = $main::{'_<' . $file};
841 if (eval($subrange) < -$window) {
842 $subrange =~ s/-.*/+/;
844 $cmd = "l $subrange";
846 print $OUT "Subroutine $subname not found.\n";
849 $cmd =~ /^\.$/ && do {
850 $incr = -1; # for backward motion.
852 $filename = $filename_ini;
853 *dbline = $main::{'_<' . $filename};
855 print_lineinfo($position);
857 $cmd =~ /^w\b\s*(\d*)$/ && do {
861 #print $OUT 'l ' . $start . '-' . ($start + $incr);
862 $cmd = 'l ' . $start . '-' . ($start + $incr); };
863 $cmd =~ /^-$/ && do {
864 $start -= $incr + $window + 1;
865 $start = 1 if $start <= 0;
867 $cmd = 'l ' . ($start) . '+'; };
868 $cmd =~ /^l$/ && do {
870 $cmd = 'l ' . $start . '-' . ($start + $incr); };
871 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
874 $incr = $window - 1 unless $incr;
875 $cmd = 'l ' . $start . '-' . ($start + $incr); };
876 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
877 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
878 $end = $max if $end > $max;
880 $i = $line if $i eq '.';
884 print $OUT "\032\032$filename:$i:0\n";
887 for (; $i <= $end; $i++) {
888 ($stop,$action) = split(/\0/, $dbline{$i}) if
891 and $filename eq $filename_ini)
893 : ($dbline[$i]+0 ? ':' : ' ') ;
894 $arrow .= 'b' if $stop;
895 $arrow .= 'a' if $action;
896 print $OUT "$i$arrow\t", $dbline[$i];
897 $i++, last if $signal;
899 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
901 $start = $i; # remember in case they want more
902 $start = $max if $start > $max;
904 $cmd =~ /^D$/ && do {
905 print $OUT "Deleting all breakpoints...\n";
907 for $file (keys %had_breakpoints) {
908 local *dbline = $main::{'_<' . $file};
912 for ($i = 1; $i <= $max ; $i++) {
913 if (defined $dbline{$i}) {
914 $dbline{$i} =~ s/^[^\0]+//;
915 if ($dbline{$i} =~ s/^\0?$//) {
921 if (not $had_breakpoints{$file} &= ~1) {
922 delete $had_breakpoints{$file};
926 undef %postponed_file;
927 undef %break_on_load;
929 $cmd =~ /^L$/ && do {
931 for $file (keys %had_breakpoints) {
932 local *dbline = $main::{'_<' . $file};
936 for ($i = 1; $i <= $max; $i++) {
937 if (defined $dbline{$i}) {
938 print $OUT "$file:\n" unless $was++;
939 print $OUT " $i:\t", $dbline[$i];
940 ($stop,$action) = split(/\0/, $dbline{$i});
941 print $OUT " break if (", $stop, ")\n"
943 print $OUT " action: ", $action, "\n"
950 print $OUT "Postponed breakpoints in subroutines:\n";
952 for $subname (keys %postponed) {
953 print $OUT " $subname\t$postponed{$subname}\n";
957 my @have = map { # Combined keys
958 keys %{$postponed_file{$_}}
959 } keys %postponed_file;
961 print $OUT "Postponed breakpoints in files:\n";
963 for $file (keys %postponed_file) {
964 my $db = $postponed_file{$file};
965 print $OUT " $file:\n";
966 for $line (sort {$a <=> $b} keys %$db) {
967 print $OUT " $line:\n";
968 my ($stop,$action) = split(/\0/, $$db{$line});
969 print $OUT " break if (", $stop, ")\n"
971 print $OUT " action: ", $action, "\n"
978 if (%break_on_load) {
979 print $OUT "Breakpoints on load:\n";
981 for $file (keys %break_on_load) {
982 print $OUT " $file\n";
987 print $OUT "Watch-expressions:\n";
989 for $expr (@to_watch) {
990 print $OUT " $expr\n";
995 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
996 my $file = $1; $file =~ s/\s+$//;
999 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
1000 my $cond = length $3 ? $3 : '1';
1001 my ($subname, $break) = ($2, $1 eq 'postpone');
1002 $subname =~ s/\'/::/g;
1003 $subname = "${'package'}::" . $subname
1004 unless $subname =~ /::/;
1005 $subname = "main".$subname if substr($subname,0,2) eq "::";
1006 $postponed{$subname} = $break
1007 ? "break +0 if $cond" : "compile";
1009 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1011 $cond = length $2 ? $2 : '1';
1012 cmd_b_sub($subname, $cond);
1014 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1016 $cond = length $2 ? $2 : '1';
1017 cmd_b_line($i, $cond);
1019 $cmd =~ /^d\b\s*(\d*)/ && do {
1022 $cmd =~ /^A$/ && do {
1023 print $OUT "Deleting all actions...\n";
1025 for $file (keys %had_breakpoints) {
1026 local *dbline = $main::{'_<' . $file};
1030 for ($i = 1; $i <= $max ; $i++) {
1031 if (defined $dbline{$i}) {
1032 $dbline{$i} =~ s/\0[^\0]*//;
1033 delete $dbline{$i} if $dbline{$i} eq '';
1037 unless ($had_breakpoints{$file} &= ~2) {
1038 delete $had_breakpoints{$file};
1042 $cmd =~ /^O\s*$/ && do {
1047 $cmd =~ /^O\s*(\S.*)/ && do {
1050 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1051 push @$pre, action($1);
1053 $cmd =~ /^>>\s*(.*)/ && do {
1054 push @$post, action($1);
1056 $cmd =~ /^<\s*(.*)/ && do {
1058 print $OUT "All < actions cleared.\n";
1064 print $OUT "No pre-prompt Perl actions.\n";
1067 print $OUT "Perl commands run before each prompt:\n";
1068 for my $action ( @$pre ) {
1069 print $OUT "\t< -- $action\n";
1073 $pre = [action($1)];
1075 $cmd =~ /^>\s*(.*)/ && do {
1077 print $OUT "All > actions cleared.\n";
1083 print $OUT "No post-prompt Perl actions.\n";
1086 print $OUT "Perl commands run after each prompt:\n";
1087 for my $action ( @$post ) {
1088 print $OUT "\t> -- $action\n";
1092 $post = [action($1)];
1094 $cmd =~ /^\{\{\s*(.*)/ && do {
1095 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1096 print $OUT "{{ is now a debugger command\n",
1097 "use `;{{' if you mean Perl code\n";
1103 $cmd =~ /^\{\s*(.*)/ && do {
1105 print $OUT "All { actions cleared.\n";
1110 unless (@$pretype) {
1111 print $OUT "No pre-prompt debugger actions.\n";
1114 print $OUT "Debugger commands run before each prompt:\n";
1115 for my $action ( @$pretype ) {
1116 print $OUT "\t{ -- $action\n";
1120 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1121 print $OUT "{ is now a debugger command\n",
1122 "use `;{' if you mean Perl code\n";
1128 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1129 $i = $1 || $line; $j = $2;
1131 if ($dbline[$i] == 0) {
1132 print $OUT "Line $i may not have an action.\n";
1134 $had_breakpoints{$filename} |= 2;
1135 $dbline{$i} =~ s/\0[^\0]*//;
1136 $dbline{$i} .= "\0" . action($j);
1139 $dbline{$i} =~ s/\0[^\0]*//;
1140 delete $dbline{$i} if $dbline{$i} eq '';
1143 $cmd =~ /^n$/ && do {
1144 end_report(), next CMD if $finished and $level <= 1;
1148 $cmd =~ /^s$/ && do {
1149 end_report(), next CMD if $finished and $level <= 1;
1153 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1154 end_report(), next CMD if $finished and $level <= 1;
1156 # Probably not needed, since we finish an interactive
1157 # sub-session anyway...
1158 # local $filename = $filename;
1159 # local *dbline = *dbline; # XXX Would this work?!
1160 if ($i =~ /\D/) { # subroutine name
1161 $subname = $package."::".$subname
1162 unless $subname =~ /::/;
1163 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1167 *dbline = $main::{'_<' . $filename};
1168 $had_breakpoints{$filename} |= 1;
1170 ++$i while $dbline[$i] == 0 && $i < $max;
1172 print $OUT "Subroutine $subname not found.\n";
1177 if ($dbline[$i] == 0) {
1178 print $OUT "Line $i not breakable.\n";
1181 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1183 for ($i=0; $i <= $stack_depth; ) {
1187 $cmd =~ /^r$/ && do {
1188 end_report(), next CMD if $finished and $level <= 1;
1189 $stack[$stack_depth] |= 1;
1190 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1192 $cmd =~ /^R$/ && do {
1193 print $OUT "Warning: some settings and command-line options may be lost!\n";
1194 my (@script, @flags, $cl);
1195 push @flags, '-w' if $ini_warn;
1196 # Put all the old includes at the start to get
1197 # the same debugger.
1199 push @flags, '-I', $_;
1201 # Arrange for setting the old INC:
1202 set_list("PERLDB_INC", @ini_INC);
1204 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1205 chomp ($cl = ${'::_<-e'}[$_]);
1206 push @script, '-e', $cl;
1211 set_list("PERLDB_HIST",
1212 $term->Features->{getHistory}
1213 ? $term->GetHistory : @hist);
1214 my @had_breakpoints = keys %had_breakpoints;
1215 set_list("PERLDB_VISITED", @had_breakpoints);
1216 set_list("PERLDB_OPT", %option);
1217 set_list("PERLDB_ON_LOAD", %break_on_load);
1219 for (0 .. $#had_breakpoints) {
1220 my $file = $had_breakpoints[$_];
1221 *dbline = $main::{'_<' . $file};
1222 next unless %dbline or $postponed_file{$file};
1223 (push @hard, $file), next
1224 if $file =~ /^\(eval \d+\)$/;
1226 @add = %{$postponed_file{$file}}
1227 if $postponed_file{$file};
1228 set_list("PERLDB_FILE_$_", %dbline, @add);
1230 for (@hard) { # Yes, really-really...
1231 # Find the subroutines in this eval
1232 *dbline = $main::{'_<' . $_};
1233 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1234 for $sub (keys %sub) {
1235 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1236 $subs{$sub} = [$1, $2];
1240 "No subroutines in $_, ignoring breakpoints.\n";
1243 LINES: for $line (keys %dbline) {
1244 # One breakpoint per sub only:
1245 my ($offset, $sub, $found);
1246 SUBS: for $sub (keys %subs) {
1247 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1248 and (not defined $offset # Not caught
1249 or $offset < 0 )) { # or badly caught
1251 $offset = $line - $subs{$sub}->[0];
1252 $offset = "+$offset", last SUBS if $offset >= 0;
1255 if (defined $offset) {
1256 $postponed{$found} =
1257 "break $offset if $dbline{$line}";
1259 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1263 set_list("PERLDB_POSTPONE", %postponed);
1264 set_list("PERLDB_PRETYPE", @$pretype);
1265 set_list("PERLDB_PRE", @$pre);
1266 set_list("PERLDB_POST", @$post);
1267 set_list("PERLDB_TYPEAHEAD", @typeahead);
1268 $ENV{PERLDB_RESTART} = 1;
1269 delete $ENV{PERLDB_PIDS}; # Restore ini state
1270 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1271 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1272 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1273 print $OUT "exec failed: $!\n";
1275 $cmd =~ /^T$/ && do {
1276 print_trace($OUT, 1); # skip DB
1278 $cmd =~ /^W\s*$/ && do {
1280 @to_watch = @old_watch = ();
1282 $cmd =~ /^W\b\s*(.*)/s && do {
1286 $val = (defined $val) ? "'$val'" : 'undef' ;
1287 push @old_watch, $val;
1290 $cmd =~ /^\/(.*)$/ && do {
1292 $inpat =~ s:([^\\])/$:$1:;
1294 # squelch the sigmangler
1295 local $SIG{__DIE__};
1296 local $SIG{__WARN__};
1297 eval '$inpat =~ m'."\a$inpat\a";
1309 $start = 1 if ($start > $max);
1310 last if ($start == $end);
1311 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1312 if ($slave_editor) {
1313 print $OUT "\032\032$filename:$start:0\n";
1315 print $OUT "$start:\t", $dbline[$start], "\n";
1320 print $OUT "/$pat/: not found\n" if ($start == $end);
1322 $cmd =~ /^\?(.*)$/ && do {
1324 $inpat =~ s:([^\\])\?$:$1:;
1326 # squelch the sigmangler
1327 local $SIG{__DIE__};
1328 local $SIG{__WARN__};
1329 eval '$inpat =~ m'."\a$inpat\a";
1341 $start = $max if ($start <= 0);
1342 last if ($start == $end);
1343 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1344 if ($slave_editor) {
1345 print $OUT "\032\032$filename:$start:0\n";
1347 print $OUT "$start:\t", $dbline[$start], "\n";
1352 print $OUT "?$pat?: not found\n" if ($start == $end);
1354 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1355 pop(@hist) if length($cmd) > 1;
1356 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1358 print $OUT $cmd, "\n";
1360 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1363 $cmd =~ /^$rc([^$rc].*)$/ && do {
1365 pop(@hist) if length($cmd) > 1;
1366 for ($i = $#hist; $i; --$i) {
1367 last if $hist[$i] =~ /$pat/;
1370 print $OUT "No such command!\n\n";
1374 print $OUT $cmd, "\n";
1376 $cmd =~ /^$sh$/ && do {
1377 &system($ENV{SHELL}||"/bin/sh");
1379 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1380 # XXX: using csh or tcsh destroys sigint retvals!
1381 #&system($1); # use this instead
1382 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1384 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1385 $end = $2 ? ($#hist-$2) : 0;
1386 $hist = 0 if $hist < 0;
1387 for ($i=$#hist; $i>$end; $i--) {
1388 print $OUT "$i: ",$hist[$i],"\n"
1389 unless $hist[$i] =~ /^.?$/;
1392 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1395 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1396 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1397 $cmd =~ s/^=\s*// && do {
1399 if (length $cmd == 0) {
1400 @keys = sort keys %alias;
1402 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1403 # can't use $_ or kill //g state
1404 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1405 $alias{$k} = "s\a$k\a$v\a";
1406 # squelch the sigmangler
1407 local $SIG{__DIE__};
1408 local $SIG{__WARN__};
1409 unless (eval "sub { s\a$k\a$v\a }; 1") {
1410 print $OUT "Can't alias $k to $v: $@\n";
1420 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1421 print $OUT "$k\t= $1\n";
1423 elsif (defined $alias{$k}) {
1424 print $OUT "$k\t$alias{$k}\n";
1427 print "No alias for $k\n";
1431 $cmd =~ /^\|\|?\s*[^|]/ && do {
1432 if ($pager =~ /^\|/) {
1433 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1434 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1436 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1439 unless ($piped=open(OUT,$pager)) {
1440 &warn("Can't pipe output to `$pager'");
1441 if ($pager =~ /^\|/) {
1442 open(OUT,">&STDOUT") # XXX: lost message
1443 || &warn("Can't restore DB::OUT");
1444 open(STDOUT,">&SAVEOUT")
1445 || &warn("Can't restore STDOUT");
1448 open(OUT,">&STDOUT") # XXX: lost message
1449 || &warn("Can't restore DB::OUT");
1453 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1454 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1455 $selected= select(OUT);
1457 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1458 $cmd =~ s/^\|+\s*//;
1461 # XXX Local variants do not work!
1462 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1463 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1464 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1466 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1468 $onetimeDump = undef;
1469 } elsif ($term_pid == $$) {
1474 if ($pager =~ /^\|/) {
1476 # we cannot warn here: the handle is missing --tchrist
1477 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1479 # most of the $? crud was coping with broken cshisms
1481 print SAVEOUT "Pager `$pager' failed: ";
1483 print SAVEOUT "shell returned -1\n";
1486 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1487 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1489 print SAVEOUT "status ", ($? >> 8), "\n";
1493 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1494 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1495 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1496 # Will stop ignoring SIGPIPE if done like nohup(1)
1497 # does SIGINT but Perl doesn't give us a choice.
1499 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1502 select($selected), $selected= "" unless $selected eq "";
1506 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1507 foreach $evalarg (@$post) {
1510 } # if ($single || $signal)
1511 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1515 # The following code may be executed now:
1519 my ($al, $ret, @ret) = "";
1520 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1523 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1524 $#stack = $stack_depth;
1525 $stack[-1] = $single;
1527 $single |= 4 if $stack_depth == $deep;
1529 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1530 # Why -1? But it works! :-(
1531 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1532 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1535 $single |= $stack[$stack_depth--];
1537 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1538 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1539 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1540 if ($doret eq $stack_depth or $frame & 16) {
1541 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1542 print $fh ' ' x $stack_depth if $frame & 16;
1543 print $fh "list context return from $sub:\n";
1544 dumpit($fh, \@ret );
1549 if (defined wantarray) {
1554 $single |= $stack[$stack_depth--];
1556 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1557 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1558 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1559 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1560 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1561 print $fh (' ' x $stack_depth) if $frame & 16;
1562 print $fh (defined wantarray
1563 ? "scalar context return from $sub: "
1564 : "void context return from $sub\n");
1565 dumpit( $fh, $ret ) if defined wantarray;
1574 ### Functions with multiple modes of failure die on error, the rest
1575 ### returns FALSE on error.
1576 ### User-interface functions cmd_* output error message.
1580 $break_on_load{$file} = 1;
1581 $had_breakpoints{$file} |= 1;
1584 sub report_break_on_load {
1585 sort keys %break_on_load;
1593 push @files, $::INC{$file} if $::INC{$file};
1594 $file .= '.pm', redo unless $file =~ /\./;
1596 break_on_load($_) for @files;
1597 @files = report_break_on_load;
1598 print $OUT "Will stop on load of `@files'.\n";
1601 $filename_error = '';
1603 sub breakable_line {
1604 my ($from, $to) = @_;
1607 my $delta = $from < $to ? +1 : -1;
1608 my $limit = $delta > 0 ? $#dbline : 1;
1609 $limit = $to if ($limit - $to) * $delta > 0;
1610 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1612 return $i unless $dbline[$i] == 0;
1613 my ($pl, $upto) = ('', '');
1614 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1615 die "Line$pl $from$upto$filename_error not breakable\n";
1618 sub breakable_line_in_filename {
1620 local *dbline = $main::{'_<' . $f};
1621 local $filename_error = " of `$f'";
1626 my ($i, $cond) = @_;
1627 $cond = 1 unless @_ >= 2;
1631 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1632 $had_breakpoints{$filename} |= 1;
1633 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1634 else { $dbline{$i} = $cond; }
1638 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1641 sub break_on_filename_line {
1642 my ($f, $i, $cond) = @_;
1643 $cond = 1 unless @_ >= 3;
1644 local *dbline = $main::{'_<' . $f};
1645 local $filename_error = " of `$f'";
1646 local $filename = $f;
1647 break_on_line($i, $cond);
1650 sub break_on_filename_line_range {
1651 my ($f, $from, $to, $cond) = @_;
1652 my $i = breakable_line_in_filename($f, $from, $to);
1653 $cond = 1 unless @_ >= 3;
1654 break_on_filename_line($f,$i,$cond);
1657 sub subroutine_filename_lines {
1658 my ($subname,$cond) = @_;
1659 # Filename below can contain ':'
1660 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1663 sub break_subroutine {
1664 my $subname = shift;
1665 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1666 die "Subroutine $subname not found.\n";
1667 $cond = 1 unless @_ >= 2;
1668 break_on_filename_line_range($file,$s,$e,@_);
1672 my ($subname,$cond) = @_;
1673 $cond = 1 unless @_ >= 2;
1674 unless (ref $subname eq 'CODE') {
1675 $subname =~ s/\'/::/g;
1677 $subname = "${'package'}::" . $subname
1678 unless $subname =~ /::/;
1679 $subname = "CORE::GLOBAL::$s"
1680 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1681 $subname = "main".$subname if substr($subname,0,2) eq "::";
1683 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1686 sub cmd_stop { # As on ^C, but not signal-safy.
1690 sub delete_breakpoint {
1692 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1693 $dbline{$i} =~ s/^[^\0]*//;
1694 delete $dbline{$i} if $dbline{$i} eq '';
1699 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1702 ### END of the API section
1705 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1706 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1709 sub print_lineinfo {
1710 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1714 # The following takes its argument via $evalarg to preserve current @_
1717 # 'my' would make it visible from user code
1718 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1721 local $otrace = $trace;
1722 local $osingle = $single;
1724 { ($evalarg) = $evalarg =~ /(.*)/s; }
1725 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1731 local $saved[0]; # Preserve the old value of $@
1735 } elsif ($onetimeDump) {
1736 dumpit($OUT, \@res) if $onetimeDump eq 'dump';
1737 methods($res[0]) if $onetimeDump eq 'methods';
1743 my $subname = shift;
1744 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1745 my $offset = $1 || 0;
1746 # Filename below can contain ':'
1747 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1750 local *dbline = $main::{'_<' . $file};
1751 local $^W = 0; # != 0 is magical below
1752 $had_breakpoints{$file} |= 1;
1754 ++$i until $dbline[$i] != 0 or $i >= $max;
1755 $dbline{$i} = delete $postponed{$subname};
1757 print $OUT "Subroutine $subname not found.\n";
1761 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1762 #print $OUT "In postponed_sub for `$subname'.\n";
1766 if ($ImmediateStop) {
1770 return &postponed_sub
1771 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1772 # Cannot be done before the file is compiled
1773 local *dbline = shift;
1774 my $filename = $dbline;
1775 $filename =~ s/^_<//;
1776 $signal = 1, print $OUT "'$filename' loaded...\n"
1777 if $break_on_load{$filename};
1778 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1779 return unless $postponed_file{$filename};
1780 $had_breakpoints{$filename} |= 1;
1781 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1783 for $key (keys %{$postponed_file{$filename}}) {
1784 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1786 delete $postponed_file{$filename};
1790 local ($savout) = select(shift);
1791 my $osingle = $single;
1792 my $otrace = $trace;
1793 $single = $trace = 0;
1796 unless (defined &main::dumpValue) {
1799 if (defined &main::dumpValue) {
1800 &main::dumpValue(shift);
1802 print $OUT "dumpvar.pl not available.\n";
1809 # Tied method do not create a context, so may get wrong message:
1813 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1814 my @sub = dump_trace($_[0] + 1, $_[1]);
1815 my $short = $_[2]; # Print short report, next one for sub name
1817 for ($i=0; $i <= $#sub; $i++) {
1820 my $args = defined $sub[$i]{args}
1821 ? "(@{ $sub[$i]{args} })"
1823 $args = (substr $args, 0, $maxtrace - 3) . '...'
1824 if length $args > $maxtrace;
1825 my $file = $sub[$i]{file};
1826 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1828 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1830 my $sub = @_ >= 4 ? $_[3] : $s;
1831 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1833 print $fh "$sub[$i]{context} = $s$args" .
1834 " called from $file" .
1835 " line $sub[$i]{line}\n";
1842 my $count = shift || 1e9;
1845 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1846 my $nothard = not $frame & 8;
1847 local $frame = 0; # Do not want to trace this.
1848 my $otrace = $trace;
1851 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1856 if (not defined $arg) {
1858 } elsif ($nothard and tied $arg) {
1860 } elsif ($nothard and $type = ref $arg) {
1861 push @a, "ref($type)";
1863 local $_ = "$arg"; # Safe to stringify now - should not call f().
1866 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1867 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1868 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1872 $context = $context ? '@' : (defined $context ? "\$" : '.');
1873 $args = $h ? [@a] : undef;
1874 $e =~ s/\n\s*\;\s*\Z// if $e;
1875 $e =~ s/([\\\'])/\\$1/g if $e;
1877 $sub = "require '$e'";
1878 } elsif (defined $r) {
1880 } elsif ($sub eq '(eval)') {
1881 $sub = "eval {...}";
1883 push(@sub, {context => $context, sub => $sub, args => $args,
1884 file => $file, line => $line});
1893 while ($action =~ s/\\$//) {
1902 # i hate using globals!
1903 $balanced_brace_re ||= qr{
1906 (?> [^{}] + ) # Non-parens without backtracking
1908 (??{ $balanced_brace_re }) # Group with matching parens
1912 return $_[0] !~ m/$balanced_brace_re/;
1916 &readline("cont: ");
1920 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1921 # some non-Unix systems can do system() but have problems with fork().
1922 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1923 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1924 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1925 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1927 # XXX: using csh or tcsh destroys sigint retvals!
1929 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1930 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1935 # most of the $? crud was coping with broken cshisms
1937 &warn("(Command exited ", ($? >> 8), ")\n");
1939 &warn( "(Command died of SIG#", ($? & 127),
1940 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1950 eval { require Term::ReadLine } or die $@;
1953 my ($i, $o) = split $tty, /,/;
1954 $o = $i unless defined $o;
1955 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1956 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1959 my $sel = select($OUT);
1963 eval "require Term::Rendezvous;" or die;
1964 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1965 my $term_rv = new Term::Rendezvous $rv;
1967 $OUT = $term_rv->OUT;
1970 if ($term_pid eq '-1') { # In a TTY with another debugger
1974 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1976 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1978 $rl_attribs = $term->Attribs;
1979 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1980 if defined $rl_attribs->{basic_word_break_characters}
1981 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1982 $rl_attribs->{special_prefixes} = '$@&%';
1983 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1984 $rl_attribs->{completion_function} = \&db_complete;
1986 $LINEINFO = $OUT unless defined $LINEINFO;
1987 $lineinfo = $console unless defined $lineinfo;
1989 if ($term->Features->{setHistory} and "@hist" ne "?") {
1990 $term->SetHistory(@hist);
1992 ornaments($ornaments) if defined $ornaments;
1996 # Example get_fork_TTY functions
1997 sub xterm_get_fork_TTY {
1998 (my $name = $0) =~ s,^.*[/\\],,s;
1999 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2003 $pidprompt = ''; # Shown anyway in titlebar
2007 # This one resets $IN, $OUT itself
2008 sub os2_get_fork_TTY {
2009 $^F = 40; # XXXX Fixme!
2010 my ($in1, $out1, $in2, $out2);
2011 # Having -d in PERL5OPT would lead to a disaster...
2012 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2013 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2014 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2015 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2016 (my $name = $0) =~ s,^.*[/\\],,s;
2017 if ( pipe $in1, $out1 and pipe $in2, $out2 and
2018 # system P_SESSION will fail if there is another process
2019 # in the same session with a "dependent" asynchronous child session.
2020 (($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
2024 my $in = shift; # Read from here and pass through
2026 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2027 open IN, '<&=$in' or die "open <&=$in: \$!";
2028 \$| = 1; print while sysread IN, \$_, 1<<16;
2032 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2034 ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
2035 print while sysread STDIN, $_, 1<<16;
2037 and close $in1 and close $out2 ) {
2038 $pidprompt = ''; # Shown anyway in titlebar
2039 reset_IN_OUT($in2, $out1);
2041 return ''; # Indicate that reset_IN_OUT is called
2046 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2047 my $in = &get_fork_TTY if defined &get_fork_TTY;
2048 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2049 if (not defined $in) {
2051 print_help(<<EOP) if $why == 1;
2052 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2054 print_help(<<EOP) if $why == 2;
2055 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2056 This may be an asynchronous session, so the parent debugger may be active.
2058 print_help(<<EOP) if $why != 4;
2059 Since two debuggers fight for the same TTY, input is severely entangled.
2063 I know how to switch the output to a different window in xterms
2064 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2065 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2067 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2068 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2071 } elsif ($in ne '') {
2077 sub resetterm { # We forked, so we need a different TTY
2079 my $systemed = $in > 1 ? '-' : '';
2081 $pids =~ s/\]/$systemed->$$]/;
2083 $pids = "[$term_pid->$$]";
2087 return unless $CreateTTY & $in;
2094 my $left = @typeahead;
2095 my $got = shift @typeahead;
2096 print $OUT "auto(-$left)", shift, $got, "\n";
2097 $term->AddHistory($got)
2098 if length($got) > 1 and defined $term->Features->{addHistory};
2103 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2104 $OUT->write(join('', @_));
2106 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2110 $term->readline(@_);
2115 my ($opt, $val)= @_;
2116 $val = option_val($opt,'N/A');
2117 $val =~ s/([\\\'])/\\$1/g;
2118 printf $OUT "%20s = '%s'\n", $opt, $val;
2122 my ($opt, $default)= @_;
2124 if (defined $optionVars{$opt}
2125 and defined ${$optionVars{$opt}}) {
2126 $val = ${$optionVars{$opt}};
2127 } elsif (defined $optionAction{$opt}
2128 and defined &{$optionAction{$opt}}) {
2129 $val = &{$optionAction{$opt}}();
2130 } elsif (defined $optionAction{$opt}
2131 and not defined $option{$opt}
2132 or defined $optionVars{$opt}
2133 and not defined ${$optionVars{$opt}}) {
2136 $val = $option{$opt};
2138 $val = $default unless defined $val;
2144 # too dangerous to let intuitive usage overwrite important things
2145 # defaultion should never be the default
2146 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2147 arrayDepth hashDepth LineInfo maxTraceLen ornaments
2148 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2153 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2154 my ($opt,$sep) = ($1,$2);
2157 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2159 #&dump_option($opt);
2160 } elsif ($sep !~ /\S/) {
2162 $val = "1"; # this is an evil default; make 'em set it!
2163 } elsif ($sep eq "=") {
2165 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2167 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2171 print OUT qq(Option better cleared using $opt=""\n)
2175 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2176 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2177 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2178 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2179 ($val = $1) =~ s/\\([\\$end])/$1/g;
2183 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2184 || grep( /^\Q$opt/i && ($option = $_), @options );
2186 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2187 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2189 if ($opt_needs_val{$option} && $val_defaulted) {
2190 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2194 $option{$option} = $val if defined $val;
2199 require '$optionRequire{$option}';
2201 } || die # XXX: shouldn't happen
2202 if defined $optionRequire{$option} &&
2205 ${$optionVars{$option}} = $val
2206 if defined $optionVars{$option} &&
2209 &{$optionAction{$option}} ($val)
2210 if defined $optionAction{$option} &&
2211 defined &{$optionAction{$option}} &&
2215 dump_option($option) unless $OUT eq \*STDERR;
2220 my ($stem,@list) = @_;
2222 $ENV{"${stem}_n"} = @list;
2223 for $i (0 .. $#list) {
2225 $val =~ s/\\/\\\\/g;
2226 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2227 $ENV{"${stem}_$i"} = $val;
2234 my $n = delete $ENV{"${stem}_n"};
2236 for $i (0 .. $n - 1) {
2237 $val = delete $ENV{"${stem}_$i"};
2238 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2246 return; # Put nothing on the stack - malloc/free land!
2250 my($msg)= join("",@_);
2251 $msg .= ": $!\n" unless $msg =~ /\n$/;
2256 my $switch_li = $LINEINFO eq $OUT;
2257 if ($term and $term->Features->{newTTY}) {
2258 ($IN, $OUT) = (shift, shift);
2259 $term->newTTY($IN, $OUT);
2261 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2263 ($IN, $OUT) = (shift, shift);
2265 my $o = select $OUT;
2268 $LINEINFO = $OUT if $switch_li;
2272 if (@_ and $term and $term->Features->{newTTY}) {
2273 my ($in, $out) = shift;
2275 ($in, $out) = split /,/, $in, 2;
2279 open IN, $in or die "cannot open `$in' for read: $!";
2280 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2281 reset_IN_OUT(\*IN,\*OUT);
2284 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2285 # Useful if done through PERLDB_OPTS:
2292 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2294 $notty = shift if @_;
2300 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2308 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2310 $remoteport = shift if @_;
2315 if (${$term->Features}{tkRunning}) {
2316 return $term->tkRunning(@_);
2318 print $OUT "tkRunning not supported by current ReadLine package.\n";
2325 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2327 $runnonstop = shift if @_;
2334 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2341 $sh = quotemeta shift;
2342 $sh .= "\\b" if $sh =~ /\w$/;
2346 $psh =~ s/\\(.)/$1/g;
2351 if (defined $term) {
2352 local ($warnLevel,$dieLevel) = (0, 1);
2353 return '' unless $term->Features->{ornaments};
2354 eval { $term->ornaments(@_) } || '';
2362 $rc = quotemeta shift;
2363 $rc .= "\\b" if $rc =~ /\w$/;
2367 $prc =~ s/\\(.)/$1/g;
2372 return $lineinfo unless @_;
2374 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2375 $slave_editor = ($stream =~ /^\|/);
2376 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2377 $LINEINFO = \*LINEINFO;
2378 my $save = select($LINEINFO);
2392 s/^Term::ReadLine::readline$/readline/;
2393 if (defined ${ $_ . '::VERSION' }) {
2394 $version{$file} = "${ $_ . '::VERSION' } from ";
2396 $version{$file} .= $INC{$file};
2398 dumpit($OUT,\%version);
2402 # XXX: make sure there are tabs between the command and explanation,
2403 # or print_help will screw up your formatting if you have
2404 # eeevil ornaments enabled. This is an insane mess.
2408 B<s> [I<expr>] Single step [in I<expr>].
2409 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2410 <B<CR>> Repeat last B<n> or B<s> command.
2411 B<r> Return from current subroutine.
2412 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2413 at the specified position.
2414 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2415 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2416 B<l> I<line> List single I<line>.
2417 B<l> I<subname> List first window of lines from subroutine.
2418 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2419 B<l> List next window of lines.
2420 B<-> List previous window of lines.
2421 B<w> [I<line>] List window around I<line>.
2422 B<.> Return to the executed line.
2423 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2424 I<filename> may be either the full name of the file, or a regular
2425 expression matching the full file name:
2426 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2427 Evals (with saved bodies) are considered to be filenames:
2428 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2429 (in the order of execution).
2430 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2431 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2432 B<L> List all breakpoints and actions.
2433 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2434 B<t> Toggle trace mode.
2435 B<t> I<expr> Trace through execution of I<expr>.
2436 B<b> [I<line>] [I<condition>]
2437 Set breakpoint; I<line> defaults to the current execution line;
2438 I<condition> breaks if it evaluates to true, defaults to '1'.
2439 B<b> I<subname> [I<condition>]
2440 Set breakpoint at first line of subroutine.
2441 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2442 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2443 B<b> B<postpone> I<subname> [I<condition>]
2444 Set breakpoint at first line of subroutine after
2446 B<b> B<compile> I<subname>
2447 Stop after the subroutine is compiled.
2448 B<d> [I<line>] Delete the breakpoint for I<line>.
2449 B<D> Delete all breakpoints.
2450 B<a> [I<line>] I<command>
2451 Set an action to be done before the I<line> is executed;
2452 I<line> defaults to the current execution line.
2453 Sequence is: check for breakpoint/watchpoint, print line
2454 if necessary, do action, prompt user if necessary,
2456 B<a> [I<line>] Delete the action for I<line>.
2457 B<A> Delete all actions.
2458 B<W> I<expr> Add a global watch-expression.
2459 B<W> Delete all watch-expressions.
2460 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2461 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2462 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2463 B<x> I<expr> Evals expression in list context, dumps the result.
2464 B<m> I<expr> Evals expression in list context, prints methods callable
2465 on the first element of the result.
2466 B<m> I<class> Prints methods callable via the given class.
2468 B<<> ? List Perl commands to run before each prompt.
2469 B<<> I<expr> Define Perl command to run before each prompt.
2470 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2471 B<>> ? List Perl commands to run after each prompt.
2472 B<>> I<expr> Define Perl command to run after each prompt.
2473 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2474 B<{> I<db_command> Define debugger command to run before each prompt.
2475 B<{> ? List debugger commands to run before each prompt.
2476 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2477 B<$prc> I<number> Redo a previous command (default previous command).
2478 B<$prc> I<-number> Redo number'th-to-last command.
2479 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2480 See 'B<O> I<recallCommand>' too.
2481 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2482 . ( $rc eq $sh ? "" : "
2483 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2484 See 'B<O> I<shellBang>' too.
2485 B<H> I<-number> Display last number commands (default all).
2486 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2487 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2488 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2489 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2490 I<command> Execute as a perl statement in current package.
2491 B<v> Show versions of loaded modules.
2492 B<R> Pure-man-restart of debugger, some of debugger state
2493 and command-line options may be lost.
2494 Currently the following settings are preserved:
2495 history, breakpoints and actions, debugger B<O>ptions
2496 and the following command-line options: I<-w>, I<-I>, I<-e>.
2498 B<O> [I<opt>] ... Set boolean option to true
2499 B<O> [I<opt>B<?>] Query options
2500 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2501 Set options. Use quotes in spaces in value.
2502 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2503 I<pager> program for output of \"|cmd\";
2504 I<tkRunning> run Tk while prompting (with ReadLine);
2505 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2506 I<inhibit_exit> Allows stepping off the end of the script.
2507 I<ImmediateStop> Debugger should stop as early as possible.
2508 I<RemotePort> Remote hostname:port for remote debugging
2509 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2510 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2511 I<compactDump>, I<veryCompact> change style of array and hash dump;
2512 I<globPrint> whether to print contents of globs;
2513 I<DumpDBFiles> dump arrays holding debugged files;
2514 I<DumpPackages> dump symbol tables of packages;
2515 I<DumpReused> dump contents of \"reused\" addresses;
2516 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2517 I<bareStringify> Do not print the overload-stringified value;
2518 Other options include:
2519 I<PrintRet> affects printing of return value after B<r> command,
2520 I<frame> affects printing messages on subroutine entry/exit.
2521 I<AutoTrace> affects printing messages on possible breaking points.
2522 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2523 I<ornaments> affects screen appearance of the command line.
2524 I<CreateTTY> bits control attempts to create a new TTY on events:
2525 1: on fork() 2: debugger is started inside debugger
2527 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2528 You can put additional initialization options I<TTY>, I<noTTY>,
2529 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2530 `B<R>' after you set them).
2532 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2533 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2534 B<h h> Summary of debugger commands.
2535 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2536 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2537 Set B<\$DB::doccmd> to change viewer.
2539 Type `|h' for a paged display if this was too hard to read.
2541 "; # Fix balance of vi % matching: }}}}
2543 # note: tabs in the following section are not-so-helpful
2544 $summary = <<"END_SUM";
2545 I<List/search source lines:> I<Control script execution:>
2546 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2547 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2548 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2549 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2550 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2551 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2552 I<Debugger controls:> B<L> List break/watch/actions
2553 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2554 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2555 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2556 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2557 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2558 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2559 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2560 B<q> or B<^D> Quit B<R> Attempt a restart
2561 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2562 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2563 B<p> I<expr> Print expression (uses script's current package).
2564 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2565 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2566 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2567 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2569 # ')}}; # Fix balance of vi % matching
2575 # Restore proper alignment destroyed by eeevil I<> and B<>
2576 # ornaments: A pox on both their houses!
2578 # A help command will have everything up to and including
2579 # the first tab sequence padded into a field 16 (or if indented 20)
2580 # wide. If it's wider than that, an extra space will be added.
2582 ^ # only matters at start of line
2583 ( \040{4} | \t )* # some subcommands are indented
2584 ( < ? # so <CR> works
2585 [BI] < [^\t\n] + ) # find an eeevil ornament
2586 ( \t+ ) # original separation, discarded
2587 ( .* ) # this will now start (no earlier) than
2590 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2591 my $clean = $command;
2592 $clean =~ s/[BI]<([^>]*)>/$1/g;
2593 # replace with this whole string:
2594 ($leadwhite ? " " x 4 : "")
2596 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2601 s{ # handle bold ornaments
2602 B < ( [^>] + | > ) >
2604 $Term::ReadLine::TermCap::rl_term_set[2]
2606 . $Term::ReadLine::TermCap::rl_term_set[3]
2609 s{ # handle italic ornaments
2610 I < ( [^>] + | > ) >
2612 $Term::ReadLine::TermCap::rl_term_set[0]
2614 . $Term::ReadLine::TermCap::rl_term_set[1]
2621 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2622 my $is_less = $pager =~ /\bless\b/;
2623 if ($pager =~ /\bmore\b/) {
2624 my @st_more = stat('/usr/bin/more');
2625 my @st_less = stat('/usr/bin/less');
2626 $is_less = @st_more && @st_less
2627 && $st_more[0] == $st_less[0]
2628 && $st_more[1] == $st_less[1];
2630 # changes environment!
2631 $ENV{LESS} .= 'r' if $is_less;
2637 $SIG{'ABRT'} = 'DEFAULT';
2638 kill 'ABRT', $$ if $panic++;
2639 if (defined &Carp::longmess) {
2640 local $SIG{__WARN__} = '';
2641 local $Carp::CarpLevel = 2; # mydie + confess
2642 &warn(Carp::longmess("Signal @_"));
2645 print $DB::OUT "Got signal @_\n";
2653 local $SIG{__WARN__} = '';
2654 local $SIG{__DIE__} = '';
2655 eval { require Carp } if defined $^S; # If error/warning during compilation,
2656 # require may be broken.
2657 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2658 return unless defined &Carp::longmess;
2659 my ($mysingle,$mytrace) = ($single,$trace);
2660 $single = 0; $trace = 0;
2661 my $mess = Carp::longmess(@_);
2662 ($single,$trace) = ($mysingle,$mytrace);
2669 local $SIG{__DIE__} = '';
2670 local $SIG{__WARN__} = '';
2671 my $i = 0; my $ineval = 0; my $sub;
2672 if ($dieLevel > 2) {
2673 local $SIG{__WARN__} = \&dbwarn;
2674 &warn(@_); # Yell no matter what
2677 if ($dieLevel < 2) {
2678 die @_ if $^S; # in eval propagate
2680 eval { require Carp } if defined $^S; # If error/warning during compilation,
2681 # require may be broken.
2683 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2684 unless defined &Carp::longmess;
2686 # We do not want to debug this chunk (automatic disabling works
2687 # inside DB::DB, but not in Carp).
2688 my ($mysingle,$mytrace) = ($single,$trace);
2689 $single = 0; $trace = 0;
2690 my $mess = Carp::longmess(@_);
2691 ($single,$trace) = ($mysingle,$mytrace);
2697 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2700 $SIG{__WARN__} = \&DB::dbwarn;
2701 } elsif ($prevwarn) {
2702 $SIG{__WARN__} = $prevwarn;
2710 $prevdie = $SIG{__DIE__} unless $dieLevel;
2713 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2714 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2715 print $OUT "Stack dump during die enabled",
2716 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2718 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2719 } elsif ($prevdie) {
2720 $SIG{__DIE__} = $prevdie;
2721 print $OUT "Default die handler restored.\n";
2729 $prevsegv = $SIG{SEGV} unless $signalLevel;
2730 $prevbus = $SIG{BUS} unless $signalLevel;
2731 $signalLevel = shift;
2733 $SIG{SEGV} = \&DB::diesignal;
2734 $SIG{BUS} = \&DB::diesignal;
2736 $SIG{SEGV} = $prevsegv;
2737 $SIG{BUS} = $prevbus;
2745 my $name = CvGV_name_or_bust($in);
2746 defined $name ? $name : $in;
2749 sub CvGV_name_or_bust {
2751 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2752 return unless ref $in;
2753 $in = \&$in; # Hard reference...
2754 eval {require Devel::Peek; 1} or return;
2755 my $gv = Devel::Peek::CvGV($in) or return;
2756 *$gv{PACKAGE} . '::' . *$gv{NAME};
2762 return unless defined &$subr;
2763 my $name = CvGV_name_or_bust($subr);
2765 $data = $sub{$name} if defined $name;
2766 return $data if defined $data;
2769 $subr = \&$subr; # Hard reference
2772 $s = $_, last if $subr eq \&$_;
2780 $class = ref $class if ref $class;
2783 methods_via($class, '', 1);
2784 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2789 return if $packs{$class}++;
2791 my $prepend = $prefix ? "via $prefix: " : '';
2793 for $name (grep {defined &{${"${class}::"}{$_}}}
2794 sort keys %{"${class}::"}) {
2795 next if $seen{ $name }++;
2796 print $DB::OUT "$prepend$name\n";
2798 return unless shift; # Recurse?
2799 for $name (@{"${class}::ISA"}) {
2800 $prepend = $prefix ? $prefix . " -> $name" : $name;
2801 methods_via($name, $prepend, 1);
2806 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
2807 ? "man" # O Happy Day!
2808 : "perldoc"; # Alas, poor unfortunates
2814 &system("$doccmd $doccmd");
2817 # this way user can override, like with $doccmd="man -Mwhatever"
2818 # or even just "man " to disable the path check.
2819 unless ($doccmd eq 'man') {
2820 &system("$doccmd $page");
2824 $page = 'perl' if lc($page) eq 'help';
2827 my $man1dir = $Config::Config{'man1dir'};
2828 my $man3dir = $Config::Config{'man3dir'};
2829 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2831 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2832 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2833 chop $manpath if $manpath;
2834 # harmless if missing, I figure
2835 my $oldpath = $ENV{MANPATH};
2836 $ENV{MANPATH} = $manpath if $manpath;
2837 my $nopathopt = $^O =~ /dunno what goes here/;
2838 if (CORE::system($doccmd,
2839 # I just *know* there are men without -M
2840 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2843 unless ($page =~ /^perl\w/) {
2844 if (grep { $page eq $_ } qw{
2845 5004delta 5005delta amiga api apio book boot bot call compile
2846 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2847 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2848 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2849 modinstall modlib number obj op opentut os2 os390 pod port
2850 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2851 trap unicode var vms win32 xs xstut
2855 CORE::system($doccmd,
2856 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2861 if (defined $oldpath) {
2862 $ENV{MANPATH} = $manpath;
2864 delete $ENV{MANPATH};
2868 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2870 BEGIN { # This does not compile, alas.
2871 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2872 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2876 $deep = 100; # warning if stack gets this deep
2880 $SIG{INT} = \&DB::catch;
2881 # This may be enabled to debug debugger:
2882 #$warnLevel = 1 unless defined $warnLevel;
2883 #$dieLevel = 1 unless defined $dieLevel;
2884 #$signalLevel = 1 unless defined $signalLevel;
2886 $db_stop = 0; # Compiler warning
2888 $level = 0; # Level of recursive debugging
2889 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2890 # Triggers bug (?) in perl is we postpone this until runtime:
2891 @postponed = @stack = (0);
2892 $stack_depth = 0; # Localized $#stack
2897 BEGIN {$^W = $ini_warn;} # Switch warnings back
2899 #use Carp; # This did break, left for debugging
2902 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2903 my($text, $line, $start) = @_;
2904 my ($itext, $search, $prefix, $pack) =
2905 ($text, "^\Q${'package'}::\E([^:]+)\$");
2907 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2908 (map { /$search/ ? ($1) : () } keys %sub)
2909 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2910 return sort grep /^\Q$text/, values %INC # files
2911 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2912 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2913 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2914 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2915 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2917 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2919 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2920 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2921 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2922 # We may want to complete to (eval 9), so $text may be wrong
2923 $prefix = length($1) - length($text);
2926 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2928 if ((substr $text, 0, 1) eq '&') { # subroutines
2929 $text = substr $text, 1;
2931 return sort map "$prefix$_",
2934 (map { /$search/ ? ($1) : () }
2937 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2938 $pack = ($1 eq 'main' ? '' : $1) . '::';
2939 $prefix = (substr $text, 0, 1) . $1 . '::';
2942 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2943 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2944 return db_complete($out[0], $line, $start);
2948 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2949 $pack = ($package eq 'main' ? '' : $package) . '::';
2950 $prefix = substr $text, 0, 1;
2951 $text = substr $text, 1;
2952 my @out = map "$prefix$_", grep /^\Q$text/,
2953 (grep /^_?[a-zA-Z]/, keys %$pack),
2954 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2955 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2956 return db_complete($out[0], $line, $start);
2960 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2961 my @out = grep /^\Q$text/, @options;
2962 my $val = option_val($out[0], undef);
2964 if (not defined $val or $val =~ /[\n\r]/) {
2965 # Can do nothing better
2966 } elsif ($val =~ /\s/) {
2968 foreach $l (split //, qq/\"\'\#\|/) {
2969 $out = "$l$val$l ", last if (index $val, $l) == -1;
2974 # Default to value if one completion, to question if many
2975 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2978 return $term->filename_list($text); # filenames
2982 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2986 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
2987 $fall_off_end = 1 unless $inhibit_exit;
2988 # Do not stop in at_exit() and destructors on exit:
2989 $DB::single = !$fall_off_end && !$runnonstop;
2990 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
2996 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2999 package DB; # Do not trace this 1; below!