3 # Debugger for Perl 5.00x; perl5db.pl patch level:
5 # It is crucial that there is no lexicals in scope of `eval ""' down below
7 # 'my' would make it visible from user code
8 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
11 local $otrace = $trace;
12 local $osingle = $single;
14 { ($evalarg) = $evalarg =~ /(.*)/s; }
15 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
21 local $saved[0]; # Preserve the old value of $@
25 } elsif ($onetimeDump) {
26 dumpit($OUT, \@res) if $onetimeDump eq 'dump';
27 methods($res[0]) if $onetimeDump eq 'methods';
32 # After this point it is safe to introduce lexicals
33 # However, one should not overdo it: leave as much control from outside as possible
36 $header = "perl5db.pl version $VERSION";
39 # This file is automatically included if you do perl -d.
40 # It's probably not useful to include this yourself.
42 # Before venturing further into these twisty passages, it is
43 # wise to read the perldebguts man page or risk the ire of dragons.
45 # Perl supplies the values for %sub. It effectively inserts
46 # a &DB'DB(); in front of every place that can have a
47 # breakpoint. Instead of a subroutine call it calls &DB::sub with
48 # $DB::sub being the called subroutine. It also inserts a BEGIN
49 # {require 'perl5db.pl'} before the first line.
51 # After each `require'd file is compiled, but before it is executed, a
52 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
53 # $filename is the expanded name of the `require'd file (as found as
56 # Additional services from Perl interpreter:
58 # if caller() is called from the package DB, it provides some
61 # The array @{$main::{'_<'.$filename}} (herein called @dbline) is the
62 # line-by-line contents of $filename.
64 # The hash %{'_<'.$filename} (herein called %dbline) contains
65 # breakpoints and action (it is keyed by line number), and individual
66 # entries are settable (as opposed to the whole hash). Only true/false
67 # is important to the interpreter, though the values used by
68 # perl5db.pl have the form "$break_condition\0$action". Values are
69 # magical in numeric context.
71 # The scalar ${'_<'.$filename} contains $filename.
73 # Note that no subroutine call is possible until &DB::sub is defined
74 # (for subroutines defined outside of the package DB). In fact the same is
75 # true if $deep is not defined.
80 # At start reads $rcfile that may set important options. This file
81 # may define a subroutine &afterinit that will be executed after the
82 # debugger is initialized.
84 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
85 # it as a rest of `O ...' line in debugger prompt.
87 # The options that can be specified only at startup:
88 # [To set in $rcfile, call &parse_options("optionName=new_value").]
90 # TTY - the TTY to use for debugging i/o.
92 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
93 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
94 # Term::Rendezvous. Current variant is to have the name of TTY in this
97 # ReadLine - If false, dummy ReadLine is used, so you can debug
98 # ReadLine applications.
100 # NonStop - if true, no i/o is performed until interrupt.
102 # LineInfo - file or pipe to print line number info to. If it is a
103 # pipe, a short "emacs like" message is used.
105 # RemotePort - host:port to connect to on remote host for remote debugging.
107 # Example $rcfile: (delete leading hashes!)
109 # &parse_options("NonStop=1 LineInfo=db.out");
110 # sub afterinit { $trace = 1; }
112 # The script will run without human intervention, putting trace
113 # information into db.out. (If you interrupt it, you would better
114 # reset LineInfo to something "interactive"!)
116 ##################################################################
118 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
120 # modified Perl debugger, to be run from Emacs in perldb-mode
121 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
122 # Johan Vromans -- upgrade to 4.0 pl 10
123 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
127 # A lot of things changed after 0.94. First of all, core now informs
128 # debugger about entry into XSUBs, overloaded operators, tied operations,
129 # BEGIN and END. Handy with `O f=2'.
131 # This can make debugger a little bit too verbose, please be patient
132 # and report your problems promptly.
134 # Now the option frame has 3 values: 0,1,2.
136 # Note that if DESTROY returns a reference to the object (or object),
137 # the deletion of data may be postponed until the next function call,
138 # due to the need to examine the return value.
140 # Changes: 0.95: `v' command shows versions.
141 # Changes: 0.96: `v' command shows version of readline.
142 # primitive completion works (dynamic variables, subs for `b' and `l',
143 # options). Can `p %var'
144 # Better help (`h <' now works). New commands <<, >>, {, {{.
145 # {dump|print}_trace() coded (to be able to do it from <<cmd).
146 # `c sub' documented.
147 # At last enough magic combined to stop after the end of debuggee.
148 # !! should work now (thanks to Emacs bracket matching an extra
149 # `]' in a regexp is caught).
150 # `L', `D' and `A' span files now (as documented).
151 # Breakpoints in `require'd code are possible (used in `R').
152 # Some additional words on internal work of debugger.
153 # `b load filename' implemented.
154 # `b postpone subr' implemented.
155 # now only `q' exits debugger (overwritable on $inhibit_exit).
156 # When restarting debugger breakpoints/actions persist.
157 # Buglet: When restarting debugger only one breakpoint/action per
158 # autoloaded function persists.
159 # Changes: 0.97: NonStop will not stop in at_exit().
160 # Option AutoTrace implemented.
161 # Trace printed differently if frames are printed too.
162 # new `inhibitExit' option.
163 # printing of a very long statement interruptible.
164 # Changes: 0.98: New command `m' for printing possible methods
165 # 'l -' is a synonym for `-'.
166 # Cosmetic bugs in printing stack trace.
167 # `frame' & 8 to print "expanded args" in stack trace.
168 # Can list/break in imported subs.
169 # new `maxTraceLen' option.
170 # frame & 4 and frame & 8 granted.
172 # nonstoppable lines do not have `:' near the line number.
173 # `b compile subname' implemented.
174 # Will not use $` any more.
175 # `-' behaves sane now.
176 # Changes: 0.99: Completion for `f', `m'.
177 # `m' will remove duplicate names instead of duplicate functions.
178 # `b load' strips trailing whitespace.
179 # completion ignores leading `|'; takes into account current package
180 # when completing a subroutine name (same for `l').
181 # Changes: 1.07: Many fixed by tchrist 13-March-2000
183 # + Added bare minimal security checks on perldb rc files, plus
184 # comments on what else is needed.
185 # + Fixed the ornaments that made "|h" completely unusable.
186 # They are not used in print_help if they will hurt. Strip pod
187 # if we're paging to less.
188 # + Fixed mis-formatting of help messages caused by ornaments
189 # to restore Larry's original formatting.
190 # + Fixed many other formatting errors. The code is still suboptimal,
191 # and needs a lot of work at restructuring. It's also misindented
193 # + Fixed bug where trying to look at an option like your pager
195 # + Fixed some $? processing. Note: if you use csh or tcsh, you will
196 # lose. You should consider shell escapes not using their shell,
197 # or else not caring about detailed status. This should really be
198 # unified into one place, too.
199 # + Fixed bug where invisible trailing whitespace on commands hoses you,
200 # tricking Perl into thinking you weren't calling a debugger command!
201 # + Fixed bug where leading whitespace on commands hoses you. (One
202 # suggests a leading semicolon or any other irrelevant non-whitespace
203 # to indicate literal Perl code.)
204 # + Fixed bugs that ate warnings due to wrong selected handle.
205 # + Fixed a precedence bug on signal stuff.
206 # + Fixed some unseemly wording.
207 # + Fixed bug in help command trying to call perl method code.
208 # + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
210 # + Added some comments. This code is still nasty spaghetti.
211 # + Added message if you clear your pre/post command stacks which was
212 # very easy to do if you just typed a bare >, <, or {. (A command
213 # without an argument should *never* be a destructive action; this
214 # API is fundamentally screwed up; likewise option setting, which
215 # is equally buggered.)
216 # + Added command stack dump on argument of "?" for >, <, or {.
217 # + Added a semi-built-in doc viewer command that calls man with the
218 # proper %Config::Config path (and thus gets caching, man -k, etc),
219 # or else perldoc on obstreperous platforms.
220 # + Added to and rearranged the help information.
221 # + Detected apparent misuse of { ... } to declare a block; this used
222 # to work but now is a command, and mysteriously gave no complaint.
224 # Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
226 # + This patch to perl5db.pl cleans up formatting issues on the help
227 # summary (h h) screen in the debugger. Mostly columnar alignment
228 # issues, plus converted the printed text to use all spaces, since
229 # tabs don't seem to help much here.
231 # Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
232 # 0) Minor bugs corrected;
233 # a) Support for auto-creation of new TTY window on startup, either
234 # unconditionally, or if started as a kid of another debugger session;
235 # b) New `O'ption CreateTTY
236 # I<CreateTTY> bits control attempts to create a new TTY on events:
237 # 1: on fork() 2: debugger is started inside debugger
239 # c) Code to auto-create a new TTY window on OS/2 (currently one
240 # extra window per session - need named pipes to have more...);
241 # d) Simplified interface for custom createTTY functions (with a backward
242 # compatibility hack); now returns the TTY name to use; return of ''
243 # means that the function reset the I/O handles itself;
244 # d') Better message on the semantic of custom createTTY function;
245 # e) Convert the existing code to create a TTY into a custom createTTY
247 # f) Consistent support for TTY names of the form "TTYin,TTYout";
248 # g) Switch line-tracing output too to the created TTY window;
249 # h) make `b fork' DWIM with CORE::GLOBAL::fork;
250 # i) High-level debugger API cmd_*():
251 # cmd_b_load($filenamepart) # b load filenamepart
252 # cmd_b_line($lineno [, $cond]) # b lineno [cond]
253 # cmd_b_sub($sub [, $cond]) # b sub [cond]
254 # cmd_stop() # Control-C
255 # cmd_d($lineno) # d lineno
256 # The cmd_*() API returns FALSE on failure; in this case it outputs
257 # the error message to the debugging output.
258 # j) Low-level debugger API
259 # break_on_load($filename) # b load filename
260 # @files = report_break_on_load() # List files with load-breakpoints
261 # breakable_line_in_filename($name, $from [, $to])
262 # # First breakable line in the
263 # # range $from .. $to. $to defaults
264 # # to $from, and may be less than $to
265 # breakable_line($from [, $to]) # Same for the current file
266 # break_on_filename_line($name, $lineno [, $cond])
267 # # Set breakpoint,$cond defaults to 1
268 # break_on_filename_line_range($name, $from, $to [, $cond])
269 # # As above, on the first
270 # # breakable line in range
271 # break_on_line($lineno [, $cond]) # As above, in the current file
272 # break_subroutine($sub [, $cond]) # break on the first breakable line
273 # ($name, $from, $to) = subroutine_filename_lines($sub)
274 # # The range of lines of the text
275 # The low-level API returns TRUE on success, and die()s on failure.
277 # Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
279 # + Fixed warnings generated by "perl -dWe 42"
280 # + Corrected spelling errors
281 # + Squeezed Help (h) output into 80 columns
283 # Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
284 # + Made "x @INC" work like it used to
286 # Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
287 # + Fixed warnings generated by "O" (Show debugger options)
288 # + Fixed warnings generated by "p 42" (Print expression)
289 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
290 # + Added windowSize option
291 # Changes: 1.14: Oct 9, 2001 multiple
292 # + Clean up after itself on VMS (Charles Lane in 12385)
293 # + Adding "@ file" syntax (Peter Scott in 12014)
294 # + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
295 # + $^S and other debugger fixes (Ilya Zakharevich in 11120)
296 # + Forgot a my() declaration (Ilya Zakharevich in 11085)
297 # Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern@pobox.com>
298 # + Updated 1.14 change log
299 # + Added *dbline explainatory comments
300 # + Mentioning perldebguts man page
301 ####################################################################
303 # Needed for the statement after exec():
305 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
306 local($^W) = 0; # Switch run-time warnings off during init.
309 $dumpvar::arrayDepth,
310 $dumpvar::dumpDBFiles,
311 $dumpvar::dumpPackages,
312 $dumpvar::quoteHighBit,
313 $dumpvar::printUndef,
322 # Command-line + PERLLIB:
325 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
327 $trace = $signal = $single = 0; # Uninitialized warning suppression
328 # (local $^W cannot help - other packages!).
329 $inhibit_exit = $option{PrintRet} = 1;
331 @options = qw(hashDepth arrayDepth dumpDepth
332 DumpDBFiles DumpPackages DumpReused
333 compactDump veryCompact quote HighBit undefPrint
334 globPrint PrintRet UsageOnly frame AutoTrace
335 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
336 recallCommand ShellBang pager tkRunning ornaments
337 signalLevel warnLevel dieLevel inhibit_exit
338 ImmediateStop bareStringify CreateTTY
339 RemotePort windowSize);
342 hashDepth => \$dumpvar::hashDepth,
343 arrayDepth => \$dumpvar::arrayDepth,
344 DumpDBFiles => \$dumpvar::dumpDBFiles,
345 DumpPackages => \$dumpvar::dumpPackages,
346 DumpReused => \$dumpvar::dumpReused,
347 HighBit => \$dumpvar::quoteHighBit,
348 undefPrint => \$dumpvar::printUndef,
349 globPrint => \$dumpvar::globPrint,
350 UsageOnly => \$dumpvar::usageOnly,
351 CreateTTY => \$CreateTTY,
352 bareStringify => \$dumpvar::bareStringify,
354 AutoTrace => \$trace,
355 inhibit_exit => \$inhibit_exit,
356 maxTraceLen => \$maxtrace,
357 ImmediateStop => \$ImmediateStop,
358 RemotePort => \$remoteport,
359 windowSize => \$window,
363 compactDump => \&dumpvar::compactDump,
364 veryCompact => \&dumpvar::veryCompact,
365 quote => \&dumpvar::quote,
368 ReadLine => \&ReadLine,
369 NonStop => \&NonStop,
370 LineInfo => \&LineInfo,
371 recallCommand => \&recallCommand,
372 ShellBang => \&shellBang,
374 signalLevel => \&signalLevel,
375 warnLevel => \&warnLevel,
376 dieLevel => \&dieLevel,
377 tkRunning => \&tkRunning,
378 ornaments => \&ornaments,
379 RemotePort => \&RemotePort,
383 compactDump => 'dumpvar.pl',
384 veryCompact => 'dumpvar.pl',
385 quote => 'dumpvar.pl',
388 # These guys may be defined in $ENV{PERL5DB} :
389 $rl = 1 unless defined $rl;
390 $warnLevel = 1 unless defined $warnLevel;
391 $dieLevel = 1 unless defined $dieLevel;
392 $signalLevel = 1 unless defined $signalLevel;
393 $pre = [] unless defined $pre;
394 $post = [] unless defined $post;
395 $pretype = [] unless defined $pretype;
396 $CreateTTY = 3 unless defined $CreateTTY;
398 warnLevel($warnLevel);
400 signalLevel($signalLevel);
403 defined $ENV{PAGER} ? $ENV{PAGER} :
404 eval { require Config } &&
405 defined $Config::Config{pager} ? $Config::Config{pager}
407 ) unless defined $pager;
409 &recallCommand("!") unless defined $prc;
410 &shellBang("!") unless defined $psh;
412 $maxtrace = 400 unless defined $maxtrace;
413 $ini_pids = $ENV{PERLDB_PIDS};
414 if (defined $ENV{PERLDB_PIDS}) {
415 $pids = "[$ENV{PERLDB_PIDS}]";
416 $ENV{PERLDB_PIDS} .= "->$$";
419 $ENV{PERLDB_PIDS} = "$$";
424 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
426 if (-e "/dev/tty") { # this is the wrong metric!
429 $rcfile="perldb.ini";
432 # This isn't really safe, because there's a race
433 # between checking and opening. The solution is to
434 # open and fstat the handle, but then you have to read and
435 # eval the contents. But then the silly thing gets
436 # your lexical scope, which is unfortunately at best.
440 # Just exactly what part of the word "CORE::" don't you understand?
441 local $SIG{__WARN__};
444 unless (is_safe_file($file)) {
445 CORE::warn <<EO_GRIPE;
446 perldb: Must not source insecure rcfile $file.
447 You or the superuser must be the owner, and it must not
448 be writable by anyone but its owner.
454 CORE::warn("perldb: couldn't parse $file: $@") if $@;
458 # Verifies that owner is either real user or superuser and that no
459 # one but owner may write to it. This function is of limited use
460 # when called on a path instead of upon a handle, because there are
461 # no guarantees that filename (by dirent) whose file (by ino) is
462 # eventually accessed is the same as the one tested.
463 # Assumes that the file's existence is not in doubt.
466 stat($path) || return; # mysteriously vaporized
467 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
469 return 0 if $uid != 0 && $uid != $<;
470 return 0 if $mode & 022;
475 safe_do("./$rcfile");
477 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
478 safe_do("$ENV{HOME}/$rcfile");
480 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
481 safe_do("$ENV{LOGDIR}/$rcfile");
484 if (defined $ENV{PERLDB_OPTS}) {
485 parse_options($ENV{PERLDB_OPTS});
488 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
489 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
490 *get_fork_TTY = \&xterm_get_fork_TTY;
491 } elsif ($^O eq 'os2') {
492 *get_fork_TTY = \&os2_get_fork_TTY;
495 # Here begin the unreadable code. It needs fixing.
497 if (exists $ENV{PERLDB_RESTART}) {
498 delete $ENV{PERLDB_RESTART};
500 @hist = get_list('PERLDB_HIST');
501 %break_on_load = get_list("PERLDB_ON_LOAD");
502 %postponed = get_list("PERLDB_POSTPONE");
503 my @had_breakpoints= get_list("PERLDB_VISITED");
504 for (0 .. $#had_breakpoints) {
505 my %pf = get_list("PERLDB_FILE_$_");
506 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
508 my %opt = get_list("PERLDB_OPT");
510 while (($opt,$val) = each %opt) {
511 $val =~ s/[\\\']/\\$1/g;
512 parse_options("$opt'$val'");
514 @INC = get_list("PERLDB_INC");
516 $pretype = [get_list("PERLDB_PRETYPE")];
517 $pre = [get_list("PERLDB_PRE")];
518 $post = [get_list("PERLDB_POST")];
519 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
525 # Is Perl being run from a slave editor or graphical debugger?
526 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
527 $rl = 0, shift(@main::ARGV) if $slave_editor;
529 #require Term::ReadLine;
531 if ($^O eq 'cygwin') {
532 # /dev/tty is binary. use stdin for textmode
534 } elsif (-e "/dev/tty") {
535 $console = "/dev/tty";
536 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
538 } elsif ($^O eq 'MacOS') {
539 if ($MacPerl::Version !~ /MPW/) {
540 $console = "Dev:Console:Perl Debug"; # Separate window for application
542 $console = "Dev:Console";
545 $console = "sys\$command";
548 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
552 if ($^O eq 'NetWare') {
557 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
565 $console = $tty if defined $tty;
567 if (defined $remoteport) {
569 $OUT = new IO::Socket::INET( Timeout => '10',
570 PeerAddr => $remoteport,
573 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
576 create_IN_OUT(4) if $CreateTTY & 4;
578 my ($i, $o) = split /,/, $console;
579 $o = $i unless defined $o;
580 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
581 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
582 || open(OUT,">&STDOUT"); # so we don't dongle stdout
583 } elsif (not defined $console) {
585 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
586 $console = 'STDIN/OUT';
588 # so open("|more") can read from STDOUT and so we don't dingle stdin
589 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
591 my $previous = select($OUT);
592 $| = 1; # for DB::OUT
595 $LINEINFO = $OUT unless defined $LINEINFO;
596 $lineinfo = $console unless defined $lineinfo;
598 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
599 unless ($runnonstop) {
600 if ($term_pid eq '-1') {
601 print $OUT "\nDaughter DB session started...\n";
603 print $OUT "\nLoading DB routines from $header\n";
604 print $OUT ("Editor support ",
605 $slave_editor ? "enabled" : "available",
607 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
615 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
618 if (defined &afterinit) { # May be defined in $rcfile
624 ############################################################ Subroutines
627 # _After_ the perl program is compiled, $single is set to 1:
628 if ($single and not $second_time++) {
629 if ($runnonstop) { # Disable until signal
630 for ($i=0; $i <= $stack_depth; ) {
634 # return; # Would not print trace!
635 } elsif ($ImmediateStop) {
640 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
642 ($package, $filename, $line) = caller;
643 $filename_ini = $filename;
644 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
645 "package $package;"; # this won't let them modify, alas
646 local(*dbline) = $main::{'_<' . $filename};
648 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
652 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
653 $dbline{$line} =~ s/;9($|\0)/$1/;
656 my $was_signal = $signal;
658 for (my $n = 0; $n <= $#to_watch; $n++) {
659 $evalarg = $to_watch[$n];
660 local $onetimeDump; # Do not output results
661 my ($val) = &eval; # Fix context (&eval is doing array)?
662 $val = ( (defined $val) ? "'$val'" : 'undef' );
663 if ($val ne $old_watch[$n]) {
666 Watchpoint $n:\t$to_watch[$n] changed:
667 old value:\t$old_watch[$n]
670 $old_watch[$n] = $val;
674 if ($trace & 4) { # User-installed watch
675 return if watchfunction($package, $filename, $line)
676 and not $single and not $was_signal and not ($trace & ~4);
678 $was_signal = $signal;
680 if ($single || ($trace & 1) || $was_signal) {
682 $position = "\032\032$filename:$line:0\n";
683 print_lineinfo($position);
684 } elsif ($package eq 'DB::fake') {
687 Debugged program terminated. Use B<q> to quit or B<R> to restart,
688 use B<O> I<inhibit_exit> to avoid stopping after program termination,
689 B<h q>, B<h R> or B<h O> to get additional info.
692 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
693 "package $package;"; # this won't let them modify, alas
696 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
697 $prefix .= "$sub($filename:";
698 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
699 if (length($prefix) > 30) {
700 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
705 $position = "$prefix$line$infix$dbline[$line]$after";
708 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
710 print_lineinfo($position);
712 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
713 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
715 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
716 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
717 $position .= $incr_pos;
719 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
721 print_lineinfo($incr_pos);
726 $evalarg = $action, &eval if $action;
727 if ($single || $was_signal) {
728 local $level = $level + 1;
729 foreach $evalarg (@$pre) {
732 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
735 $incr = -1; # for backward motion.
736 @typeahead = (@$pretype, @typeahead);
738 while (($term || &setterm),
739 ($term_pid == $$ or resetterm(1)),
740 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
741 ($#hist+1) . ('>' x $level) .
746 $cmd =~ s/\\$/\n/ && do {
747 $cmd .= &readline(" cont: ");
750 $cmd =~ /^$/ && ($cmd = $laststep);
751 push(@hist,$cmd) if length($cmd) > 1;
753 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
754 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
755 ($i) = split(/\s+/,$cmd);
757 # squelch the sigmangler
759 local $SIG{__WARN__};
760 eval "\$cmd =~ $alias{$i}";
762 print $OUT "Couldn't evaluate `$i' alias: $@";
766 $cmd =~ /^q$/ && ($fall_off_end = 1) && clean_ENV() && exit $?;
767 $cmd =~ /^h$/ && do {
770 $cmd =~ /^h\s+h$/ && do {
771 print_help($summary);
773 # support long commands; otherwise bogus errors
774 # happen when you ask for h on <CR> for example
775 $cmd =~ /^h\s+(\S.*)$/ && do {
776 my $asked = $1; # for proper errmsg
777 my $qasked = quotemeta($asked); # for searching
778 # XXX: finds CR but not <CR>
779 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
780 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
784 print_help("B<$asked> is not a debugger command.\n");
787 $cmd =~ /^t$/ && do {
789 print $OUT "Trace = " .
790 (($trace & 1) ? "on" : "off" ) . "\n";
792 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
793 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
794 foreach $subname (sort(keys %sub)) {
795 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
796 print $OUT $subname,"\n";
800 $cmd =~ /^v$/ && do {
801 list_versions(); next CMD};
802 $cmd =~ s/^X\b/V $package/;
803 $cmd =~ /^V$/ && do {
804 $cmd = "V $package"; };
805 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
806 local ($savout) = select($OUT);
808 @vars = split(' ',$2);
809 do 'dumpvar.pl' unless defined &main::dumpvar;
810 if (defined &main::dumpvar) {
813 # must detect sigpipe failures
814 eval { &main::dumpvar($packname,@vars) };
816 die unless $@ =~ /dumpvar print failed/;
819 print $OUT "dumpvar.pl not available.\n";
823 $cmd =~ s/^x\b/ / && do { # So that will be evaled
824 $onetimeDump = 'dump'; };
825 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
826 methods($1); next CMD};
827 $cmd =~ s/^m\b/ / && do { # So this will be evaled
828 $onetimeDump = 'methods'; };
829 $cmd =~ /^f\b\s*(.*)/ && do {
833 print $OUT "The old f command is now the r command.\n";
834 print $OUT "The new f command switches filenames.\n";
837 if (!defined $main::{'_<' . $file}) {
838 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
839 $try = substr($try,2);
840 print $OUT "Choosing $try matching `$file':\n";
844 if (!defined $main::{'_<' . $file}) {
845 print $OUT "No file matching `$file' is loaded.\n";
847 } elsif ($file ne $filename) {
848 *dbline = $main::{'_<' . $file};
854 print $OUT "Already in $file.\n";
858 $cmd =~ s/^l\s+-\s*$/-/;
859 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
862 print($OUT "Error: $@\n"), next CMD if $@;
864 print($OUT "Interpreted as: $1 $s\n");
867 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
868 my $s = $subname = $1;
869 $subname =~ s/\'/::/;
870 $subname = $package."::".$subname
871 unless $subname =~ /::/;
872 $subname = "CORE::GLOBAL::$s"
873 if not defined &$subname and $s !~ /::/
874 and defined &{"CORE::GLOBAL::$s"};
875 $subname = "main".$subname if substr($subname,0,2) eq "::";
876 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
877 $subrange = pop @pieces;
878 $file = join(':', @pieces);
879 if ($file ne $filename) {
880 print $OUT "Switching to file '$file'.\n"
881 unless $slave_editor;
882 *dbline = $main::{'_<' . $file};
887 if (eval($subrange) < -$window) {
888 $subrange =~ s/-.*/+/;
890 $cmd = "l $subrange";
892 print $OUT "Subroutine $subname not found.\n";
895 $cmd =~ /^\.$/ && do {
896 $incr = -1; # for backward motion.
898 $filename = $filename_ini;
899 *dbline = $main::{'_<' . $filename};
901 print_lineinfo($position);
903 $cmd =~ /^w\b\s*(\d*)$/ && do {
907 #print $OUT 'l ' . $start . '-' . ($start + $incr);
908 $cmd = 'l ' . $start . '-' . ($start + $incr); };
909 $cmd =~ /^-$/ && do {
910 $start -= $incr + $window + 1;
911 $start = 1 if $start <= 0;
913 $cmd = 'l ' . ($start) . '+'; };
914 $cmd =~ /^l$/ && do {
916 $cmd = 'l ' . $start . '-' . ($start + $incr); };
917 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
920 $incr = $window - 1 unless $incr;
921 $cmd = 'l ' . $start . '-' . ($start + $incr); };
922 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
923 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
924 $end = $max if $end > $max;
926 $i = $line if $i eq '.';
930 print $OUT "\032\032$filename:$i:0\n";
933 for (; $i <= $end; $i++) {
935 ($stop,$action) = split(/\0/, $dbline{$i}) if
938 and $filename eq $filename_ini)
940 : ($dbline[$i]+0 ? ':' : ' ') ;
941 $arrow .= 'b' if $stop;
942 $arrow .= 'a' if $action;
943 print $OUT "$i$arrow\t", $dbline[$i];
944 $i++, last if $signal;
946 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
948 $start = $i; # remember in case they want more
949 $start = $max if $start > $max;
951 $cmd =~ /^D$/ && do {
952 print $OUT "Deleting all breakpoints...\n";
954 for $file (keys %had_breakpoints) {
955 local *dbline = $main::{'_<' . $file};
959 for ($i = 1; $i <= $max ; $i++) {
960 if (defined $dbline{$i}) {
961 $dbline{$i} =~ s/^[^\0]+//;
962 if ($dbline{$i} =~ s/^\0?$//) {
968 if (not $had_breakpoints{$file} &= ~1) {
969 delete $had_breakpoints{$file};
973 undef %postponed_file;
974 undef %break_on_load;
976 $cmd =~ /^L$/ && do {
978 for $file (keys %had_breakpoints) {
979 local *dbline = $main::{'_<' . $file};
983 for ($i = 1; $i <= $max; $i++) {
984 if (defined $dbline{$i}) {
985 print $OUT "$file:\n" unless $was++;
986 print $OUT " $i:\t", $dbline[$i];
987 ($stop,$action) = split(/\0/, $dbline{$i});
988 print $OUT " break if (", $stop, ")\n"
990 print $OUT " action: ", $action, "\n"
997 print $OUT "Postponed breakpoints in subroutines:\n";
999 for $subname (keys %postponed) {
1000 print $OUT " $subname\t$postponed{$subname}\n";
1004 my @have = map { # Combined keys
1005 keys %{$postponed_file{$_}}
1006 } keys %postponed_file;
1008 print $OUT "Postponed breakpoints in files:\n";
1010 for $file (keys %postponed_file) {
1011 my $db = $postponed_file{$file};
1012 print $OUT " $file:\n";
1013 for $line (sort {$a <=> $b} keys %$db) {
1014 print $OUT " $line:\n";
1015 my ($stop,$action) = split(/\0/, $$db{$line});
1016 print $OUT " break if (", $stop, ")\n"
1018 print $OUT " action: ", $action, "\n"
1025 if (%break_on_load) {
1026 print $OUT "Breakpoints on load:\n";
1028 for $file (keys %break_on_load) {
1029 print $OUT " $file\n";
1034 print $OUT "Watch-expressions:\n";
1036 for $expr (@to_watch) {
1037 print $OUT " $expr\n";
1042 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
1043 my $file = $1; $file =~ s/\s+$//;
1046 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
1047 my $cond = length $3 ? $3 : '1';
1048 my ($subname, $break) = ($2, $1 eq 'postpone');
1049 $subname =~ s/\'/::/g;
1050 $subname = "${'package'}::" . $subname
1051 unless $subname =~ /::/;
1052 $subname = "main".$subname if substr($subname,0,2) eq "::";
1053 $postponed{$subname} = $break
1054 ? "break +0 if $cond" : "compile";
1056 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1058 $cond = length $2 ? $2 : '1';
1059 cmd_b_sub($subname, $cond);
1061 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1063 $cond = length $2 ? $2 : '1';
1064 cmd_b_line($i, $cond);
1066 $cmd =~ /^d\b\s*(\d*)/ && do {
1069 $cmd =~ /^A$/ && do {
1070 print $OUT "Deleting all actions...\n";
1072 for $file (keys %had_breakpoints) {
1073 local *dbline = $main::{'_<' . $file};
1077 for ($i = 1; $i <= $max ; $i++) {
1078 if (defined $dbline{$i}) {
1079 $dbline{$i} =~ s/\0[^\0]*//;
1080 delete $dbline{$i} if $dbline{$i} eq '';
1084 unless ($had_breakpoints{$file} &= ~2) {
1085 delete $had_breakpoints{$file};
1089 $cmd =~ /^O\s*$/ && do {
1094 $cmd =~ /^O\s*(\S.*)/ && do {
1097 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1098 push @$pre, action($1);
1100 $cmd =~ /^>>\s*(.*)/ && do {
1101 push @$post, action($1);
1103 $cmd =~ /^<\s*(.*)/ && do {
1105 print $OUT "All < actions cleared.\n";
1111 print $OUT "No pre-prompt Perl actions.\n";
1114 print $OUT "Perl commands run before each prompt:\n";
1115 for my $action ( @$pre ) {
1116 print $OUT "\t< -- $action\n";
1120 $pre = [action($1)];
1122 $cmd =~ /^>\s*(.*)/ && do {
1124 print $OUT "All > actions cleared.\n";
1130 print $OUT "No post-prompt Perl actions.\n";
1133 print $OUT "Perl commands run after each prompt:\n";
1134 for my $action ( @$post ) {
1135 print $OUT "\t> -- $action\n";
1139 $post = [action($1)];
1141 $cmd =~ /^\{\{\s*(.*)/ && do {
1142 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1143 print $OUT "{{ is now a debugger command\n",
1144 "use `;{{' if you mean Perl code\n";
1150 $cmd =~ /^\{\s*(.*)/ && do {
1152 print $OUT "All { actions cleared.\n";
1157 unless (@$pretype) {
1158 print $OUT "No pre-prompt debugger actions.\n";
1161 print $OUT "Debugger commands run before each prompt:\n";
1162 for my $action ( @$pretype ) {
1163 print $OUT "\t{ -- $action\n";
1167 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1168 print $OUT "{ is now a debugger command\n",
1169 "use `;{' if you mean Perl code\n";
1175 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1176 $i = $1 || $line; $j = $2;
1178 if ($dbline[$i] == 0) {
1179 print $OUT "Line $i may not have an action.\n";
1181 $had_breakpoints{$filename} |= 2;
1182 $dbline{$i} =~ s/\0[^\0]*//;
1183 $dbline{$i} .= "\0" . action($j);
1186 $dbline{$i} =~ s/\0[^\0]*//;
1187 delete $dbline{$i} if $dbline{$i} eq '';
1190 $cmd =~ /^n$/ && do {
1191 end_report(), next CMD if $finished and $level <= 1;
1195 $cmd =~ /^s$/ && do {
1196 end_report(), next CMD if $finished and $level <= 1;
1200 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1201 end_report(), next CMD if $finished and $level <= 1;
1203 # Probably not needed, since we finish an interactive
1204 # sub-session anyway...
1205 # local $filename = $filename;
1206 # local *dbline = *dbline; # XXX Would this work?!
1207 if ($i =~ /\D/) { # subroutine name
1208 $subname = $package."::".$subname
1209 unless $subname =~ /::/;
1210 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1214 *dbline = $main::{'_<' . $filename};
1215 $had_breakpoints{$filename} |= 1;
1217 ++$i while $dbline[$i] == 0 && $i < $max;
1219 print $OUT "Subroutine $subname not found.\n";
1224 if ($dbline[$i] == 0) {
1225 print $OUT "Line $i not breakable.\n";
1228 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1230 for ($i=0; $i <= $stack_depth; ) {
1234 $cmd =~ /^r$/ && do {
1235 end_report(), next CMD if $finished and $level <= 1;
1236 $stack[$stack_depth] |= 1;
1237 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1239 $cmd =~ /^R$/ && do {
1240 print $OUT "Warning: some settings and command-line options may be lost!\n";
1241 my (@script, @flags, $cl);
1242 push @flags, '-w' if $ini_warn;
1243 # Put all the old includes at the start to get
1244 # the same debugger.
1246 push @flags, '-I', $_;
1248 push @flags, '-T' if ${^TAINT};
1249 # Arrange for setting the old INC:
1250 set_list("PERLDB_INC", @ini_INC);
1252 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1253 chomp ($cl = ${'::_<-e'}[$_]);
1254 push @script, '-e', $cl;
1259 set_list("PERLDB_HIST",
1260 $term->Features->{getHistory}
1261 ? $term->GetHistory : @hist);
1262 my @had_breakpoints = keys %had_breakpoints;
1263 set_list("PERLDB_VISITED", @had_breakpoints);
1264 set_list("PERLDB_OPT", %option);
1265 set_list("PERLDB_ON_LOAD", %break_on_load);
1267 for (0 .. $#had_breakpoints) {
1268 my $file = $had_breakpoints[$_];
1269 *dbline = $main::{'_<' . $file};
1270 next unless %dbline or $postponed_file{$file};
1271 (push @hard, $file), next
1272 if $file =~ /^\(\w*eval/;
1274 @add = %{$postponed_file{$file}}
1275 if $postponed_file{$file};
1276 set_list("PERLDB_FILE_$_", %dbline, @add);
1278 for (@hard) { # Yes, really-really...
1279 # Find the subroutines in this eval
1280 *dbline = $main::{'_<' . $_};
1281 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1282 for $sub (keys %sub) {
1283 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1284 $subs{$sub} = [$1, $2];
1288 "No subroutines in $_, ignoring breakpoints.\n";
1291 LINES: for $line (keys %dbline) {
1292 # One breakpoint per sub only:
1293 my ($offset, $sub, $found);
1294 SUBS: for $sub (keys %subs) {
1295 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1296 and (not defined $offset # Not caught
1297 or $offset < 0 )) { # or badly caught
1299 $offset = $line - $subs{$sub}->[0];
1300 $offset = "+$offset", last SUBS if $offset >= 0;
1303 if (defined $offset) {
1304 $postponed{$found} =
1305 "break $offset if $dbline{$line}";
1307 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1311 set_list("PERLDB_POSTPONE", %postponed);
1312 set_list("PERLDB_PRETYPE", @$pretype);
1313 set_list("PERLDB_PRE", @$pre);
1314 set_list("PERLDB_POST", @$post);
1315 set_list("PERLDB_TYPEAHEAD", @typeahead);
1316 $ENV{PERLDB_RESTART} = 1;
1317 delete $ENV{PERLDB_PIDS}; # Restore ini state
1318 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1319 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1320 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1321 print $OUT "exec failed: $!\n";
1323 $cmd =~ /^T$/ && do {
1324 print_trace($OUT, 1); # skip DB
1326 $cmd =~ /^W\s*$/ && do {
1328 @to_watch = @old_watch = ();
1330 $cmd =~ /^W\b\s*(.*)/s && do {
1334 $val = (defined $val) ? "'$val'" : 'undef' ;
1335 push @old_watch, $val;
1338 $cmd =~ /^\/(.*)$/ && do {
1340 $inpat =~ s:([^\\])/$:$1:;
1342 # squelch the sigmangler
1343 local $SIG{__DIE__};
1344 local $SIG{__WARN__};
1345 eval '$inpat =~ m'."\a$inpat\a";
1357 $start = 1 if ($start > $max);
1358 last if ($start == $end);
1359 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1360 if ($slave_editor) {
1361 print $OUT "\032\032$filename:$start:0\n";
1363 print $OUT "$start:\t", $dbline[$start], "\n";
1368 print $OUT "/$pat/: not found\n" if ($start == $end);
1370 $cmd =~ /^\?(.*)$/ && do {
1372 $inpat =~ s:([^\\])\?$:$1:;
1374 # squelch the sigmangler
1375 local $SIG{__DIE__};
1376 local $SIG{__WARN__};
1377 eval '$inpat =~ m'."\a$inpat\a";
1389 $start = $max if ($start <= 0);
1390 last if ($start == $end);
1391 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1392 if ($slave_editor) {
1393 print $OUT "\032\032$filename:$start:0\n";
1395 print $OUT "$start:\t", $dbline[$start], "\n";
1400 print $OUT "?$pat?: not found\n" if ($start == $end);
1402 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1403 pop(@hist) if length($cmd) > 1;
1404 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1406 print $OUT $cmd, "\n";
1408 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1411 $cmd =~ /^$rc([^$rc].*)$/ && do {
1413 pop(@hist) if length($cmd) > 1;
1414 for ($i = $#hist; $i; --$i) {
1415 last if $hist[$i] =~ /$pat/;
1418 print $OUT "No such command!\n\n";
1422 print $OUT $cmd, "\n";
1424 $cmd =~ /^$sh$/ && do {
1425 &system($ENV{SHELL}||"/bin/sh");
1427 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1428 # XXX: using csh or tcsh destroys sigint retvals!
1429 #&system($1); # use this instead
1430 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1432 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1433 $end = $2 ? ($#hist-$2) : 0;
1434 $hist = 0 if $hist < 0;
1435 for ($i=$#hist; $i>$end; $i--) {
1436 print $OUT "$i: ",$hist[$i],"\n"
1437 unless $hist[$i] =~ /^.?$/;
1440 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1443 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1444 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1445 $cmd =~ s/^=\s*// && do {
1447 if (length $cmd == 0) {
1448 @keys = sort keys %alias;
1450 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1451 # can't use $_ or kill //g state
1452 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1453 $alias{$k} = "s\a$k\a$v\a";
1454 # squelch the sigmangler
1455 local $SIG{__DIE__};
1456 local $SIG{__WARN__};
1457 unless (eval "sub { s\a$k\a$v\a }; 1") {
1458 print $OUT "Can't alias $k to $v: $@\n";
1468 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1469 print $OUT "$k\t= $1\n";
1471 elsif (defined $alias{$k}) {
1472 print $OUT "$k\t$alias{$k}\n";
1475 print "No alias for $k\n";
1479 $cmd =~ /^\@\s*(.*\S)/ && do {
1480 if (open my $fh, $1) {
1484 &warn("Can't execute `$1': $!\n");
1487 $cmd =~ /^\|\|?\s*[^|]/ && do {
1488 if ($pager =~ /^\|/) {
1489 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1490 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1492 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1495 unless ($piped=open(OUT,$pager)) {
1496 &warn("Can't pipe output to `$pager'");
1497 if ($pager =~ /^\|/) {
1498 open(OUT,">&STDOUT") # XXX: lost message
1499 || &warn("Can't restore DB::OUT");
1500 open(STDOUT,">&SAVEOUT")
1501 || &warn("Can't restore STDOUT");
1504 open(OUT,">&STDOUT") # XXX: lost message
1505 || &warn("Can't restore DB::OUT");
1509 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1510 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1511 $selected= select(OUT);
1513 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1514 $cmd =~ s/^\|+\s*//;
1517 # XXX Local variants do not work!
1518 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1519 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1520 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1522 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1524 $onetimeDump = undef;
1525 } elsif ($term_pid == $$) {
1530 if ($pager =~ /^\|/) {
1532 # we cannot warn here: the handle is missing --tchrist
1533 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1535 # most of the $? crud was coping with broken cshisms
1537 print SAVEOUT "Pager `$pager' failed: ";
1539 print SAVEOUT "shell returned -1\n";
1542 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1543 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1545 print SAVEOUT "status ", ($? >> 8), "\n";
1549 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1550 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1551 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1552 # Will stop ignoring SIGPIPE if done like nohup(1)
1553 # does SIGINT but Perl doesn't give us a choice.
1555 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1558 select($selected), $selected= "" unless $selected eq "";
1562 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1563 foreach $evalarg (@$post) {
1566 } # if ($single || $signal)
1567 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1571 # The following code may be executed now:
1575 my ($al, $ret, @ret) = "";
1576 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1579 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1580 $#stack = $stack_depth;
1581 $stack[-1] = $single;
1583 $single |= 4 if $stack_depth == $deep;
1585 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1586 # Why -1? But it works! :-(
1587 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1588 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1591 $single |= $stack[$stack_depth--];
1593 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1594 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1595 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1596 if ($doret eq $stack_depth or $frame & 16) {
1597 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1598 print $fh ' ' x $stack_depth if $frame & 16;
1599 print $fh "list context return from $sub:\n";
1600 dumpit($fh, \@ret );
1605 if (defined wantarray) {
1610 $single |= $stack[$stack_depth--];
1612 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1613 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1614 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1615 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1616 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1617 print $fh (' ' x $stack_depth) if $frame & 16;
1618 print $fh (defined wantarray
1619 ? "scalar context return from $sub: "
1620 : "void context return from $sub\n");
1621 dumpit( $fh, $ret ) if defined wantarray;
1630 ### Functions with multiple modes of failure die on error, the rest
1631 ### returns FALSE on error.
1632 ### User-interface functions cmd_* output error message.
1636 $break_on_load{$file} = 1;
1637 $had_breakpoints{$file} |= 1;
1640 sub report_break_on_load {
1641 sort keys %break_on_load;
1649 push @files, $::INC{$file} if $::INC{$file};
1650 $file .= '.pm', redo unless $file =~ /\./;
1652 break_on_load($_) for @files;
1653 @files = report_break_on_load;
1654 print $OUT "Will stop on load of `@files'.\n";
1657 $filename_error = '';
1659 sub breakable_line {
1660 my ($from, $to) = @_;
1663 my $delta = $from < $to ? +1 : -1;
1664 my $limit = $delta > 0 ? $#dbline : 1;
1665 $limit = $to if ($limit - $to) * $delta > 0;
1666 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1668 return $i unless $dbline[$i] == 0;
1669 my ($pl, $upto) = ('', '');
1670 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1671 die "Line$pl $from$upto$filename_error not breakable\n";
1674 sub breakable_line_in_filename {
1676 local *dbline = $main::{'_<' . $f};
1677 local $filename_error = " of `$f'";
1682 my ($i, $cond) = @_;
1683 $cond = 1 unless @_ >= 2;
1687 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1688 $had_breakpoints{$filename} |= 1;
1689 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1690 else { $dbline{$i} = $cond; }
1694 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1697 sub break_on_filename_line {
1698 my ($f, $i, $cond) = @_;
1699 $cond = 1 unless @_ >= 3;
1700 local *dbline = $main::{'_<' . $f};
1701 local $filename_error = " of `$f'";
1702 local $filename = $f;
1703 break_on_line($i, $cond);
1706 sub break_on_filename_line_range {
1707 my ($f, $from, $to, $cond) = @_;
1708 my $i = breakable_line_in_filename($f, $from, $to);
1709 $cond = 1 unless @_ >= 3;
1710 break_on_filename_line($f,$i,$cond);
1713 sub subroutine_filename_lines {
1714 my ($subname,$cond) = @_;
1715 # Filename below can contain ':'
1716 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1719 sub break_subroutine {
1720 my $subname = shift;
1721 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1722 die "Subroutine $subname not found.\n";
1723 $cond = 1 unless @_ >= 2;
1724 break_on_filename_line_range($file,$s,$e,@_);
1728 my ($subname,$cond) = @_;
1729 $cond = 1 unless @_ >= 2;
1730 unless (ref $subname eq 'CODE') {
1731 $subname =~ s/\'/::/g;
1733 $subname = "${'package'}::" . $subname
1734 unless $subname =~ /::/;
1735 $subname = "CORE::GLOBAL::$s"
1736 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1737 $subname = "main".$subname if substr($subname,0,2) eq "::";
1739 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1742 sub cmd_stop { # As on ^C, but not signal-safy.
1746 sub delete_breakpoint {
1748 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1749 $dbline{$i} =~ s/^[^\0]*//;
1750 delete $dbline{$i} if $dbline{$i} eq '';
1755 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1758 ### END of the API section
1761 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1762 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1765 sub print_lineinfo {
1766 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1770 # The following takes its argument via $evalarg to preserve current @_
1773 my $subname = shift;
1774 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1775 my $offset = $1 || 0;
1776 # Filename below can contain ':'
1777 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1780 local *dbline = $main::{'_<' . $file};
1781 local $^W = 0; # != 0 is magical below
1782 $had_breakpoints{$file} |= 1;
1784 ++$i until $dbline[$i] != 0 or $i >= $max;
1785 $dbline{$i} = delete $postponed{$subname};
1787 print $OUT "Subroutine $subname not found.\n";
1791 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1792 #print $OUT "In postponed_sub for `$subname'.\n";
1796 if ($ImmediateStop) {
1800 return &postponed_sub
1801 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1802 # Cannot be done before the file is compiled
1803 local *dbline = shift;
1804 my $filename = $dbline;
1805 $filename =~ s/^_<//;
1806 $signal = 1, print $OUT "'$filename' loaded...\n"
1807 if $break_on_load{$filename};
1808 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1809 return unless $postponed_file{$filename};
1810 $had_breakpoints{$filename} |= 1;
1811 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1813 for $key (keys %{$postponed_file{$filename}}) {
1814 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1816 delete $postponed_file{$filename};
1820 local ($savout) = select(shift);
1821 my $osingle = $single;
1822 my $otrace = $trace;
1823 $single = $trace = 0;
1826 unless (defined &main::dumpValue) {
1829 if (defined &main::dumpValue) {
1831 my $maxdepth = shift || $option{dumpDepth};
1832 $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
1833 &main::dumpValue($v, $maxdepth);
1835 print $OUT "dumpvar.pl not available.\n";
1842 # Tied method do not create a context, so may get wrong message:
1846 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1847 my @sub = dump_trace($_[0] + 1, $_[1]);
1848 my $short = $_[2]; # Print short report, next one for sub name
1850 for ($i=0; $i <= $#sub; $i++) {
1853 my $args = defined $sub[$i]{args}
1854 ? "(@{ $sub[$i]{args} })"
1856 $args = (substr $args, 0, $maxtrace - 3) . '...'
1857 if length $args > $maxtrace;
1858 my $file = $sub[$i]{file};
1859 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1861 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1863 my $sub = @_ >= 4 ? $_[3] : $s;
1864 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1866 print $fh "$sub[$i]{context} = $s$args" .
1867 " called from $file" .
1868 " line $sub[$i]{line}\n";
1875 my $count = shift || 1e9;
1878 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1879 my $nothard = not $frame & 8;
1880 local $frame = 0; # Do not want to trace this.
1881 my $otrace = $trace;
1884 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1889 if (not defined $arg) {
1891 } elsif ($nothard and tied $arg) {
1893 } elsif ($nothard and $type = ref $arg) {
1894 push @a, "ref($type)";
1896 local $_ = "$arg"; # Safe to stringify now - should not call f().
1899 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1900 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1901 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1905 $context = $context ? '@' : (defined $context ? "\$" : '.');
1906 $args = $h ? [@a] : undef;
1907 $e =~ s/\n\s*\;\s*\Z// if $e;
1908 $e =~ s/([\\\'])/\\$1/g if $e;
1910 $sub = "require '$e'";
1911 } elsif (defined $r) {
1913 } elsif ($sub eq '(eval)') {
1914 $sub = "eval {...}";
1916 push(@sub, {context => $context, sub => $sub, args => $args,
1917 file => $file, line => $line});
1926 while ($action =~ s/\\$//) {
1935 # i hate using globals!
1936 $balanced_brace_re ||= qr{
1939 (?> [^{}] + ) # Non-parens without backtracking
1941 (??{ $balanced_brace_re }) # Group with matching parens
1945 return $_[0] !~ m/$balanced_brace_re/;
1949 &readline("cont: ");
1953 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1954 # some non-Unix systems can do system() but have problems with fork().
1955 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1956 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1957 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1958 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1960 # XXX: using csh or tcsh destroys sigint retvals!
1962 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1963 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1968 # most of the $? crud was coping with broken cshisms
1970 &warn("(Command exited ", ($? >> 8), ")\n");
1972 &warn( "(Command died of SIG#", ($? & 127),
1973 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1983 eval { require Term::ReadLine } or die $@;
1986 my ($i, $o) = split $tty, /,/;
1987 $o = $i unless defined $o;
1988 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1989 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1992 my $sel = select($OUT);
1996 eval "require Term::Rendezvous;" or die;
1997 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1998 my $term_rv = new Term::Rendezvous $rv;
2000 $OUT = $term_rv->OUT;
2003 if ($term_pid eq '-1') { # In a TTY with another debugger
2007 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2009 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2011 $rl_attribs = $term->Attribs;
2012 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2013 if defined $rl_attribs->{basic_word_break_characters}
2014 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2015 $rl_attribs->{special_prefixes} = '$@&%';
2016 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2017 $rl_attribs->{completion_function} = \&db_complete;
2019 $LINEINFO = $OUT unless defined $LINEINFO;
2020 $lineinfo = $console unless defined $lineinfo;
2022 if ($term->Features->{setHistory} and "@hist" ne "?") {
2023 $term->SetHistory(@hist);
2025 ornaments($ornaments) if defined $ornaments;
2029 # Example get_fork_TTY functions
2030 sub xterm_get_fork_TTY {
2031 (my $name = $0) =~ s,^.*[/\\],,s;
2032 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2036 $pidprompt = ''; # Shown anyway in titlebar
2040 # This example function resets $IN, $OUT itself
2041 sub os2_get_fork_TTY {
2042 local $^F = 40; # XXXX Fixme!
2043 my ($in1, $out1, $in2, $out2);
2044 # Having -d in PERL5OPT would lead to a disaster...
2045 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2046 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2047 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2048 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2049 (my $name = $0) =~ s,^.*[/\\],,s;
2051 if ( pipe $in1, $out1 and pipe $in2, $out2
2052 # system P_SESSION will fail if there is another process
2053 # in the same session with a "dependent" asynchronous child session.
2054 and @args = ($rl, fileno $in1, fileno $out2,
2055 "Daughter Perl debugger $pids $name") and
2056 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2059 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2061 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2062 open IN, '<&=$in' or die "open <&=$in: \$!";
2063 \$| = 1; print while sysread IN, \$_, 1<<16;
2067 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2069 require Term::ReadKey if $rl;
2070 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2071 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2073 or warn "system P_SESSION: $!, $^E" and 0)
2074 and close $in1 and close $out2 ) {
2075 $pidprompt = ''; # Shown anyway in titlebar
2076 reset_IN_OUT($in2, $out1);
2078 return ''; # Indicate that reset_IN_OUT is called
2083 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2084 my $in = &get_fork_TTY if defined &get_fork_TTY;
2085 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2086 if (not defined $in) {
2088 print_help(<<EOP) if $why == 1;
2089 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2091 print_help(<<EOP) if $why == 2;
2092 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2093 This may be an asynchronous session, so the parent debugger may be active.
2095 print_help(<<EOP) if $why != 4;
2096 Since two debuggers fight for the same TTY, input is severely entangled.
2100 I know how to switch the output to a different window in xterms
2101 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2102 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2104 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2105 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2108 } elsif ($in ne '') {
2111 $console = ''; # Indicate no need to open-from-the-console
2116 sub resetterm { # We forked, so we need a different TTY
2118 my $systemed = $in > 1 ? '-' : '';
2120 $pids =~ s/\]/$systemed->$$]/;
2122 $pids = "[$term_pid->$$]";
2126 return unless $CreateTTY & $in;
2133 my $left = @typeahead;
2134 my $got = shift @typeahead;
2135 print $OUT "auto(-$left)", shift, $got, "\n";
2136 $term->AddHistory($got)
2137 if length($got) > 1 and defined $term->Features->{addHistory};
2143 my $line = CORE::readline($cmdfhs[-1]);
2144 defined $line ? (print $OUT ">> $line" and return $line)
2145 : close pop @cmdfhs;
2147 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2148 $OUT->write(join('', @_));
2150 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2154 $term->readline(@_);
2159 my ($opt, $val)= @_;
2160 $val = option_val($opt,'N/A');
2161 $val =~ s/([\\\'])/\\$1/g;
2162 printf $OUT "%20s = '%s'\n", $opt, $val;
2166 my ($opt, $default)= @_;
2168 if (defined $optionVars{$opt}
2169 and defined ${$optionVars{$opt}}) {
2170 $val = ${$optionVars{$opt}};
2171 } elsif (defined $optionAction{$opt}
2172 and defined &{$optionAction{$opt}}) {
2173 $val = &{$optionAction{$opt}}();
2174 } elsif (defined $optionAction{$opt}
2175 and not defined $option{$opt}
2176 or defined $optionVars{$opt}
2177 and not defined ${$optionVars{$opt}}) {
2180 $val = $option{$opt};
2182 $val = $default unless defined $val;
2188 # too dangerous to let intuitive usage overwrite important things
2189 # defaultion should never be the default
2190 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2191 dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2192 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2197 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2198 my ($opt,$sep) = ($1,$2);
2201 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2203 #&dump_option($opt);
2204 } elsif ($sep !~ /\S/) {
2206 $val = "1"; # this is an evil default; make 'em set it!
2207 } elsif ($sep eq "=") {
2209 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2211 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2215 print OUT qq(Option better cleared using $opt=""\n)
2219 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2220 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2221 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2222 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2223 ($val = $1) =~ s/\\([\\$end])/$1/g;
2227 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2228 || grep( /^\Q$opt/i && ($option = $_), @options );
2230 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2231 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2233 if ($opt_needs_val{$option} && $val_defaulted) {
2234 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2238 $option{$option} = $val if defined $val;
2243 require '$optionRequire{$option}';
2245 } || die # XXX: shouldn't happen
2246 if defined $optionRequire{$option} &&
2249 ${$optionVars{$option}} = $val
2250 if defined $optionVars{$option} &&
2253 &{$optionAction{$option}} ($val)
2254 if defined $optionAction{$option} &&
2255 defined &{$optionAction{$option}} &&
2259 dump_option($option) unless $OUT eq \*STDERR;
2264 my ($stem,@list) = @_;
2266 $ENV{"${stem}_n"} = @list;
2267 for $i (0 .. $#list) {
2269 $val =~ s/\\/\\\\/g;
2270 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2271 $ENV{"${stem}_$i"} = $val;
2278 my $n = delete $ENV{"${stem}_n"};
2280 for $i (0 .. $n - 1) {
2281 $val = delete $ENV{"${stem}_$i"};
2282 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2290 return; # Put nothing on the stack - malloc/free land!
2294 my($msg)= join("",@_);
2295 $msg .= ": $!\n" unless $msg =~ /\n$/;
2300 my $switch_li = $LINEINFO eq $OUT;
2301 if ($term and $term->Features->{newTTY}) {
2302 ($IN, $OUT) = (shift, shift);
2303 $term->newTTY($IN, $OUT);
2305 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2307 ($IN, $OUT) = (shift, shift);
2309 my $o = select $OUT;
2312 $LINEINFO = $OUT if $switch_li;
2316 if (@_ and $term and $term->Features->{newTTY}) {
2317 my ($in, $out) = shift;
2319 ($in, $out) = split /,/, $in, 2;
2323 open IN, $in or die "cannot open `$in' for read: $!";
2324 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2325 reset_IN_OUT(\*IN,\*OUT);
2328 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2329 # Useful if done through PERLDB_OPTS:
2330 $console = $tty = shift if @_;
2336 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2338 $notty = shift if @_;
2344 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2352 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2354 $remoteport = shift if @_;
2359 if (${$term->Features}{tkRunning}) {
2360 return $term->tkRunning(@_);
2362 print $OUT "tkRunning not supported by current ReadLine package.\n";
2369 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2371 $runnonstop = shift if @_;
2378 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2385 $sh = quotemeta shift;
2386 $sh .= "\\b" if $sh =~ /\w$/;
2390 $psh =~ s/\\(.)/$1/g;
2395 if (defined $term) {
2396 local ($warnLevel,$dieLevel) = (0, 1);
2397 return '' unless $term->Features->{ornaments};
2398 eval { $term->ornaments(@_) } || '';
2406 $rc = quotemeta shift;
2407 $rc .= "\\b" if $rc =~ /\w$/;
2411 $prc =~ s/\\(.)/$1/g;
2416 return $lineinfo unless @_;
2418 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2419 $slave_editor = ($stream =~ /^\|/);
2420 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2421 $LINEINFO = \*LINEINFO;
2422 my $save = select($LINEINFO);
2436 s/^Term::ReadLine::readline$/readline/;
2437 if (defined ${ $_ . '::VERSION' }) {
2438 $version{$file} = "${ $_ . '::VERSION' } from ";
2440 $version{$file} .= $INC{$file};
2442 dumpit($OUT,\%version);
2446 # XXX: make sure there are tabs between the command and explanation,
2447 # or print_help will screw up your formatting if you have
2448 # eeevil ornaments enabled. This is an insane mess.
2452 B<s> [I<expr>] Single step [in I<expr>].
2453 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2454 <B<CR>> Repeat last B<n> or B<s> command.
2455 B<r> Return from current subroutine.
2456 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2457 at the specified position.
2458 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2459 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2460 B<l> I<line> List single I<line>.
2461 B<l> I<subname> List first window of lines from subroutine.
2462 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2463 B<l> List next window of lines.
2464 B<-> List previous window of lines.
2465 B<w> [I<line>] List window around I<line>.
2466 B<.> Return to the executed line.
2467 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2468 I<filename> may be either the full name of the file, or a regular
2469 expression matching the full file name:
2470 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2471 Evals (with saved bodies) are considered to be filenames:
2472 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2473 (in the order of execution).
2474 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2475 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2476 B<L> List all breakpoints and actions.
2477 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2478 B<t> Toggle trace mode.
2479 B<t> I<expr> Trace through execution of I<expr>.
2480 B<b> [I<line>] [I<condition>]
2481 Set breakpoint; I<line> defaults to the current execution line;
2482 I<condition> breaks if it evaluates to true, defaults to '1'.
2483 B<b> I<subname> [I<condition>]
2484 Set breakpoint at first line of subroutine.
2485 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2486 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2487 B<b> B<postpone> I<subname> [I<condition>]
2488 Set breakpoint at first line of subroutine after
2490 B<b> B<compile> I<subname>
2491 Stop after the subroutine is compiled.
2492 B<d> [I<line>] Delete the breakpoint for I<line>.
2493 B<D> Delete all breakpoints.
2494 B<a> [I<line>] I<command>
2495 Set an action to be done before the I<line> is executed;
2496 I<line> defaults to the current execution line.
2497 Sequence is: check for breakpoint/watchpoint, print line
2498 if necessary, do action, prompt user if necessary,
2500 B<a> [I<line>] Delete the action for I<line>.
2501 B<A> Delete all actions.
2502 B<W> I<expr> Add a global watch-expression.
2503 B<W> Delete all watch-expressions.
2504 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2505 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2506 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2507 B<x> I<expr> Evals expression in list context, dumps the result.
2508 B<m> I<expr> Evals expression in list context, prints methods callable
2509 on the first element of the result.
2510 B<m> I<class> Prints methods callable via the given class.
2512 B<<> ? List Perl commands to run before each prompt.
2513 B<<> I<expr> Define Perl command to run before each prompt.
2514 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2515 B<>> ? List Perl commands to run after each prompt.
2516 B<>> I<expr> Define Perl command to run after each prompt.
2517 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2518 B<{> I<db_command> Define debugger command to run before each prompt.
2519 B<{> ? List debugger commands to run before each prompt.
2520 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2521 B<$prc> I<number> Redo a previous command (default previous command).
2522 B<$prc> I<-number> Redo number'th-to-last command.
2523 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2524 See 'B<O> I<recallCommand>' too.
2525 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2526 . ( $rc eq $sh ? "" : "
2527 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2528 See 'B<O> I<shellBang>' too.
2529 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2530 B<H> I<-number> Display last number commands (default all).
2531 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2532 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2533 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2534 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2535 I<command> Execute as a perl statement in current package.
2536 B<v> Show versions of loaded modules.
2537 B<R> Pure-man-restart of debugger, some of debugger state
2538 and command-line options may be lost.
2539 Currently the following settings are preserved:
2540 history, breakpoints and actions, debugger B<O>ptions
2541 and the following command-line options: I<-w>, I<-I>, I<-e>.
2543 B<O> [I<opt>] ... Set boolean option to true
2544 B<O> [I<opt>B<?>] Query options
2545 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2546 Set options. Use quotes in spaces in value.
2547 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2548 I<pager> program for output of \"|cmd\";
2549 I<tkRunning> run Tk while prompting (with ReadLine);
2550 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2551 I<inhibit_exit> Allows stepping off the end of the script.
2552 I<ImmediateStop> Debugger should stop as early as possible.
2553 I<RemotePort> Remote hostname:port for remote debugging
2554 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2555 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2556 I<compactDump>, I<veryCompact> change style of array and hash dump;
2557 I<globPrint> whether to print contents of globs;
2558 I<DumpDBFiles> dump arrays holding debugged files;
2559 I<DumpPackages> dump symbol tables of packages;
2560 I<DumpReused> dump contents of \"reused\" addresses;
2561 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2562 I<bareStringify> Do not print the overload-stringified value;
2563 Other options include:
2564 I<PrintRet> affects printing of return value after B<r> command,
2565 I<frame> affects printing messages on subroutine entry/exit.
2566 I<AutoTrace> affects printing messages on possible breaking points.
2567 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2568 I<ornaments> affects screen appearance of the command line.
2569 I<CreateTTY> bits control attempts to create a new TTY on events:
2570 1: on fork() 2: debugger is started inside debugger
2572 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2573 You can put additional initialization options I<TTY>, I<noTTY>,
2574 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2575 `B<R>' after you set them).
2577 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2578 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2579 B<h h> Summary of debugger commands.
2580 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2581 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2582 Set B<\$DB::doccmd> to change viewer.
2584 Type `|h' for a paged display if this was too hard to read.
2586 "; # Fix balance of vi % matching: }}}}
2588 # note: tabs in the following section are not-so-helpful
2589 $summary = <<"END_SUM";
2590 I<List/search source lines:> I<Control script execution:>
2591 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2592 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2593 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2594 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2595 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2596 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2597 I<Debugger controls:> B<L> List break/watch/actions
2598 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2599 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2600 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2601 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2602 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2603 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2604 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2605 B<q> or B<^D> Quit B<R> Attempt a restart
2606 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2607 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2608 B<p> I<expr> Print expression (uses script's current package).
2609 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2610 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2611 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2612 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2614 # ')}}; # Fix balance of vi % matching
2620 # Restore proper alignment destroyed by eeevil I<> and B<>
2621 # ornaments: A pox on both their houses!
2623 # A help command will have everything up to and including
2624 # the first tab sequence padded into a field 16 (or if indented 20)
2625 # wide. If it's wider than that, an extra space will be added.
2627 ^ # only matters at start of line
2628 ( \040{4} | \t )* # some subcommands are indented
2629 ( < ? # so <CR> works
2630 [BI] < [^\t\n] + ) # find an eeevil ornament
2631 ( \t+ ) # original separation, discarded
2632 ( .* ) # this will now start (no earlier) than
2635 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2636 my $clean = $command;
2637 $clean =~ s/[BI]<([^>]*)>/$1/g;
2638 # replace with this whole string:
2639 ($leadwhite ? " " x 4 : "")
2641 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2646 s{ # handle bold ornaments
2647 B < ( [^>] + | > ) >
2649 $Term::ReadLine::TermCap::rl_term_set[2]
2651 . $Term::ReadLine::TermCap::rl_term_set[3]
2654 s{ # handle italic ornaments
2655 I < ( [^>] + | > ) >
2657 $Term::ReadLine::TermCap::rl_term_set[0]
2659 . $Term::ReadLine::TermCap::rl_term_set[1]
2666 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2667 my $is_less = $pager =~ /\bless\b/;
2668 if ($pager =~ /\bmore\b/) {
2669 my @st_more = stat('/usr/bin/more');
2670 my @st_less = stat('/usr/bin/less');
2671 $is_less = @st_more && @st_less
2672 && $st_more[0] == $st_less[0]
2673 && $st_more[1] == $st_less[1];
2675 # changes environment!
2676 $ENV{LESS} .= 'r' if $is_less;
2682 $SIG{'ABRT'} = 'DEFAULT';
2683 kill 'ABRT', $$ if $panic++;
2684 if (defined &Carp::longmess) {
2685 local $SIG{__WARN__} = '';
2686 local $Carp::CarpLevel = 2; # mydie + confess
2687 &warn(Carp::longmess("Signal @_"));
2690 print $DB::OUT "Got signal @_\n";
2698 local $SIG{__WARN__} = '';
2699 local $SIG{__DIE__} = '';
2700 eval { require Carp } if defined $^S; # If error/warning during compilation,
2701 # require may be broken.
2702 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2703 return unless defined &Carp::longmess;
2704 my ($mysingle,$mytrace) = ($single,$trace);
2705 $single = 0; $trace = 0;
2706 my $mess = Carp::longmess(@_);
2707 ($single,$trace) = ($mysingle,$mytrace);
2714 local $SIG{__DIE__} = '';
2715 local $SIG{__WARN__} = '';
2716 my $i = 0; my $ineval = 0; my $sub;
2717 if ($dieLevel > 2) {
2718 local $SIG{__WARN__} = \&dbwarn;
2719 &warn(@_); # Yell no matter what
2722 if ($dieLevel < 2) {
2723 die @_ if $^S; # in eval propagate
2725 # No need to check $^S, eval is much more robust nowadays
2726 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
2727 # require may be broken.
2729 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2730 unless defined &Carp::longmess;
2732 # We do not want to debug this chunk (automatic disabling works
2733 # inside DB::DB, but not in Carp).
2734 my ($mysingle,$mytrace) = ($single,$trace);
2735 $single = 0; $trace = 0;
2738 package Carp; # Do not include us in the list
2740 $mess = Carp::longmess(@_);
2743 ($single,$trace) = ($mysingle,$mytrace);
2749 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2752 $SIG{__WARN__} = \&DB::dbwarn;
2753 } elsif ($prevwarn) {
2754 $SIG{__WARN__} = $prevwarn;
2762 $prevdie = $SIG{__DIE__} unless $dieLevel;
2765 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2766 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2767 print $OUT "Stack dump during die enabled",
2768 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2770 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2771 } elsif ($prevdie) {
2772 $SIG{__DIE__} = $prevdie;
2773 print $OUT "Default die handler restored.\n";
2781 $prevsegv = $SIG{SEGV} unless $signalLevel;
2782 $prevbus = $SIG{BUS} unless $signalLevel;
2783 $signalLevel = shift;
2785 $SIG{SEGV} = \&DB::diesignal;
2786 $SIG{BUS} = \&DB::diesignal;
2788 $SIG{SEGV} = $prevsegv;
2789 $SIG{BUS} = $prevbus;
2797 my $name = CvGV_name_or_bust($in);
2798 defined $name ? $name : $in;
2801 sub CvGV_name_or_bust {
2803 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2804 return unless ref $in;
2805 $in = \&$in; # Hard reference...
2806 eval {require Devel::Peek; 1} or return;
2807 my $gv = Devel::Peek::CvGV($in) or return;
2808 *$gv{PACKAGE} . '::' . *$gv{NAME};
2814 return unless defined &$subr;
2815 my $name = CvGV_name_or_bust($subr);
2817 $data = $sub{$name} if defined $name;
2818 return $data if defined $data;
2821 $subr = \&$subr; # Hard reference
2824 $s = $_, last if $subr eq \&$_;
2832 $class = ref $class if ref $class;
2835 methods_via($class, '', 1);
2836 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2841 return if $packs{$class}++;
2843 my $prepend = $prefix ? "via $prefix: " : '';
2845 for $name (grep {defined &{${"${class}::"}{$_}}}
2846 sort keys %{"${class}::"}) {
2847 next if $seen{ $name }++;
2848 print $DB::OUT "$prepend$name\n";
2850 return unless shift; # Recurse?
2851 for $name (@{"${class}::ISA"}) {
2852 $prepend = $prefix ? $prefix . " -> $name" : $name;
2853 methods_via($name, $prepend, 1);
2858 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2859 ? "man" # O Happy Day!
2860 : "perldoc"; # Alas, poor unfortunates
2866 &system("$doccmd $doccmd");
2869 # this way user can override, like with $doccmd="man -Mwhatever"
2870 # or even just "man " to disable the path check.
2871 unless ($doccmd eq 'man') {
2872 &system("$doccmd $page");
2876 $page = 'perl' if lc($page) eq 'help';
2879 my $man1dir = $Config::Config{'man1dir'};
2880 my $man3dir = $Config::Config{'man3dir'};
2881 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2883 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2884 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2885 chop $manpath if $manpath;
2886 # harmless if missing, I figure
2887 my $oldpath = $ENV{MANPATH};
2888 $ENV{MANPATH} = $manpath if $manpath;
2889 my $nopathopt = $^O =~ /dunno what goes here/;
2890 if (CORE::system($doccmd,
2891 # I just *know* there are men without -M
2892 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2895 unless ($page =~ /^perl\w/) {
2896 if (grep { $page eq $_ } qw{
2897 5004delta 5005delta amiga api apio book boot bot call compile
2898 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2899 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2900 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2901 modinstall modlib number obj op opentut os2 os390 pod port
2902 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2903 trap unicode var vms win32 xs xstut
2907 CORE::system($doccmd,
2908 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2913 if (defined $oldpath) {
2914 $ENV{MANPATH} = $manpath;
2916 delete $ENV{MANPATH};
2920 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2922 BEGIN { # This does not compile, alas.
2923 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2924 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2928 $deep = 100; # warning if stack gets this deep
2932 $SIG{INT} = \&DB::catch;
2933 # This may be enabled to debug debugger:
2934 #$warnLevel = 1 unless defined $warnLevel;
2935 #$dieLevel = 1 unless defined $dieLevel;
2936 #$signalLevel = 1 unless defined $signalLevel;
2938 $db_stop = 0; # Compiler warning
2940 $level = 0; # Level of recursive debugging
2941 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2942 # Triggers bug (?) in perl is we postpone this until runtime:
2943 @postponed = @stack = (0);
2944 $stack_depth = 0; # Localized $#stack
2949 BEGIN {$^W = $ini_warn;} # Switch warnings back
2951 #use Carp; # This did break, left for debugging
2954 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2955 my($text, $line, $start) = @_;
2956 my ($itext, $search, $prefix, $pack) =
2957 ($text, "^\Q${'package'}::\E([^:]+)\$");
2959 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2960 (map { /$search/ ? ($1) : () } keys %sub)
2961 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2962 return sort grep /^\Q$text/, values %INC # files
2963 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2964 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2965 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2966 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2967 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2969 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2971 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2972 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2973 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2974 # We may want to complete to (eval 9), so $text may be wrong
2975 $prefix = length($1) - length($text);
2978 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2980 if ((substr $text, 0, 1) eq '&') { # subroutines
2981 $text = substr $text, 1;
2983 return sort map "$prefix$_",
2986 (map { /$search/ ? ($1) : () }
2989 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2990 $pack = ($1 eq 'main' ? '' : $1) . '::';
2991 $prefix = (substr $text, 0, 1) . $1 . '::';
2994 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2995 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2996 return db_complete($out[0], $line, $start);
3000 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3001 $pack = ($package eq 'main' ? '' : $package) . '::';
3002 $prefix = substr $text, 0, 1;
3003 $text = substr $text, 1;
3004 my @out = map "$prefix$_", grep /^\Q$text/,
3005 (grep /^_?[a-zA-Z]/, keys %$pack),
3006 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3007 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3008 return db_complete($out[0], $line, $start);
3012 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3013 my @out = grep /^\Q$text/, @options;
3014 my $val = option_val($out[0], undef);
3016 if (not defined $val or $val =~ /[\n\r]/) {
3017 # Can do nothing better
3018 } elsif ($val =~ /\s/) {
3020 foreach $l (split //, qq/\"\'\#\|/) {
3021 $out = "$l$val$l ", last if (index $val, $l) == -1;
3026 # Default to value if one completion, to question if many
3027 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3030 return $term->filename_list($text); # filenames
3034 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3038 if (defined($ini_pids)) {
3039 $ENV{PERLDB_PIDS} = $ini_pids;
3041 delete($ENV{PERLDB_PIDS});
3046 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3047 $fall_off_end = 1 unless $inhibit_exit;
3048 # Do not stop in at_exit() and destructors on exit:
3049 $DB::single = !$fall_off_end && !$runnonstop;
3050 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3056 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3059 package DB; # Do not trace this 1; below!