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 DumpDBFiles DumpPackages DumpReused
332 compactDump veryCompact quote HighBit undefPrint
333 globPrint PrintRet UsageOnly frame AutoTrace
334 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
335 recallCommand ShellBang pager tkRunning ornaments
336 signalLevel warnLevel dieLevel inhibit_exit
337 ImmediateStop bareStringify CreateTTY
338 RemotePort windowSize);
341 hashDepth => \$dumpvar::hashDepth,
342 arrayDepth => \$dumpvar::arrayDepth,
343 DumpDBFiles => \$dumpvar::dumpDBFiles,
344 DumpPackages => \$dumpvar::dumpPackages,
345 DumpReused => \$dumpvar::dumpReused,
346 HighBit => \$dumpvar::quoteHighBit,
347 undefPrint => \$dumpvar::printUndef,
348 globPrint => \$dumpvar::globPrint,
349 UsageOnly => \$dumpvar::usageOnly,
350 CreateTTY => \$CreateTTY,
351 bareStringify => \$dumpvar::bareStringify,
353 AutoTrace => \$trace,
354 inhibit_exit => \$inhibit_exit,
355 maxTraceLen => \$maxtrace,
356 ImmediateStop => \$ImmediateStop,
357 RemotePort => \$remoteport,
358 windowSize => \$window,
362 compactDump => \&dumpvar::compactDump,
363 veryCompact => \&dumpvar::veryCompact,
364 quote => \&dumpvar::quote,
367 ReadLine => \&ReadLine,
368 NonStop => \&NonStop,
369 LineInfo => \&LineInfo,
370 recallCommand => \&recallCommand,
371 ShellBang => \&shellBang,
373 signalLevel => \&signalLevel,
374 warnLevel => \&warnLevel,
375 dieLevel => \&dieLevel,
376 tkRunning => \&tkRunning,
377 ornaments => \&ornaments,
378 RemotePort => \&RemotePort,
382 compactDump => 'dumpvar.pl',
383 veryCompact => 'dumpvar.pl',
384 quote => 'dumpvar.pl',
387 # These guys may be defined in $ENV{PERL5DB} :
388 $rl = 1 unless defined $rl;
389 $warnLevel = 1 unless defined $warnLevel;
390 $dieLevel = 1 unless defined $dieLevel;
391 $signalLevel = 1 unless defined $signalLevel;
392 $pre = [] unless defined $pre;
393 $post = [] unless defined $post;
394 $pretype = [] unless defined $pretype;
395 $CreateTTY = 3 unless defined $CreateTTY;
397 warnLevel($warnLevel);
399 signalLevel($signalLevel);
402 (defined($ENV{PAGER})
406 : 'more'))) unless defined $pager;
408 &recallCommand("!") unless defined $prc;
409 &shellBang("!") unless defined $psh;
411 $maxtrace = 400 unless defined $maxtrace;
412 $ini_pids = $ENV{PERLDB_PIDS};
413 if (defined $ENV{PERLDB_PIDS}) {
414 $pids = "[$ENV{PERLDB_PIDS}]";
415 $ENV{PERLDB_PIDS} .= "->$$";
418 $ENV{PERLDB_PIDS} = "$$";
423 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
425 if (-e "/dev/tty") { # this is the wrong metric!
428 $rcfile="perldb.ini";
431 # This isn't really safe, because there's a race
432 # between checking and opening. The solution is to
433 # open and fstat the handle, but then you have to read and
434 # eval the contents. But then the silly thing gets
435 # your lexical scope, which is unfortunately at best.
439 # Just exactly what part of the word "CORE::" don't you understand?
440 local $SIG{__WARN__};
443 unless (is_safe_file($file)) {
444 CORE::warn <<EO_GRIPE;
445 perldb: Must not source insecure rcfile $file.
446 You or the superuser must be the owner, and it must not
447 be writable by anyone but its owner.
453 CORE::warn("perldb: couldn't parse $file: $@") if $@;
457 # Verifies that owner is either real user or superuser and that no
458 # one but owner may write to it. This function is of limited use
459 # when called on a path instead of upon a handle, because there are
460 # no guarantees that filename (by dirent) whose file (by ino) is
461 # eventually accessed is the same as the one tested.
462 # Assumes that the file's existence is not in doubt.
465 stat($path) || return; # mysteriously vaporized
466 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
468 return 0 if $uid != 0 && $uid != $<;
469 return 0 if $mode & 022;
474 safe_do("./$rcfile");
476 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
477 safe_do("$ENV{HOME}/$rcfile");
479 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
480 safe_do("$ENV{LOGDIR}/$rcfile");
483 if (defined $ENV{PERLDB_OPTS}) {
484 parse_options($ENV{PERLDB_OPTS});
487 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
488 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
489 *get_fork_TTY = \&xterm_get_fork_TTY;
490 } elsif ($^O eq 'os2') {
491 *get_fork_TTY = \&os2_get_fork_TTY;
494 # Here begin the unreadable code. It needs fixing.
496 if (exists $ENV{PERLDB_RESTART}) {
497 delete $ENV{PERLDB_RESTART};
499 @hist = get_list('PERLDB_HIST');
500 %break_on_load = get_list("PERLDB_ON_LOAD");
501 %postponed = get_list("PERLDB_POSTPONE");
502 my @had_breakpoints= get_list("PERLDB_VISITED");
503 for (0 .. $#had_breakpoints) {
504 my %pf = get_list("PERLDB_FILE_$_");
505 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
507 my %opt = get_list("PERLDB_OPT");
509 while (($opt,$val) = each %opt) {
510 $val =~ s/[\\\']/\\$1/g;
511 parse_options("$opt'$val'");
513 @INC = get_list("PERLDB_INC");
515 $pretype = [get_list("PERLDB_PRETYPE")];
516 $pre = [get_list("PERLDB_PRE")];
517 $post = [get_list("PERLDB_POST")];
518 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
524 # Is Perl being run from a slave editor or graphical debugger?
525 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
526 $rl = 0, shift(@main::ARGV) if $slave_editor;
528 #require Term::ReadLine;
530 if ($^O eq 'cygwin') {
531 # /dev/tty is binary. use stdin for textmode
533 } elsif (-e "/dev/tty") {
534 $console = "/dev/tty";
535 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
537 } elsif ($^O eq 'MacOS') {
538 if ($MacPerl::Version !~ /MPW/) {
539 $console = "Dev:Console:Perl Debug"; # Separate window for application
541 $console = "Dev:Console";
544 $console = "sys\$command";
547 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
551 if ($^O eq 'NetWare') {
556 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
564 $console = $tty if defined $tty;
566 if (defined $remoteport) {
568 $OUT = new IO::Socket::INET( Timeout => '10',
569 PeerAddr => $remoteport,
572 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
575 create_IN_OUT(4) if $CreateTTY & 4;
577 my ($i, $o) = split /,/, $console;
578 $o = $i unless defined $o;
579 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
580 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
581 || open(OUT,">&STDOUT"); # so we don't dongle stdout
582 } elsif (not defined $console) {
584 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
585 $console = 'STDIN/OUT';
587 # so open("|more") can read from STDOUT and so we don't dingle stdin
588 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
590 my $previous = select($OUT);
591 $| = 1; # for DB::OUT
594 $LINEINFO = $OUT unless defined $LINEINFO;
595 $lineinfo = $console unless defined $lineinfo;
597 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
598 unless ($runnonstop) {
599 if ($term_pid eq '-1') {
600 print $OUT "\nDaughter DB session started...\n";
602 print $OUT "\nLoading DB routines from $header\n";
603 print $OUT ("Editor support ",
604 $slave_editor ? "enabled" : "available",
606 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
614 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
617 if (defined &afterinit) { # May be defined in $rcfile
623 ############################################################ Subroutines
626 # _After_ the perl program is compiled, $single is set to 1:
627 if ($single and not $second_time++) {
628 if ($runnonstop) { # Disable until signal
629 for ($i=0; $i <= $stack_depth; ) {
633 # return; # Would not print trace!
634 } elsif ($ImmediateStop) {
639 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
641 ($package, $filename, $line) = caller;
642 $filename_ini = $filename;
643 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
644 "package $package;"; # this won't let them modify, alas
645 local(*dbline) = $main::{'_<' . $filename};
647 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
651 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
652 $dbline{$line} =~ s/;9($|\0)/$1/;
655 my $was_signal = $signal;
657 for (my $n = 0; $n <= $#to_watch; $n++) {
658 $evalarg = $to_watch[$n];
659 local $onetimeDump; # Do not output results
660 my ($val) = &eval; # Fix context (&eval is doing array)?
661 $val = ( (defined $val) ? "'$val'" : 'undef' );
662 if ($val ne $old_watch[$n]) {
665 Watchpoint $n:\t$to_watch[$n] changed:
666 old value:\t$old_watch[$n]
669 $old_watch[$n] = $val;
673 if ($trace & 4) { # User-installed watch
674 return if watchfunction($package, $filename, $line)
675 and not $single and not $was_signal and not ($trace & ~4);
677 $was_signal = $signal;
679 if ($single || ($trace & 1) || $was_signal) {
681 $position = "\032\032$filename:$line:0\n";
682 print_lineinfo($position);
683 } elsif ($package eq 'DB::fake') {
686 Debugged program terminated. Use B<q> to quit or B<R> to restart,
687 use B<O> I<inhibit_exit> to avoid stopping after program termination,
688 B<h q>, B<h R> or B<h O> to get additional info.
691 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
692 "package $package;"; # this won't let them modify, alas
695 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
696 $prefix .= "$sub($filename:";
697 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
698 if (length($prefix) > 30) {
699 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
704 $position = "$prefix$line$infix$dbline[$line]$after";
707 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
709 print_lineinfo($position);
711 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
712 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
714 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
715 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
716 $position .= $incr_pos;
718 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
720 print_lineinfo($incr_pos);
725 $evalarg = $action, &eval if $action;
726 if ($single || $was_signal) {
727 local $level = $level + 1;
728 foreach $evalarg (@$pre) {
731 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
734 $incr = -1; # for backward motion.
735 @typeahead = (@$pretype, @typeahead);
737 while (($term || &setterm),
738 ($term_pid == $$ or resetterm(1)),
739 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
740 ($#hist+1) . ('>' x $level) .
745 $cmd =~ s/\\$/\n/ && do {
746 $cmd .= &readline(" cont: ");
749 $cmd =~ /^$/ && ($cmd = $laststep);
750 push(@hist,$cmd) if length($cmd) > 1;
752 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
753 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
754 ($i) = split(/\s+/,$cmd);
756 # squelch the sigmangler
758 local $SIG{__WARN__};
759 eval "\$cmd =~ $alias{$i}";
761 print $OUT "Couldn't evaluate `$i' alias: $@";
765 $cmd =~ /^q$/ && ($fall_off_end = 1) && clean_ENV() && exit $?;
766 $cmd =~ /^h$/ && do {
769 $cmd =~ /^h\s+h$/ && do {
770 print_help($summary);
772 # support long commands; otherwise bogus errors
773 # happen when you ask for h on <CR> for example
774 $cmd =~ /^h\s+(\S.*)$/ && do {
775 my $asked = $1; # for proper errmsg
776 my $qasked = quotemeta($asked); # for searching
777 # XXX: finds CR but not <CR>
778 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
779 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
783 print_help("B<$asked> is not a debugger command.\n");
786 $cmd =~ /^t$/ && do {
788 print $OUT "Trace = " .
789 (($trace & 1) ? "on" : "off" ) . "\n";
791 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
792 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
793 foreach $subname (sort(keys %sub)) {
794 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
795 print $OUT $subname,"\n";
799 $cmd =~ /^v$/ && do {
800 list_versions(); next CMD};
801 $cmd =~ s/^X\b/V $package/;
802 $cmd =~ /^V$/ && do {
803 $cmd = "V $package"; };
804 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
805 local ($savout) = select($OUT);
807 @vars = split(' ',$2);
808 do 'dumpvar.pl' unless defined &main::dumpvar;
809 if (defined &main::dumpvar) {
812 # must detect sigpipe failures
813 eval { &main::dumpvar($packname,@vars) };
815 die unless $@ =~ /dumpvar print failed/;
818 print $OUT "dumpvar.pl not available.\n";
822 $cmd =~ s/^x\b/ / && do { # So that will be evaled
823 $onetimeDump = 'dump'; };
824 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
825 methods($1); next CMD};
826 $cmd =~ s/^m\b/ / && do { # So this will be evaled
827 $onetimeDump = 'methods'; };
828 $cmd =~ /^f\b\s*(.*)/ && do {
832 print $OUT "The old f command is now the r command.\n";
833 print $OUT "The new f command switches filenames.\n";
836 if (!defined $main::{'_<' . $file}) {
837 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
838 $try = substr($try,2);
839 print $OUT "Choosing $try matching `$file':\n";
843 if (!defined $main::{'_<' . $file}) {
844 print $OUT "No file matching `$file' is loaded.\n";
846 } elsif ($file ne $filename) {
847 *dbline = $main::{'_<' . $file};
853 print $OUT "Already in $file.\n";
857 $cmd =~ s/^l\s+-\s*$/-/;
858 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
861 print($OUT "Error: $@\n"), next CMD if $@;
863 print($OUT "Interpreted as: $1 $s\n");
866 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
867 my $s = $subname = $1;
868 $subname =~ s/\'/::/;
869 $subname = $package."::".$subname
870 unless $subname =~ /::/;
871 $subname = "CORE::GLOBAL::$s"
872 if not defined &$subname and $s !~ /::/
873 and defined &{"CORE::GLOBAL::$s"};
874 $subname = "main".$subname if substr($subname,0,2) eq "::";
875 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
876 $subrange = pop @pieces;
877 $file = join(':', @pieces);
878 if ($file ne $filename) {
879 print $OUT "Switching to file '$file'.\n"
880 unless $slave_editor;
881 *dbline = $main::{'_<' . $file};
886 if (eval($subrange) < -$window) {
887 $subrange =~ s/-.*/+/;
889 $cmd = "l $subrange";
891 print $OUT "Subroutine $subname not found.\n";
894 $cmd =~ /^\.$/ && do {
895 $incr = -1; # for backward motion.
897 $filename = $filename_ini;
898 *dbline = $main::{'_<' . $filename};
900 print_lineinfo($position);
902 $cmd =~ /^w\b\s*(\d*)$/ && do {
906 #print $OUT 'l ' . $start . '-' . ($start + $incr);
907 $cmd = 'l ' . $start . '-' . ($start + $incr); };
908 $cmd =~ /^-$/ && do {
909 $start -= $incr + $window + 1;
910 $start = 1 if $start <= 0;
912 $cmd = 'l ' . ($start) . '+'; };
913 $cmd =~ /^l$/ && do {
915 $cmd = 'l ' . $start . '-' . ($start + $incr); };
916 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
919 $incr = $window - 1 unless $incr;
920 $cmd = 'l ' . $start . '-' . ($start + $incr); };
921 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
922 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
923 $end = $max if $end > $max;
925 $i = $line if $i eq '.';
929 print $OUT "\032\032$filename:$i:0\n";
932 for (; $i <= $end; $i++) {
934 ($stop,$action) = split(/\0/, $dbline{$i}) if
937 and $filename eq $filename_ini)
939 : ($dbline[$i]+0 ? ':' : ' ') ;
940 $arrow .= 'b' if $stop;
941 $arrow .= 'a' if $action;
942 print $OUT "$i$arrow\t", $dbline[$i];
943 $i++, last if $signal;
945 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
947 $start = $i; # remember in case they want more
948 $start = $max if $start > $max;
950 $cmd =~ /^D$/ && do {
951 print $OUT "Deleting all breakpoints...\n";
953 for $file (keys %had_breakpoints) {
954 local *dbline = $main::{'_<' . $file};
958 for ($i = 1; $i <= $max ; $i++) {
959 if (defined $dbline{$i}) {
960 $dbline{$i} =~ s/^[^\0]+//;
961 if ($dbline{$i} =~ s/^\0?$//) {
967 if (not $had_breakpoints{$file} &= ~1) {
968 delete $had_breakpoints{$file};
972 undef %postponed_file;
973 undef %break_on_load;
975 $cmd =~ /^L$/ && do {
977 for $file (keys %had_breakpoints) {
978 local *dbline = $main::{'_<' . $file};
982 for ($i = 1; $i <= $max; $i++) {
983 if (defined $dbline{$i}) {
984 print $OUT "$file:\n" unless $was++;
985 print $OUT " $i:\t", $dbline[$i];
986 ($stop,$action) = split(/\0/, $dbline{$i});
987 print $OUT " break if (", $stop, ")\n"
989 print $OUT " action: ", $action, "\n"
996 print $OUT "Postponed breakpoints in subroutines:\n";
998 for $subname (keys %postponed) {
999 print $OUT " $subname\t$postponed{$subname}\n";
1003 my @have = map { # Combined keys
1004 keys %{$postponed_file{$_}}
1005 } keys %postponed_file;
1007 print $OUT "Postponed breakpoints in files:\n";
1009 for $file (keys %postponed_file) {
1010 my $db = $postponed_file{$file};
1011 print $OUT " $file:\n";
1012 for $line (sort {$a <=> $b} keys %$db) {
1013 print $OUT " $line:\n";
1014 my ($stop,$action) = split(/\0/, $$db{$line});
1015 print $OUT " break if (", $stop, ")\n"
1017 print $OUT " action: ", $action, "\n"
1024 if (%break_on_load) {
1025 print $OUT "Breakpoints on load:\n";
1027 for $file (keys %break_on_load) {
1028 print $OUT " $file\n";
1033 print $OUT "Watch-expressions:\n";
1035 for $expr (@to_watch) {
1036 print $OUT " $expr\n";
1041 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
1042 my $file = $1; $file =~ s/\s+$//;
1045 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
1046 my $cond = length $3 ? $3 : '1';
1047 my ($subname, $break) = ($2, $1 eq 'postpone');
1048 $subname =~ s/\'/::/g;
1049 $subname = "${'package'}::" . $subname
1050 unless $subname =~ /::/;
1051 $subname = "main".$subname if substr($subname,0,2) eq "::";
1052 $postponed{$subname} = $break
1053 ? "break +0 if $cond" : "compile";
1055 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1057 $cond = length $2 ? $2 : '1';
1058 cmd_b_sub($subname, $cond);
1060 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1062 $cond = length $2 ? $2 : '1';
1063 cmd_b_line($i, $cond);
1065 $cmd =~ /^d\b\s*(\d*)/ && do {
1068 $cmd =~ /^A$/ && do {
1069 print $OUT "Deleting all actions...\n";
1071 for $file (keys %had_breakpoints) {
1072 local *dbline = $main::{'_<' . $file};
1076 for ($i = 1; $i <= $max ; $i++) {
1077 if (defined $dbline{$i}) {
1078 $dbline{$i} =~ s/\0[^\0]*//;
1079 delete $dbline{$i} if $dbline{$i} eq '';
1083 unless ($had_breakpoints{$file} &= ~2) {
1084 delete $had_breakpoints{$file};
1088 $cmd =~ /^O\s*$/ && do {
1093 $cmd =~ /^O\s*(\S.*)/ && do {
1096 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1097 push @$pre, action($1);
1099 $cmd =~ /^>>\s*(.*)/ && do {
1100 push @$post, action($1);
1102 $cmd =~ /^<\s*(.*)/ && do {
1104 print $OUT "All < actions cleared.\n";
1110 print $OUT "No pre-prompt Perl actions.\n";
1113 print $OUT "Perl commands run before each prompt:\n";
1114 for my $action ( @$pre ) {
1115 print $OUT "\t< -- $action\n";
1119 $pre = [action($1)];
1121 $cmd =~ /^>\s*(.*)/ && do {
1123 print $OUT "All > actions cleared.\n";
1129 print $OUT "No post-prompt Perl actions.\n";
1132 print $OUT "Perl commands run after each prompt:\n";
1133 for my $action ( @$post ) {
1134 print $OUT "\t> -- $action\n";
1138 $post = [action($1)];
1140 $cmd =~ /^\{\{\s*(.*)/ && do {
1141 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1142 print $OUT "{{ is now a debugger command\n",
1143 "use `;{{' if you mean Perl code\n";
1149 $cmd =~ /^\{\s*(.*)/ && do {
1151 print $OUT "All { actions cleared.\n";
1156 unless (@$pretype) {
1157 print $OUT "No pre-prompt debugger actions.\n";
1160 print $OUT "Debugger commands run before each prompt:\n";
1161 for my $action ( @$pretype ) {
1162 print $OUT "\t{ -- $action\n";
1166 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1167 print $OUT "{ is now a debugger command\n",
1168 "use `;{' if you mean Perl code\n";
1174 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1175 $i = $1 || $line; $j = $2;
1177 if ($dbline[$i] == 0) {
1178 print $OUT "Line $i may not have an action.\n";
1180 $had_breakpoints{$filename} |= 2;
1181 $dbline{$i} =~ s/\0[^\0]*//;
1182 $dbline{$i} .= "\0" . action($j);
1185 $dbline{$i} =~ s/\0[^\0]*//;
1186 delete $dbline{$i} if $dbline{$i} eq '';
1189 $cmd =~ /^n$/ && do {
1190 end_report(), next CMD if $finished and $level <= 1;
1194 $cmd =~ /^s$/ && do {
1195 end_report(), next CMD if $finished and $level <= 1;
1199 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1200 end_report(), next CMD if $finished and $level <= 1;
1202 # Probably not needed, since we finish an interactive
1203 # sub-session anyway...
1204 # local $filename = $filename;
1205 # local *dbline = *dbline; # XXX Would this work?!
1206 if ($i =~ /\D/) { # subroutine name
1207 $subname = $package."::".$subname
1208 unless $subname =~ /::/;
1209 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1213 *dbline = $main::{'_<' . $filename};
1214 $had_breakpoints{$filename} |= 1;
1216 ++$i while $dbline[$i] == 0 && $i < $max;
1218 print $OUT "Subroutine $subname not found.\n";
1223 if ($dbline[$i] == 0) {
1224 print $OUT "Line $i not breakable.\n";
1227 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1229 for ($i=0; $i <= $stack_depth; ) {
1233 $cmd =~ /^r$/ && do {
1234 end_report(), next CMD if $finished and $level <= 1;
1235 $stack[$stack_depth] |= 1;
1236 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1238 $cmd =~ /^R$/ && do {
1239 print $OUT "Warning: some settings and command-line options may be lost!\n";
1240 my (@script, @flags, $cl);
1241 push @flags, '-w' if $ini_warn;
1242 # Put all the old includes at the start to get
1243 # the same debugger.
1245 push @flags, '-I', $_;
1247 # Arrange for setting the old INC:
1248 set_list("PERLDB_INC", @ini_INC);
1250 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1251 chomp ($cl = ${'::_<-e'}[$_]);
1252 push @script, '-e', $cl;
1257 set_list("PERLDB_HIST",
1258 $term->Features->{getHistory}
1259 ? $term->GetHistory : @hist);
1260 my @had_breakpoints = keys %had_breakpoints;
1261 set_list("PERLDB_VISITED", @had_breakpoints);
1262 set_list("PERLDB_OPT", %option);
1263 set_list("PERLDB_ON_LOAD", %break_on_load);
1265 for (0 .. $#had_breakpoints) {
1266 my $file = $had_breakpoints[$_];
1267 *dbline = $main::{'_<' . $file};
1268 next unless %dbline or $postponed_file{$file};
1269 (push @hard, $file), next
1270 if $file =~ /^\(\w*eval/;
1272 @add = %{$postponed_file{$file}}
1273 if $postponed_file{$file};
1274 set_list("PERLDB_FILE_$_", %dbline, @add);
1276 for (@hard) { # Yes, really-really...
1277 # Find the subroutines in this eval
1278 *dbline = $main::{'_<' . $_};
1279 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1280 for $sub (keys %sub) {
1281 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1282 $subs{$sub} = [$1, $2];
1286 "No subroutines in $_, ignoring breakpoints.\n";
1289 LINES: for $line (keys %dbline) {
1290 # One breakpoint per sub only:
1291 my ($offset, $sub, $found);
1292 SUBS: for $sub (keys %subs) {
1293 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1294 and (not defined $offset # Not caught
1295 or $offset < 0 )) { # or badly caught
1297 $offset = $line - $subs{$sub}->[0];
1298 $offset = "+$offset", last SUBS if $offset >= 0;
1301 if (defined $offset) {
1302 $postponed{$found} =
1303 "break $offset if $dbline{$line}";
1305 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1309 set_list("PERLDB_POSTPONE", %postponed);
1310 set_list("PERLDB_PRETYPE", @$pretype);
1311 set_list("PERLDB_PRE", @$pre);
1312 set_list("PERLDB_POST", @$post);
1313 set_list("PERLDB_TYPEAHEAD", @typeahead);
1314 $ENV{PERLDB_RESTART} = 1;
1315 delete $ENV{PERLDB_PIDS}; # Restore ini state
1316 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1317 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1318 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1319 print $OUT "exec failed: $!\n";
1321 $cmd =~ /^T$/ && do {
1322 print_trace($OUT, 1); # skip DB
1324 $cmd =~ /^W\s*$/ && do {
1326 @to_watch = @old_watch = ();
1328 $cmd =~ /^W\b\s*(.*)/s && do {
1332 $val = (defined $val) ? "'$val'" : 'undef' ;
1333 push @old_watch, $val;
1336 $cmd =~ /^\/(.*)$/ && do {
1338 $inpat =~ s:([^\\])/$:$1:;
1340 # squelch the sigmangler
1341 local $SIG{__DIE__};
1342 local $SIG{__WARN__};
1343 eval '$inpat =~ m'."\a$inpat\a";
1355 $start = 1 if ($start > $max);
1356 last if ($start == $end);
1357 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1358 if ($slave_editor) {
1359 print $OUT "\032\032$filename:$start:0\n";
1361 print $OUT "$start:\t", $dbline[$start], "\n";
1366 print $OUT "/$pat/: not found\n" if ($start == $end);
1368 $cmd =~ /^\?(.*)$/ && do {
1370 $inpat =~ s:([^\\])\?$:$1:;
1372 # squelch the sigmangler
1373 local $SIG{__DIE__};
1374 local $SIG{__WARN__};
1375 eval '$inpat =~ m'."\a$inpat\a";
1387 $start = $max if ($start <= 0);
1388 last if ($start == $end);
1389 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1390 if ($slave_editor) {
1391 print $OUT "\032\032$filename:$start:0\n";
1393 print $OUT "$start:\t", $dbline[$start], "\n";
1398 print $OUT "?$pat?: not found\n" if ($start == $end);
1400 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1401 pop(@hist) if length($cmd) > 1;
1402 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1404 print $OUT $cmd, "\n";
1406 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1409 $cmd =~ /^$rc([^$rc].*)$/ && do {
1411 pop(@hist) if length($cmd) > 1;
1412 for ($i = $#hist; $i; --$i) {
1413 last if $hist[$i] =~ /$pat/;
1416 print $OUT "No such command!\n\n";
1420 print $OUT $cmd, "\n";
1422 $cmd =~ /^$sh$/ && do {
1423 &system($ENV{SHELL}||"/bin/sh");
1425 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1426 # XXX: using csh or tcsh destroys sigint retvals!
1427 #&system($1); # use this instead
1428 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1430 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1431 $end = $2 ? ($#hist-$2) : 0;
1432 $hist = 0 if $hist < 0;
1433 for ($i=$#hist; $i>$end; $i--) {
1434 print $OUT "$i: ",$hist[$i],"\n"
1435 unless $hist[$i] =~ /^.?$/;
1438 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1441 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1442 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1443 $cmd =~ s/^=\s*// && do {
1445 if (length $cmd == 0) {
1446 @keys = sort keys %alias;
1448 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1449 # can't use $_ or kill //g state
1450 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1451 $alias{$k} = "s\a$k\a$v\a";
1452 # squelch the sigmangler
1453 local $SIG{__DIE__};
1454 local $SIG{__WARN__};
1455 unless (eval "sub { s\a$k\a$v\a }; 1") {
1456 print $OUT "Can't alias $k to $v: $@\n";
1466 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1467 print $OUT "$k\t= $1\n";
1469 elsif (defined $alias{$k}) {
1470 print $OUT "$k\t$alias{$k}\n";
1473 print "No alias for $k\n";
1477 $cmd =~ /^\@\s*(.*\S)/ && do {
1478 if (open my $fh, $1) {
1482 &warn("Can't execute `$1': $!\n");
1485 $cmd =~ /^\|\|?\s*[^|]/ && do {
1486 if ($pager =~ /^\|/) {
1487 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1488 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1490 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1493 unless ($piped=open(OUT,$pager)) {
1494 &warn("Can't pipe output to `$pager'");
1495 if ($pager =~ /^\|/) {
1496 open(OUT,">&STDOUT") # XXX: lost message
1497 || &warn("Can't restore DB::OUT");
1498 open(STDOUT,">&SAVEOUT")
1499 || &warn("Can't restore STDOUT");
1502 open(OUT,">&STDOUT") # XXX: lost message
1503 || &warn("Can't restore DB::OUT");
1507 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1508 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1509 $selected= select(OUT);
1511 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1512 $cmd =~ s/^\|+\s*//;
1515 # XXX Local variants do not work!
1516 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1517 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1518 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1520 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1522 $onetimeDump = undef;
1523 } elsif ($term_pid == $$) {
1528 if ($pager =~ /^\|/) {
1530 # we cannot warn here: the handle is missing --tchrist
1531 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1533 # most of the $? crud was coping with broken cshisms
1535 print SAVEOUT "Pager `$pager' failed: ";
1537 print SAVEOUT "shell returned -1\n";
1540 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1541 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1543 print SAVEOUT "status ", ($? >> 8), "\n";
1547 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1548 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1549 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1550 # Will stop ignoring SIGPIPE if done like nohup(1)
1551 # does SIGINT but Perl doesn't give us a choice.
1553 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1556 select($selected), $selected= "" unless $selected eq "";
1560 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1561 foreach $evalarg (@$post) {
1564 } # if ($single || $signal)
1565 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1569 # The following code may be executed now:
1573 my ($al, $ret, @ret) = "";
1574 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1577 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1578 $#stack = $stack_depth;
1579 $stack[-1] = $single;
1581 $single |= 4 if $stack_depth == $deep;
1583 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1584 # Why -1? But it works! :-(
1585 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1586 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1589 $single |= $stack[$stack_depth--];
1591 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1592 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1593 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1594 if ($doret eq $stack_depth or $frame & 16) {
1595 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1596 print $fh ' ' x $stack_depth if $frame & 16;
1597 print $fh "list context return from $sub:\n";
1598 dumpit($fh, \@ret );
1603 if (defined wantarray) {
1608 $single |= $stack[$stack_depth--];
1610 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1611 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1612 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1613 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1614 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1615 print $fh (' ' x $stack_depth) if $frame & 16;
1616 print $fh (defined wantarray
1617 ? "scalar context return from $sub: "
1618 : "void context return from $sub\n");
1619 dumpit( $fh, $ret ) if defined wantarray;
1628 ### Functions with multiple modes of failure die on error, the rest
1629 ### returns FALSE on error.
1630 ### User-interface functions cmd_* output error message.
1634 $break_on_load{$file} = 1;
1635 $had_breakpoints{$file} |= 1;
1638 sub report_break_on_load {
1639 sort keys %break_on_load;
1647 push @files, $::INC{$file} if $::INC{$file};
1648 $file .= '.pm', redo unless $file =~ /\./;
1650 break_on_load($_) for @files;
1651 @files = report_break_on_load;
1652 print $OUT "Will stop on load of `@files'.\n";
1655 $filename_error = '';
1657 sub breakable_line {
1658 my ($from, $to) = @_;
1661 my $delta = $from < $to ? +1 : -1;
1662 my $limit = $delta > 0 ? $#dbline : 1;
1663 $limit = $to if ($limit - $to) * $delta > 0;
1664 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1666 return $i unless $dbline[$i] == 0;
1667 my ($pl, $upto) = ('', '');
1668 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1669 die "Line$pl $from$upto$filename_error not breakable\n";
1672 sub breakable_line_in_filename {
1674 local *dbline = $main::{'_<' . $f};
1675 local $filename_error = " of `$f'";
1680 my ($i, $cond) = @_;
1681 $cond = 1 unless @_ >= 2;
1685 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1686 $had_breakpoints{$filename} |= 1;
1687 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1688 else { $dbline{$i} = $cond; }
1692 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1695 sub break_on_filename_line {
1696 my ($f, $i, $cond) = @_;
1697 $cond = 1 unless @_ >= 3;
1698 local *dbline = $main::{'_<' . $f};
1699 local $filename_error = " of `$f'";
1700 local $filename = $f;
1701 break_on_line($i, $cond);
1704 sub break_on_filename_line_range {
1705 my ($f, $from, $to, $cond) = @_;
1706 my $i = breakable_line_in_filename($f, $from, $to);
1707 $cond = 1 unless @_ >= 3;
1708 break_on_filename_line($f,$i,$cond);
1711 sub subroutine_filename_lines {
1712 my ($subname,$cond) = @_;
1713 # Filename below can contain ':'
1714 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1717 sub break_subroutine {
1718 my $subname = shift;
1719 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1720 die "Subroutine $subname not found.\n";
1721 $cond = 1 unless @_ >= 2;
1722 break_on_filename_line_range($file,$s,$e,@_);
1726 my ($subname,$cond) = @_;
1727 $cond = 1 unless @_ >= 2;
1728 unless (ref $subname eq 'CODE') {
1729 $subname =~ s/\'/::/g;
1731 $subname = "${'package'}::" . $subname
1732 unless $subname =~ /::/;
1733 $subname = "CORE::GLOBAL::$s"
1734 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1735 $subname = "main".$subname if substr($subname,0,2) eq "::";
1737 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1740 sub cmd_stop { # As on ^C, but not signal-safy.
1744 sub delete_breakpoint {
1746 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1747 $dbline{$i} =~ s/^[^\0]*//;
1748 delete $dbline{$i} if $dbline{$i} eq '';
1753 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1756 ### END of the API section
1759 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1760 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1763 sub print_lineinfo {
1764 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1768 # The following takes its argument via $evalarg to preserve current @_
1771 my $subname = shift;
1772 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1773 my $offset = $1 || 0;
1774 # Filename below can contain ':'
1775 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1778 local *dbline = $main::{'_<' . $file};
1779 local $^W = 0; # != 0 is magical below
1780 $had_breakpoints{$file} |= 1;
1782 ++$i until $dbline[$i] != 0 or $i >= $max;
1783 $dbline{$i} = delete $postponed{$subname};
1785 print $OUT "Subroutine $subname not found.\n";
1789 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1790 #print $OUT "In postponed_sub for `$subname'.\n";
1794 if ($ImmediateStop) {
1798 return &postponed_sub
1799 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1800 # Cannot be done before the file is compiled
1801 local *dbline = shift;
1802 my $filename = $dbline;
1803 $filename =~ s/^_<//;
1804 $signal = 1, print $OUT "'$filename' loaded...\n"
1805 if $break_on_load{$filename};
1806 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1807 return unless $postponed_file{$filename};
1808 $had_breakpoints{$filename} |= 1;
1809 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1811 for $key (keys %{$postponed_file{$filename}}) {
1812 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1814 delete $postponed_file{$filename};
1818 local ($savout) = select(shift);
1819 my $osingle = $single;
1820 my $otrace = $trace;
1821 $single = $trace = 0;
1824 unless (defined &main::dumpValue) {
1827 if (defined &main::dumpValue) {
1828 &main::dumpValue(shift);
1830 print $OUT "dumpvar.pl not available.\n";
1837 # Tied method do not create a context, so may get wrong message:
1841 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1842 my @sub = dump_trace($_[0] + 1, $_[1]);
1843 my $short = $_[2]; # Print short report, next one for sub name
1845 for ($i=0; $i <= $#sub; $i++) {
1848 my $args = defined $sub[$i]{args}
1849 ? "(@{ $sub[$i]{args} })"
1851 $args = (substr $args, 0, $maxtrace - 3) . '...'
1852 if length $args > $maxtrace;
1853 my $file = $sub[$i]{file};
1854 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1856 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1858 my $sub = @_ >= 4 ? $_[3] : $s;
1859 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1861 print $fh "$sub[$i]{context} = $s$args" .
1862 " called from $file" .
1863 " line $sub[$i]{line}\n";
1870 my $count = shift || 1e9;
1873 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1874 my $nothard = not $frame & 8;
1875 local $frame = 0; # Do not want to trace this.
1876 my $otrace = $trace;
1879 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1884 if (not defined $arg) {
1886 } elsif ($nothard and tied $arg) {
1888 } elsif ($nothard and $type = ref $arg) {
1889 push @a, "ref($type)";
1891 local $_ = "$arg"; # Safe to stringify now - should not call f().
1894 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1895 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1896 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1900 $context = $context ? '@' : (defined $context ? "\$" : '.');
1901 $args = $h ? [@a] : undef;
1902 $e =~ s/\n\s*\;\s*\Z// if $e;
1903 $e =~ s/([\\\'])/\\$1/g if $e;
1905 $sub = "require '$e'";
1906 } elsif (defined $r) {
1908 } elsif ($sub eq '(eval)') {
1909 $sub = "eval {...}";
1911 push(@sub, {context => $context, sub => $sub, args => $args,
1912 file => $file, line => $line});
1921 while ($action =~ s/\\$//) {
1930 # i hate using globals!
1931 $balanced_brace_re ||= qr{
1934 (?> [^{}] + ) # Non-parens without backtracking
1936 (??{ $balanced_brace_re }) # Group with matching parens
1940 return $_[0] !~ m/$balanced_brace_re/;
1944 &readline("cont: ");
1948 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1949 # some non-Unix systems can do system() but have problems with fork().
1950 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1951 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1952 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1953 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1955 # XXX: using csh or tcsh destroys sigint retvals!
1957 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1958 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1963 # most of the $? crud was coping with broken cshisms
1965 &warn("(Command exited ", ($? >> 8), ")\n");
1967 &warn( "(Command died of SIG#", ($? & 127),
1968 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1978 eval { require Term::ReadLine } or die $@;
1981 my ($i, $o) = split $tty, /,/;
1982 $o = $i unless defined $o;
1983 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1984 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1987 my $sel = select($OUT);
1991 eval "require Term::Rendezvous;" or die;
1992 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1993 my $term_rv = new Term::Rendezvous $rv;
1995 $OUT = $term_rv->OUT;
1998 if ($term_pid eq '-1') { # In a TTY with another debugger
2002 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2004 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2006 $rl_attribs = $term->Attribs;
2007 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2008 if defined $rl_attribs->{basic_word_break_characters}
2009 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2010 $rl_attribs->{special_prefixes} = '$@&%';
2011 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2012 $rl_attribs->{completion_function} = \&db_complete;
2014 $LINEINFO = $OUT unless defined $LINEINFO;
2015 $lineinfo = $console unless defined $lineinfo;
2017 if ($term->Features->{setHistory} and "@hist" ne "?") {
2018 $term->SetHistory(@hist);
2020 ornaments($ornaments) if defined $ornaments;
2024 # Example get_fork_TTY functions
2025 sub xterm_get_fork_TTY {
2026 (my $name = $0) =~ s,^.*[/\\],,s;
2027 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2031 $pidprompt = ''; # Shown anyway in titlebar
2035 # This example function resets $IN, $OUT itself
2036 sub os2_get_fork_TTY {
2037 local $^F = 40; # XXXX Fixme!
2038 my ($in1, $out1, $in2, $out2);
2039 # Having -d in PERL5OPT would lead to a disaster...
2040 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2041 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2042 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2043 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2044 (my $name = $0) =~ s,^.*[/\\],,s;
2046 if ( pipe $in1, $out1 and pipe $in2, $out2
2047 # system P_SESSION will fail if there is another process
2048 # in the same session with a "dependent" asynchronous child session.
2049 and @args = ($rl, fileno $in1, fileno $out2,
2050 "Daughter Perl debugger $pids $name") and
2051 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2054 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2056 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2057 open IN, '<&=$in' or die "open <&=$in: \$!";
2058 \$| = 1; print while sysread IN, \$_, 1<<16;
2062 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2064 require Term::ReadKey if $rl;
2065 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2066 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2068 or warn "system P_SESSION: $!, $^E" and 0)
2069 and close $in1 and close $out2 ) {
2070 $pidprompt = ''; # Shown anyway in titlebar
2071 reset_IN_OUT($in2, $out1);
2073 return ''; # Indicate that reset_IN_OUT is called
2078 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2079 my $in = &get_fork_TTY if defined &get_fork_TTY;
2080 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2081 if (not defined $in) {
2083 print_help(<<EOP) if $why == 1;
2084 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2086 print_help(<<EOP) if $why == 2;
2087 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2088 This may be an asynchronous session, so the parent debugger may be active.
2090 print_help(<<EOP) if $why != 4;
2091 Since two debuggers fight for the same TTY, input is severely entangled.
2095 I know how to switch the output to a different window in xterms
2096 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2097 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2099 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2100 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2103 } elsif ($in ne '') {
2106 $console = ''; # Indicate no need to open-from-the-console
2111 sub resetterm { # We forked, so we need a different TTY
2113 my $systemed = $in > 1 ? '-' : '';
2115 $pids =~ s/\]/$systemed->$$]/;
2117 $pids = "[$term_pid->$$]";
2121 return unless $CreateTTY & $in;
2128 my $left = @typeahead;
2129 my $got = shift @typeahead;
2130 print $OUT "auto(-$left)", shift, $got, "\n";
2131 $term->AddHistory($got)
2132 if length($got) > 1 and defined $term->Features->{addHistory};
2138 my $line = CORE::readline($cmdfhs[-1]);
2139 defined $line ? (print $OUT ">> $line" and return $line)
2140 : close pop @cmdfhs;
2142 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2143 $OUT->write(join('', @_));
2145 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2149 $term->readline(@_);
2154 my ($opt, $val)= @_;
2155 $val = option_val($opt,'N/A');
2156 $val =~ s/([\\\'])/\\$1/g;
2157 printf $OUT "%20s = '%s'\n", $opt, $val;
2161 my ($opt, $default)= @_;
2163 if (defined $optionVars{$opt}
2164 and defined ${$optionVars{$opt}}) {
2165 $val = ${$optionVars{$opt}};
2166 } elsif (defined $optionAction{$opt}
2167 and defined &{$optionAction{$opt}}) {
2168 $val = &{$optionAction{$opt}}();
2169 } elsif (defined $optionAction{$opt}
2170 and not defined $option{$opt}
2171 or defined $optionVars{$opt}
2172 and not defined ${$optionVars{$opt}}) {
2175 $val = $option{$opt};
2177 $val = $default unless defined $val;
2183 # too dangerous to let intuitive usage overwrite important things
2184 # defaultion should never be the default
2185 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2186 arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2187 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2192 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2193 my ($opt,$sep) = ($1,$2);
2196 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2198 #&dump_option($opt);
2199 } elsif ($sep !~ /\S/) {
2201 $val = "1"; # this is an evil default; make 'em set it!
2202 } elsif ($sep eq "=") {
2204 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2206 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2210 print OUT qq(Option better cleared using $opt=""\n)
2214 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2215 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2216 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2217 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2218 ($val = $1) =~ s/\\([\\$end])/$1/g;
2222 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2223 || grep( /^\Q$opt/i && ($option = $_), @options );
2225 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2226 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2228 if ($opt_needs_val{$option} && $val_defaulted) {
2229 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2233 $option{$option} = $val if defined $val;
2238 require '$optionRequire{$option}';
2240 } || die # XXX: shouldn't happen
2241 if defined $optionRequire{$option} &&
2244 ${$optionVars{$option}} = $val
2245 if defined $optionVars{$option} &&
2248 &{$optionAction{$option}} ($val)
2249 if defined $optionAction{$option} &&
2250 defined &{$optionAction{$option}} &&
2254 dump_option($option) unless $OUT eq \*STDERR;
2259 my ($stem,@list) = @_;
2261 $ENV{"${stem}_n"} = @list;
2262 for $i (0 .. $#list) {
2264 $val =~ s/\\/\\\\/g;
2265 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2266 $ENV{"${stem}_$i"} = $val;
2273 my $n = delete $ENV{"${stem}_n"};
2275 for $i (0 .. $n - 1) {
2276 $val = delete $ENV{"${stem}_$i"};
2277 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2285 return; # Put nothing on the stack - malloc/free land!
2289 my($msg)= join("",@_);
2290 $msg .= ": $!\n" unless $msg =~ /\n$/;
2295 my $switch_li = $LINEINFO eq $OUT;
2296 if ($term and $term->Features->{newTTY}) {
2297 ($IN, $OUT) = (shift, shift);
2298 $term->newTTY($IN, $OUT);
2300 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2302 ($IN, $OUT) = (shift, shift);
2304 my $o = select $OUT;
2307 $LINEINFO = $OUT if $switch_li;
2311 if (@_ and $term and $term->Features->{newTTY}) {
2312 my ($in, $out) = shift;
2314 ($in, $out) = split /,/, $in, 2;
2318 open IN, $in or die "cannot open `$in' for read: $!";
2319 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2320 reset_IN_OUT(\*IN,\*OUT);
2323 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2324 # Useful if done through PERLDB_OPTS:
2325 $console = $tty = shift if @_;
2331 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2333 $notty = shift if @_;
2339 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2347 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2349 $remoteport = shift if @_;
2354 if (${$term->Features}{tkRunning}) {
2355 return $term->tkRunning(@_);
2357 print $OUT "tkRunning not supported by current ReadLine package.\n";
2364 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2366 $runnonstop = shift if @_;
2373 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2380 $sh = quotemeta shift;
2381 $sh .= "\\b" if $sh =~ /\w$/;
2385 $psh =~ s/\\(.)/$1/g;
2390 if (defined $term) {
2391 local ($warnLevel,$dieLevel) = (0, 1);
2392 return '' unless $term->Features->{ornaments};
2393 eval { $term->ornaments(@_) } || '';
2401 $rc = quotemeta shift;
2402 $rc .= "\\b" if $rc =~ /\w$/;
2406 $prc =~ s/\\(.)/$1/g;
2411 return $lineinfo unless @_;
2413 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2414 $slave_editor = ($stream =~ /^\|/);
2415 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2416 $LINEINFO = \*LINEINFO;
2417 my $save = select($LINEINFO);
2431 s/^Term::ReadLine::readline$/readline/;
2432 if (defined ${ $_ . '::VERSION' }) {
2433 $version{$file} = "${ $_ . '::VERSION' } from ";
2435 $version{$file} .= $INC{$file};
2437 dumpit($OUT,\%version);
2441 # XXX: make sure there are tabs between the command and explanation,
2442 # or print_help will screw up your formatting if you have
2443 # eeevil ornaments enabled. This is an insane mess.
2447 B<s> [I<expr>] Single step [in I<expr>].
2448 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2449 <B<CR>> Repeat last B<n> or B<s> command.
2450 B<r> Return from current subroutine.
2451 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2452 at the specified position.
2453 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2454 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2455 B<l> I<line> List single I<line>.
2456 B<l> I<subname> List first window of lines from subroutine.
2457 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2458 B<l> List next window of lines.
2459 B<-> List previous window of lines.
2460 B<w> [I<line>] List window around I<line>.
2461 B<.> Return to the executed line.
2462 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2463 I<filename> may be either the full name of the file, or a regular
2464 expression matching the full file name:
2465 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2466 Evals (with saved bodies) are considered to be filenames:
2467 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2468 (in the order of execution).
2469 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2470 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2471 B<L> List all breakpoints and actions.
2472 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2473 B<t> Toggle trace mode.
2474 B<t> I<expr> Trace through execution of I<expr>.
2475 B<b> [I<line>] [I<condition>]
2476 Set breakpoint; I<line> defaults to the current execution line;
2477 I<condition> breaks if it evaluates to true, defaults to '1'.
2478 B<b> I<subname> [I<condition>]
2479 Set breakpoint at first line of subroutine.
2480 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2481 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2482 B<b> B<postpone> I<subname> [I<condition>]
2483 Set breakpoint at first line of subroutine after
2485 B<b> B<compile> I<subname>
2486 Stop after the subroutine is compiled.
2487 B<d> [I<line>] Delete the breakpoint for I<line>.
2488 B<D> Delete all breakpoints.
2489 B<a> [I<line>] I<command>
2490 Set an action to be done before the I<line> is executed;
2491 I<line> defaults to the current execution line.
2492 Sequence is: check for breakpoint/watchpoint, print line
2493 if necessary, do action, prompt user if necessary,
2495 B<a> [I<line>] Delete the action for I<line>.
2496 B<A> Delete all actions.
2497 B<W> I<expr> Add a global watch-expression.
2498 B<W> Delete all watch-expressions.
2499 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2500 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2501 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2502 B<x> I<expr> Evals expression in list context, dumps the result.
2503 B<m> I<expr> Evals expression in list context, prints methods callable
2504 on the first element of the result.
2505 B<m> I<class> Prints methods callable via the given class.
2507 B<<> ? List Perl commands to run before each prompt.
2508 B<<> I<expr> Define Perl command to run before each prompt.
2509 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2510 B<>> ? List Perl commands to run after each prompt.
2511 B<>> I<expr> Define Perl command to run after each prompt.
2512 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2513 B<{> I<db_command> Define debugger command to run before each prompt.
2514 B<{> ? List debugger commands to run before each prompt.
2515 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2516 B<$prc> I<number> Redo a previous command (default previous command).
2517 B<$prc> I<-number> Redo number'th-to-last command.
2518 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2519 See 'B<O> I<recallCommand>' too.
2520 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2521 . ( $rc eq $sh ? "" : "
2522 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2523 See 'B<O> I<shellBang>' too.
2524 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2525 B<H> I<-number> Display last number commands (default all).
2526 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2527 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2528 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2529 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2530 I<command> Execute as a perl statement in current package.
2531 B<v> Show versions of loaded modules.
2532 B<R> Pure-man-restart of debugger, some of debugger state
2533 and command-line options may be lost.
2534 Currently the following settings are preserved:
2535 history, breakpoints and actions, debugger B<O>ptions
2536 and the following command-line options: I<-w>, I<-I>, I<-e>.
2538 B<O> [I<opt>] ... Set boolean option to true
2539 B<O> [I<opt>B<?>] Query options
2540 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2541 Set options. Use quotes in spaces in value.
2542 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2543 I<pager> program for output of \"|cmd\";
2544 I<tkRunning> run Tk while prompting (with ReadLine);
2545 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2546 I<inhibit_exit> Allows stepping off the end of the script.
2547 I<ImmediateStop> Debugger should stop as early as possible.
2548 I<RemotePort> Remote hostname:port for remote debugging
2549 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2550 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2551 I<compactDump>, I<veryCompact> change style of array and hash dump;
2552 I<globPrint> whether to print contents of globs;
2553 I<DumpDBFiles> dump arrays holding debugged files;
2554 I<DumpPackages> dump symbol tables of packages;
2555 I<DumpReused> dump contents of \"reused\" addresses;
2556 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2557 I<bareStringify> Do not print the overload-stringified value;
2558 Other options include:
2559 I<PrintRet> affects printing of return value after B<r> command,
2560 I<frame> affects printing messages on subroutine entry/exit.
2561 I<AutoTrace> affects printing messages on possible breaking points.
2562 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2563 I<ornaments> affects screen appearance of the command line.
2564 I<CreateTTY> bits control attempts to create a new TTY on events:
2565 1: on fork() 2: debugger is started inside debugger
2567 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2568 You can put additional initialization options I<TTY>, I<noTTY>,
2569 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2570 `B<R>' after you set them).
2572 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2573 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2574 B<h h> Summary of debugger commands.
2575 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2576 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2577 Set B<\$DB::doccmd> to change viewer.
2579 Type `|h' for a paged display if this was too hard to read.
2581 "; # Fix balance of vi % matching: }}}}
2583 # note: tabs in the following section are not-so-helpful
2584 $summary = <<"END_SUM";
2585 I<List/search source lines:> I<Control script execution:>
2586 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2587 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2588 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2589 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2590 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2591 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2592 I<Debugger controls:> B<L> List break/watch/actions
2593 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2594 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2595 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2596 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2597 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2598 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2599 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2600 B<q> or B<^D> Quit B<R> Attempt a restart
2601 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2602 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2603 B<p> I<expr> Print expression (uses script's current package).
2604 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2605 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2606 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2607 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2609 # ')}}; # Fix balance of vi % matching
2615 # Restore proper alignment destroyed by eeevil I<> and B<>
2616 # ornaments: A pox on both their houses!
2618 # A help command will have everything up to and including
2619 # the first tab sequence padded into a field 16 (or if indented 20)
2620 # wide. If it's wider than that, an extra space will be added.
2622 ^ # only matters at start of line
2623 ( \040{4} | \t )* # some subcommands are indented
2624 ( < ? # so <CR> works
2625 [BI] < [^\t\n] + ) # find an eeevil ornament
2626 ( \t+ ) # original separation, discarded
2627 ( .* ) # this will now start (no earlier) than
2630 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2631 my $clean = $command;
2632 $clean =~ s/[BI]<([^>]*)>/$1/g;
2633 # replace with this whole string:
2634 ($leadwhite ? " " x 4 : "")
2636 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2641 s{ # handle bold ornaments
2642 B < ( [^>] + | > ) >
2644 $Term::ReadLine::TermCap::rl_term_set[2]
2646 . $Term::ReadLine::TermCap::rl_term_set[3]
2649 s{ # handle italic ornaments
2650 I < ( [^>] + | > ) >
2652 $Term::ReadLine::TermCap::rl_term_set[0]
2654 . $Term::ReadLine::TermCap::rl_term_set[1]
2661 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2662 my $is_less = $pager =~ /\bless\b/;
2663 if ($pager =~ /\bmore\b/) {
2664 my @st_more = stat('/usr/bin/more');
2665 my @st_less = stat('/usr/bin/less');
2666 $is_less = @st_more && @st_less
2667 && $st_more[0] == $st_less[0]
2668 && $st_more[1] == $st_less[1];
2670 # changes environment!
2671 $ENV{LESS} .= 'r' if $is_less;
2677 $SIG{'ABRT'} = 'DEFAULT';
2678 kill 'ABRT', $$ if $panic++;
2679 if (defined &Carp::longmess) {
2680 local $SIG{__WARN__} = '';
2681 local $Carp::CarpLevel = 2; # mydie + confess
2682 &warn(Carp::longmess("Signal @_"));
2685 print $DB::OUT "Got signal @_\n";
2693 local $SIG{__WARN__} = '';
2694 local $SIG{__DIE__} = '';
2695 eval { require Carp } if defined $^S; # If error/warning during compilation,
2696 # require may be broken.
2697 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2698 return unless defined &Carp::longmess;
2699 my ($mysingle,$mytrace) = ($single,$trace);
2700 $single = 0; $trace = 0;
2701 my $mess = Carp::longmess(@_);
2702 ($single,$trace) = ($mysingle,$mytrace);
2709 local $SIG{__DIE__} = '';
2710 local $SIG{__WARN__} = '';
2711 my $i = 0; my $ineval = 0; my $sub;
2712 if ($dieLevel > 2) {
2713 local $SIG{__WARN__} = \&dbwarn;
2714 &warn(@_); # Yell no matter what
2717 if ($dieLevel < 2) {
2718 die @_ if $^S; # in eval propagate
2720 # No need to check $^S, eval is much more robust nowadays
2721 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
2722 # require may be broken.
2724 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2725 unless defined &Carp::longmess;
2727 # We do not want to debug this chunk (automatic disabling works
2728 # inside DB::DB, but not in Carp).
2729 my ($mysingle,$mytrace) = ($single,$trace);
2730 $single = 0; $trace = 0;
2733 package Carp; # Do not include us in the list
2735 $mess = Carp::longmess(@_);
2738 ($single,$trace) = ($mysingle,$mytrace);
2744 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2747 $SIG{__WARN__} = \&DB::dbwarn;
2748 } elsif ($prevwarn) {
2749 $SIG{__WARN__} = $prevwarn;
2757 $prevdie = $SIG{__DIE__} unless $dieLevel;
2760 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2761 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2762 print $OUT "Stack dump during die enabled",
2763 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2765 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2766 } elsif ($prevdie) {
2767 $SIG{__DIE__} = $prevdie;
2768 print $OUT "Default die handler restored.\n";
2776 $prevsegv = $SIG{SEGV} unless $signalLevel;
2777 $prevbus = $SIG{BUS} unless $signalLevel;
2778 $signalLevel = shift;
2780 $SIG{SEGV} = \&DB::diesignal;
2781 $SIG{BUS} = \&DB::diesignal;
2783 $SIG{SEGV} = $prevsegv;
2784 $SIG{BUS} = $prevbus;
2792 my $name = CvGV_name_or_bust($in);
2793 defined $name ? $name : $in;
2796 sub CvGV_name_or_bust {
2798 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2799 return unless ref $in;
2800 $in = \&$in; # Hard reference...
2801 eval {require Devel::Peek; 1} or return;
2802 my $gv = Devel::Peek::CvGV($in) or return;
2803 *$gv{PACKAGE} . '::' . *$gv{NAME};
2809 return unless defined &$subr;
2810 my $name = CvGV_name_or_bust($subr);
2812 $data = $sub{$name} if defined $name;
2813 return $data if defined $data;
2816 $subr = \&$subr; # Hard reference
2819 $s = $_, last if $subr eq \&$_;
2827 $class = ref $class if ref $class;
2830 methods_via($class, '', 1);
2831 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2836 return if $packs{$class}++;
2838 my $prepend = $prefix ? "via $prefix: " : '';
2840 for $name (grep {defined &{${"${class}::"}{$_}}}
2841 sort keys %{"${class}::"}) {
2842 next if $seen{ $name }++;
2843 print $DB::OUT "$prepend$name\n";
2845 return unless shift; # Recurse?
2846 for $name (@{"${class}::ISA"}) {
2847 $prepend = $prefix ? $prefix . " -> $name" : $name;
2848 methods_via($name, $prepend, 1);
2853 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2854 ? "man" # O Happy Day!
2855 : "perldoc"; # Alas, poor unfortunates
2861 &system("$doccmd $doccmd");
2864 # this way user can override, like with $doccmd="man -Mwhatever"
2865 # or even just "man " to disable the path check.
2866 unless ($doccmd eq 'man') {
2867 &system("$doccmd $page");
2871 $page = 'perl' if lc($page) eq 'help';
2874 my $man1dir = $Config::Config{'man1dir'};
2875 my $man3dir = $Config::Config{'man3dir'};
2876 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2878 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2879 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2880 chop $manpath if $manpath;
2881 # harmless if missing, I figure
2882 my $oldpath = $ENV{MANPATH};
2883 $ENV{MANPATH} = $manpath if $manpath;
2884 my $nopathopt = $^O =~ /dunno what goes here/;
2885 if (CORE::system($doccmd,
2886 # I just *know* there are men without -M
2887 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2890 unless ($page =~ /^perl\w/) {
2891 if (grep { $page eq $_ } qw{
2892 5004delta 5005delta amiga api apio book boot bot call compile
2893 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2894 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2895 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2896 modinstall modlib number obj op opentut os2 os390 pod port
2897 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2898 trap unicode var vms win32 xs xstut
2902 CORE::system($doccmd,
2903 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2908 if (defined $oldpath) {
2909 $ENV{MANPATH} = $manpath;
2911 delete $ENV{MANPATH};
2915 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2917 BEGIN { # This does not compile, alas.
2918 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2919 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2923 $deep = 100; # warning if stack gets this deep
2927 $SIG{INT} = \&DB::catch;
2928 # This may be enabled to debug debugger:
2929 #$warnLevel = 1 unless defined $warnLevel;
2930 #$dieLevel = 1 unless defined $dieLevel;
2931 #$signalLevel = 1 unless defined $signalLevel;
2933 $db_stop = 0; # Compiler warning
2935 $level = 0; # Level of recursive debugging
2936 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2937 # Triggers bug (?) in perl is we postpone this until runtime:
2938 @postponed = @stack = (0);
2939 $stack_depth = 0; # Localized $#stack
2944 BEGIN {$^W = $ini_warn;} # Switch warnings back
2946 #use Carp; # This did break, left for debugging
2949 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2950 my($text, $line, $start) = @_;
2951 my ($itext, $search, $prefix, $pack) =
2952 ($text, "^\Q${'package'}::\E([^:]+)\$");
2954 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2955 (map { /$search/ ? ($1) : () } keys %sub)
2956 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2957 return sort grep /^\Q$text/, values %INC # files
2958 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2959 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2960 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2961 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2962 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2964 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2966 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2967 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2968 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2969 # We may want to complete to (eval 9), so $text may be wrong
2970 $prefix = length($1) - length($text);
2973 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2975 if ((substr $text, 0, 1) eq '&') { # subroutines
2976 $text = substr $text, 1;
2978 return sort map "$prefix$_",
2981 (map { /$search/ ? ($1) : () }
2984 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2985 $pack = ($1 eq 'main' ? '' : $1) . '::';
2986 $prefix = (substr $text, 0, 1) . $1 . '::';
2989 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2990 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2991 return db_complete($out[0], $line, $start);
2995 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2996 $pack = ($package eq 'main' ? '' : $package) . '::';
2997 $prefix = substr $text, 0, 1;
2998 $text = substr $text, 1;
2999 my @out = map "$prefix$_", grep /^\Q$text/,
3000 (grep /^_?[a-zA-Z]/, keys %$pack),
3001 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3002 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3003 return db_complete($out[0], $line, $start);
3007 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3008 my @out = grep /^\Q$text/, @options;
3009 my $val = option_val($out[0], undef);
3011 if (not defined $val or $val =~ /[\n\r]/) {
3012 # Can do nothing better
3013 } elsif ($val =~ /\s/) {
3015 foreach $l (split //, qq/\"\'\#\|/) {
3016 $out = "$l$val$l ", last if (index $val, $l) == -1;
3021 # Default to value if one completion, to question if many
3022 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3025 return $term->filename_list($text); # filenames
3029 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3033 if (defined($ini_pids)) {
3034 $ENV{PERLDB_PIDS} = $ini_pids;
3036 delete($ENV{PERLDB_PIDS});
3041 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3042 $fall_off_end = 1 unless $inhibit_exit;
3043 # Do not stop in at_exit() and destructors on exit:
3044 $DB::single = !$fall_off_end && !$runnonstop;
3045 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3051 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3054 package DB; # Do not trace this 1; below!