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*(.*\S)/ && do {
1437 if (open my $fh, $1) {
1441 &warn("Can't execute `$1': $!\n");
1444 $cmd =~ /^\|\|?\s*[^|]/ && do {
1445 if ($pager =~ /^\|/) {
1446 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1447 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1449 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1452 unless ($piped=open(OUT,$pager)) {
1453 &warn("Can't pipe output to `$pager'");
1454 if ($pager =~ /^\|/) {
1455 open(OUT,">&STDOUT") # XXX: lost message
1456 || &warn("Can't restore DB::OUT");
1457 open(STDOUT,">&SAVEOUT")
1458 || &warn("Can't restore STDOUT");
1461 open(OUT,">&STDOUT") # XXX: lost message
1462 || &warn("Can't restore DB::OUT");
1466 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1467 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1468 $selected= select(OUT);
1470 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1471 $cmd =~ s/^\|+\s*//;
1474 # XXX Local variants do not work!
1475 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1476 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1477 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1479 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1481 $onetimeDump = undef;
1482 } elsif ($term_pid == $$) {
1487 if ($pager =~ /^\|/) {
1489 # we cannot warn here: the handle is missing --tchrist
1490 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1492 # most of the $? crud was coping with broken cshisms
1494 print SAVEOUT "Pager `$pager' failed: ";
1496 print SAVEOUT "shell returned -1\n";
1499 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1500 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1502 print SAVEOUT "status ", ($? >> 8), "\n";
1506 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1507 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1508 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1509 # Will stop ignoring SIGPIPE if done like nohup(1)
1510 # does SIGINT but Perl doesn't give us a choice.
1512 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1515 select($selected), $selected= "" unless $selected eq "";
1519 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1520 foreach $evalarg (@$post) {
1523 } # if ($single || $signal)
1524 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1528 # The following code may be executed now:
1532 my ($al, $ret, @ret) = "";
1533 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1536 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1537 $#stack = $stack_depth;
1538 $stack[-1] = $single;
1540 $single |= 4 if $stack_depth == $deep;
1542 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1543 # Why -1? But it works! :-(
1544 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1545 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1548 $single |= $stack[$stack_depth--];
1550 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1551 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1552 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1553 if ($doret eq $stack_depth or $frame & 16) {
1554 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1555 print $fh ' ' x $stack_depth if $frame & 16;
1556 print $fh "list context return from $sub:\n";
1557 dumpit($fh, \@ret );
1562 if (defined wantarray) {
1567 $single |= $stack[$stack_depth--];
1569 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1570 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1571 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1572 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1573 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1574 print $fh (' ' x $stack_depth) if $frame & 16;
1575 print $fh (defined wantarray
1576 ? "scalar context return from $sub: "
1577 : "void context return from $sub\n");
1578 dumpit( $fh, $ret ) if defined wantarray;
1587 ### Functions with multiple modes of failure die on error, the rest
1588 ### returns FALSE on error.
1589 ### User-interface functions cmd_* output error message.
1593 $break_on_load{$file} = 1;
1594 $had_breakpoints{$file} |= 1;
1597 sub report_break_on_load {
1598 sort keys %break_on_load;
1606 push @files, $::INC{$file} if $::INC{$file};
1607 $file .= '.pm', redo unless $file =~ /\./;
1609 break_on_load($_) for @files;
1610 @files = report_break_on_load;
1611 print $OUT "Will stop on load of `@files'.\n";
1614 $filename_error = '';
1616 sub breakable_line {
1617 my ($from, $to) = @_;
1620 my $delta = $from < $to ? +1 : -1;
1621 my $limit = $delta > 0 ? $#dbline : 1;
1622 $limit = $to if ($limit - $to) * $delta > 0;
1623 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1625 return $i unless $dbline[$i] == 0;
1626 my ($pl, $upto) = ('', '');
1627 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1628 die "Line$pl $from$upto$filename_error not breakable\n";
1631 sub breakable_line_in_filename {
1633 local *dbline = $main::{'_<' . $f};
1634 local $filename_error = " of `$f'";
1639 my ($i, $cond) = @_;
1640 $cond = 1 unless @_ >= 2;
1644 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1645 $had_breakpoints{$filename} |= 1;
1646 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1647 else { $dbline{$i} = $cond; }
1651 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1654 sub break_on_filename_line {
1655 my ($f, $i, $cond) = @_;
1656 $cond = 1 unless @_ >= 3;
1657 local *dbline = $main::{'_<' . $f};
1658 local $filename_error = " of `$f'";
1659 local $filename = $f;
1660 break_on_line($i, $cond);
1663 sub break_on_filename_line_range {
1664 my ($f, $from, $to, $cond) = @_;
1665 my $i = breakable_line_in_filename($f, $from, $to);
1666 $cond = 1 unless @_ >= 3;
1667 break_on_filename_line($f,$i,$cond);
1670 sub subroutine_filename_lines {
1671 my ($subname,$cond) = @_;
1672 # Filename below can contain ':'
1673 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1676 sub break_subroutine {
1677 my $subname = shift;
1678 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1679 die "Subroutine $subname not found.\n";
1680 $cond = 1 unless @_ >= 2;
1681 break_on_filename_line_range($file,$s,$e,@_);
1685 my ($subname,$cond) = @_;
1686 $cond = 1 unless @_ >= 2;
1687 unless (ref $subname eq 'CODE') {
1688 $subname =~ s/\'/::/g;
1690 $subname = "${'package'}::" . $subname
1691 unless $subname =~ /::/;
1692 $subname = "CORE::GLOBAL::$s"
1693 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1694 $subname = "main".$subname if substr($subname,0,2) eq "::";
1696 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1699 sub cmd_stop { # As on ^C, but not signal-safy.
1703 sub delete_breakpoint {
1705 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1706 $dbline{$i} =~ s/^[^\0]*//;
1707 delete $dbline{$i} if $dbline{$i} eq '';
1712 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1715 ### END of the API section
1718 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1719 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1722 sub print_lineinfo {
1723 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1727 # The following takes its argument via $evalarg to preserve current @_
1730 # 'my' would make it visible from user code
1731 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1734 local $otrace = $trace;
1735 local $osingle = $single;
1737 { ($evalarg) = $evalarg =~ /(.*)/s; }
1738 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1744 local $saved[0]; # Preserve the old value of $@
1748 } elsif ($onetimeDump) {
1749 dumpit($OUT, \@res) if $onetimeDump eq 'dump';
1750 methods($res[0]) if $onetimeDump eq 'methods';
1756 my $subname = shift;
1757 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1758 my $offset = $1 || 0;
1759 # Filename below can contain ':'
1760 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1763 local *dbline = $main::{'_<' . $file};
1764 local $^W = 0; # != 0 is magical below
1765 $had_breakpoints{$file} |= 1;
1767 ++$i until $dbline[$i] != 0 or $i >= $max;
1768 $dbline{$i} = delete $postponed{$subname};
1770 print $OUT "Subroutine $subname not found.\n";
1774 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1775 #print $OUT "In postponed_sub for `$subname'.\n";
1779 if ($ImmediateStop) {
1783 return &postponed_sub
1784 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1785 # Cannot be done before the file is compiled
1786 local *dbline = shift;
1787 my $filename = $dbline;
1788 $filename =~ s/^_<//;
1789 $signal = 1, print $OUT "'$filename' loaded...\n"
1790 if $break_on_load{$filename};
1791 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1792 return unless $postponed_file{$filename};
1793 $had_breakpoints{$filename} |= 1;
1794 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1796 for $key (keys %{$postponed_file{$filename}}) {
1797 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1799 delete $postponed_file{$filename};
1803 local ($savout) = select(shift);
1804 my $osingle = $single;
1805 my $otrace = $trace;
1806 $single = $trace = 0;
1809 unless (defined &main::dumpValue) {
1812 if (defined &main::dumpValue) {
1813 &main::dumpValue(shift);
1815 print $OUT "dumpvar.pl not available.\n";
1822 # Tied method do not create a context, so may get wrong message:
1826 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1827 my @sub = dump_trace($_[0] + 1, $_[1]);
1828 my $short = $_[2]; # Print short report, next one for sub name
1830 for ($i=0; $i <= $#sub; $i++) {
1833 my $args = defined $sub[$i]{args}
1834 ? "(@{ $sub[$i]{args} })"
1836 $args = (substr $args, 0, $maxtrace - 3) . '...'
1837 if length $args > $maxtrace;
1838 my $file = $sub[$i]{file};
1839 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1841 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1843 my $sub = @_ >= 4 ? $_[3] : $s;
1844 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1846 print $fh "$sub[$i]{context} = $s$args" .
1847 " called from $file" .
1848 " line $sub[$i]{line}\n";
1855 my $count = shift || 1e9;
1858 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1859 my $nothard = not $frame & 8;
1860 local $frame = 0; # Do not want to trace this.
1861 my $otrace = $trace;
1864 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1869 if (not defined $arg) {
1871 } elsif ($nothard and tied $arg) {
1873 } elsif ($nothard and $type = ref $arg) {
1874 push @a, "ref($type)";
1876 local $_ = "$arg"; # Safe to stringify now - should not call f().
1879 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1880 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1881 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1885 $context = $context ? '@' : (defined $context ? "\$" : '.');
1886 $args = $h ? [@a] : undef;
1887 $e =~ s/\n\s*\;\s*\Z// if $e;
1888 $e =~ s/([\\\'])/\\$1/g if $e;
1890 $sub = "require '$e'";
1891 } elsif (defined $r) {
1893 } elsif ($sub eq '(eval)') {
1894 $sub = "eval {...}";
1896 push(@sub, {context => $context, sub => $sub, args => $args,
1897 file => $file, line => $line});
1906 while ($action =~ s/\\$//) {
1915 # i hate using globals!
1916 $balanced_brace_re ||= qr{
1919 (?> [^{}] + ) # Non-parens without backtracking
1921 (??{ $balanced_brace_re }) # Group with matching parens
1925 return $_[0] !~ m/$balanced_brace_re/;
1929 &readline("cont: ");
1933 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1934 # some non-Unix systems can do system() but have problems with fork().
1935 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1936 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1937 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1938 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1940 # XXX: using csh or tcsh destroys sigint retvals!
1942 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1943 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1948 # most of the $? crud was coping with broken cshisms
1950 &warn("(Command exited ", ($? >> 8), ")\n");
1952 &warn( "(Command died of SIG#", ($? & 127),
1953 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1963 eval { require Term::ReadLine } or die $@;
1966 my ($i, $o) = split $tty, /,/;
1967 $o = $i unless defined $o;
1968 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1969 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1972 my $sel = select($OUT);
1976 eval "require Term::Rendezvous;" or die;
1977 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1978 my $term_rv = new Term::Rendezvous $rv;
1980 $OUT = $term_rv->OUT;
1983 if ($term_pid eq '-1') { # In a TTY with another debugger
1987 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1989 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1991 $rl_attribs = $term->Attribs;
1992 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1993 if defined $rl_attribs->{basic_word_break_characters}
1994 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1995 $rl_attribs->{special_prefixes} = '$@&%';
1996 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1997 $rl_attribs->{completion_function} = \&db_complete;
1999 $LINEINFO = $OUT unless defined $LINEINFO;
2000 $lineinfo = $console unless defined $lineinfo;
2002 if ($term->Features->{setHistory} and "@hist" ne "?") {
2003 $term->SetHistory(@hist);
2005 ornaments($ornaments) if defined $ornaments;
2009 # Example get_fork_TTY functions
2010 sub xterm_get_fork_TTY {
2011 (my $name = $0) =~ s,^.*[/\\],,s;
2012 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2016 $pidprompt = ''; # Shown anyway in titlebar
2020 # This one resets $IN, $OUT itself
2021 sub os2_get_fork_TTY {
2022 $^F = 40; # XXXX Fixme!
2023 my ($in1, $out1, $in2, $out2);
2024 # Having -d in PERL5OPT would lead to a disaster...
2025 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2026 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2027 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2028 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2029 (my $name = $0) =~ s,^.*[/\\],,s;
2030 if ( pipe $in1, $out1 and pipe $in2, $out2 and
2031 # system P_SESSION will fail if there is another process
2032 # in the same session with a "dependent" asynchronous child session.
2033 (($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
2037 my $in = shift; # Read from here and pass through
2039 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2040 open IN, '<&=$in' or die "open <&=$in: \$!";
2041 \$| = 1; print while sysread IN, \$_, 1<<16;
2045 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2047 ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
2048 print while sysread STDIN, $_, 1<<16;
2050 and close $in1 and close $out2 ) {
2051 $pidprompt = ''; # Shown anyway in titlebar
2052 reset_IN_OUT($in2, $out1);
2054 return ''; # Indicate that reset_IN_OUT is called
2059 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2060 my $in = &get_fork_TTY if defined &get_fork_TTY;
2061 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2062 if (not defined $in) {
2064 print_help(<<EOP) if $why == 1;
2065 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2067 print_help(<<EOP) if $why == 2;
2068 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2069 This may be an asynchronous session, so the parent debugger may be active.
2071 print_help(<<EOP) if $why != 4;
2072 Since two debuggers fight for the same TTY, input is severely entangled.
2076 I know how to switch the output to a different window in xterms
2077 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2078 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2080 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2081 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2084 } elsif ($in ne '') {
2090 sub resetterm { # We forked, so we need a different TTY
2092 my $systemed = $in > 1 ? '-' : '';
2094 $pids =~ s/\]/$systemed->$$]/;
2096 $pids = "[$term_pid->$$]";
2100 return unless $CreateTTY & $in;
2107 my $left = @typeahead;
2108 my $got = shift @typeahead;
2109 print $OUT "auto(-$left)", shift, $got, "\n";
2110 $term->AddHistory($got)
2111 if length($got) > 1 and defined $term->Features->{addHistory};
2117 my $line = CORE::readline($cmdfhs[-1]);
2118 defined $line ? (print $OUT ">> $line" and return $line)
2119 : close pop @cmdfhs;
2121 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2122 $OUT->write(join('', @_));
2124 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2128 $term->readline(@_);
2133 my ($opt, $val)= @_;
2134 $val = option_val($opt,'N/A');
2135 $val =~ s/([\\\'])/\\$1/g;
2136 printf $OUT "%20s = '%s'\n", $opt, $val;
2140 my ($opt, $default)= @_;
2142 if (defined $optionVars{$opt}
2143 and defined ${$optionVars{$opt}}) {
2144 $val = ${$optionVars{$opt}};
2145 } elsif (defined $optionAction{$opt}
2146 and defined &{$optionAction{$opt}}) {
2147 $val = &{$optionAction{$opt}}();
2148 } elsif (defined $optionAction{$opt}
2149 and not defined $option{$opt}
2150 or defined $optionVars{$opt}
2151 and not defined ${$optionVars{$opt}}) {
2154 $val = $option{$opt};
2156 $val = $default unless defined $val;
2162 # too dangerous to let intuitive usage overwrite important things
2163 # defaultion should never be the default
2164 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2165 arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2166 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2171 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2172 my ($opt,$sep) = ($1,$2);
2175 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2177 #&dump_option($opt);
2178 } elsif ($sep !~ /\S/) {
2180 $val = "1"; # this is an evil default; make 'em set it!
2181 } elsif ($sep eq "=") {
2183 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2185 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2189 print OUT qq(Option better cleared using $opt=""\n)
2193 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2194 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2195 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2196 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2197 ($val = $1) =~ s/\\([\\$end])/$1/g;
2201 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2202 || grep( /^\Q$opt/i && ($option = $_), @options );
2204 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2205 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2207 if ($opt_needs_val{$option} && $val_defaulted) {
2208 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2212 $option{$option} = $val if defined $val;
2217 require '$optionRequire{$option}';
2219 } || die # XXX: shouldn't happen
2220 if defined $optionRequire{$option} &&
2223 ${$optionVars{$option}} = $val
2224 if defined $optionVars{$option} &&
2227 &{$optionAction{$option}} ($val)
2228 if defined $optionAction{$option} &&
2229 defined &{$optionAction{$option}} &&
2233 dump_option($option) unless $OUT eq \*STDERR;
2238 my ($stem,@list) = @_;
2240 $ENV{"${stem}_n"} = @list;
2241 for $i (0 .. $#list) {
2243 $val =~ s/\\/\\\\/g;
2244 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2245 $ENV{"${stem}_$i"} = $val;
2252 my $n = delete $ENV{"${stem}_n"};
2254 for $i (0 .. $n - 1) {
2255 $val = delete $ENV{"${stem}_$i"};
2256 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2264 return; # Put nothing on the stack - malloc/free land!
2268 my($msg)= join("",@_);
2269 $msg .= ": $!\n" unless $msg =~ /\n$/;
2274 my $switch_li = $LINEINFO eq $OUT;
2275 if ($term and $term->Features->{newTTY}) {
2276 ($IN, $OUT) = (shift, shift);
2277 $term->newTTY($IN, $OUT);
2279 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2281 ($IN, $OUT) = (shift, shift);
2283 my $o = select $OUT;
2286 $LINEINFO = $OUT if $switch_li;
2290 if (@_ and $term and $term->Features->{newTTY}) {
2291 my ($in, $out) = shift;
2293 ($in, $out) = split /,/, $in, 2;
2297 open IN, $in or die "cannot open `$in' for read: $!";
2298 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2299 reset_IN_OUT(\*IN,\*OUT);
2302 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2303 # Useful if done through PERLDB_OPTS:
2310 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2312 $notty = shift if @_;
2318 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2326 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2328 $remoteport = shift if @_;
2333 if (${$term->Features}{tkRunning}) {
2334 return $term->tkRunning(@_);
2336 print $OUT "tkRunning not supported by current ReadLine package.\n";
2343 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2345 $runnonstop = shift if @_;
2352 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2359 $sh = quotemeta shift;
2360 $sh .= "\\b" if $sh =~ /\w$/;
2364 $psh =~ s/\\(.)/$1/g;
2369 if (defined $term) {
2370 local ($warnLevel,$dieLevel) = (0, 1);
2371 return '' unless $term->Features->{ornaments};
2372 eval { $term->ornaments(@_) } || '';
2380 $rc = quotemeta shift;
2381 $rc .= "\\b" if $rc =~ /\w$/;
2385 $prc =~ s/\\(.)/$1/g;
2390 return $lineinfo unless @_;
2392 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2393 $slave_editor = ($stream =~ /^\|/);
2394 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2395 $LINEINFO = \*LINEINFO;
2396 my $save = select($LINEINFO);
2410 s/^Term::ReadLine::readline$/readline/;
2411 if (defined ${ $_ . '::VERSION' }) {
2412 $version{$file} = "${ $_ . '::VERSION' } from ";
2414 $version{$file} .= $INC{$file};
2416 dumpit($OUT,\%version);
2420 # XXX: make sure there are tabs between the command and explanation,
2421 # or print_help will screw up your formatting if you have
2422 # eeevil ornaments enabled. This is an insane mess.
2426 B<s> [I<expr>] Single step [in I<expr>].
2427 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2428 <B<CR>> Repeat last B<n> or B<s> command.
2429 B<r> Return from current subroutine.
2430 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2431 at the specified position.
2432 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2433 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2434 B<l> I<line> List single I<line>.
2435 B<l> I<subname> List first window of lines from subroutine.
2436 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2437 B<l> List next window of lines.
2438 B<-> List previous window of lines.
2439 B<w> [I<line>] List window around I<line>.
2440 B<.> Return to the executed line.
2441 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2442 I<filename> may be either the full name of the file, or a regular
2443 expression matching the full file name:
2444 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2445 Evals (with saved bodies) are considered to be filenames:
2446 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2447 (in the order of execution).
2448 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2449 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2450 B<L> List all breakpoints and actions.
2451 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2452 B<t> Toggle trace mode.
2453 B<t> I<expr> Trace through execution of I<expr>.
2454 B<b> [I<line>] [I<condition>]
2455 Set breakpoint; I<line> defaults to the current execution line;
2456 I<condition> breaks if it evaluates to true, defaults to '1'.
2457 B<b> I<subname> [I<condition>]
2458 Set breakpoint at first line of subroutine.
2459 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2460 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2461 B<b> B<postpone> I<subname> [I<condition>]
2462 Set breakpoint at first line of subroutine after
2464 B<b> B<compile> I<subname>
2465 Stop after the subroutine is compiled.
2466 B<d> [I<line>] Delete the breakpoint for I<line>.
2467 B<D> Delete all breakpoints.
2468 B<a> [I<line>] I<command>
2469 Set an action to be done before the I<line> is executed;
2470 I<line> defaults to the current execution line.
2471 Sequence is: check for breakpoint/watchpoint, print line
2472 if necessary, do action, prompt user if necessary,
2474 B<a> [I<line>] Delete the action for I<line>.
2475 B<A> Delete all actions.
2476 B<W> I<expr> Add a global watch-expression.
2477 B<W> Delete all watch-expressions.
2478 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2479 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2480 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2481 B<x> I<expr> Evals expression in list context, dumps the result.
2482 B<m> I<expr> Evals expression in list context, prints methods callable
2483 on the first element of the result.
2484 B<m> I<class> Prints methods callable via the given class.
2486 B<<> ? List Perl commands to run before each prompt.
2487 B<<> I<expr> Define Perl command to run before each prompt.
2488 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2489 B<>> ? List Perl commands to run after each prompt.
2490 B<>> I<expr> Define Perl command to run after each prompt.
2491 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2492 B<{> I<db_command> Define debugger command to run before each prompt.
2493 B<{> ? List debugger commands to run before each prompt.
2494 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2495 B<$prc> I<number> Redo a previous command (default previous command).
2496 B<$prc> I<-number> Redo number'th-to-last command.
2497 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2498 See 'B<O> I<recallCommand>' too.
2499 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2500 . ( $rc eq $sh ? "" : "
2501 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2502 See 'B<O> I<shellBang>' too.
2503 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2504 B<H> I<-number> Display last number commands (default all).
2505 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2506 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2507 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2508 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2509 I<command> Execute as a perl statement in current package.
2510 B<v> Show versions of loaded modules.
2511 B<R> Pure-man-restart of debugger, some of debugger state
2512 and command-line options may be lost.
2513 Currently the following settings are preserved:
2514 history, breakpoints and actions, debugger B<O>ptions
2515 and the following command-line options: I<-w>, I<-I>, I<-e>.
2517 B<O> [I<opt>] ... Set boolean option to true
2518 B<O> [I<opt>B<?>] Query options
2519 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2520 Set options. Use quotes in spaces in value.
2521 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2522 I<pager> program for output of \"|cmd\";
2523 I<tkRunning> run Tk while prompting (with ReadLine);
2524 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2525 I<inhibit_exit> Allows stepping off the end of the script.
2526 I<ImmediateStop> Debugger should stop as early as possible.
2527 I<RemotePort> Remote hostname:port for remote debugging
2528 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2529 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2530 I<compactDump>, I<veryCompact> change style of array and hash dump;
2531 I<globPrint> whether to print contents of globs;
2532 I<DumpDBFiles> dump arrays holding debugged files;
2533 I<DumpPackages> dump symbol tables of packages;
2534 I<DumpReused> dump contents of \"reused\" addresses;
2535 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2536 I<bareStringify> Do not print the overload-stringified value;
2537 Other options include:
2538 I<PrintRet> affects printing of return value after B<r> command,
2539 I<frame> affects printing messages on subroutine entry/exit.
2540 I<AutoTrace> affects printing messages on possible breaking points.
2541 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2542 I<ornaments> affects screen appearance of the command line.
2543 I<CreateTTY> bits control attempts to create a new TTY on events:
2544 1: on fork() 2: debugger is started inside debugger
2546 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2547 You can put additional initialization options I<TTY>, I<noTTY>,
2548 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2549 `B<R>' after you set them).
2551 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2552 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2553 B<h h> Summary of debugger commands.
2554 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2555 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2556 Set B<\$DB::doccmd> to change viewer.
2558 Type `|h' for a paged display if this was too hard to read.
2560 "; # Fix balance of vi % matching: }}}}
2562 # note: tabs in the following section are not-so-helpful
2563 $summary = <<"END_SUM";
2564 I<List/search source lines:> I<Control script execution:>
2565 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2566 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2567 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2568 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2569 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2570 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2571 I<Debugger controls:> B<L> List break/watch/actions
2572 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2573 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2574 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2575 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2576 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2577 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2578 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2579 B<q> or B<^D> Quit B<R> Attempt a restart
2580 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2581 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2582 B<p> I<expr> Print expression (uses script's current package).
2583 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2584 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2585 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2586 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2588 # ')}}; # Fix balance of vi % matching
2594 # Restore proper alignment destroyed by eeevil I<> and B<>
2595 # ornaments: A pox on both their houses!
2597 # A help command will have everything up to and including
2598 # the first tab sequence padded into a field 16 (or if indented 20)
2599 # wide. If it's wider than that, an extra space will be added.
2601 ^ # only matters at start of line
2602 ( \040{4} | \t )* # some subcommands are indented
2603 ( < ? # so <CR> works
2604 [BI] < [^\t\n] + ) # find an eeevil ornament
2605 ( \t+ ) # original separation, discarded
2606 ( .* ) # this will now start (no earlier) than
2609 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2610 my $clean = $command;
2611 $clean =~ s/[BI]<([^>]*)>/$1/g;
2612 # replace with this whole string:
2613 ($leadwhite ? " " x 4 : "")
2615 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2620 s{ # handle bold ornaments
2621 B < ( [^>] + | > ) >
2623 $Term::ReadLine::TermCap::rl_term_set[2]
2625 . $Term::ReadLine::TermCap::rl_term_set[3]
2628 s{ # handle italic ornaments
2629 I < ( [^>] + | > ) >
2631 $Term::ReadLine::TermCap::rl_term_set[0]
2633 . $Term::ReadLine::TermCap::rl_term_set[1]
2640 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2641 my $is_less = $pager =~ /\bless\b/;
2642 if ($pager =~ /\bmore\b/) {
2643 my @st_more = stat('/usr/bin/more');
2644 my @st_less = stat('/usr/bin/less');
2645 $is_less = @st_more && @st_less
2646 && $st_more[0] == $st_less[0]
2647 && $st_more[1] == $st_less[1];
2649 # changes environment!
2650 $ENV{LESS} .= 'r' if $is_less;
2656 $SIG{'ABRT'} = 'DEFAULT';
2657 kill 'ABRT', $$ if $panic++;
2658 if (defined &Carp::longmess) {
2659 local $SIG{__WARN__} = '';
2660 local $Carp::CarpLevel = 2; # mydie + confess
2661 &warn(Carp::longmess("Signal @_"));
2664 print $DB::OUT "Got signal @_\n";
2672 local $SIG{__WARN__} = '';
2673 local $SIG{__DIE__} = '';
2674 eval { require Carp } if defined $^S; # If error/warning during compilation,
2675 # require may be broken.
2676 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2677 return unless defined &Carp::longmess;
2678 my ($mysingle,$mytrace) = ($single,$trace);
2679 $single = 0; $trace = 0;
2680 my $mess = Carp::longmess(@_);
2681 ($single,$trace) = ($mysingle,$mytrace);
2688 local $SIG{__DIE__} = '';
2689 local $SIG{__WARN__} = '';
2690 my $i = 0; my $ineval = 0; my $sub;
2691 if ($dieLevel > 2) {
2692 local $SIG{__WARN__} = \&dbwarn;
2693 &warn(@_); # Yell no matter what
2696 if ($dieLevel < 2) {
2697 die @_ if $^S; # in eval propagate
2699 # No need to check $^S, eval is much more robust nowadays
2700 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
2701 # require may be broken.
2703 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2704 unless defined &Carp::longmess;
2706 # We do not want to debug this chunk (automatic disabling works
2707 # inside DB::DB, but not in Carp).
2708 my ($mysingle,$mytrace) = ($single,$trace);
2709 $single = 0; $trace = 0;
2712 package Carp; # Do not include us in the list
2714 $mess = Carp::longmess(@_);
2717 ($single,$trace) = ($mysingle,$mytrace);
2723 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2726 $SIG{__WARN__} = \&DB::dbwarn;
2727 } elsif ($prevwarn) {
2728 $SIG{__WARN__} = $prevwarn;
2736 $prevdie = $SIG{__DIE__} unless $dieLevel;
2739 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2740 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2741 print $OUT "Stack dump during die enabled",
2742 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2744 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2745 } elsif ($prevdie) {
2746 $SIG{__DIE__} = $prevdie;
2747 print $OUT "Default die handler restored.\n";
2755 $prevsegv = $SIG{SEGV} unless $signalLevel;
2756 $prevbus = $SIG{BUS} unless $signalLevel;
2757 $signalLevel = shift;
2759 $SIG{SEGV} = \&DB::diesignal;
2760 $SIG{BUS} = \&DB::diesignal;
2762 $SIG{SEGV} = $prevsegv;
2763 $SIG{BUS} = $prevbus;
2771 my $name = CvGV_name_or_bust($in);
2772 defined $name ? $name : $in;
2775 sub CvGV_name_or_bust {
2777 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2778 return unless ref $in;
2779 $in = \&$in; # Hard reference...
2780 eval {require Devel::Peek; 1} or return;
2781 my $gv = Devel::Peek::CvGV($in) or return;
2782 *$gv{PACKAGE} . '::' . *$gv{NAME};
2788 return unless defined &$subr;
2789 my $name = CvGV_name_or_bust($subr);
2791 $data = $sub{$name} if defined $name;
2792 return $data if defined $data;
2795 $subr = \&$subr; # Hard reference
2798 $s = $_, last if $subr eq \&$_;
2806 $class = ref $class if ref $class;
2809 methods_via($class, '', 1);
2810 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2815 return if $packs{$class}++;
2817 my $prepend = $prefix ? "via $prefix: " : '';
2819 for $name (grep {defined &{${"${class}::"}{$_}}}
2820 sort keys %{"${class}::"}) {
2821 next if $seen{ $name }++;
2822 print $DB::OUT "$prepend$name\n";
2824 return unless shift; # Recurse?
2825 for $name (@{"${class}::ISA"}) {
2826 $prepend = $prefix ? $prefix . " -> $name" : $name;
2827 methods_via($name, $prepend, 1);
2832 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2833 ? "man" # O Happy Day!
2834 : "perldoc"; # Alas, poor unfortunates
2840 &system("$doccmd $doccmd");
2843 # this way user can override, like with $doccmd="man -Mwhatever"
2844 # or even just "man " to disable the path check.
2845 unless ($doccmd eq 'man') {
2846 &system("$doccmd $page");
2850 $page = 'perl' if lc($page) eq 'help';
2853 my $man1dir = $Config::Config{'man1dir'};
2854 my $man3dir = $Config::Config{'man3dir'};
2855 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2857 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2858 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2859 chop $manpath if $manpath;
2860 # harmless if missing, I figure
2861 my $oldpath = $ENV{MANPATH};
2862 $ENV{MANPATH} = $manpath if $manpath;
2863 my $nopathopt = $^O =~ /dunno what goes here/;
2864 if (CORE::system($doccmd,
2865 # I just *know* there are men without -M
2866 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2869 unless ($page =~ /^perl\w/) {
2870 if (grep { $page eq $_ } qw{
2871 5004delta 5005delta amiga api apio book boot bot call compile
2872 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2873 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2874 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2875 modinstall modlib number obj op opentut os2 os390 pod port
2876 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2877 trap unicode var vms win32 xs xstut
2881 CORE::system($doccmd,
2882 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2887 if (defined $oldpath) {
2888 $ENV{MANPATH} = $manpath;
2890 delete $ENV{MANPATH};
2894 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2896 BEGIN { # This does not compile, alas.
2897 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2898 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2902 $deep = 100; # warning if stack gets this deep
2906 $SIG{INT} = \&DB::catch;
2907 # This may be enabled to debug debugger:
2908 #$warnLevel = 1 unless defined $warnLevel;
2909 #$dieLevel = 1 unless defined $dieLevel;
2910 #$signalLevel = 1 unless defined $signalLevel;
2912 $db_stop = 0; # Compiler warning
2914 $level = 0; # Level of recursive debugging
2915 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2916 # Triggers bug (?) in perl is we postpone this until runtime:
2917 @postponed = @stack = (0);
2918 $stack_depth = 0; # Localized $#stack
2923 BEGIN {$^W = $ini_warn;} # Switch warnings back
2925 #use Carp; # This did break, left for debugging
2928 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2929 my($text, $line, $start) = @_;
2930 my ($itext, $search, $prefix, $pack) =
2931 ($text, "^\Q${'package'}::\E([^:]+)\$");
2933 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2934 (map { /$search/ ? ($1) : () } keys %sub)
2935 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2936 return sort grep /^\Q$text/, values %INC # files
2937 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2938 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2939 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2940 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2941 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2943 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2945 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2946 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2947 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2948 # We may want to complete to (eval 9), so $text may be wrong
2949 $prefix = length($1) - length($text);
2952 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2954 if ((substr $text, 0, 1) eq '&') { # subroutines
2955 $text = substr $text, 1;
2957 return sort map "$prefix$_",
2960 (map { /$search/ ? ($1) : () }
2963 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2964 $pack = ($1 eq 'main' ? '' : $1) . '::';
2965 $prefix = (substr $text, 0, 1) . $1 . '::';
2968 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2969 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2970 return db_complete($out[0], $line, $start);
2974 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2975 $pack = ($package eq 'main' ? '' : $package) . '::';
2976 $prefix = substr $text, 0, 1;
2977 $text = substr $text, 1;
2978 my @out = map "$prefix$_", grep /^\Q$text/,
2979 (grep /^_?[a-zA-Z]/, keys %$pack),
2980 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2981 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2982 return db_complete($out[0], $line, $start);
2986 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2987 my @out = grep /^\Q$text/, @options;
2988 my $val = option_val($out[0], undef);
2990 if (not defined $val or $val =~ /[\n\r]/) {
2991 # Can do nothing better
2992 } elsif ($val =~ /\s/) {
2994 foreach $l (split //, qq/\"\'\#\|/) {
2995 $out = "$l$val$l ", last if (index $val, $l) == -1;
3000 # Default to value if one completion, to question if many
3001 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3004 return $term->filename_list($text); # filenames
3008 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3012 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3013 $fall_off_end = 1 unless $inhibit_exit;
3014 # Do not stop in at_exit() and destructors on exit:
3015 $DB::single = !$fall_off_end && !$runnonstop;
3016 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3022 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3025 package DB; # Do not trace this 1; below!