3 # Debugger for Perl 5.00x; perl5db.pl patch level:
6 $header = "perl5db.pl version $VERSION";
9 # This file is automatically included if you do perl -d.
10 # It's probably not useful to include this yourself.
12 # Perl supplies the values for %sub. It effectively inserts
13 # a &DB'DB(); in front of every place that can have a
14 # breakpoint. Instead of a subroutine call it calls &DB::sub with
15 # $DB::sub being the called subroutine. It also inserts a BEGIN
16 # {require 'perl5db.pl'} before the first line.
18 # After each `require'd file is compiled, but before it is executed, a
19 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
20 # $filename is the expanded name of the `require'd file (as found as
23 # Additional services from Perl interpreter:
25 # if caller() is called from the package DB, it provides some
28 # The array @{$main::{'_<'.$filename}} is the line-by-line contents of
31 # The hash %{'_<'.$filename} contains breakpoints and action (it is
32 # keyed by line number), and individual entries are settable (as
33 # opposed to the whole hash). Only true/false is important to the
34 # interpreter, though the values used by perl5db.pl have the form
35 # "$break_condition\0$action". Values are magical in numeric context.
37 # The scalar ${'_<'.$filename} contains $filename.
39 # Note that no subroutine call is possible until &DB::sub is defined
40 # (for subroutines defined outside of the package DB). In fact the same is
41 # true if $deep is not defined.
46 # At start reads $rcfile that may set important options. This file
47 # may define a subroutine &afterinit that will be executed after the
48 # debugger is initialized.
50 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
51 # it as a rest of `O ...' line in debugger prompt.
53 # The options that can be specified only at startup:
54 # [To set in $rcfile, call &parse_options("optionName=new_value").]
56 # TTY - the TTY to use for debugging i/o.
58 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
59 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
60 # Term::Rendezvous. Current variant is to have the name of TTY in this
63 # ReadLine - If false, dummy ReadLine is used, so you can debug
64 # ReadLine applications.
66 # NonStop - if true, no i/o is performed until interrupt.
68 # LineInfo - file or pipe to print line number info to. If it is a
69 # pipe, a short "emacs like" message is used.
71 # RemotePort - host:port to connect to on remote host for remote debugging.
73 # Example $rcfile: (delete leading hashes!)
75 # &parse_options("NonStop=1 LineInfo=db.out");
76 # sub afterinit { $trace = 1; }
78 # The script will run without human intervention, putting trace
79 # information into db.out. (If you interrupt it, you would better
80 # reset LineInfo to something "interactive"!)
82 ##################################################################
84 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
86 # modified Perl debugger, to be run from Emacs in perldb-mode
87 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
88 # Johan Vromans -- upgrade to 4.0 pl 10
89 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
93 # A lot of things changed after 0.94. First of all, core now informs
94 # debugger about entry into XSUBs, overloaded operators, tied operations,
95 # BEGIN and END. Handy with `O f=2'.
97 # This can make debugger a little bit too verbose, please be patient
98 # and report your problems promptly.
100 # Now the option frame has 3 values: 0,1,2.
102 # Note that if DESTROY returns a reference to the object (or object),
103 # the deletion of data may be postponed until the next function call,
104 # due to the need to examine the return value.
106 # Changes: 0.95: `v' command shows versions.
107 # Changes: 0.96: `v' command shows version of readline.
108 # primitive completion works (dynamic variables, subs for `b' and `l',
109 # options). Can `p %var'
110 # Better help (`h <' now works). New commands <<, >>, {, {{.
111 # {dump|print}_trace() coded (to be able to do it from <<cmd).
112 # `c sub' documented.
113 # At last enough magic combined to stop after the end of debuggee.
114 # !! should work now (thanks to Emacs bracket matching an extra
115 # `]' in a regexp is caught).
116 # `L', `D' and `A' span files now (as documented).
117 # Breakpoints in `require'd code are possible (used in `R').
118 # Some additional words on internal work of debugger.
119 # `b load filename' implemented.
120 # `b postpone subr' implemented.
121 # now only `q' exits debugger (overwritable on $inhibit_exit).
122 # When restarting debugger breakpoints/actions persist.
123 # Buglet: When restarting debugger only one breakpoint/action per
124 # autoloaded function persists.
125 # Changes: 0.97: NonStop will not stop in at_exit().
126 # Option AutoTrace implemented.
127 # Trace printed differently if frames are printed too.
128 # new `inhibitExit' option.
129 # printing of a very long statement interruptible.
130 # Changes: 0.98: New command `m' for printing possible methods
131 # 'l -' is a synonym for `-'.
132 # Cosmetic bugs in printing stack trace.
133 # `frame' & 8 to print "expanded args" in stack trace.
134 # Can list/break in imported subs.
135 # new `maxTraceLen' option.
136 # frame & 4 and frame & 8 granted.
138 # nonstoppable lines do not have `:' near the line number.
139 # `b compile subname' implemented.
140 # Will not use $` any more.
141 # `-' behaves sane now.
142 # Changes: 0.99: Completion for `f', `m'.
143 # `m' will remove duplicate names instead of duplicate functions.
144 # `b load' strips trailing whitespace.
145 # completion ignores leading `|'; takes into account current package
146 # when completing a subroutine name (same for `l').
147 # Changes: 1.07: Many fixed by tchrist 13-March-2000
149 # + Added bare minimal security checks on perldb rc files, plus
150 # comments on what else is needed.
151 # + Fixed the ornaments that made "|h" completely unusable.
152 # They are not used in print_help if they will hurt. Strip pod
153 # if we're paging to less.
154 # + Fixed mis-formatting of help messages caused by ornaments
155 # to restore Larry's original formatting.
156 # + Fixed many other formatting errors. The code is still suboptimal,
157 # and needs a lot of work at restructuring. It's also misindented
159 # + Fixed bug where trying to look at an option like your pager
161 # + Fixed some $? processing. Note: if you use csh or tcsh, you will
162 # lose. You should consider shell escapes not using their shell,
163 # or else not caring about detailed status. This should really be
164 # unified into one place, too.
165 # + Fixed bug where invisible trailing whitespace on commands hoses you,
166 # tricking Perl into thinking you weren't calling a debugger command!
167 # + Fixed bug where leading whitespace on commands hoses you. (One
168 # suggests a leading semicolon or any other irrelevant non-whitespace
169 # to indicate literal Perl code.)
170 # + Fixed bugs that ate warnings due to wrong selected handle.
171 # + Fixed a precedence bug on signal stuff.
172 # + Fixed some unseemly wording.
173 # + Fixed bug in help command trying to call perl method code.
174 # + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
176 # + Added some comments. This code is still nasty spaghetti.
177 # + Added message if you clear your pre/post command stacks which was
178 # very easy to do if you just typed a bare >, <, or {. (A command
179 # without an argument should *never* be a destructive action; this
180 # API is fundamentally screwed up; likewise option setting, which
181 # is equally buggered.)
182 # + Added command stack dump on argument of "?" for >, <, or {.
183 # + Added a semi-built-in doc viewer command that calls man with the
184 # proper %Config::Config path (and thus gets caching, man -k, etc),
185 # or else perldoc on obstreperous platforms.
186 # + Added to and rearranged the help information.
187 # + Detected apparent misuse of { ... } to declare a block; this used
188 # to work but now is a command, and mysteriously gave no complaint.
190 # Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
192 # + This patch to perl5db.pl cleans up formatting issues on the help
193 # summary (h h) screen in the debugger. Mostly columnar alignment
194 # issues, plus converted the printed text to use all spaces, since
195 # tabs don't seem to help much here.
197 # Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
198 # 0) Minor bugs corrected;
199 # a) Support for auto-creation of new TTY window on startup, either
200 # unconditionally, or if started as a kid of another debugger session;
201 # b) New `O'ption CreateTTY
202 # I<CreateTTY> bits control attempts to create a new TTY on events:
203 # 1: on fork() 2: debugger is started inside debugger
205 # c) Code to auto-create a new TTY window on OS/2 (currently one one
206 # extra window per session - need named pipes to have more...);
207 # d) Simplified interface for custom createTTY functions (with a backward
208 # compatibility hack); now returns the TTY name to use; return of ''
209 # means that the function reset the I/O handles itself;
210 # d') Better message on the semantic of custom createTTY function;
211 # e) Convert the existing code to create a TTY into a custom createTTY
213 # f) Consistent support for TTY names of the form "TTYin,TTYout";
214 # g) Switch line-tracing output too to the created TTY window;
215 # h) make `b fork' DWIM with CORE::GLOBAL::fork;
216 # i) High-level debugger API cmd_*():
217 # cmd_b_load($filenamepart) # b load filenamepart
218 # cmd_b_line($lineno [, $cond]) # b lineno [cond]
219 # cmd_b_sub($sub [, $cond]) # b sub [cond]
220 # cmd_stop() # Control-C
221 # cmd_d($lineno) # d lineno
222 # The cmd_*() API returns FALSE on failure; in this case it outputs
223 # the error message to the debugging output.
224 # j) Low-level debugger API
225 # break_on_load($filename) # b load filename
226 # @files = report_break_on_load() # List files with load-breakpoints
227 # breakable_line_in_filename($name, $from [, $to])
228 # # First breakable line in the
229 # # range $from .. $to. $to defaults
230 # # to $from, and may be less than $to
231 # breakable_line($from [, $to]) # Same for the current file
232 # break_on_filename_line($name, $lineno [, $cond])
233 # # Set breakpoint,$cond defaults to 1
234 # break_on_filename_line_range($name, $from, $to [, $cond])
235 # # As above, on the first
236 # # breakable line in range
237 # break_on_line($lineno [, $cond]) # As above, in the current file
238 # break_subroutine($sub [, $cond]) # break on the first breakable line
239 # ($name, $from, $to) = subroutine_filename_lines($sub)
240 # # The range of lines of the text
241 # The low-level API returns TRUE on success, and die()s on failure.
243 # Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
245 # + Fixed warnings generated by "perl -dWe 42"
246 # + Corrected spelling errors
247 # + Squeezed Help (h) output into 80 columns
249 # Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
250 # + Made "x @INC" work like it used to
252 # Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
253 # + Fixed warnings generated by "O" (Show debugger options)
254 # + Fixed warnings generated by "p 42" (Print expression)
255 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
256 # + Added windowSize option
257 ####################################################################
259 # Needed for the statement after exec():
261 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
262 local($^W) = 0; # Switch run-time warnings off during init.
265 $dumpvar::arrayDepth,
266 $dumpvar::dumpDBFiles,
267 $dumpvar::dumpPackages,
268 $dumpvar::quoteHighBit,
269 $dumpvar::printUndef,
278 # Command-line + PERLLIB:
281 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
283 $trace = $signal = $single = 0; # Uninitialized warning suppression
284 # (local $^W cannot help - other packages!).
285 $inhibit_exit = $option{PrintRet} = 1;
287 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
288 compactDump veryCompact quote HighBit undefPrint
289 globPrint PrintRet UsageOnly frame AutoTrace
290 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
291 recallCommand ShellBang pager tkRunning ornaments
292 signalLevel warnLevel dieLevel inhibit_exit
293 ImmediateStop bareStringify CreateTTY
294 RemotePort windowSize);
297 hashDepth => \$dumpvar::hashDepth,
298 arrayDepth => \$dumpvar::arrayDepth,
299 DumpDBFiles => \$dumpvar::dumpDBFiles,
300 DumpPackages => \$dumpvar::dumpPackages,
301 DumpReused => \$dumpvar::dumpReused,
302 HighBit => \$dumpvar::quoteHighBit,
303 undefPrint => \$dumpvar::printUndef,
304 globPrint => \$dumpvar::globPrint,
305 UsageOnly => \$dumpvar::usageOnly,
306 CreateTTY => \$CreateTTY,
307 bareStringify => \$dumpvar::bareStringify,
309 AutoTrace => \$trace,
310 inhibit_exit => \$inhibit_exit,
311 maxTraceLen => \$maxtrace,
312 ImmediateStop => \$ImmediateStop,
313 RemotePort => \$remoteport,
314 windowSize => \$window,
318 compactDump => \&dumpvar::compactDump,
319 veryCompact => \&dumpvar::veryCompact,
320 quote => \&dumpvar::quote,
323 ReadLine => \&ReadLine,
324 NonStop => \&NonStop,
325 LineInfo => \&LineInfo,
326 recallCommand => \&recallCommand,
327 ShellBang => \&shellBang,
329 signalLevel => \&signalLevel,
330 warnLevel => \&warnLevel,
331 dieLevel => \&dieLevel,
332 tkRunning => \&tkRunning,
333 ornaments => \&ornaments,
334 RemotePort => \&RemotePort,
338 compactDump => 'dumpvar.pl',
339 veryCompact => 'dumpvar.pl',
340 quote => 'dumpvar.pl',
343 # These guys may be defined in $ENV{PERL5DB} :
344 $rl = 1 unless defined $rl;
345 $warnLevel = 1 unless defined $warnLevel;
346 $dieLevel = 1 unless defined $dieLevel;
347 $signalLevel = 1 unless defined $signalLevel;
348 $pre = [] unless defined $pre;
349 $post = [] unless defined $post;
350 $pretype = [] unless defined $pretype;
351 $CreateTTY = 3 unless defined $CreateTTY;
353 warnLevel($warnLevel);
355 signalLevel($signalLevel);
358 (defined($ENV{PAGER})
362 : 'more'))) unless defined $pager;
364 &recallCommand("!") unless defined $prc;
365 &shellBang("!") unless defined $psh;
367 $maxtrace = 400 unless defined $maxtrace;
368 $ini_pids = $ENV{PERLDB_PIDS};
369 if (defined $ENV{PERLDB_PIDS}) {
370 $pids = "[$ENV{PERLDB_PIDS}]";
371 $ENV{PERLDB_PIDS} .= "->$$";
374 $ENV{PERLDB_PIDS} = "$$";
379 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
381 if (-e "/dev/tty") { # this is the wrong metric!
384 $rcfile="perldb.ini";
387 # This isn't really safe, because there's a race
388 # between checking and opening. The solution is to
389 # open and fstat the handle, but then you have to read and
390 # eval the contents. But then the silly thing gets
391 # your lexical scope, which is unfortunately at best.
395 # Just exactly what part of the word "CORE::" don't you understand?
396 local $SIG{__WARN__};
399 unless (is_safe_file($file)) {
400 CORE::warn <<EO_GRIPE;
401 perldb: Must not source insecure rcfile $file.
402 You or the superuser must be the owner, and it must not
403 be writable by anyone but its owner.
409 CORE::warn("perldb: couldn't parse $file: $@") if $@;
413 # Verifies that owner is either real user or superuser and that no
414 # one but owner may write to it. This function is of limited use
415 # when called on a path instead of upon a handle, because there are
416 # no guarantees that filename (by dirent) whose file (by ino) is
417 # eventually accessed is the same as the one tested.
418 # Assumes that the file's existence is not in doubt.
421 stat($path) || return; # mysteriously vaporized
422 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
424 return 0 if $uid != 0 && $uid != $<;
425 return 0 if $mode & 022;
430 safe_do("./$rcfile");
432 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
433 safe_do("$ENV{HOME}/$rcfile");
435 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
436 safe_do("$ENV{LOGDIR}/$rcfile");
439 if (defined $ENV{PERLDB_OPTS}) {
440 parse_options($ENV{PERLDB_OPTS});
443 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
444 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
445 *get_fork_TTY = \&xterm_get_fork_TTY;
446 } elsif ($^O eq 'os2') {
447 *get_fork_TTY = \&os2_get_fork_TTY;
450 # Here begin the unreadable code. It needs fixing.
452 if (exists $ENV{PERLDB_RESTART}) {
453 delete $ENV{PERLDB_RESTART};
455 @hist = get_list('PERLDB_HIST');
456 %break_on_load = get_list("PERLDB_ON_LOAD");
457 %postponed = get_list("PERLDB_POSTPONE");
458 my @had_breakpoints= get_list("PERLDB_VISITED");
459 for (0 .. $#had_breakpoints) {
460 my %pf = get_list("PERLDB_FILE_$_");
461 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
463 my %opt = get_list("PERLDB_OPT");
465 while (($opt,$val) = each %opt) {
466 $val =~ s/[\\\']/\\$1/g;
467 parse_options("$opt'$val'");
469 @INC = get_list("PERLDB_INC");
471 $pretype = [get_list("PERLDB_PRETYPE")];
472 $pre = [get_list("PERLDB_PRE")];
473 $post = [get_list("PERLDB_POST")];
474 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
480 # Is Perl being run from a slave editor or graphical debugger?
481 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
482 $rl = 0, shift(@main::ARGV) if $slave_editor;
484 #require Term::ReadLine;
486 if ($^O eq 'cygwin') {
487 # /dev/tty is binary. use stdin for textmode
489 } elsif (-e "/dev/tty") {
490 $console = "/dev/tty";
491 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
493 } elsif ($^O eq 'MacOS') {
494 if ($MacPerl::Version !~ /MPW/) {
495 $console = "Dev:Console:Perl Debug"; # Separate window for application
497 $console = "Dev:Console";
500 $console = "sys\$command";
503 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
507 if ($^O eq 'NetWare') {
512 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
520 $console = $tty if defined $tty;
522 if (defined $remoteport) {
524 $OUT = new IO::Socket::INET( Timeout => '10',
525 PeerAddr => $remoteport,
528 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
530 } elsif ($CreateTTY & 4) {
533 if (defined $console) {
534 my ($i, $o) = split /,/, $console;
535 $o = $i unless defined $o;
536 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
537 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
538 || open(OUT,">&STDOUT"); # so we don't dongle stdout
541 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
542 $console = 'STDIN/OUT';
544 # so open("|more") can read from STDOUT and so we don't dingle stdin
549 my $previous = select($OUT);
550 $| = 1; # for DB::OUT
553 $LINEINFO = $OUT unless defined $LINEINFO;
554 $lineinfo = $console unless defined $lineinfo;
556 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
557 unless ($runnonstop) {
558 if ($term_pid eq '-1') {
559 print $OUT "\nDaughter DB session started...\n";
561 print $OUT "\nLoading DB routines from $header\n";
562 print $OUT ("Editor support ",
563 $slave_editor ? "enabled" : "available",
565 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
573 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
576 if (defined &afterinit) { # May be defined in $rcfile
582 ############################################################ Subroutines
585 # _After_ the perl program is compiled, $single is set to 1:
586 if ($single and not $second_time++) {
587 if ($runnonstop) { # Disable until signal
588 for ($i=0; $i <= $stack_depth; ) {
592 # return; # Would not print trace!
593 } elsif ($ImmediateStop) {
598 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
600 ($package, $filename, $line) = caller;
601 $filename_ini = $filename;
602 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
603 "package $package;"; # this won't let them modify, alas
604 local(*dbline) = $main::{'_<' . $filename};
606 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
610 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
611 $dbline{$line} =~ s/;9($|\0)/$1/;
614 my $was_signal = $signal;
616 for (my $n = 0; $n <= $#to_watch; $n++) {
617 $evalarg = $to_watch[$n];
618 local $onetimeDump; # Do not output results
619 my ($val) = &eval; # Fix context (&eval is doing array)?
620 $val = ( (defined $val) ? "'$val'" : 'undef' );
621 if ($val ne $old_watch[$n]) {
624 Watchpoint $n:\t$to_watch[$n] changed:
625 old value:\t$old_watch[$n]
628 $old_watch[$n] = $val;
632 if ($trace & 4) { # User-installed watch
633 return if watchfunction($package, $filename, $line)
634 and not $single and not $was_signal and not ($trace & ~4);
636 $was_signal = $signal;
638 if ($single || ($trace & 1) || $was_signal) {
640 $position = "\032\032$filename:$line:0\n";
641 print_lineinfo($position);
642 } elsif ($package eq 'DB::fake') {
645 Debugged program terminated. Use B<q> to quit or B<R> to restart,
646 use B<O> I<inhibit_exit> to avoid stopping after program termination,
647 B<h q>, B<h R> or B<h O> to get additional info.
650 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
651 "package $package;"; # this won't let them modify, alas
654 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
655 $prefix .= "$sub($filename:";
656 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
657 if (length($prefix) > 30) {
658 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
663 $position = "$prefix$line$infix$dbline[$line]$after";
666 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
668 print_lineinfo($position);
670 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
671 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
673 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
674 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
675 $position .= $incr_pos;
677 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
679 print_lineinfo($incr_pos);
684 $evalarg = $action, &eval if $action;
685 if ($single || $was_signal) {
686 local $level = $level + 1;
687 foreach $evalarg (@$pre) {
690 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
693 $incr = -1; # for backward motion.
694 @typeahead = (@$pretype, @typeahead);
696 while (($term || &setterm),
697 ($term_pid == $$ or resetterm(1)),
698 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
699 ($#hist+1) . ('>' x $level) .
704 $cmd =~ s/\\$/\n/ && do {
705 $cmd .= &readline(" cont: ");
708 $cmd =~ /^$/ && ($cmd = $laststep);
709 push(@hist,$cmd) if length($cmd) > 1;
711 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
712 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
713 ($i) = split(/\s+/,$cmd);
715 # squelch the sigmangler
717 local $SIG{__WARN__};
718 eval "\$cmd =~ $alias{$i}";
720 print $OUT "Couldn't evaluate `$i' alias: $@";
724 $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
725 $cmd =~ /^h$/ && do {
728 $cmd =~ /^h\s+h$/ && do {
729 print_help($summary);
731 # support long commands; otherwise bogus errors
732 # happen when you ask for h on <CR> for example
733 $cmd =~ /^h\s+(\S.*)$/ && do {
734 my $asked = $1; # for proper errmsg
735 my $qasked = quotemeta($asked); # for searching
736 # XXX: finds CR but not <CR>
737 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
738 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
742 print_help("B<$asked> is not a debugger command.\n");
745 $cmd =~ /^t$/ && do {
747 print $OUT "Trace = " .
748 (($trace & 1) ? "on" : "off" ) . "\n";
750 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
751 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
752 foreach $subname (sort(keys %sub)) {
753 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
754 print $OUT $subname,"\n";
758 $cmd =~ /^v$/ && do {
759 list_versions(); next CMD};
760 $cmd =~ s/^X\b/V $package/;
761 $cmd =~ /^V$/ && do {
762 $cmd = "V $package"; };
763 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
764 local ($savout) = select($OUT);
766 @vars = split(' ',$2);
767 do 'dumpvar.pl' unless defined &main::dumpvar;
768 if (defined &main::dumpvar) {
771 # must detect sigpipe failures
772 eval { &main::dumpvar($packname,@vars) };
774 die unless $@ =~ /dumpvar print failed/;
777 print $OUT "dumpvar.pl not available.\n";
781 $cmd =~ s/^x\b/ / && do { # So that will be evaled
782 $onetimeDump = 'dump'; };
783 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
784 methods($1); next CMD};
785 $cmd =~ s/^m\b/ / && do { # So this will be evaled
786 $onetimeDump = 'methods'; };
787 $cmd =~ /^f\b\s*(.*)/ && do {
791 print $OUT "The old f command is now the r command.\n";
792 print $OUT "The new f command switches filenames.\n";
795 if (!defined $main::{'_<' . $file}) {
796 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
797 $try = substr($try,2);
798 print $OUT "Choosing $try matching `$file':\n";
802 if (!defined $main::{'_<' . $file}) {
803 print $OUT "No file matching `$file' is loaded.\n";
805 } elsif ($file ne $filename) {
806 *dbline = $main::{'_<' . $file};
812 print $OUT "Already in $file.\n";
816 $cmd =~ s/^l\s+-\s*$/-/;
817 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
820 print($OUT "Error: $@\n"), next CMD if $@;
822 print($OUT "Interpreted as: $1 $s\n");
825 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
826 my $s = $subname = $1;
827 $subname =~ s/\'/::/;
828 $subname = $package."::".$subname
829 unless $subname =~ /::/;
830 $subname = "CORE::GLOBAL::$s"
831 if not defined &$subname and $s !~ /::/
832 and defined &{"CORE::GLOBAL::$s"};
833 $subname = "main".$subname if substr($subname,0,2) eq "::";
834 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
835 $subrange = pop @pieces;
836 $file = join(':', @pieces);
837 if ($file ne $filename) {
838 print $OUT "Switching to file '$file'.\n"
839 unless $slave_editor;
840 *dbline = $main::{'_<' . $file};
845 if (eval($subrange) < -$window) {
846 $subrange =~ s/-.*/+/;
848 $cmd = "l $subrange";
850 print $OUT "Subroutine $subname not found.\n";
853 $cmd =~ /^\.$/ && do {
854 $incr = -1; # for backward motion.
856 $filename = $filename_ini;
857 *dbline = $main::{'_<' . $filename};
859 print_lineinfo($position);
861 $cmd =~ /^w\b\s*(\d*)$/ && do {
865 #print $OUT 'l ' . $start . '-' . ($start + $incr);
866 $cmd = 'l ' . $start . '-' . ($start + $incr); };
867 $cmd =~ /^-$/ && do {
868 $start -= $incr + $window + 1;
869 $start = 1 if $start <= 0;
871 $cmd = 'l ' . ($start) . '+'; };
872 $cmd =~ /^l$/ && do {
874 $cmd = 'l ' . $start . '-' . ($start + $incr); };
875 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
878 $incr = $window - 1 unless $incr;
879 $cmd = 'l ' . $start . '-' . ($start + $incr); };
880 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
881 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
882 $end = $max if $end > $max;
884 $i = $line if $i eq '.';
888 print $OUT "\032\032$filename:$i:0\n";
891 for (; $i <= $end; $i++) {
893 ($stop,$action) = split(/\0/, $dbline{$i}) if
896 and $filename eq $filename_ini)
898 : ($dbline[$i]+0 ? ':' : ' ') ;
899 $arrow .= 'b' if $stop;
900 $arrow .= 'a' if $action;
901 print $OUT "$i$arrow\t", $dbline[$i];
902 $i++, last if $signal;
904 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
906 $start = $i; # remember in case they want more
907 $start = $max if $start > $max;
909 $cmd =~ /^D$/ && do {
910 print $OUT "Deleting all breakpoints...\n";
912 for $file (keys %had_breakpoints) {
913 local *dbline = $main::{'_<' . $file};
917 for ($i = 1; $i <= $max ; $i++) {
918 if (defined $dbline{$i}) {
919 $dbline{$i} =~ s/^[^\0]+//;
920 if ($dbline{$i} =~ s/^\0?$//) {
926 if (not $had_breakpoints{$file} &= ~1) {
927 delete $had_breakpoints{$file};
931 undef %postponed_file;
932 undef %break_on_load;
934 $cmd =~ /^L$/ && do {
936 for $file (keys %had_breakpoints) {
937 local *dbline = $main::{'_<' . $file};
941 for ($i = 1; $i <= $max; $i++) {
942 if (defined $dbline{$i}) {
943 print $OUT "$file:\n" unless $was++;
944 print $OUT " $i:\t", $dbline[$i];
945 ($stop,$action) = split(/\0/, $dbline{$i});
946 print $OUT " break if (", $stop, ")\n"
948 print $OUT " action: ", $action, "\n"
955 print $OUT "Postponed breakpoints in subroutines:\n";
957 for $subname (keys %postponed) {
958 print $OUT " $subname\t$postponed{$subname}\n";
962 my @have = map { # Combined keys
963 keys %{$postponed_file{$_}}
964 } keys %postponed_file;
966 print $OUT "Postponed breakpoints in files:\n";
968 for $file (keys %postponed_file) {
969 my $db = $postponed_file{$file};
970 print $OUT " $file:\n";
971 for $line (sort {$a <=> $b} keys %$db) {
972 print $OUT " $line:\n";
973 my ($stop,$action) = split(/\0/, $$db{$line});
974 print $OUT " break if (", $stop, ")\n"
976 print $OUT " action: ", $action, "\n"
983 if (%break_on_load) {
984 print $OUT "Breakpoints on load:\n";
986 for $file (keys %break_on_load) {
987 print $OUT " $file\n";
992 print $OUT "Watch-expressions:\n";
994 for $expr (@to_watch) {
995 print $OUT " $expr\n";
1000 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
1001 my $file = $1; $file =~ s/\s+$//;
1004 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
1005 my $cond = length $3 ? $3 : '1';
1006 my ($subname, $break) = ($2, $1 eq 'postpone');
1007 $subname =~ s/\'/::/g;
1008 $subname = "${'package'}::" . $subname
1009 unless $subname =~ /::/;
1010 $subname = "main".$subname if substr($subname,0,2) eq "::";
1011 $postponed{$subname} = $break
1012 ? "break +0 if $cond" : "compile";
1014 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1016 $cond = length $2 ? $2 : '1';
1017 cmd_b_sub($subname, $cond);
1019 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1021 $cond = length $2 ? $2 : '1';
1022 cmd_b_line($i, $cond);
1024 $cmd =~ /^d\b\s*(\d*)/ && do {
1027 $cmd =~ /^A$/ && do {
1028 print $OUT "Deleting all actions...\n";
1030 for $file (keys %had_breakpoints) {
1031 local *dbline = $main::{'_<' . $file};
1035 for ($i = 1; $i <= $max ; $i++) {
1036 if (defined $dbline{$i}) {
1037 $dbline{$i} =~ s/\0[^\0]*//;
1038 delete $dbline{$i} if $dbline{$i} eq '';
1042 unless ($had_breakpoints{$file} &= ~2) {
1043 delete $had_breakpoints{$file};
1047 $cmd =~ /^O\s*$/ && do {
1052 $cmd =~ /^O\s*(\S.*)/ && do {
1055 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1056 push @$pre, action($1);
1058 $cmd =~ /^>>\s*(.*)/ && do {
1059 push @$post, action($1);
1061 $cmd =~ /^<\s*(.*)/ && do {
1063 print $OUT "All < actions cleared.\n";
1069 print $OUT "No pre-prompt Perl actions.\n";
1072 print $OUT "Perl commands run before each prompt:\n";
1073 for my $action ( @$pre ) {
1074 print $OUT "\t< -- $action\n";
1078 $pre = [action($1)];
1080 $cmd =~ /^>\s*(.*)/ && do {
1082 print $OUT "All > actions cleared.\n";
1088 print $OUT "No post-prompt Perl actions.\n";
1091 print $OUT "Perl commands run after each prompt:\n";
1092 for my $action ( @$post ) {
1093 print $OUT "\t> -- $action\n";
1097 $post = [action($1)];
1099 $cmd =~ /^\{\{\s*(.*)/ && do {
1100 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1101 print $OUT "{{ is now a debugger command\n",
1102 "use `;{{' if you mean Perl code\n";
1108 $cmd =~ /^\{\s*(.*)/ && do {
1110 print $OUT "All { actions cleared.\n";
1115 unless (@$pretype) {
1116 print $OUT "No pre-prompt debugger actions.\n";
1119 print $OUT "Debugger commands run before each prompt:\n";
1120 for my $action ( @$pretype ) {
1121 print $OUT "\t{ -- $action\n";
1125 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1126 print $OUT "{ is now a debugger command\n",
1127 "use `;{' if you mean Perl code\n";
1133 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1134 $i = $1 || $line; $j = $2;
1136 if ($dbline[$i] == 0) {
1137 print $OUT "Line $i may not have an action.\n";
1139 $had_breakpoints{$filename} |= 2;
1140 $dbline{$i} =~ s/\0[^\0]*//;
1141 $dbline{$i} .= "\0" . action($j);
1144 $dbline{$i} =~ s/\0[^\0]*//;
1145 delete $dbline{$i} if $dbline{$i} eq '';
1148 $cmd =~ /^n$/ && do {
1149 end_report(), next CMD if $finished and $level <= 1;
1153 $cmd =~ /^s$/ && do {
1154 end_report(), next CMD if $finished and $level <= 1;
1158 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1159 end_report(), next CMD if $finished and $level <= 1;
1161 # Probably not needed, since we finish an interactive
1162 # sub-session anyway...
1163 # local $filename = $filename;
1164 # local *dbline = *dbline; # XXX Would this work?!
1165 if ($i =~ /\D/) { # subroutine name
1166 $subname = $package."::".$subname
1167 unless $subname =~ /::/;
1168 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1172 *dbline = $main::{'_<' . $filename};
1173 $had_breakpoints{$filename} |= 1;
1175 ++$i while $dbline[$i] == 0 && $i < $max;
1177 print $OUT "Subroutine $subname not found.\n";
1182 if ($dbline[$i] == 0) {
1183 print $OUT "Line $i not breakable.\n";
1186 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1188 for ($i=0; $i <= $stack_depth; ) {
1192 $cmd =~ /^r$/ && do {
1193 end_report(), next CMD if $finished and $level <= 1;
1194 $stack[$stack_depth] |= 1;
1195 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1197 $cmd =~ /^R$/ && do {
1198 print $OUT "Warning: some settings and command-line options may be lost!\n";
1199 my (@script, @flags, $cl);
1200 push @flags, '-w' if $ini_warn;
1201 # Put all the old includes at the start to get
1202 # the same debugger.
1204 push @flags, '-I', $_;
1206 # Arrange for setting the old INC:
1207 set_list("PERLDB_INC", @ini_INC);
1209 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1210 chomp ($cl = ${'::_<-e'}[$_]);
1211 push @script, '-e', $cl;
1216 set_list("PERLDB_HIST",
1217 $term->Features->{getHistory}
1218 ? $term->GetHistory : @hist);
1219 my @had_breakpoints = keys %had_breakpoints;
1220 set_list("PERLDB_VISITED", @had_breakpoints);
1221 set_list("PERLDB_OPT", %option);
1222 set_list("PERLDB_ON_LOAD", %break_on_load);
1224 for (0 .. $#had_breakpoints) {
1225 my $file = $had_breakpoints[$_];
1226 *dbline = $main::{'_<' . $file};
1227 next unless %dbline or $postponed_file{$file};
1228 (push @hard, $file), next
1229 if $file =~ /^\(\w*eval/;
1231 @add = %{$postponed_file{$file}}
1232 if $postponed_file{$file};
1233 set_list("PERLDB_FILE_$_", %dbline, @add);
1235 for (@hard) { # Yes, really-really...
1236 # Find the subroutines in this eval
1237 *dbline = $main::{'_<' . $_};
1238 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1239 for $sub (keys %sub) {
1240 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1241 $subs{$sub} = [$1, $2];
1245 "No subroutines in $_, ignoring breakpoints.\n";
1248 LINES: for $line (keys %dbline) {
1249 # One breakpoint per sub only:
1250 my ($offset, $sub, $found);
1251 SUBS: for $sub (keys %subs) {
1252 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1253 and (not defined $offset # Not caught
1254 or $offset < 0 )) { # or badly caught
1256 $offset = $line - $subs{$sub}->[0];
1257 $offset = "+$offset", last SUBS if $offset >= 0;
1260 if (defined $offset) {
1261 $postponed{$found} =
1262 "break $offset if $dbline{$line}";
1264 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1268 set_list("PERLDB_POSTPONE", %postponed);
1269 set_list("PERLDB_PRETYPE", @$pretype);
1270 set_list("PERLDB_PRE", @$pre);
1271 set_list("PERLDB_POST", @$post);
1272 set_list("PERLDB_TYPEAHEAD", @typeahead);
1273 $ENV{PERLDB_RESTART} = 1;
1274 delete $ENV{PERLDB_PIDS}; # Restore ini state
1275 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1276 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1277 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1278 print $OUT "exec failed: $!\n";
1280 $cmd =~ /^T$/ && do {
1281 print_trace($OUT, 1); # skip DB
1283 $cmd =~ /^W\s*$/ && do {
1285 @to_watch = @old_watch = ();
1287 $cmd =~ /^W\b\s*(.*)/s && do {
1291 $val = (defined $val) ? "'$val'" : 'undef' ;
1292 push @old_watch, $val;
1295 $cmd =~ /^\/(.*)$/ && do {
1297 $inpat =~ s:([^\\])/$:$1:;
1299 # squelch the sigmangler
1300 local $SIG{__DIE__};
1301 local $SIG{__WARN__};
1302 eval '$inpat =~ m'."\a$inpat\a";
1314 $start = 1 if ($start > $max);
1315 last if ($start == $end);
1316 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1317 if ($slave_editor) {
1318 print $OUT "\032\032$filename:$start:0\n";
1320 print $OUT "$start:\t", $dbline[$start], "\n";
1325 print $OUT "/$pat/: not found\n" if ($start == $end);
1327 $cmd =~ /^\?(.*)$/ && do {
1329 $inpat =~ s:([^\\])\?$:$1:;
1331 # squelch the sigmangler
1332 local $SIG{__DIE__};
1333 local $SIG{__WARN__};
1334 eval '$inpat =~ m'."\a$inpat\a";
1346 $start = $max if ($start <= 0);
1347 last if ($start == $end);
1348 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1349 if ($slave_editor) {
1350 print $OUT "\032\032$filename:$start:0\n";
1352 print $OUT "$start:\t", $dbline[$start], "\n";
1357 print $OUT "?$pat?: not found\n" if ($start == $end);
1359 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1360 pop(@hist) if length($cmd) > 1;
1361 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1363 print $OUT $cmd, "\n";
1365 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1368 $cmd =~ /^$rc([^$rc].*)$/ && do {
1370 pop(@hist) if length($cmd) > 1;
1371 for ($i = $#hist; $i; --$i) {
1372 last if $hist[$i] =~ /$pat/;
1375 print $OUT "No such command!\n\n";
1379 print $OUT $cmd, "\n";
1381 $cmd =~ /^$sh$/ && do {
1382 &system($ENV{SHELL}||"/bin/sh");
1384 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1385 # XXX: using csh or tcsh destroys sigint retvals!
1386 #&system($1); # use this instead
1387 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1389 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1390 $end = $2 ? ($#hist-$2) : 0;
1391 $hist = 0 if $hist < 0;
1392 for ($i=$#hist; $i>$end; $i--) {
1393 print $OUT "$i: ",$hist[$i],"\n"
1394 unless $hist[$i] =~ /^.?$/;
1397 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1400 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1401 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1402 $cmd =~ s/^=\s*// && do {
1404 if (length $cmd == 0) {
1405 @keys = sort keys %alias;
1407 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1408 # can't use $_ or kill //g state
1409 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1410 $alias{$k} = "s\a$k\a$v\a";
1411 # squelch the sigmangler
1412 local $SIG{__DIE__};
1413 local $SIG{__WARN__};
1414 unless (eval "sub { s\a$k\a$v\a }; 1") {
1415 print $OUT "Can't alias $k to $v: $@\n";
1425 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1426 print $OUT "$k\t= $1\n";
1428 elsif (defined $alias{$k}) {
1429 print $OUT "$k\t$alias{$k}\n";
1432 print "No alias for $k\n";
1436 $cmd =~ /^\|\|?\s*[^|]/ && do {
1437 if ($pager =~ /^\|/) {
1438 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1439 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1441 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1444 unless ($piped=open(OUT,$pager)) {
1445 &warn("Can't pipe output to `$pager'");
1446 if ($pager =~ /^\|/) {
1447 open(OUT,">&STDOUT") # XXX: lost message
1448 || &warn("Can't restore DB::OUT");
1449 open(STDOUT,">&SAVEOUT")
1450 || &warn("Can't restore STDOUT");
1453 open(OUT,">&STDOUT") # XXX: lost message
1454 || &warn("Can't restore DB::OUT");
1458 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1459 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1460 $selected= select(OUT);
1462 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1463 $cmd =~ s/^\|+\s*//;
1466 # XXX Local variants do not work!
1467 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1468 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1469 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1471 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1473 $onetimeDump = undef;
1474 } elsif ($term_pid == $$) {
1479 if ($pager =~ /^\|/) {
1481 # we cannot warn here: the handle is missing --tchrist
1482 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1484 # most of the $? crud was coping with broken cshisms
1486 print SAVEOUT "Pager `$pager' failed: ";
1488 print SAVEOUT "shell returned -1\n";
1491 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1492 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1494 print SAVEOUT "status ", ($? >> 8), "\n";
1498 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1499 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1500 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1501 # Will stop ignoring SIGPIPE if done like nohup(1)
1502 # does SIGINT but Perl doesn't give us a choice.
1504 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1507 select($selected), $selected= "" unless $selected eq "";
1511 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1512 foreach $evalarg (@$post) {
1515 } # if ($single || $signal)
1516 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1520 # The following code may be executed now:
1524 my ($al, $ret, @ret) = "";
1525 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1528 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1529 $#stack = $stack_depth;
1530 $stack[-1] = $single;
1532 $single |= 4 if $stack_depth == $deep;
1534 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1535 # Why -1? But it works! :-(
1536 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1537 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1540 $single |= $stack[$stack_depth--];
1542 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1543 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1544 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1545 if ($doret eq $stack_depth or $frame & 16) {
1546 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1547 print $fh ' ' x $stack_depth if $frame & 16;
1548 print $fh "list context return from $sub:\n";
1549 dumpit($fh, \@ret );
1554 if (defined wantarray) {
1559 $single |= $stack[$stack_depth--];
1561 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1562 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1563 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1564 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1565 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1566 print $fh (' ' x $stack_depth) if $frame & 16;
1567 print $fh (defined wantarray
1568 ? "scalar context return from $sub: "
1569 : "void context return from $sub\n");
1570 dumpit( $fh, $ret ) if defined wantarray;
1579 ### Functions with multiple modes of failure die on error, the rest
1580 ### returns FALSE on error.
1581 ### User-interface functions cmd_* output error message.
1585 $break_on_load{$file} = 1;
1586 $had_breakpoints{$file} |= 1;
1589 sub report_break_on_load {
1590 sort keys %break_on_load;
1598 push @files, $::INC{$file} if $::INC{$file};
1599 $file .= '.pm', redo unless $file =~ /\./;
1601 break_on_load($_) for @files;
1602 @files = report_break_on_load;
1603 print $OUT "Will stop on load of `@files'.\n";
1606 $filename_error = '';
1608 sub breakable_line {
1609 my ($from, $to) = @_;
1612 my $delta = $from < $to ? +1 : -1;
1613 my $limit = $delta > 0 ? $#dbline : 1;
1614 $limit = $to if ($limit - $to) * $delta > 0;
1615 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1617 return $i unless $dbline[$i] == 0;
1618 my ($pl, $upto) = ('', '');
1619 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1620 die "Line$pl $from$upto$filename_error not breakable\n";
1623 sub breakable_line_in_filename {
1625 local *dbline = $main::{'_<' . $f};
1626 local $filename_error = " of `$f'";
1631 my ($i, $cond) = @_;
1632 $cond = 1 unless @_ >= 2;
1636 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1637 $had_breakpoints{$filename} |= 1;
1638 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1639 else { $dbline{$i} = $cond; }
1643 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1646 sub break_on_filename_line {
1647 my ($f, $i, $cond) = @_;
1648 $cond = 1 unless @_ >= 3;
1649 local *dbline = $main::{'_<' . $f};
1650 local $filename_error = " of `$f'";
1651 local $filename = $f;
1652 break_on_line($i, $cond);
1655 sub break_on_filename_line_range {
1656 my ($f, $from, $to, $cond) = @_;
1657 my $i = breakable_line_in_filename($f, $from, $to);
1658 $cond = 1 unless @_ >= 3;
1659 break_on_filename_line($f,$i,$cond);
1662 sub subroutine_filename_lines {
1663 my ($subname,$cond) = @_;
1664 # Filename below can contain ':'
1665 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1668 sub break_subroutine {
1669 my $subname = shift;
1670 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1671 die "Subroutine $subname not found.\n";
1672 $cond = 1 unless @_ >= 2;
1673 break_on_filename_line_range($file,$s,$e,@_);
1677 my ($subname,$cond) = @_;
1678 $cond = 1 unless @_ >= 2;
1679 unless (ref $subname eq 'CODE') {
1680 $subname =~ s/\'/::/g;
1682 $subname = "${'package'}::" . $subname
1683 unless $subname =~ /::/;
1684 $subname = "CORE::GLOBAL::$s"
1685 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1686 $subname = "main".$subname if substr($subname,0,2) eq "::";
1688 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1691 sub cmd_stop { # As on ^C, but not signal-safy.
1695 sub delete_breakpoint {
1697 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1698 $dbline{$i} =~ s/^[^\0]*//;
1699 delete $dbline{$i} if $dbline{$i} eq '';
1704 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1707 ### END of the API section
1710 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1711 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1714 sub print_lineinfo {
1715 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1719 # The following takes its argument via $evalarg to preserve current @_
1722 # 'my' would make it visible from user code
1723 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1726 local $otrace = $trace;
1727 local $osingle = $single;
1729 { ($evalarg) = $evalarg =~ /(.*)/s; }
1730 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1736 local $saved[0]; # Preserve the old value of $@
1740 } elsif ($onetimeDump) {
1741 dumpit($OUT, \@res) if $onetimeDump eq 'dump';
1742 methods($res[0]) if $onetimeDump eq 'methods';
1748 my $subname = shift;
1749 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1750 my $offset = $1 || 0;
1751 # Filename below can contain ':'
1752 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1755 local *dbline = $main::{'_<' . $file};
1756 local $^W = 0; # != 0 is magical below
1757 $had_breakpoints{$file} |= 1;
1759 ++$i until $dbline[$i] != 0 or $i >= $max;
1760 $dbline{$i} = delete $postponed{$subname};
1762 print $OUT "Subroutine $subname not found.\n";
1766 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1767 #print $OUT "In postponed_sub for `$subname'.\n";
1771 if ($ImmediateStop) {
1775 return &postponed_sub
1776 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1777 # Cannot be done before the file is compiled
1778 local *dbline = shift;
1779 my $filename = $dbline;
1780 $filename =~ s/^_<//;
1781 $signal = 1, print $OUT "'$filename' loaded...\n"
1782 if $break_on_load{$filename};
1783 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1784 return unless $postponed_file{$filename};
1785 $had_breakpoints{$filename} |= 1;
1786 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1788 for $key (keys %{$postponed_file{$filename}}) {
1789 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1791 delete $postponed_file{$filename};
1795 local ($savout) = select(shift);
1796 my $osingle = $single;
1797 my $otrace = $trace;
1798 $single = $trace = 0;
1801 unless (defined &main::dumpValue) {
1804 if (defined &main::dumpValue) {
1805 &main::dumpValue(shift);
1807 print $OUT "dumpvar.pl not available.\n";
1814 # Tied method do not create a context, so may get wrong message:
1818 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1819 my @sub = dump_trace($_[0] + 1, $_[1]);
1820 my $short = $_[2]; # Print short report, next one for sub name
1822 for ($i=0; $i <= $#sub; $i++) {
1825 my $args = defined $sub[$i]{args}
1826 ? "(@{ $sub[$i]{args} })"
1828 $args = (substr $args, 0, $maxtrace - 3) . '...'
1829 if length $args > $maxtrace;
1830 my $file = $sub[$i]{file};
1831 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1833 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1835 my $sub = @_ >= 4 ? $_[3] : $s;
1836 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1838 print $fh "$sub[$i]{context} = $s$args" .
1839 " called from $file" .
1840 " line $sub[$i]{line}\n";
1847 my $count = shift || 1e9;
1850 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1851 my $nothard = not $frame & 8;
1852 local $frame = 0; # Do not want to trace this.
1853 my $otrace = $trace;
1856 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1861 if (not defined $arg) {
1863 } elsif ($nothard and tied $arg) {
1865 } elsif ($nothard and $type = ref $arg) {
1866 push @a, "ref($type)";
1868 local $_ = "$arg"; # Safe to stringify now - should not call f().
1871 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1872 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1873 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1877 $context = $context ? '@' : (defined $context ? "\$" : '.');
1878 $args = $h ? [@a] : undef;
1879 $e =~ s/\n\s*\;\s*\Z// if $e;
1880 $e =~ s/([\\\'])/\\$1/g if $e;
1882 $sub = "require '$e'";
1883 } elsif (defined $r) {
1885 } elsif ($sub eq '(eval)') {
1886 $sub = "eval {...}";
1888 push(@sub, {context => $context, sub => $sub, args => $args,
1889 file => $file, line => $line});
1898 while ($action =~ s/\\$//) {
1907 # i hate using globals!
1908 $balanced_brace_re ||= qr{
1911 (?> [^{}] + ) # Non-parens without backtracking
1913 (??{ $balanced_brace_re }) # Group with matching parens
1917 return $_[0] !~ m/$balanced_brace_re/;
1921 &readline("cont: ");
1925 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1926 # some non-Unix systems can do system() but have problems with fork().
1927 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1928 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1929 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1930 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1932 # XXX: using csh or tcsh destroys sigint retvals!
1934 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1935 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1940 # most of the $? crud was coping with broken cshisms
1942 &warn("(Command exited ", ($? >> 8), ")\n");
1944 &warn( "(Command died of SIG#", ($? & 127),
1945 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1955 eval { require Term::ReadLine } or die $@;
1958 my ($i, $o) = split $tty, /,/;
1959 $o = $i unless defined $o;
1960 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1961 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1964 my $sel = select($OUT);
1968 eval "require Term::Rendezvous;" or die;
1969 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1970 my $term_rv = new Term::Rendezvous $rv;
1972 $OUT = $term_rv->OUT;
1975 if ($term_pid eq '-1') { # In a TTY with another debugger
1979 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1981 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1983 $rl_attribs = $term->Attribs;
1984 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1985 if defined $rl_attribs->{basic_word_break_characters}
1986 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1987 $rl_attribs->{special_prefixes} = '$@&%';
1988 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1989 $rl_attribs->{completion_function} = \&db_complete;
1991 $LINEINFO = $OUT unless defined $LINEINFO;
1992 $lineinfo = $console unless defined $lineinfo;
1994 if ($term->Features->{setHistory} and "@hist" ne "?") {
1995 $term->SetHistory(@hist);
1997 ornaments($ornaments) if defined $ornaments;
2001 # Example get_fork_TTY functions
2002 sub xterm_get_fork_TTY {
2003 (my $name = $0) =~ s,^.*[/\\],,s;
2004 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2008 $pidprompt = ''; # Shown anyway in titlebar
2012 # This one resets $IN, $OUT itself
2013 sub os2_get_fork_TTY {
2014 $^F = 40; # XXXX Fixme!
2015 my ($in1, $out1, $in2, $out2);
2016 # Having -d in PERL5OPT would lead to a disaster...
2017 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2018 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2019 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2020 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2021 (my $name = $0) =~ s,^.*[/\\],,s;
2022 if ( pipe $in1, $out1 and pipe $in2, $out2 and
2023 # system P_SESSION will fail if there is another process
2024 # in the same session with a "dependent" asynchronous child session.
2025 (($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
2029 my $in = shift; # Read from here and pass through
2031 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2032 open IN, '<&=$in' or die "open <&=$in: \$!";
2033 \$| = 1; print while sysread IN, \$_, 1<<16;
2037 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2039 ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
2040 print while sysread STDIN, $_, 1<<16;
2042 and close $in1 and close $out2 ) {
2043 $pidprompt = ''; # Shown anyway in titlebar
2044 reset_IN_OUT($in2, $out1);
2046 return ''; # Indicate that reset_IN_OUT is called
2051 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2052 my $in = &get_fork_TTY if defined &get_fork_TTY;
2053 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2054 if (not defined $in) {
2056 print_help(<<EOP) if $why == 1;
2057 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2059 print_help(<<EOP) if $why == 2;
2060 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2061 This may be an asynchronous session, so the parent debugger may be active.
2063 print_help(<<EOP) if $why != 4;
2064 Since two debuggers fight for the same TTY, input is severely entangled.
2068 I know how to switch the output to a different window in xterms
2069 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2070 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2072 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2073 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2076 } elsif ($in ne '') {
2082 sub resetterm { # We forked, so we need a different TTY
2084 my $systemed = $in > 1 ? '-' : '';
2086 $pids =~ s/\]/$systemed->$$]/;
2088 $pids = "[$term_pid->$$]";
2092 return unless $CreateTTY & $in;
2099 my $left = @typeahead;
2100 my $got = shift @typeahead;
2101 print $OUT "auto(-$left)", shift, $got, "\n";
2102 $term->AddHistory($got)
2103 if length($got) > 1 and defined $term->Features->{addHistory};
2108 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2109 $OUT->write(join('', @_));
2111 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2115 $term->readline(@_);
2120 my ($opt, $val)= @_;
2121 $val = option_val($opt,'N/A');
2122 $val =~ s/([\\\'])/\\$1/g;
2123 printf $OUT "%20s = '%s'\n", $opt, $val;
2127 my ($opt, $default)= @_;
2129 if (defined $optionVars{$opt}
2130 and defined ${$optionVars{$opt}}) {
2131 $val = ${$optionVars{$opt}};
2132 } elsif (defined $optionAction{$opt}
2133 and defined &{$optionAction{$opt}}) {
2134 $val = &{$optionAction{$opt}}();
2135 } elsif (defined $optionAction{$opt}
2136 and not defined $option{$opt}
2137 or defined $optionVars{$opt}
2138 and not defined ${$optionVars{$opt}}) {
2141 $val = $option{$opt};
2143 $val = $default unless defined $val;
2149 # too dangerous to let intuitive usage overwrite important things
2150 # defaultion should never be the default
2151 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2152 arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2153 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2158 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2159 my ($opt,$sep) = ($1,$2);
2162 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2164 #&dump_option($opt);
2165 } elsif ($sep !~ /\S/) {
2167 $val = "1"; # this is an evil default; make 'em set it!
2168 } elsif ($sep eq "=") {
2170 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2172 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2176 print OUT qq(Option better cleared using $opt=""\n)
2180 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2181 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2182 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2183 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2184 ($val = $1) =~ s/\\([\\$end])/$1/g;
2188 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2189 || grep( /^\Q$opt/i && ($option = $_), @options );
2191 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2192 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2194 if ($opt_needs_val{$option} && $val_defaulted) {
2195 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2199 $option{$option} = $val if defined $val;
2204 require '$optionRequire{$option}';
2206 } || die # XXX: shouldn't happen
2207 if defined $optionRequire{$option} &&
2210 ${$optionVars{$option}} = $val
2211 if defined $optionVars{$option} &&
2214 &{$optionAction{$option}} ($val)
2215 if defined $optionAction{$option} &&
2216 defined &{$optionAction{$option}} &&
2220 dump_option($option) unless $OUT eq \*STDERR;
2225 my ($stem,@list) = @_;
2227 $ENV{"${stem}_n"} = @list;
2228 for $i (0 .. $#list) {
2230 $val =~ s/\\/\\\\/g;
2231 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2232 $ENV{"${stem}_$i"} = $val;
2239 my $n = delete $ENV{"${stem}_n"};
2241 for $i (0 .. $n - 1) {
2242 $val = delete $ENV{"${stem}_$i"};
2243 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2251 return; # Put nothing on the stack - malloc/free land!
2255 my($msg)= join("",@_);
2256 $msg .= ": $!\n" unless $msg =~ /\n$/;
2261 my $switch_li = $LINEINFO eq $OUT;
2262 if ($term and $term->Features->{newTTY}) {
2263 ($IN, $OUT) = (shift, shift);
2264 $term->newTTY($IN, $OUT);
2266 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2268 ($IN, $OUT) = (shift, shift);
2270 my $o = select $OUT;
2273 $LINEINFO = $OUT if $switch_li;
2277 if (@_ and $term and $term->Features->{newTTY}) {
2278 my ($in, $out) = shift;
2280 ($in, $out) = split /,/, $in, 2;
2284 open IN, $in or die "cannot open `$in' for read: $!";
2285 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2286 reset_IN_OUT(\*IN,\*OUT);
2289 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2290 # Useful if done through PERLDB_OPTS:
2297 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2299 $notty = shift if @_;
2305 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2313 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2315 $remoteport = shift if @_;
2320 if (${$term->Features}{tkRunning}) {
2321 return $term->tkRunning(@_);
2323 print $OUT "tkRunning not supported by current ReadLine package.\n";
2330 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2332 $runnonstop = shift if @_;
2339 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2346 $sh = quotemeta shift;
2347 $sh .= "\\b" if $sh =~ /\w$/;
2351 $psh =~ s/\\(.)/$1/g;
2356 if (defined $term) {
2357 local ($warnLevel,$dieLevel) = (0, 1);
2358 return '' unless $term->Features->{ornaments};
2359 eval { $term->ornaments(@_) } || '';
2367 $rc = quotemeta shift;
2368 $rc .= "\\b" if $rc =~ /\w$/;
2372 $prc =~ s/\\(.)/$1/g;
2377 return $lineinfo unless @_;
2379 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2380 $slave_editor = ($stream =~ /^\|/);
2381 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2382 $LINEINFO = \*LINEINFO;
2383 my $save = select($LINEINFO);
2397 s/^Term::ReadLine::readline$/readline/;
2398 if (defined ${ $_ . '::VERSION' }) {
2399 $version{$file} = "${ $_ . '::VERSION' } from ";
2401 $version{$file} .= $INC{$file};
2403 dumpit($OUT,\%version);
2407 # XXX: make sure there are tabs between the command and explanation,
2408 # or print_help will screw up your formatting if you have
2409 # eeevil ornaments enabled. This is an insane mess.
2413 B<s> [I<expr>] Single step [in I<expr>].
2414 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2415 <B<CR>> Repeat last B<n> or B<s> command.
2416 B<r> Return from current subroutine.
2417 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2418 at the specified position.
2419 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2420 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2421 B<l> I<line> List single I<line>.
2422 B<l> I<subname> List first window of lines from subroutine.
2423 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2424 B<l> List next window of lines.
2425 B<-> List previous window of lines.
2426 B<w> [I<line>] List window around I<line>.
2427 B<.> Return to the executed line.
2428 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2429 I<filename> may be either the full name of the file, or a regular
2430 expression matching the full file name:
2431 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2432 Evals (with saved bodies) are considered to be filenames:
2433 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2434 (in the order of execution).
2435 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2436 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2437 B<L> List all breakpoints and actions.
2438 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2439 B<t> Toggle trace mode.
2440 B<t> I<expr> Trace through execution of I<expr>.
2441 B<b> [I<line>] [I<condition>]
2442 Set breakpoint; I<line> defaults to the current execution line;
2443 I<condition> breaks if it evaluates to true, defaults to '1'.
2444 B<b> I<subname> [I<condition>]
2445 Set breakpoint at first line of subroutine.
2446 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2447 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2448 B<b> B<postpone> I<subname> [I<condition>]
2449 Set breakpoint at first line of subroutine after
2451 B<b> B<compile> I<subname>
2452 Stop after the subroutine is compiled.
2453 B<d> [I<line>] Delete the breakpoint for I<line>.
2454 B<D> Delete all breakpoints.
2455 B<a> [I<line>] I<command>
2456 Set an action to be done before the I<line> is executed;
2457 I<line> defaults to the current execution line.
2458 Sequence is: check for breakpoint/watchpoint, print line
2459 if necessary, do action, prompt user if necessary,
2461 B<a> [I<line>] Delete the action for I<line>.
2462 B<A> Delete all actions.
2463 B<W> I<expr> Add a global watch-expression.
2464 B<W> Delete all watch-expressions.
2465 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2466 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2467 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2468 B<x> I<expr> Evals expression in list context, dumps the result.
2469 B<m> I<expr> Evals expression in list context, prints methods callable
2470 on the first element of the result.
2471 B<m> I<class> Prints methods callable via the given class.
2473 B<<> ? List Perl commands to run before each prompt.
2474 B<<> I<expr> Define Perl command to run before each prompt.
2475 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2476 B<>> ? List Perl commands to run after each prompt.
2477 B<>> I<expr> Define Perl command to run after each prompt.
2478 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2479 B<{> I<db_command> Define debugger command to run before each prompt.
2480 B<{> ? List debugger commands to run before each prompt.
2481 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2482 B<$prc> I<number> Redo a previous command (default previous command).
2483 B<$prc> I<-number> Redo number'th-to-last command.
2484 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2485 See 'B<O> I<recallCommand>' too.
2486 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2487 . ( $rc eq $sh ? "" : "
2488 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2489 See 'B<O> I<shellBang>' too.
2490 B<H> I<-number> Display last number commands (default all).
2491 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2492 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2493 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2494 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2495 I<command> Execute as a perl statement in current package.
2496 B<v> Show versions of loaded modules.
2497 B<R> Pure-man-restart of debugger, some of debugger state
2498 and command-line options may be lost.
2499 Currently the following settings are preserved:
2500 history, breakpoints and actions, debugger B<O>ptions
2501 and the following command-line options: I<-w>, I<-I>, I<-e>.
2503 B<O> [I<opt>] ... Set boolean option to true
2504 B<O> [I<opt>B<?>] Query options
2505 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2506 Set options. Use quotes in spaces in value.
2507 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2508 I<pager> program for output of \"|cmd\";
2509 I<tkRunning> run Tk while prompting (with ReadLine);
2510 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2511 I<inhibit_exit> Allows stepping off the end of the script.
2512 I<ImmediateStop> Debugger should stop as early as possible.
2513 I<RemotePort> Remote hostname:port for remote debugging
2514 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2515 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2516 I<compactDump>, I<veryCompact> change style of array and hash dump;
2517 I<globPrint> whether to print contents of globs;
2518 I<DumpDBFiles> dump arrays holding debugged files;
2519 I<DumpPackages> dump symbol tables of packages;
2520 I<DumpReused> dump contents of \"reused\" addresses;
2521 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2522 I<bareStringify> Do not print the overload-stringified value;
2523 Other options include:
2524 I<PrintRet> affects printing of return value after B<r> command,
2525 I<frame> affects printing messages on subroutine entry/exit.
2526 I<AutoTrace> affects printing messages on possible breaking points.
2527 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2528 I<ornaments> affects screen appearance of the command line.
2529 I<CreateTTY> bits control attempts to create a new TTY on events:
2530 1: on fork() 2: debugger is started inside debugger
2532 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2533 You can put additional initialization options I<TTY>, I<noTTY>,
2534 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2535 `B<R>' after you set them).
2537 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2538 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2539 B<h h> Summary of debugger commands.
2540 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2541 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2542 Set B<\$DB::doccmd> to change viewer.
2544 Type `|h' for a paged display if this was too hard to read.
2546 "; # Fix balance of vi % matching: }}}}
2548 # note: tabs in the following section are not-so-helpful
2549 $summary = <<"END_SUM";
2550 I<List/search source lines:> I<Control script execution:>
2551 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2552 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2553 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2554 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2555 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2556 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2557 I<Debugger controls:> B<L> List break/watch/actions
2558 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2559 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2560 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2561 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2562 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2563 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2564 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2565 B<q> or B<^D> Quit B<R> Attempt a restart
2566 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2567 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2568 B<p> I<expr> Print expression (uses script's current package).
2569 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2570 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2571 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2572 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2574 # ')}}; # Fix balance of vi % matching
2580 # Restore proper alignment destroyed by eeevil I<> and B<>
2581 # ornaments: A pox on both their houses!
2583 # A help command will have everything up to and including
2584 # the first tab sequence padded into a field 16 (or if indented 20)
2585 # wide. If it's wider than that, an extra space will be added.
2587 ^ # only matters at start of line
2588 ( \040{4} | \t )* # some subcommands are indented
2589 ( < ? # so <CR> works
2590 [BI] < [^\t\n] + ) # find an eeevil ornament
2591 ( \t+ ) # original separation, discarded
2592 ( .* ) # this will now start (no earlier) than
2595 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2596 my $clean = $command;
2597 $clean =~ s/[BI]<([^>]*)>/$1/g;
2598 # replace with this whole string:
2599 ($leadwhite ? " " x 4 : "")
2601 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2606 s{ # handle bold ornaments
2607 B < ( [^>] + | > ) >
2609 $Term::ReadLine::TermCap::rl_term_set[2]
2611 . $Term::ReadLine::TermCap::rl_term_set[3]
2614 s{ # handle italic ornaments
2615 I < ( [^>] + | > ) >
2617 $Term::ReadLine::TermCap::rl_term_set[0]
2619 . $Term::ReadLine::TermCap::rl_term_set[1]
2626 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2627 my $is_less = $pager =~ /\bless\b/;
2628 if ($pager =~ /\bmore\b/) {
2629 my @st_more = stat('/usr/bin/more');
2630 my @st_less = stat('/usr/bin/less');
2631 $is_less = @st_more && @st_less
2632 && $st_more[0] == $st_less[0]
2633 && $st_more[1] == $st_less[1];
2635 # changes environment!
2636 $ENV{LESS} .= 'r' if $is_less;
2642 $SIG{'ABRT'} = 'DEFAULT';
2643 kill 'ABRT', $$ if $panic++;
2644 if (defined &Carp::longmess) {
2645 local $SIG{__WARN__} = '';
2646 local $Carp::CarpLevel = 2; # mydie + confess
2647 &warn(Carp::longmess("Signal @_"));
2650 print $DB::OUT "Got signal @_\n";
2658 local $SIG{__WARN__} = '';
2659 local $SIG{__DIE__} = '';
2660 eval { require Carp } if defined $^S; # If error/warning during compilation,
2661 # require may be broken.
2662 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2663 return unless defined &Carp::longmess;
2664 my ($mysingle,$mytrace) = ($single,$trace);
2665 $single = 0; $trace = 0;
2666 my $mess = Carp::longmess(@_);
2667 ($single,$trace) = ($mysingle,$mytrace);
2674 local $SIG{__DIE__} = '';
2675 local $SIG{__WARN__} = '';
2676 my $i = 0; my $ineval = 0; my $sub;
2677 if ($dieLevel > 2) {
2678 local $SIG{__WARN__} = \&dbwarn;
2679 &warn(@_); # Yell no matter what
2682 if ($dieLevel < 2) {
2683 die @_ if $^S; # in eval propagate
2685 # No need to check $^S, eval is much more robust nowadays
2686 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
2687 # require may be broken.
2689 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2690 unless defined &Carp::longmess;
2692 # We do not want to debug this chunk (automatic disabling works
2693 # inside DB::DB, but not in Carp).
2694 my ($mysingle,$mytrace) = ($single,$trace);
2695 $single = 0; $trace = 0;
2698 package Carp; # Do not include us in the list
2700 $mess = Carp::longmess(@_);
2703 ($single,$trace) = ($mysingle,$mytrace);
2709 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2712 $SIG{__WARN__} = \&DB::dbwarn;
2713 } elsif ($prevwarn) {
2714 $SIG{__WARN__} = $prevwarn;
2722 $prevdie = $SIG{__DIE__} unless $dieLevel;
2725 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2726 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2727 print $OUT "Stack dump during die enabled",
2728 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2730 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2731 } elsif ($prevdie) {
2732 $SIG{__DIE__} = $prevdie;
2733 print $OUT "Default die handler restored.\n";
2741 $prevsegv = $SIG{SEGV} unless $signalLevel;
2742 $prevbus = $SIG{BUS} unless $signalLevel;
2743 $signalLevel = shift;
2745 $SIG{SEGV} = \&DB::diesignal;
2746 $SIG{BUS} = \&DB::diesignal;
2748 $SIG{SEGV} = $prevsegv;
2749 $SIG{BUS} = $prevbus;
2757 my $name = CvGV_name_or_bust($in);
2758 defined $name ? $name : $in;
2761 sub CvGV_name_or_bust {
2763 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2764 return unless ref $in;
2765 $in = \&$in; # Hard reference...
2766 eval {require Devel::Peek; 1} or return;
2767 my $gv = Devel::Peek::CvGV($in) or return;
2768 *$gv{PACKAGE} . '::' . *$gv{NAME};
2774 return unless defined &$subr;
2775 my $name = CvGV_name_or_bust($subr);
2777 $data = $sub{$name} if defined $name;
2778 return $data if defined $data;
2781 $subr = \&$subr; # Hard reference
2784 $s = $_, last if $subr eq \&$_;
2792 $class = ref $class if ref $class;
2795 methods_via($class, '', 1);
2796 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2801 return if $packs{$class}++;
2803 my $prepend = $prefix ? "via $prefix: " : '';
2805 for $name (grep {defined &{${"${class}::"}{$_}}}
2806 sort keys %{"${class}::"}) {
2807 next if $seen{ $name }++;
2808 print $DB::OUT "$prepend$name\n";
2810 return unless shift; # Recurse?
2811 for $name (@{"${class}::ISA"}) {
2812 $prepend = $prefix ? $prefix . " -> $name" : $name;
2813 methods_via($name, $prepend, 1);
2818 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2819 ? "man" # O Happy Day!
2820 : "perldoc"; # Alas, poor unfortunates
2826 &system("$doccmd $doccmd");
2829 # this way user can override, like with $doccmd="man -Mwhatever"
2830 # or even just "man " to disable the path check.
2831 unless ($doccmd eq 'man') {
2832 &system("$doccmd $page");
2836 $page = 'perl' if lc($page) eq 'help';
2839 my $man1dir = $Config::Config{'man1dir'};
2840 my $man3dir = $Config::Config{'man3dir'};
2841 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2843 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2844 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2845 chop $manpath if $manpath;
2846 # harmless if missing, I figure
2847 my $oldpath = $ENV{MANPATH};
2848 $ENV{MANPATH} = $manpath if $manpath;
2849 my $nopathopt = $^O =~ /dunno what goes here/;
2850 if (CORE::system($doccmd,
2851 # I just *know* there are men without -M
2852 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2855 unless ($page =~ /^perl\w/) {
2856 if (grep { $page eq $_ } qw{
2857 5004delta 5005delta amiga api apio book boot bot call compile
2858 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2859 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2860 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2861 modinstall modlib number obj op opentut os2 os390 pod port
2862 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2863 trap unicode var vms win32 xs xstut
2867 CORE::system($doccmd,
2868 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2873 if (defined $oldpath) {
2874 $ENV{MANPATH} = $manpath;
2876 delete $ENV{MANPATH};
2880 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2882 BEGIN { # This does not compile, alas.
2883 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2884 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2888 $deep = 100; # warning if stack gets this deep
2892 $SIG{INT} = \&DB::catch;
2893 # This may be enabled to debug debugger:
2894 #$warnLevel = 1 unless defined $warnLevel;
2895 #$dieLevel = 1 unless defined $dieLevel;
2896 #$signalLevel = 1 unless defined $signalLevel;
2898 $db_stop = 0; # Compiler warning
2900 $level = 0; # Level of recursive debugging
2901 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2902 # Triggers bug (?) in perl is we postpone this until runtime:
2903 @postponed = @stack = (0);
2904 $stack_depth = 0; # Localized $#stack
2909 BEGIN {$^W = $ini_warn;} # Switch warnings back
2911 #use Carp; # This did break, left for debugging
2914 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2915 my($text, $line, $start) = @_;
2916 my ($itext, $search, $prefix, $pack) =
2917 ($text, "^\Q${'package'}::\E([^:]+)\$");
2919 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2920 (map { /$search/ ? ($1) : () } keys %sub)
2921 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2922 return sort grep /^\Q$text/, values %INC # files
2923 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2924 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2925 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2926 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2927 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2929 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2931 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2932 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2933 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2934 # We may want to complete to (eval 9), so $text may be wrong
2935 $prefix = length($1) - length($text);
2938 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2940 if ((substr $text, 0, 1) eq '&') { # subroutines
2941 $text = substr $text, 1;
2943 return sort map "$prefix$_",
2946 (map { /$search/ ? ($1) : () }
2949 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2950 $pack = ($1 eq 'main' ? '' : $1) . '::';
2951 $prefix = (substr $text, 0, 1) . $1 . '::';
2954 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2955 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2956 return db_complete($out[0], $line, $start);
2960 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2961 $pack = ($package eq 'main' ? '' : $package) . '::';
2962 $prefix = substr $text, 0, 1;
2963 $text = substr $text, 1;
2964 my @out = map "$prefix$_", grep /^\Q$text/,
2965 (grep /^_?[a-zA-Z]/, keys %$pack),
2966 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2967 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2968 return db_complete($out[0], $line, $start);
2972 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2973 my @out = grep /^\Q$text/, @options;
2974 my $val = option_val($out[0], undef);
2976 if (not defined $val or $val =~ /[\n\r]/) {
2977 # Can do nothing better
2978 } elsif ($val =~ /\s/) {
2980 foreach $l (split //, qq/\"\'\#\|/) {
2981 $out = "$l$val$l ", last if (index $val, $l) == -1;
2986 # Default to value if one completion, to question if many
2987 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2990 return $term->filename_list($text); # filenames
2994 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2998 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
2999 $fall_off_end = 1 unless $inhibit_exit;
3000 # Do not stop in at_exit() and destructors on exit:
3001 $DB::single = !$fall_off_end && !$runnonstop;
3002 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3008 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3011 package DB; # Do not trace this 1; below!