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 # Before venturing further into these twisty passages, it is
13 # wise to read the perldebguts man page or risk the ire of dragons.
15 # Perl supplies the values for %sub. It effectively inserts
16 # a &DB'DB(); in front of every place that can have a
17 # breakpoint. Instead of a subroutine call it calls &DB::sub with
18 # $DB::sub being the called subroutine. It also inserts a BEGIN
19 # {require 'perl5db.pl'} before the first line.
21 # After each `require'd file is compiled, but before it is executed, a
22 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
23 # $filename is the expanded name of the `require'd file (as found as
26 # Additional services from Perl interpreter:
28 # if caller() is called from the package DB, it provides some
31 # The array @{$main::{'_<'.$filename}} (herein called @dbline) is the
32 # line-by-line contents of $filename.
34 # The hash %{'_<'.$filename} (herein called %dbline) contains
35 # breakpoints and action (it is keyed by line number), and individual
36 # entries are settable (as opposed to the whole hash). Only true/false
37 # is important to the interpreter, though the values used by
38 # perl5db.pl have the form "$break_condition\0$action". Values are
39 # magical in numeric context.
41 # The scalar ${'_<'.$filename} contains $filename.
43 # Note that no subroutine call is possible until &DB::sub is defined
44 # (for subroutines defined outside of the package DB). In fact the same is
45 # true if $deep is not defined.
50 # At start reads $rcfile that may set important options. This file
51 # may define a subroutine &afterinit that will be executed after the
52 # debugger is initialized.
54 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
55 # it as a rest of `O ...' line in debugger prompt.
57 # The options that can be specified only at startup:
58 # [To set in $rcfile, call &parse_options("optionName=new_value").]
60 # TTY - the TTY to use for debugging i/o.
62 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
63 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
64 # Term::Rendezvous. Current variant is to have the name of TTY in this
67 # ReadLine - If false, dummy ReadLine is used, so you can debug
68 # ReadLine applications.
70 # NonStop - if true, no i/o is performed until interrupt.
72 # LineInfo - file or pipe to print line number info to. If it is a
73 # pipe, a short "emacs like" message is used.
75 # RemotePort - host:port to connect to on remote host for remote debugging.
77 # Example $rcfile: (delete leading hashes!)
79 # &parse_options("NonStop=1 LineInfo=db.out");
80 # sub afterinit { $trace = 1; }
82 # The script will run without human intervention, putting trace
83 # information into db.out. (If you interrupt it, you would better
84 # reset LineInfo to something "interactive"!)
86 ##################################################################
88 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
90 # modified Perl debugger, to be run from Emacs in perldb-mode
91 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
92 # Johan Vromans -- upgrade to 4.0 pl 10
93 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
97 # A lot of things changed after 0.94. First of all, core now informs
98 # debugger about entry into XSUBs, overloaded operators, tied operations,
99 # BEGIN and END. Handy with `O f=2'.
101 # This can make debugger a little bit too verbose, please be patient
102 # and report your problems promptly.
104 # Now the option frame has 3 values: 0,1,2.
106 # Note that if DESTROY returns a reference to the object (or object),
107 # the deletion of data may be postponed until the next function call,
108 # due to the need to examine the return value.
110 # Changes: 0.95: `v' command shows versions.
111 # Changes: 0.96: `v' command shows version of readline.
112 # primitive completion works (dynamic variables, subs for `b' and `l',
113 # options). Can `p %var'
114 # Better help (`h <' now works). New commands <<, >>, {, {{.
115 # {dump|print}_trace() coded (to be able to do it from <<cmd).
116 # `c sub' documented.
117 # At last enough magic combined to stop after the end of debuggee.
118 # !! should work now (thanks to Emacs bracket matching an extra
119 # `]' in a regexp is caught).
120 # `L', `D' and `A' span files now (as documented).
121 # Breakpoints in `require'd code are possible (used in `R').
122 # Some additional words on internal work of debugger.
123 # `b load filename' implemented.
124 # `b postpone subr' implemented.
125 # now only `q' exits debugger (overwritable on $inhibit_exit).
126 # When restarting debugger breakpoints/actions persist.
127 # Buglet: When restarting debugger only one breakpoint/action per
128 # autoloaded function persists.
129 # Changes: 0.97: NonStop will not stop in at_exit().
130 # Option AutoTrace implemented.
131 # Trace printed differently if frames are printed too.
132 # new `inhibitExit' option.
133 # printing of a very long statement interruptible.
134 # Changes: 0.98: New command `m' for printing possible methods
135 # 'l -' is a synonym for `-'.
136 # Cosmetic bugs in printing stack trace.
137 # `frame' & 8 to print "expanded args" in stack trace.
138 # Can list/break in imported subs.
139 # new `maxTraceLen' option.
140 # frame & 4 and frame & 8 granted.
142 # nonstoppable lines do not have `:' near the line number.
143 # `b compile subname' implemented.
144 # Will not use $` any more.
145 # `-' behaves sane now.
146 # Changes: 0.99: Completion for `f', `m'.
147 # `m' will remove duplicate names instead of duplicate functions.
148 # `b load' strips trailing whitespace.
149 # completion ignores leading `|'; takes into account current package
150 # when completing a subroutine name (same for `l').
151 # Changes: 1.07: Many fixed by tchrist 13-March-2000
153 # + Added bare minimal security checks on perldb rc files, plus
154 # comments on what else is needed.
155 # + Fixed the ornaments that made "|h" completely unusable.
156 # They are not used in print_help if they will hurt. Strip pod
157 # if we're paging to less.
158 # + Fixed mis-formatting of help messages caused by ornaments
159 # to restore Larry's original formatting.
160 # + Fixed many other formatting errors. The code is still suboptimal,
161 # and needs a lot of work at restructuring. It's also misindented
163 # + Fixed bug where trying to look at an option like your pager
165 # + Fixed some $? processing. Note: if you use csh or tcsh, you will
166 # lose. You should consider shell escapes not using their shell,
167 # or else not caring about detailed status. This should really be
168 # unified into one place, too.
169 # + Fixed bug where invisible trailing whitespace on commands hoses you,
170 # tricking Perl into thinking you weren't calling a debugger command!
171 # + Fixed bug where leading whitespace on commands hoses you. (One
172 # suggests a leading semicolon or any other irrelevant non-whitespace
173 # to indicate literal Perl code.)
174 # + Fixed bugs that ate warnings due to wrong selected handle.
175 # + Fixed a precedence bug on signal stuff.
176 # + Fixed some unseemly wording.
177 # + Fixed bug in help command trying to call perl method code.
178 # + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
180 # + Added some comments. This code is still nasty spaghetti.
181 # + Added message if you clear your pre/post command stacks which was
182 # very easy to do if you just typed a bare >, <, or {. (A command
183 # without an argument should *never* be a destructive action; this
184 # API is fundamentally screwed up; likewise option setting, which
185 # is equally buggered.)
186 # + Added command stack dump on argument of "?" for >, <, or {.
187 # + Added a semi-built-in doc viewer command that calls man with the
188 # proper %Config::Config path (and thus gets caching, man -k, etc),
189 # or else perldoc on obstreperous platforms.
190 # + Added to and rearranged the help information.
191 # + Detected apparent misuse of { ... } to declare a block; this used
192 # to work but now is a command, and mysteriously gave no complaint.
194 # Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
196 # + This patch to perl5db.pl cleans up formatting issues on the help
197 # summary (h h) screen in the debugger. Mostly columnar alignment
198 # issues, plus converted the printed text to use all spaces, since
199 # tabs don't seem to help much here.
201 # Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
202 # 0) Minor bugs corrected;
203 # a) Support for auto-creation of new TTY window on startup, either
204 # unconditionally, or if started as a kid of another debugger session;
205 # b) New `O'ption CreateTTY
206 # I<CreateTTY> bits control attempts to create a new TTY on events:
207 # 1: on fork() 2: debugger is started inside debugger
209 # c) Code to auto-create a new TTY window on OS/2 (currently one one
210 # extra window per session - need named pipes to have more...);
211 # d) Simplified interface for custom createTTY functions (with a backward
212 # compatibility hack); now returns the TTY name to use; return of ''
213 # means that the function reset the I/O handles itself;
214 # d') Better message on the semantic of custom createTTY function;
215 # e) Convert the existing code to create a TTY into a custom createTTY
217 # f) Consistent support for TTY names of the form "TTYin,TTYout";
218 # g) Switch line-tracing output too to the created TTY window;
219 # h) make `b fork' DWIM with CORE::GLOBAL::fork;
220 # i) High-level debugger API cmd_*():
221 # cmd_b_load($filenamepart) # b load filenamepart
222 # cmd_b_line($lineno [, $cond]) # b lineno [cond]
223 # cmd_b_sub($sub [, $cond]) # b sub [cond]
224 # cmd_stop() # Control-C
225 # cmd_d($lineno) # d lineno
226 # The cmd_*() API returns FALSE on failure; in this case it outputs
227 # the error message to the debugging output.
228 # j) Low-level debugger API
229 # break_on_load($filename) # b load filename
230 # @files = report_break_on_load() # List files with load-breakpoints
231 # breakable_line_in_filename($name, $from [, $to])
232 # # First breakable line in the
233 # # range $from .. $to. $to defaults
234 # # to $from, and may be less than $to
235 # breakable_line($from [, $to]) # Same for the current file
236 # break_on_filename_line($name, $lineno [, $cond])
237 # # Set breakpoint,$cond defaults to 1
238 # break_on_filename_line_range($name, $from, $to [, $cond])
239 # # As above, on the first
240 # # breakable line in range
241 # break_on_line($lineno [, $cond]) # As above, in the current file
242 # break_subroutine($sub [, $cond]) # break on the first breakable line
243 # ($name, $from, $to) = subroutine_filename_lines($sub)
244 # # The range of lines of the text
245 # The low-level API returns TRUE on success, and die()s on failure.
247 # Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
249 # + Fixed warnings generated by "perl -dWe 42"
250 # + Corrected spelling errors
251 # + Squeezed Help (h) output into 80 columns
253 # Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
254 # + Made "x @INC" work like it used to
256 # Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
257 # + Fixed warnings generated by "O" (Show debugger options)
258 # + Fixed warnings generated by "p 42" (Print expression)
259 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
260 # + Added windowSize option
261 # Changes: 1.14: Oct 9, 2001 multiple
262 # + Clean up after itself on VMS (Charles Lane in 12385)
263 # + Adding "@ file" syntax (Peter Scott in 12014)
264 # + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
265 # + $^S and other debugger fixes (Ilya Zakharevich in 11120)
266 # + Forgot a my() declaration (Ilya Zakharevich in 11085)
267 # Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern@pobox.com>
268 # + Updated 1.14 change log
269 # + Added *dbline explainatory comments
270 # + Mentioning perldebguts man page
271 ####################################################################
273 # Needed for the statement after exec():
275 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
276 local($^W) = 0; # Switch run-time warnings off during init.
279 $dumpvar::arrayDepth,
280 $dumpvar::dumpDBFiles,
281 $dumpvar::dumpPackages,
282 $dumpvar::quoteHighBit,
283 $dumpvar::printUndef,
292 # Command-line + PERLLIB:
295 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
297 $trace = $signal = $single = 0; # Uninitialized warning suppression
298 # (local $^W cannot help - other packages!).
299 $inhibit_exit = $option{PrintRet} = 1;
301 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
302 compactDump veryCompact quote HighBit undefPrint
303 globPrint PrintRet UsageOnly frame AutoTrace
304 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
305 recallCommand ShellBang pager tkRunning ornaments
306 signalLevel warnLevel dieLevel inhibit_exit
307 ImmediateStop bareStringify CreateTTY
308 RemotePort windowSize);
311 hashDepth => \$dumpvar::hashDepth,
312 arrayDepth => \$dumpvar::arrayDepth,
313 DumpDBFiles => \$dumpvar::dumpDBFiles,
314 DumpPackages => \$dumpvar::dumpPackages,
315 DumpReused => \$dumpvar::dumpReused,
316 HighBit => \$dumpvar::quoteHighBit,
317 undefPrint => \$dumpvar::printUndef,
318 globPrint => \$dumpvar::globPrint,
319 UsageOnly => \$dumpvar::usageOnly,
320 CreateTTY => \$CreateTTY,
321 bareStringify => \$dumpvar::bareStringify,
323 AutoTrace => \$trace,
324 inhibit_exit => \$inhibit_exit,
325 maxTraceLen => \$maxtrace,
326 ImmediateStop => \$ImmediateStop,
327 RemotePort => \$remoteport,
328 windowSize => \$window,
332 compactDump => \&dumpvar::compactDump,
333 veryCompact => \&dumpvar::veryCompact,
334 quote => \&dumpvar::quote,
337 ReadLine => \&ReadLine,
338 NonStop => \&NonStop,
339 LineInfo => \&LineInfo,
340 recallCommand => \&recallCommand,
341 ShellBang => \&shellBang,
343 signalLevel => \&signalLevel,
344 warnLevel => \&warnLevel,
345 dieLevel => \&dieLevel,
346 tkRunning => \&tkRunning,
347 ornaments => \&ornaments,
348 RemotePort => \&RemotePort,
352 compactDump => 'dumpvar.pl',
353 veryCompact => 'dumpvar.pl',
354 quote => 'dumpvar.pl',
357 # These guys may be defined in $ENV{PERL5DB} :
358 $rl = 1 unless defined $rl;
359 $warnLevel = 1 unless defined $warnLevel;
360 $dieLevel = 1 unless defined $dieLevel;
361 $signalLevel = 1 unless defined $signalLevel;
362 $pre = [] unless defined $pre;
363 $post = [] unless defined $post;
364 $pretype = [] unless defined $pretype;
365 $CreateTTY = 3 unless defined $CreateTTY;
367 warnLevel($warnLevel);
369 signalLevel($signalLevel);
372 (defined($ENV{PAGER})
376 : 'more'))) unless defined $pager;
378 &recallCommand("!") unless defined $prc;
379 &shellBang("!") unless defined $psh;
381 $maxtrace = 400 unless defined $maxtrace;
382 $ini_pids = $ENV{PERLDB_PIDS};
383 if (defined $ENV{PERLDB_PIDS}) {
384 $pids = "[$ENV{PERLDB_PIDS}]";
385 $ENV{PERLDB_PIDS} .= "->$$";
388 $ENV{PERLDB_PIDS} = "$$";
393 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
395 if (-e "/dev/tty") { # this is the wrong metric!
398 $rcfile="perldb.ini";
401 # This isn't really safe, because there's a race
402 # between checking and opening. The solution is to
403 # open and fstat the handle, but then you have to read and
404 # eval the contents. But then the silly thing gets
405 # your lexical scope, which is unfortunately at best.
409 # Just exactly what part of the word "CORE::" don't you understand?
410 local $SIG{__WARN__};
413 unless (is_safe_file($file)) {
414 CORE::warn <<EO_GRIPE;
415 perldb: Must not source insecure rcfile $file.
416 You or the superuser must be the owner, and it must not
417 be writable by anyone but its owner.
423 CORE::warn("perldb: couldn't parse $file: $@") if $@;
427 # Verifies that owner is either real user or superuser and that no
428 # one but owner may write to it. This function is of limited use
429 # when called on a path instead of upon a handle, because there are
430 # no guarantees that filename (by dirent) whose file (by ino) is
431 # eventually accessed is the same as the one tested.
432 # Assumes that the file's existence is not in doubt.
435 stat($path) || return; # mysteriously vaporized
436 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
438 return 0 if $uid != 0 && $uid != $<;
439 return 0 if $mode & 022;
444 safe_do("./$rcfile");
446 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
447 safe_do("$ENV{HOME}/$rcfile");
449 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
450 safe_do("$ENV{LOGDIR}/$rcfile");
453 if (defined $ENV{PERLDB_OPTS}) {
454 parse_options($ENV{PERLDB_OPTS});
457 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
458 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
459 *get_fork_TTY = \&xterm_get_fork_TTY;
460 } elsif ($^O eq 'os2') {
461 *get_fork_TTY = \&os2_get_fork_TTY;
464 # Here begin the unreadable code. It needs fixing.
466 if (exists $ENV{PERLDB_RESTART}) {
467 delete $ENV{PERLDB_RESTART};
469 @hist = get_list('PERLDB_HIST');
470 %break_on_load = get_list("PERLDB_ON_LOAD");
471 %postponed = get_list("PERLDB_POSTPONE");
472 my @had_breakpoints= get_list("PERLDB_VISITED");
473 for (0 .. $#had_breakpoints) {
474 my %pf = get_list("PERLDB_FILE_$_");
475 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
477 my %opt = get_list("PERLDB_OPT");
479 while (($opt,$val) = each %opt) {
480 $val =~ s/[\\\']/\\$1/g;
481 parse_options("$opt'$val'");
483 @INC = get_list("PERLDB_INC");
485 $pretype = [get_list("PERLDB_PRETYPE")];
486 $pre = [get_list("PERLDB_PRE")];
487 $post = [get_list("PERLDB_POST")];
488 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
494 # Is Perl being run from a slave editor or graphical debugger?
495 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
496 $rl = 0, shift(@main::ARGV) if $slave_editor;
498 #require Term::ReadLine;
500 if ($^O eq 'cygwin') {
501 # /dev/tty is binary. use stdin for textmode
503 } elsif (-e "/dev/tty") {
504 $console = "/dev/tty";
505 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
507 } elsif ($^O eq 'MacOS') {
508 if ($MacPerl::Version !~ /MPW/) {
509 $console = "Dev:Console:Perl Debug"; # Separate window for application
511 $console = "Dev:Console";
514 $console = "sys\$command";
517 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
521 if ($^O eq 'NetWare') {
526 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
534 $console = $tty if defined $tty;
536 if (defined $remoteport) {
538 $OUT = new IO::Socket::INET( Timeout => '10',
539 PeerAddr => $remoteport,
542 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
544 } elsif ($CreateTTY & 4) {
547 if (defined $console) {
548 my ($i, $o) = split /,/, $console;
549 $o = $i unless defined $o;
550 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
551 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
552 || open(OUT,">&STDOUT"); # so we don't dongle stdout
555 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
556 $console = 'STDIN/OUT';
558 # so open("|more") can read from STDOUT and so we don't dingle stdin
563 my $previous = select($OUT);
564 $| = 1; # for DB::OUT
567 $LINEINFO = $OUT unless defined $LINEINFO;
568 $lineinfo = $console unless defined $lineinfo;
570 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
571 unless ($runnonstop) {
572 if ($term_pid eq '-1') {
573 print $OUT "\nDaughter DB session started...\n";
575 print $OUT "\nLoading DB routines from $header\n";
576 print $OUT ("Editor support ",
577 $slave_editor ? "enabled" : "available",
579 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
587 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
590 if (defined &afterinit) { # May be defined in $rcfile
596 ############################################################ Subroutines
599 # _After_ the perl program is compiled, $single is set to 1:
600 if ($single and not $second_time++) {
601 if ($runnonstop) { # Disable until signal
602 for ($i=0; $i <= $stack_depth; ) {
606 # return; # Would not print trace!
607 } elsif ($ImmediateStop) {
612 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
614 ($package, $filename, $line) = caller;
615 $filename_ini = $filename;
616 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
617 "package $package;"; # this won't let them modify, alas
618 local(*dbline) = $main::{'_<' . $filename};
620 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
624 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
625 $dbline{$line} =~ s/;9($|\0)/$1/;
628 my $was_signal = $signal;
630 for (my $n = 0; $n <= $#to_watch; $n++) {
631 $evalarg = $to_watch[$n];
632 local $onetimeDump; # Do not output results
633 my ($val) = &eval; # Fix context (&eval is doing array)?
634 $val = ( (defined $val) ? "'$val'" : 'undef' );
635 if ($val ne $old_watch[$n]) {
638 Watchpoint $n:\t$to_watch[$n] changed:
639 old value:\t$old_watch[$n]
642 $old_watch[$n] = $val;
646 if ($trace & 4) { # User-installed watch
647 return if watchfunction($package, $filename, $line)
648 and not $single and not $was_signal and not ($trace & ~4);
650 $was_signal = $signal;
652 if ($single || ($trace & 1) || $was_signal) {
654 $position = "\032\032$filename:$line:0\n";
655 print_lineinfo($position);
656 } elsif ($package eq 'DB::fake') {
659 Debugged program terminated. Use B<q> to quit or B<R> to restart,
660 use B<O> I<inhibit_exit> to avoid stopping after program termination,
661 B<h q>, B<h R> or B<h O> to get additional info.
664 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
665 "package $package;"; # this won't let them modify, alas
668 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
669 $prefix .= "$sub($filename:";
670 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
671 if (length($prefix) > 30) {
672 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
677 $position = "$prefix$line$infix$dbline[$line]$after";
680 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
682 print_lineinfo($position);
684 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
685 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
687 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
688 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
689 $position .= $incr_pos;
691 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
693 print_lineinfo($incr_pos);
698 $evalarg = $action, &eval if $action;
699 if ($single || $was_signal) {
700 local $level = $level + 1;
701 foreach $evalarg (@$pre) {
704 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
707 $incr = -1; # for backward motion.
708 @typeahead = (@$pretype, @typeahead);
710 while (($term || &setterm),
711 ($term_pid == $$ or resetterm(1)),
712 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
713 ($#hist+1) . ('>' x $level) .
718 $cmd =~ s/\\$/\n/ && do {
719 $cmd .= &readline(" cont: ");
722 $cmd =~ /^$/ && ($cmd = $laststep);
723 push(@hist,$cmd) if length($cmd) > 1;
725 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
726 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
727 ($i) = split(/\s+/,$cmd);
729 # squelch the sigmangler
731 local $SIG{__WARN__};
732 eval "\$cmd =~ $alias{$i}";
734 print $OUT "Couldn't evaluate `$i' alias: $@";
738 $cmd =~ /^q$/ && ($fall_off_end = 1) && clean_ENV() && exit $?;
739 $cmd =~ /^h$/ && do {
742 $cmd =~ /^h\s+h$/ && do {
743 print_help($summary);
745 # support long commands; otherwise bogus errors
746 # happen when you ask for h on <CR> for example
747 $cmd =~ /^h\s+(\S.*)$/ && do {
748 my $asked = $1; # for proper errmsg
749 my $qasked = quotemeta($asked); # for searching
750 # XXX: finds CR but not <CR>
751 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
752 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
756 print_help("B<$asked> is not a debugger command.\n");
759 $cmd =~ /^t$/ && do {
761 print $OUT "Trace = " .
762 (($trace & 1) ? "on" : "off" ) . "\n";
764 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
765 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
766 foreach $subname (sort(keys %sub)) {
767 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
768 print $OUT $subname,"\n";
772 $cmd =~ /^v$/ && do {
773 list_versions(); next CMD};
774 $cmd =~ s/^X\b/V $package/;
775 $cmd =~ /^V$/ && do {
776 $cmd = "V $package"; };
777 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
778 local ($savout) = select($OUT);
780 @vars = split(' ',$2);
781 do 'dumpvar.pl' unless defined &main::dumpvar;
782 if (defined &main::dumpvar) {
785 # must detect sigpipe failures
786 eval { &main::dumpvar($packname,@vars) };
788 die unless $@ =~ /dumpvar print failed/;
791 print $OUT "dumpvar.pl not available.\n";
795 $cmd =~ s/^x\b/ / && do { # So that will be evaled
796 $onetimeDump = 'dump'; };
797 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
798 methods($1); next CMD};
799 $cmd =~ s/^m\b/ / && do { # So this will be evaled
800 $onetimeDump = 'methods'; };
801 $cmd =~ /^f\b\s*(.*)/ && do {
805 print $OUT "The old f command is now the r command.\n";
806 print $OUT "The new f command switches filenames.\n";
809 if (!defined $main::{'_<' . $file}) {
810 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
811 $try = substr($try,2);
812 print $OUT "Choosing $try matching `$file':\n";
816 if (!defined $main::{'_<' . $file}) {
817 print $OUT "No file matching `$file' is loaded.\n";
819 } elsif ($file ne $filename) {
820 *dbline = $main::{'_<' . $file};
826 print $OUT "Already in $file.\n";
830 $cmd =~ s/^l\s+-\s*$/-/;
831 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
834 print($OUT "Error: $@\n"), next CMD if $@;
836 print($OUT "Interpreted as: $1 $s\n");
839 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
840 my $s = $subname = $1;
841 $subname =~ s/\'/::/;
842 $subname = $package."::".$subname
843 unless $subname =~ /::/;
844 $subname = "CORE::GLOBAL::$s"
845 if not defined &$subname and $s !~ /::/
846 and defined &{"CORE::GLOBAL::$s"};
847 $subname = "main".$subname if substr($subname,0,2) eq "::";
848 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
849 $subrange = pop @pieces;
850 $file = join(':', @pieces);
851 if ($file ne $filename) {
852 print $OUT "Switching to file '$file'.\n"
853 unless $slave_editor;
854 *dbline = $main::{'_<' . $file};
859 if (eval($subrange) < -$window) {
860 $subrange =~ s/-.*/+/;
862 $cmd = "l $subrange";
864 print $OUT "Subroutine $subname not found.\n";
867 $cmd =~ /^\.$/ && do {
868 $incr = -1; # for backward motion.
870 $filename = $filename_ini;
871 *dbline = $main::{'_<' . $filename};
873 print_lineinfo($position);
875 $cmd =~ /^w\b\s*(\d*)$/ && do {
879 #print $OUT 'l ' . $start . '-' . ($start + $incr);
880 $cmd = 'l ' . $start . '-' . ($start + $incr); };
881 $cmd =~ /^-$/ && do {
882 $start -= $incr + $window + 1;
883 $start = 1 if $start <= 0;
885 $cmd = 'l ' . ($start) . '+'; };
886 $cmd =~ /^l$/ && do {
888 $cmd = 'l ' . $start . '-' . ($start + $incr); };
889 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
892 $incr = $window - 1 unless $incr;
893 $cmd = 'l ' . $start . '-' . ($start + $incr); };
894 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
895 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
896 $end = $max if $end > $max;
898 $i = $line if $i eq '.';
902 print $OUT "\032\032$filename:$i:0\n";
905 for (; $i <= $end; $i++) {
907 ($stop,$action) = split(/\0/, $dbline{$i}) if
910 and $filename eq $filename_ini)
912 : ($dbline[$i]+0 ? ':' : ' ') ;
913 $arrow .= 'b' if $stop;
914 $arrow .= 'a' if $action;
915 print $OUT "$i$arrow\t", $dbline[$i];
916 $i++, last if $signal;
918 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
920 $start = $i; # remember in case they want more
921 $start = $max if $start > $max;
923 $cmd =~ /^D$/ && do {
924 print $OUT "Deleting all breakpoints...\n";
926 for $file (keys %had_breakpoints) {
927 local *dbline = $main::{'_<' . $file};
931 for ($i = 1; $i <= $max ; $i++) {
932 if (defined $dbline{$i}) {
933 $dbline{$i} =~ s/^[^\0]+//;
934 if ($dbline{$i} =~ s/^\0?$//) {
940 if (not $had_breakpoints{$file} &= ~1) {
941 delete $had_breakpoints{$file};
945 undef %postponed_file;
946 undef %break_on_load;
948 $cmd =~ /^L$/ && do {
950 for $file (keys %had_breakpoints) {
951 local *dbline = $main::{'_<' . $file};
955 for ($i = 1; $i <= $max; $i++) {
956 if (defined $dbline{$i}) {
957 print $OUT "$file:\n" unless $was++;
958 print $OUT " $i:\t", $dbline[$i];
959 ($stop,$action) = split(/\0/, $dbline{$i});
960 print $OUT " break if (", $stop, ")\n"
962 print $OUT " action: ", $action, "\n"
969 print $OUT "Postponed breakpoints in subroutines:\n";
971 for $subname (keys %postponed) {
972 print $OUT " $subname\t$postponed{$subname}\n";
976 my @have = map { # Combined keys
977 keys %{$postponed_file{$_}}
978 } keys %postponed_file;
980 print $OUT "Postponed breakpoints in files:\n";
982 for $file (keys %postponed_file) {
983 my $db = $postponed_file{$file};
984 print $OUT " $file:\n";
985 for $line (sort {$a <=> $b} keys %$db) {
986 print $OUT " $line:\n";
987 my ($stop,$action) = split(/\0/, $$db{$line});
988 print $OUT " break if (", $stop, ")\n"
990 print $OUT " action: ", $action, "\n"
997 if (%break_on_load) {
998 print $OUT "Breakpoints on load:\n";
1000 for $file (keys %break_on_load) {
1001 print $OUT " $file\n";
1006 print $OUT "Watch-expressions:\n";
1008 for $expr (@to_watch) {
1009 print $OUT " $expr\n";
1014 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
1015 my $file = $1; $file =~ s/\s+$//;
1018 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
1019 my $cond = length $3 ? $3 : '1';
1020 my ($subname, $break) = ($2, $1 eq 'postpone');
1021 $subname =~ s/\'/::/g;
1022 $subname = "${'package'}::" . $subname
1023 unless $subname =~ /::/;
1024 $subname = "main".$subname if substr($subname,0,2) eq "::";
1025 $postponed{$subname} = $break
1026 ? "break +0 if $cond" : "compile";
1028 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1030 $cond = length $2 ? $2 : '1';
1031 cmd_b_sub($subname, $cond);
1033 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1035 $cond = length $2 ? $2 : '1';
1036 cmd_b_line($i, $cond);
1038 $cmd =~ /^d\b\s*(\d*)/ && do {
1041 $cmd =~ /^A$/ && do {
1042 print $OUT "Deleting all actions...\n";
1044 for $file (keys %had_breakpoints) {
1045 local *dbline = $main::{'_<' . $file};
1049 for ($i = 1; $i <= $max ; $i++) {
1050 if (defined $dbline{$i}) {
1051 $dbline{$i} =~ s/\0[^\0]*//;
1052 delete $dbline{$i} if $dbline{$i} eq '';
1056 unless ($had_breakpoints{$file} &= ~2) {
1057 delete $had_breakpoints{$file};
1061 $cmd =~ /^O\s*$/ && do {
1066 $cmd =~ /^O\s*(\S.*)/ && do {
1069 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1070 push @$pre, action($1);
1072 $cmd =~ /^>>\s*(.*)/ && do {
1073 push @$post, action($1);
1075 $cmd =~ /^<\s*(.*)/ && do {
1077 print $OUT "All < actions cleared.\n";
1083 print $OUT "No pre-prompt Perl actions.\n";
1086 print $OUT "Perl commands run before each prompt:\n";
1087 for my $action ( @$pre ) {
1088 print $OUT "\t< -- $action\n";
1092 $pre = [action($1)];
1094 $cmd =~ /^>\s*(.*)/ && do {
1096 print $OUT "All > actions cleared.\n";
1102 print $OUT "No post-prompt Perl actions.\n";
1105 print $OUT "Perl commands run after each prompt:\n";
1106 for my $action ( @$post ) {
1107 print $OUT "\t> -- $action\n";
1111 $post = [action($1)];
1113 $cmd =~ /^\{\{\s*(.*)/ && do {
1114 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1115 print $OUT "{{ is now a debugger command\n",
1116 "use `;{{' if you mean Perl code\n";
1122 $cmd =~ /^\{\s*(.*)/ && do {
1124 print $OUT "All { actions cleared.\n";
1129 unless (@$pretype) {
1130 print $OUT "No pre-prompt debugger actions.\n";
1133 print $OUT "Debugger commands run before each prompt:\n";
1134 for my $action ( @$pretype ) {
1135 print $OUT "\t{ -- $action\n";
1139 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1140 print $OUT "{ is now a debugger command\n",
1141 "use `;{' if you mean Perl code\n";
1147 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1148 $i = $1 || $line; $j = $2;
1150 if ($dbline[$i] == 0) {
1151 print $OUT "Line $i may not have an action.\n";
1153 $had_breakpoints{$filename} |= 2;
1154 $dbline{$i} =~ s/\0[^\0]*//;
1155 $dbline{$i} .= "\0" . action($j);
1158 $dbline{$i} =~ s/\0[^\0]*//;
1159 delete $dbline{$i} if $dbline{$i} eq '';
1162 $cmd =~ /^n$/ && do {
1163 end_report(), next CMD if $finished and $level <= 1;
1167 $cmd =~ /^s$/ && do {
1168 end_report(), next CMD if $finished and $level <= 1;
1172 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1173 end_report(), next CMD if $finished and $level <= 1;
1175 # Probably not needed, since we finish an interactive
1176 # sub-session anyway...
1177 # local $filename = $filename;
1178 # local *dbline = *dbline; # XXX Would this work?!
1179 if ($i =~ /\D/) { # subroutine name
1180 $subname = $package."::".$subname
1181 unless $subname =~ /::/;
1182 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1186 *dbline = $main::{'_<' . $filename};
1187 $had_breakpoints{$filename} |= 1;
1189 ++$i while $dbline[$i] == 0 && $i < $max;
1191 print $OUT "Subroutine $subname not found.\n";
1196 if ($dbline[$i] == 0) {
1197 print $OUT "Line $i not breakable.\n";
1200 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1202 for ($i=0; $i <= $stack_depth; ) {
1206 $cmd =~ /^r$/ && do {
1207 end_report(), next CMD if $finished and $level <= 1;
1208 $stack[$stack_depth] |= 1;
1209 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1211 $cmd =~ /^R$/ && do {
1212 print $OUT "Warning: some settings and command-line options may be lost!\n";
1213 my (@script, @flags, $cl);
1214 push @flags, '-w' if $ini_warn;
1215 # Put all the old includes at the start to get
1216 # the same debugger.
1218 push @flags, '-I', $_;
1220 # Arrange for setting the old INC:
1221 set_list("PERLDB_INC", @ini_INC);
1223 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1224 chomp ($cl = ${'::_<-e'}[$_]);
1225 push @script, '-e', $cl;
1230 set_list("PERLDB_HIST",
1231 $term->Features->{getHistory}
1232 ? $term->GetHistory : @hist);
1233 my @had_breakpoints = keys %had_breakpoints;
1234 set_list("PERLDB_VISITED", @had_breakpoints);
1235 set_list("PERLDB_OPT", %option);
1236 set_list("PERLDB_ON_LOAD", %break_on_load);
1238 for (0 .. $#had_breakpoints) {
1239 my $file = $had_breakpoints[$_];
1240 *dbline = $main::{'_<' . $file};
1241 next unless %dbline or $postponed_file{$file};
1242 (push @hard, $file), next
1243 if $file =~ /^\(\w*eval/;
1245 @add = %{$postponed_file{$file}}
1246 if $postponed_file{$file};
1247 set_list("PERLDB_FILE_$_", %dbline, @add);
1249 for (@hard) { # Yes, really-really...
1250 # Find the subroutines in this eval
1251 *dbline = $main::{'_<' . $_};
1252 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1253 for $sub (keys %sub) {
1254 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1255 $subs{$sub} = [$1, $2];
1259 "No subroutines in $_, ignoring breakpoints.\n";
1262 LINES: for $line (keys %dbline) {
1263 # One breakpoint per sub only:
1264 my ($offset, $sub, $found);
1265 SUBS: for $sub (keys %subs) {
1266 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1267 and (not defined $offset # Not caught
1268 or $offset < 0 )) { # or badly caught
1270 $offset = $line - $subs{$sub}->[0];
1271 $offset = "+$offset", last SUBS if $offset >= 0;
1274 if (defined $offset) {
1275 $postponed{$found} =
1276 "break $offset if $dbline{$line}";
1278 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1282 set_list("PERLDB_POSTPONE", %postponed);
1283 set_list("PERLDB_PRETYPE", @$pretype);
1284 set_list("PERLDB_PRE", @$pre);
1285 set_list("PERLDB_POST", @$post);
1286 set_list("PERLDB_TYPEAHEAD", @typeahead);
1287 $ENV{PERLDB_RESTART} = 1;
1288 delete $ENV{PERLDB_PIDS}; # Restore ini state
1289 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1290 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1291 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1292 print $OUT "exec failed: $!\n";
1294 $cmd =~ /^T$/ && do {
1295 print_trace($OUT, 1); # skip DB
1297 $cmd =~ /^W\s*$/ && do {
1299 @to_watch = @old_watch = ();
1301 $cmd =~ /^W\b\s*(.*)/s && do {
1305 $val = (defined $val) ? "'$val'" : 'undef' ;
1306 push @old_watch, $val;
1309 $cmd =~ /^\/(.*)$/ && do {
1311 $inpat =~ s:([^\\])/$:$1:;
1313 # squelch the sigmangler
1314 local $SIG{__DIE__};
1315 local $SIG{__WARN__};
1316 eval '$inpat =~ m'."\a$inpat\a";
1328 $start = 1 if ($start > $max);
1329 last if ($start == $end);
1330 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1331 if ($slave_editor) {
1332 print $OUT "\032\032$filename:$start:0\n";
1334 print $OUT "$start:\t", $dbline[$start], "\n";
1339 print $OUT "/$pat/: not found\n" if ($start == $end);
1341 $cmd =~ /^\?(.*)$/ && do {
1343 $inpat =~ s:([^\\])\?$:$1:;
1345 # squelch the sigmangler
1346 local $SIG{__DIE__};
1347 local $SIG{__WARN__};
1348 eval '$inpat =~ m'."\a$inpat\a";
1360 $start = $max if ($start <= 0);
1361 last if ($start == $end);
1362 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1363 if ($slave_editor) {
1364 print $OUT "\032\032$filename:$start:0\n";
1366 print $OUT "$start:\t", $dbline[$start], "\n";
1371 print $OUT "?$pat?: not found\n" if ($start == $end);
1373 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1374 pop(@hist) if length($cmd) > 1;
1375 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1377 print $OUT $cmd, "\n";
1379 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1382 $cmd =~ /^$rc([^$rc].*)$/ && do {
1384 pop(@hist) if length($cmd) > 1;
1385 for ($i = $#hist; $i; --$i) {
1386 last if $hist[$i] =~ /$pat/;
1389 print $OUT "No such command!\n\n";
1393 print $OUT $cmd, "\n";
1395 $cmd =~ /^$sh$/ && do {
1396 &system($ENV{SHELL}||"/bin/sh");
1398 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1399 # XXX: using csh or tcsh destroys sigint retvals!
1400 #&system($1); # use this instead
1401 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1403 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1404 $end = $2 ? ($#hist-$2) : 0;
1405 $hist = 0 if $hist < 0;
1406 for ($i=$#hist; $i>$end; $i--) {
1407 print $OUT "$i: ",$hist[$i],"\n"
1408 unless $hist[$i] =~ /^.?$/;
1411 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1414 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1415 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1416 $cmd =~ s/^=\s*// && do {
1418 if (length $cmd == 0) {
1419 @keys = sort keys %alias;
1421 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1422 # can't use $_ or kill //g state
1423 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1424 $alias{$k} = "s\a$k\a$v\a";
1425 # squelch the sigmangler
1426 local $SIG{__DIE__};
1427 local $SIG{__WARN__};
1428 unless (eval "sub { s\a$k\a$v\a }; 1") {
1429 print $OUT "Can't alias $k to $v: $@\n";
1439 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1440 print $OUT "$k\t= $1\n";
1442 elsif (defined $alias{$k}) {
1443 print $OUT "$k\t$alias{$k}\n";
1446 print "No alias for $k\n";
1450 $cmd =~ /^\@\s*(.*\S)/ && do {
1451 if (open my $fh, $1) {
1455 &warn("Can't execute `$1': $!\n");
1458 $cmd =~ /^\|\|?\s*[^|]/ && do {
1459 if ($pager =~ /^\|/) {
1460 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1461 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1463 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1466 unless ($piped=open(OUT,$pager)) {
1467 &warn("Can't pipe output to `$pager'");
1468 if ($pager =~ /^\|/) {
1469 open(OUT,">&STDOUT") # XXX: lost message
1470 || &warn("Can't restore DB::OUT");
1471 open(STDOUT,">&SAVEOUT")
1472 || &warn("Can't restore STDOUT");
1475 open(OUT,">&STDOUT") # XXX: lost message
1476 || &warn("Can't restore DB::OUT");
1480 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1481 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1482 $selected= select(OUT);
1484 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1485 $cmd =~ s/^\|+\s*//;
1488 # XXX Local variants do not work!
1489 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1490 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1491 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1493 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1495 $onetimeDump = undef;
1496 } elsif ($term_pid == $$) {
1501 if ($pager =~ /^\|/) {
1503 # we cannot warn here: the handle is missing --tchrist
1504 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1506 # most of the $? crud was coping with broken cshisms
1508 print SAVEOUT "Pager `$pager' failed: ";
1510 print SAVEOUT "shell returned -1\n";
1513 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1514 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1516 print SAVEOUT "status ", ($? >> 8), "\n";
1520 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1521 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1522 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1523 # Will stop ignoring SIGPIPE if done like nohup(1)
1524 # does SIGINT but Perl doesn't give us a choice.
1526 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1529 select($selected), $selected= "" unless $selected eq "";
1533 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1534 foreach $evalarg (@$post) {
1537 } # if ($single || $signal)
1538 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1542 # The following code may be executed now:
1546 my ($al, $ret, @ret) = "";
1547 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1550 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1551 $#stack = $stack_depth;
1552 $stack[-1] = $single;
1554 $single |= 4 if $stack_depth == $deep;
1556 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1557 # Why -1? But it works! :-(
1558 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1559 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1562 $single |= $stack[$stack_depth--];
1564 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1565 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1566 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1567 if ($doret eq $stack_depth or $frame & 16) {
1568 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1569 print $fh ' ' x $stack_depth if $frame & 16;
1570 print $fh "list context return from $sub:\n";
1571 dumpit($fh, \@ret );
1576 if (defined wantarray) {
1581 $single |= $stack[$stack_depth--];
1583 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1584 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1585 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1586 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1587 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1588 print $fh (' ' x $stack_depth) if $frame & 16;
1589 print $fh (defined wantarray
1590 ? "scalar context return from $sub: "
1591 : "void context return from $sub\n");
1592 dumpit( $fh, $ret ) if defined wantarray;
1601 ### Functions with multiple modes of failure die on error, the rest
1602 ### returns FALSE on error.
1603 ### User-interface functions cmd_* output error message.
1607 $break_on_load{$file} = 1;
1608 $had_breakpoints{$file} |= 1;
1611 sub report_break_on_load {
1612 sort keys %break_on_load;
1620 push @files, $::INC{$file} if $::INC{$file};
1621 $file .= '.pm', redo unless $file =~ /\./;
1623 break_on_load($_) for @files;
1624 @files = report_break_on_load;
1625 print $OUT "Will stop on load of `@files'.\n";
1628 $filename_error = '';
1630 sub breakable_line {
1631 my ($from, $to) = @_;
1634 my $delta = $from < $to ? +1 : -1;
1635 my $limit = $delta > 0 ? $#dbline : 1;
1636 $limit = $to if ($limit - $to) * $delta > 0;
1637 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1639 return $i unless $dbline[$i] == 0;
1640 my ($pl, $upto) = ('', '');
1641 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1642 die "Line$pl $from$upto$filename_error not breakable\n";
1645 sub breakable_line_in_filename {
1647 local *dbline = $main::{'_<' . $f};
1648 local $filename_error = " of `$f'";
1653 my ($i, $cond) = @_;
1654 $cond = 1 unless @_ >= 2;
1658 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1659 $had_breakpoints{$filename} |= 1;
1660 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1661 else { $dbline{$i} = $cond; }
1665 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1668 sub break_on_filename_line {
1669 my ($f, $i, $cond) = @_;
1670 $cond = 1 unless @_ >= 3;
1671 local *dbline = $main::{'_<' . $f};
1672 local $filename_error = " of `$f'";
1673 local $filename = $f;
1674 break_on_line($i, $cond);
1677 sub break_on_filename_line_range {
1678 my ($f, $from, $to, $cond) = @_;
1679 my $i = breakable_line_in_filename($f, $from, $to);
1680 $cond = 1 unless @_ >= 3;
1681 break_on_filename_line($f,$i,$cond);
1684 sub subroutine_filename_lines {
1685 my ($subname,$cond) = @_;
1686 # Filename below can contain ':'
1687 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1690 sub break_subroutine {
1691 my $subname = shift;
1692 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1693 die "Subroutine $subname not found.\n";
1694 $cond = 1 unless @_ >= 2;
1695 break_on_filename_line_range($file,$s,$e,@_);
1699 my ($subname,$cond) = @_;
1700 $cond = 1 unless @_ >= 2;
1701 unless (ref $subname eq 'CODE') {
1702 $subname =~ s/\'/::/g;
1704 $subname = "${'package'}::" . $subname
1705 unless $subname =~ /::/;
1706 $subname = "CORE::GLOBAL::$s"
1707 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1708 $subname = "main".$subname if substr($subname,0,2) eq "::";
1710 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1713 sub cmd_stop { # As on ^C, but not signal-safy.
1717 sub delete_breakpoint {
1719 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1720 $dbline{$i} =~ s/^[^\0]*//;
1721 delete $dbline{$i} if $dbline{$i} eq '';
1726 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1729 ### END of the API section
1732 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1733 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1736 sub print_lineinfo {
1737 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1741 # The following takes its argument via $evalarg to preserve current @_
1744 # 'my' would make it visible from user code
1745 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1748 local $otrace = $trace;
1749 local $osingle = $single;
1751 { ($evalarg) = $evalarg =~ /(.*)/s; }
1752 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1758 local $saved[0]; # Preserve the old value of $@
1762 } elsif ($onetimeDump) {
1763 dumpit($OUT, \@res) if $onetimeDump eq 'dump';
1764 methods($res[0]) if $onetimeDump eq 'methods';
1770 my $subname = shift;
1771 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1772 my $offset = $1 || 0;
1773 # Filename below can contain ':'
1774 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1777 local *dbline = $main::{'_<' . $file};
1778 local $^W = 0; # != 0 is magical below
1779 $had_breakpoints{$file} |= 1;
1781 ++$i until $dbline[$i] != 0 or $i >= $max;
1782 $dbline{$i} = delete $postponed{$subname};
1784 print $OUT "Subroutine $subname not found.\n";
1788 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1789 #print $OUT "In postponed_sub for `$subname'.\n";
1793 if ($ImmediateStop) {
1797 return &postponed_sub
1798 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1799 # Cannot be done before the file is compiled
1800 local *dbline = shift;
1801 my $filename = $dbline;
1802 $filename =~ s/^_<//;
1803 $signal = 1, print $OUT "'$filename' loaded...\n"
1804 if $break_on_load{$filename};
1805 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1806 return unless $postponed_file{$filename};
1807 $had_breakpoints{$filename} |= 1;
1808 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1810 for $key (keys %{$postponed_file{$filename}}) {
1811 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1813 delete $postponed_file{$filename};
1817 local ($savout) = select(shift);
1818 my $osingle = $single;
1819 my $otrace = $trace;
1820 $single = $trace = 0;
1823 unless (defined &main::dumpValue) {
1826 if (defined &main::dumpValue) {
1827 &main::dumpValue(shift);
1829 print $OUT "dumpvar.pl not available.\n";
1836 # Tied method do not create a context, so may get wrong message:
1840 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1841 my @sub = dump_trace($_[0] + 1, $_[1]);
1842 my $short = $_[2]; # Print short report, next one for sub name
1844 for ($i=0; $i <= $#sub; $i++) {
1847 my $args = defined $sub[$i]{args}
1848 ? "(@{ $sub[$i]{args} })"
1850 $args = (substr $args, 0, $maxtrace - 3) . '...'
1851 if length $args > $maxtrace;
1852 my $file = $sub[$i]{file};
1853 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1855 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1857 my $sub = @_ >= 4 ? $_[3] : $s;
1858 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1860 print $fh "$sub[$i]{context} = $s$args" .
1861 " called from $file" .
1862 " line $sub[$i]{line}\n";
1869 my $count = shift || 1e9;
1872 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1873 my $nothard = not $frame & 8;
1874 local $frame = 0; # Do not want to trace this.
1875 my $otrace = $trace;
1878 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1883 if (not defined $arg) {
1885 } elsif ($nothard and tied $arg) {
1887 } elsif ($nothard and $type = ref $arg) {
1888 push @a, "ref($type)";
1890 local $_ = "$arg"; # Safe to stringify now - should not call f().
1893 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1894 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1895 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1899 $context = $context ? '@' : (defined $context ? "\$" : '.');
1900 $args = $h ? [@a] : undef;
1901 $e =~ s/\n\s*\;\s*\Z// if $e;
1902 $e =~ s/([\\\'])/\\$1/g if $e;
1904 $sub = "require '$e'";
1905 } elsif (defined $r) {
1907 } elsif ($sub eq '(eval)') {
1908 $sub = "eval {...}";
1910 push(@sub, {context => $context, sub => $sub, args => $args,
1911 file => $file, line => $line});
1920 while ($action =~ s/\\$//) {
1929 # i hate using globals!
1930 $balanced_brace_re ||= qr{
1933 (?> [^{}] + ) # Non-parens without backtracking
1935 (??{ $balanced_brace_re }) # Group with matching parens
1939 return $_[0] !~ m/$balanced_brace_re/;
1943 &readline("cont: ");
1947 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1948 # some non-Unix systems can do system() but have problems with fork().
1949 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1950 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1951 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1952 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1954 # XXX: using csh or tcsh destroys sigint retvals!
1956 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1957 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1962 # most of the $? crud was coping with broken cshisms
1964 &warn("(Command exited ", ($? >> 8), ")\n");
1966 &warn( "(Command died of SIG#", ($? & 127),
1967 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1977 eval { require Term::ReadLine } or die $@;
1980 my ($i, $o) = split $tty, /,/;
1981 $o = $i unless defined $o;
1982 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1983 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1986 my $sel = select($OUT);
1990 eval "require Term::Rendezvous;" or die;
1991 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1992 my $term_rv = new Term::Rendezvous $rv;
1994 $OUT = $term_rv->OUT;
1997 if ($term_pid eq '-1') { # In a TTY with another debugger
2001 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2003 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2005 $rl_attribs = $term->Attribs;
2006 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2007 if defined $rl_attribs->{basic_word_break_characters}
2008 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2009 $rl_attribs->{special_prefixes} = '$@&%';
2010 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2011 $rl_attribs->{completion_function} = \&db_complete;
2013 $LINEINFO = $OUT unless defined $LINEINFO;
2014 $lineinfo = $console unless defined $lineinfo;
2016 if ($term->Features->{setHistory} and "@hist" ne "?") {
2017 $term->SetHistory(@hist);
2019 ornaments($ornaments) if defined $ornaments;
2023 # Example get_fork_TTY functions
2024 sub xterm_get_fork_TTY {
2025 (my $name = $0) =~ s,^.*[/\\],,s;
2026 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2030 $pidprompt = ''; # Shown anyway in titlebar
2034 # This one resets $IN, $OUT itself
2035 sub os2_get_fork_TTY {
2036 $^F = 40; # XXXX Fixme!
2037 my ($in1, $out1, $in2, $out2);
2038 # Having -d in PERL5OPT would lead to a disaster...
2039 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2040 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2041 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2042 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2043 (my $name = $0) =~ s,^.*[/\\],,s;
2044 if ( pipe $in1, $out1 and pipe $in2, $out2 and
2045 # system P_SESSION will fail if there is another process
2046 # in the same session with a "dependent" asynchronous child session.
2047 (($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
2051 my $in = shift; # Read from here and pass through
2053 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2054 open IN, '<&=$in' or die "open <&=$in: \$!";
2055 \$| = 1; print while sysread IN, \$_, 1<<16;
2059 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2061 ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
2062 print while sysread STDIN, $_, 1<<16;
2064 and close $in1 and close $out2 ) {
2065 $pidprompt = ''; # Shown anyway in titlebar
2066 reset_IN_OUT($in2, $out1);
2068 return ''; # Indicate that reset_IN_OUT is called
2073 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2074 my $in = &get_fork_TTY if defined &get_fork_TTY;
2075 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2076 if (not defined $in) {
2078 print_help(<<EOP) if $why == 1;
2079 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2081 print_help(<<EOP) if $why == 2;
2082 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2083 This may be an asynchronous session, so the parent debugger may be active.
2085 print_help(<<EOP) if $why != 4;
2086 Since two debuggers fight for the same TTY, input is severely entangled.
2090 I know how to switch the output to a different window in xterms
2091 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2092 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2094 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2095 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2098 } elsif ($in ne '') {
2104 sub resetterm { # We forked, so we need a different TTY
2106 my $systemed = $in > 1 ? '-' : '';
2108 $pids =~ s/\]/$systemed->$$]/;
2110 $pids = "[$term_pid->$$]";
2114 return unless $CreateTTY & $in;
2121 my $left = @typeahead;
2122 my $got = shift @typeahead;
2123 print $OUT "auto(-$left)", shift, $got, "\n";
2124 $term->AddHistory($got)
2125 if length($got) > 1 and defined $term->Features->{addHistory};
2131 my $line = CORE::readline($cmdfhs[-1]);
2132 defined $line ? (print $OUT ">> $line" and return $line)
2133 : close pop @cmdfhs;
2135 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2136 $OUT->write(join('', @_));
2138 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2142 $term->readline(@_);
2147 my ($opt, $val)= @_;
2148 $val = option_val($opt,'N/A');
2149 $val =~ s/([\\\'])/\\$1/g;
2150 printf $OUT "%20s = '%s'\n", $opt, $val;
2154 my ($opt, $default)= @_;
2156 if (defined $optionVars{$opt}
2157 and defined ${$optionVars{$opt}}) {
2158 $val = ${$optionVars{$opt}};
2159 } elsif (defined $optionAction{$opt}
2160 and defined &{$optionAction{$opt}}) {
2161 $val = &{$optionAction{$opt}}();
2162 } elsif (defined $optionAction{$opt}
2163 and not defined $option{$opt}
2164 or defined $optionVars{$opt}
2165 and not defined ${$optionVars{$opt}}) {
2168 $val = $option{$opt};
2170 $val = $default unless defined $val;
2176 # too dangerous to let intuitive usage overwrite important things
2177 # defaultion should never be the default
2178 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2179 arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2180 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2185 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2186 my ($opt,$sep) = ($1,$2);
2189 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2191 #&dump_option($opt);
2192 } elsif ($sep !~ /\S/) {
2194 $val = "1"; # this is an evil default; make 'em set it!
2195 } elsif ($sep eq "=") {
2197 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2199 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2203 print OUT qq(Option better cleared using $opt=""\n)
2207 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2208 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2209 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2210 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2211 ($val = $1) =~ s/\\([\\$end])/$1/g;
2215 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2216 || grep( /^\Q$opt/i && ($option = $_), @options );
2218 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2219 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2221 if ($opt_needs_val{$option} && $val_defaulted) {
2222 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2226 $option{$option} = $val if defined $val;
2231 require '$optionRequire{$option}';
2233 } || die # XXX: shouldn't happen
2234 if defined $optionRequire{$option} &&
2237 ${$optionVars{$option}} = $val
2238 if defined $optionVars{$option} &&
2241 &{$optionAction{$option}} ($val)
2242 if defined $optionAction{$option} &&
2243 defined &{$optionAction{$option}} &&
2247 dump_option($option) unless $OUT eq \*STDERR;
2252 my ($stem,@list) = @_;
2254 $ENV{"${stem}_n"} = @list;
2255 for $i (0 .. $#list) {
2257 $val =~ s/\\/\\\\/g;
2258 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2259 $ENV{"${stem}_$i"} = $val;
2266 my $n = delete $ENV{"${stem}_n"};
2268 for $i (0 .. $n - 1) {
2269 $val = delete $ENV{"${stem}_$i"};
2270 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2278 return; # Put nothing on the stack - malloc/free land!
2282 my($msg)= join("",@_);
2283 $msg .= ": $!\n" unless $msg =~ /\n$/;
2288 my $switch_li = $LINEINFO eq $OUT;
2289 if ($term and $term->Features->{newTTY}) {
2290 ($IN, $OUT) = (shift, shift);
2291 $term->newTTY($IN, $OUT);
2293 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2295 ($IN, $OUT) = (shift, shift);
2297 my $o = select $OUT;
2300 $LINEINFO = $OUT if $switch_li;
2304 if (@_ and $term and $term->Features->{newTTY}) {
2305 my ($in, $out) = shift;
2307 ($in, $out) = split /,/, $in, 2;
2311 open IN, $in or die "cannot open `$in' for read: $!";
2312 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2313 reset_IN_OUT(\*IN,\*OUT);
2316 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2317 # Useful if done through PERLDB_OPTS:
2324 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2326 $notty = shift if @_;
2332 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2340 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2342 $remoteport = shift if @_;
2347 if (${$term->Features}{tkRunning}) {
2348 return $term->tkRunning(@_);
2350 print $OUT "tkRunning not supported by current ReadLine package.\n";
2357 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2359 $runnonstop = shift if @_;
2366 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2373 $sh = quotemeta shift;
2374 $sh .= "\\b" if $sh =~ /\w$/;
2378 $psh =~ s/\\(.)/$1/g;
2383 if (defined $term) {
2384 local ($warnLevel,$dieLevel) = (0, 1);
2385 return '' unless $term->Features->{ornaments};
2386 eval { $term->ornaments(@_) } || '';
2394 $rc = quotemeta shift;
2395 $rc .= "\\b" if $rc =~ /\w$/;
2399 $prc =~ s/\\(.)/$1/g;
2404 return $lineinfo unless @_;
2406 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2407 $slave_editor = ($stream =~ /^\|/);
2408 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2409 $LINEINFO = \*LINEINFO;
2410 my $save = select($LINEINFO);
2424 s/^Term::ReadLine::readline$/readline/;
2425 if (defined ${ $_ . '::VERSION' }) {
2426 $version{$file} = "${ $_ . '::VERSION' } from ";
2428 $version{$file} .= $INC{$file};
2430 dumpit($OUT,\%version);
2434 # XXX: make sure there are tabs between the command and explanation,
2435 # or print_help will screw up your formatting if you have
2436 # eeevil ornaments enabled. This is an insane mess.
2440 B<s> [I<expr>] Single step [in I<expr>].
2441 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2442 <B<CR>> Repeat last B<n> or B<s> command.
2443 B<r> Return from current subroutine.
2444 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2445 at the specified position.
2446 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2447 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2448 B<l> I<line> List single I<line>.
2449 B<l> I<subname> List first window of lines from subroutine.
2450 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2451 B<l> List next window of lines.
2452 B<-> List previous window of lines.
2453 B<w> [I<line>] List window around I<line>.
2454 B<.> Return to the executed line.
2455 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2456 I<filename> may be either the full name of the file, or a regular
2457 expression matching the full file name:
2458 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2459 Evals (with saved bodies) are considered to be filenames:
2460 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2461 (in the order of execution).
2462 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2463 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2464 B<L> List all breakpoints and actions.
2465 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2466 B<t> Toggle trace mode.
2467 B<t> I<expr> Trace through execution of I<expr>.
2468 B<b> [I<line>] [I<condition>]
2469 Set breakpoint; I<line> defaults to the current execution line;
2470 I<condition> breaks if it evaluates to true, defaults to '1'.
2471 B<b> I<subname> [I<condition>]
2472 Set breakpoint at first line of subroutine.
2473 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2474 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2475 B<b> B<postpone> I<subname> [I<condition>]
2476 Set breakpoint at first line of subroutine after
2478 B<b> B<compile> I<subname>
2479 Stop after the subroutine is compiled.
2480 B<d> [I<line>] Delete the breakpoint for I<line>.
2481 B<D> Delete all breakpoints.
2482 B<a> [I<line>] I<command>
2483 Set an action to be done before the I<line> is executed;
2484 I<line> defaults to the current execution line.
2485 Sequence is: check for breakpoint/watchpoint, print line
2486 if necessary, do action, prompt user if necessary,
2488 B<a> [I<line>] Delete the action for I<line>.
2489 B<A> Delete all actions.
2490 B<W> I<expr> Add a global watch-expression.
2491 B<W> Delete all watch-expressions.
2492 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2493 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2494 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2495 B<x> I<expr> Evals expression in list context, dumps the result.
2496 B<m> I<expr> Evals expression in list context, prints methods callable
2497 on the first element of the result.
2498 B<m> I<class> Prints methods callable via the given class.
2500 B<<> ? List Perl commands to run before each prompt.
2501 B<<> I<expr> Define Perl command to run before each prompt.
2502 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2503 B<>> ? List Perl commands to run after each prompt.
2504 B<>> I<expr> Define Perl command to run after each prompt.
2505 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2506 B<{> I<db_command> Define debugger command to run before each prompt.
2507 B<{> ? List debugger commands to run before each prompt.
2508 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2509 B<$prc> I<number> Redo a previous command (default previous command).
2510 B<$prc> I<-number> Redo number'th-to-last command.
2511 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2512 See 'B<O> I<recallCommand>' too.
2513 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2514 . ( $rc eq $sh ? "" : "
2515 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2516 See 'B<O> I<shellBang>' too.
2517 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2518 B<H> I<-number> Display last number commands (default all).
2519 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2520 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2521 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2522 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2523 I<command> Execute as a perl statement in current package.
2524 B<v> Show versions of loaded modules.
2525 B<R> Pure-man-restart of debugger, some of debugger state
2526 and command-line options may be lost.
2527 Currently the following settings are preserved:
2528 history, breakpoints and actions, debugger B<O>ptions
2529 and the following command-line options: I<-w>, I<-I>, I<-e>.
2531 B<O> [I<opt>] ... Set boolean option to true
2532 B<O> [I<opt>B<?>] Query options
2533 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2534 Set options. Use quotes in spaces in value.
2535 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2536 I<pager> program for output of \"|cmd\";
2537 I<tkRunning> run Tk while prompting (with ReadLine);
2538 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2539 I<inhibit_exit> Allows stepping off the end of the script.
2540 I<ImmediateStop> Debugger should stop as early as possible.
2541 I<RemotePort> Remote hostname:port for remote debugging
2542 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2543 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2544 I<compactDump>, I<veryCompact> change style of array and hash dump;
2545 I<globPrint> whether to print contents of globs;
2546 I<DumpDBFiles> dump arrays holding debugged files;
2547 I<DumpPackages> dump symbol tables of packages;
2548 I<DumpReused> dump contents of \"reused\" addresses;
2549 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2550 I<bareStringify> Do not print the overload-stringified value;
2551 Other options include:
2552 I<PrintRet> affects printing of return value after B<r> command,
2553 I<frame> affects printing messages on subroutine entry/exit.
2554 I<AutoTrace> affects printing messages on possible breaking points.
2555 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2556 I<ornaments> affects screen appearance of the command line.
2557 I<CreateTTY> bits control attempts to create a new TTY on events:
2558 1: on fork() 2: debugger is started inside debugger
2560 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2561 You can put additional initialization options I<TTY>, I<noTTY>,
2562 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2563 `B<R>' after you set them).
2565 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2566 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2567 B<h h> Summary of debugger commands.
2568 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2569 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2570 Set B<\$DB::doccmd> to change viewer.
2572 Type `|h' for a paged display if this was too hard to read.
2574 "; # Fix balance of vi % matching: }}}}
2576 # note: tabs in the following section are not-so-helpful
2577 $summary = <<"END_SUM";
2578 I<List/search source lines:> I<Control script execution:>
2579 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2580 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2581 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2582 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2583 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2584 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2585 I<Debugger controls:> B<L> List break/watch/actions
2586 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2587 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2588 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2589 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2590 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2591 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2592 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2593 B<q> or B<^D> Quit B<R> Attempt a restart
2594 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2595 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2596 B<p> I<expr> Print expression (uses script's current package).
2597 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2598 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2599 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2600 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2602 # ')}}; # Fix balance of vi % matching
2608 # Restore proper alignment destroyed by eeevil I<> and B<>
2609 # ornaments: A pox on both their houses!
2611 # A help command will have everything up to and including
2612 # the first tab sequence padded into a field 16 (or if indented 20)
2613 # wide. If it's wider than that, an extra space will be added.
2615 ^ # only matters at start of line
2616 ( \040{4} | \t )* # some subcommands are indented
2617 ( < ? # so <CR> works
2618 [BI] < [^\t\n] + ) # find an eeevil ornament
2619 ( \t+ ) # original separation, discarded
2620 ( .* ) # this will now start (no earlier) than
2623 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2624 my $clean = $command;
2625 $clean =~ s/[BI]<([^>]*)>/$1/g;
2626 # replace with this whole string:
2627 ($leadwhite ? " " x 4 : "")
2629 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2634 s{ # handle bold ornaments
2635 B < ( [^>] + | > ) >
2637 $Term::ReadLine::TermCap::rl_term_set[2]
2639 . $Term::ReadLine::TermCap::rl_term_set[3]
2642 s{ # handle italic ornaments
2643 I < ( [^>] + | > ) >
2645 $Term::ReadLine::TermCap::rl_term_set[0]
2647 . $Term::ReadLine::TermCap::rl_term_set[1]
2654 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2655 my $is_less = $pager =~ /\bless\b/;
2656 if ($pager =~ /\bmore\b/) {
2657 my @st_more = stat('/usr/bin/more');
2658 my @st_less = stat('/usr/bin/less');
2659 $is_less = @st_more && @st_less
2660 && $st_more[0] == $st_less[0]
2661 && $st_more[1] == $st_less[1];
2663 # changes environment!
2664 $ENV{LESS} .= 'r' if $is_less;
2670 $SIG{'ABRT'} = 'DEFAULT';
2671 kill 'ABRT', $$ if $panic++;
2672 if (defined &Carp::longmess) {
2673 local $SIG{__WARN__} = '';
2674 local $Carp::CarpLevel = 2; # mydie + confess
2675 &warn(Carp::longmess("Signal @_"));
2678 print $DB::OUT "Got signal @_\n";
2686 local $SIG{__WARN__} = '';
2687 local $SIG{__DIE__} = '';
2688 eval { require Carp } if defined $^S; # If error/warning during compilation,
2689 # require may be broken.
2690 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2691 return unless defined &Carp::longmess;
2692 my ($mysingle,$mytrace) = ($single,$trace);
2693 $single = 0; $trace = 0;
2694 my $mess = Carp::longmess(@_);
2695 ($single,$trace) = ($mysingle,$mytrace);
2702 local $SIG{__DIE__} = '';
2703 local $SIG{__WARN__} = '';
2704 my $i = 0; my $ineval = 0; my $sub;
2705 if ($dieLevel > 2) {
2706 local $SIG{__WARN__} = \&dbwarn;
2707 &warn(@_); # Yell no matter what
2710 if ($dieLevel < 2) {
2711 die @_ if $^S; # in eval propagate
2713 # No need to check $^S, eval is much more robust nowadays
2714 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
2715 # require may be broken.
2717 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2718 unless defined &Carp::longmess;
2720 # We do not want to debug this chunk (automatic disabling works
2721 # inside DB::DB, but not in Carp).
2722 my ($mysingle,$mytrace) = ($single,$trace);
2723 $single = 0; $trace = 0;
2726 package Carp; # Do not include us in the list
2728 $mess = Carp::longmess(@_);
2731 ($single,$trace) = ($mysingle,$mytrace);
2737 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2740 $SIG{__WARN__} = \&DB::dbwarn;
2741 } elsif ($prevwarn) {
2742 $SIG{__WARN__} = $prevwarn;
2750 $prevdie = $SIG{__DIE__} unless $dieLevel;
2753 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2754 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2755 print $OUT "Stack dump during die enabled",
2756 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2758 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2759 } elsif ($prevdie) {
2760 $SIG{__DIE__} = $prevdie;
2761 print $OUT "Default die handler restored.\n";
2769 $prevsegv = $SIG{SEGV} unless $signalLevel;
2770 $prevbus = $SIG{BUS} unless $signalLevel;
2771 $signalLevel = shift;
2773 $SIG{SEGV} = \&DB::diesignal;
2774 $SIG{BUS} = \&DB::diesignal;
2776 $SIG{SEGV} = $prevsegv;
2777 $SIG{BUS} = $prevbus;
2785 my $name = CvGV_name_or_bust($in);
2786 defined $name ? $name : $in;
2789 sub CvGV_name_or_bust {
2791 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2792 return unless ref $in;
2793 $in = \&$in; # Hard reference...
2794 eval {require Devel::Peek; 1} or return;
2795 my $gv = Devel::Peek::CvGV($in) or return;
2796 *$gv{PACKAGE} . '::' . *$gv{NAME};
2802 return unless defined &$subr;
2803 my $name = CvGV_name_or_bust($subr);
2805 $data = $sub{$name} if defined $name;
2806 return $data if defined $data;
2809 $subr = \&$subr; # Hard reference
2812 $s = $_, last if $subr eq \&$_;
2820 $class = ref $class if ref $class;
2823 methods_via($class, '', 1);
2824 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2829 return if $packs{$class}++;
2831 my $prepend = $prefix ? "via $prefix: " : '';
2833 for $name (grep {defined &{${"${class}::"}{$_}}}
2834 sort keys %{"${class}::"}) {
2835 next if $seen{ $name }++;
2836 print $DB::OUT "$prepend$name\n";
2838 return unless shift; # Recurse?
2839 for $name (@{"${class}::ISA"}) {
2840 $prepend = $prefix ? $prefix . " -> $name" : $name;
2841 methods_via($name, $prepend, 1);
2846 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2847 ? "man" # O Happy Day!
2848 : "perldoc"; # Alas, poor unfortunates
2854 &system("$doccmd $doccmd");
2857 # this way user can override, like with $doccmd="man -Mwhatever"
2858 # or even just "man " to disable the path check.
2859 unless ($doccmd eq 'man') {
2860 &system("$doccmd $page");
2864 $page = 'perl' if lc($page) eq 'help';
2867 my $man1dir = $Config::Config{'man1dir'};
2868 my $man3dir = $Config::Config{'man3dir'};
2869 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2871 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2872 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2873 chop $manpath if $manpath;
2874 # harmless if missing, I figure
2875 my $oldpath = $ENV{MANPATH};
2876 $ENV{MANPATH} = $manpath if $manpath;
2877 my $nopathopt = $^O =~ /dunno what goes here/;
2878 if (CORE::system($doccmd,
2879 # I just *know* there are men without -M
2880 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2883 unless ($page =~ /^perl\w/) {
2884 if (grep { $page eq $_ } qw{
2885 5004delta 5005delta amiga api apio book boot bot call compile
2886 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2887 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2888 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2889 modinstall modlib number obj op opentut os2 os390 pod port
2890 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2891 trap unicode var vms win32 xs xstut
2895 CORE::system($doccmd,
2896 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2901 if (defined $oldpath) {
2902 $ENV{MANPATH} = $manpath;
2904 delete $ENV{MANPATH};
2908 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2910 BEGIN { # This does not compile, alas.
2911 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2912 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2916 $deep = 100; # warning if stack gets this deep
2920 $SIG{INT} = \&DB::catch;
2921 # This may be enabled to debug debugger:
2922 #$warnLevel = 1 unless defined $warnLevel;
2923 #$dieLevel = 1 unless defined $dieLevel;
2924 #$signalLevel = 1 unless defined $signalLevel;
2926 $db_stop = 0; # Compiler warning
2928 $level = 0; # Level of recursive debugging
2929 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2930 # Triggers bug (?) in perl is we postpone this until runtime:
2931 @postponed = @stack = (0);
2932 $stack_depth = 0; # Localized $#stack
2937 BEGIN {$^W = $ini_warn;} # Switch warnings back
2939 #use Carp; # This did break, left for debugging
2942 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2943 my($text, $line, $start) = @_;
2944 my ($itext, $search, $prefix, $pack) =
2945 ($text, "^\Q${'package'}::\E([^:]+)\$");
2947 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2948 (map { /$search/ ? ($1) : () } keys %sub)
2949 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2950 return sort grep /^\Q$text/, values %INC # files
2951 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2952 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2953 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2954 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2955 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2957 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2959 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2960 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2961 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2962 # We may want to complete to (eval 9), so $text may be wrong
2963 $prefix = length($1) - length($text);
2966 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2968 if ((substr $text, 0, 1) eq '&') { # subroutines
2969 $text = substr $text, 1;
2971 return sort map "$prefix$_",
2974 (map { /$search/ ? ($1) : () }
2977 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2978 $pack = ($1 eq 'main' ? '' : $1) . '::';
2979 $prefix = (substr $text, 0, 1) . $1 . '::';
2982 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2983 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2984 return db_complete($out[0], $line, $start);
2988 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2989 $pack = ($package eq 'main' ? '' : $package) . '::';
2990 $prefix = substr $text, 0, 1;
2991 $text = substr $text, 1;
2992 my @out = map "$prefix$_", grep /^\Q$text/,
2993 (grep /^_?[a-zA-Z]/, keys %$pack),
2994 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2995 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2996 return db_complete($out[0], $line, $start);
3000 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3001 my @out = grep /^\Q$text/, @options;
3002 my $val = option_val($out[0], undef);
3004 if (not defined $val or $val =~ /[\n\r]/) {
3005 # Can do nothing better
3006 } elsif ($val =~ /\s/) {
3008 foreach $l (split //, qq/\"\'\#\|/) {
3009 $out = "$l$val$l ", last if (index $val, $l) == -1;
3014 # Default to value if one completion, to question if many
3015 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3018 return $term->filename_list($text); # filenames
3022 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3026 if (defined($ini_pids)) {
3027 $ENV{PERLDB_PIDS} = $ini_pids;
3029 delete($ENV{PERLDB_PIDS});
3034 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3035 $fall_off_end = 1 unless $inhibit_exit;
3036 # Do not stop in at_exit() and destructors on exit:
3037 $DB::single = !$fall_off_end && !$runnonstop;
3038 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3044 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3047 package DB; # Do not trace this 1; below!