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 push @flags, '-T' if ${^TAINT};
1248 # Arrange for setting the old INC:
1249 set_list("PERLDB_INC", @ini_INC);
1251 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1252 chomp ($cl = ${'::_<-e'}[$_]);
1253 push @script, '-e', $cl;
1258 set_list("PERLDB_HIST",
1259 $term->Features->{getHistory}
1260 ? $term->GetHistory : @hist);
1261 my @had_breakpoints = keys %had_breakpoints;
1262 set_list("PERLDB_VISITED", @had_breakpoints);
1263 set_list("PERLDB_OPT", %option);
1264 set_list("PERLDB_ON_LOAD", %break_on_load);
1266 for (0 .. $#had_breakpoints) {
1267 my $file = $had_breakpoints[$_];
1268 *dbline = $main::{'_<' . $file};
1269 next unless %dbline or $postponed_file{$file};
1270 (push @hard, $file), next
1271 if $file =~ /^\(\w*eval/;
1273 @add = %{$postponed_file{$file}}
1274 if $postponed_file{$file};
1275 set_list("PERLDB_FILE_$_", %dbline, @add);
1277 for (@hard) { # Yes, really-really...
1278 # Find the subroutines in this eval
1279 *dbline = $main::{'_<' . $_};
1280 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1281 for $sub (keys %sub) {
1282 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1283 $subs{$sub} = [$1, $2];
1287 "No subroutines in $_, ignoring breakpoints.\n";
1290 LINES: for $line (keys %dbline) {
1291 # One breakpoint per sub only:
1292 my ($offset, $sub, $found);
1293 SUBS: for $sub (keys %subs) {
1294 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1295 and (not defined $offset # Not caught
1296 or $offset < 0 )) { # or badly caught
1298 $offset = $line - $subs{$sub}->[0];
1299 $offset = "+$offset", last SUBS if $offset >= 0;
1302 if (defined $offset) {
1303 $postponed{$found} =
1304 "break $offset if $dbline{$line}";
1306 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1310 set_list("PERLDB_POSTPONE", %postponed);
1311 set_list("PERLDB_PRETYPE", @$pretype);
1312 set_list("PERLDB_PRE", @$pre);
1313 set_list("PERLDB_POST", @$post);
1314 set_list("PERLDB_TYPEAHEAD", @typeahead);
1315 $ENV{PERLDB_RESTART} = 1;
1316 delete $ENV{PERLDB_PIDS}; # Restore ini state
1317 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1318 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1319 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1320 print $OUT "exec failed: $!\n";
1322 $cmd =~ /^T$/ && do {
1323 print_trace($OUT, 1); # skip DB
1325 $cmd =~ /^W\s*$/ && do {
1327 @to_watch = @old_watch = ();
1329 $cmd =~ /^W\b\s*(.*)/s && do {
1333 $val = (defined $val) ? "'$val'" : 'undef' ;
1334 push @old_watch, $val;
1337 $cmd =~ /^\/(.*)$/ && do {
1339 $inpat =~ s:([^\\])/$:$1:;
1341 # squelch the sigmangler
1342 local $SIG{__DIE__};
1343 local $SIG{__WARN__};
1344 eval '$inpat =~ m'."\a$inpat\a";
1356 $start = 1 if ($start > $max);
1357 last if ($start == $end);
1358 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1359 if ($slave_editor) {
1360 print $OUT "\032\032$filename:$start:0\n";
1362 print $OUT "$start:\t", $dbline[$start], "\n";
1367 print $OUT "/$pat/: not found\n" if ($start == $end);
1369 $cmd =~ /^\?(.*)$/ && do {
1371 $inpat =~ s:([^\\])\?$:$1:;
1373 # squelch the sigmangler
1374 local $SIG{__DIE__};
1375 local $SIG{__WARN__};
1376 eval '$inpat =~ m'."\a$inpat\a";
1388 $start = $max if ($start <= 0);
1389 last if ($start == $end);
1390 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1391 if ($slave_editor) {
1392 print $OUT "\032\032$filename:$start:0\n";
1394 print $OUT "$start:\t", $dbline[$start], "\n";
1399 print $OUT "?$pat?: not found\n" if ($start == $end);
1401 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1402 pop(@hist) if length($cmd) > 1;
1403 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1405 print $OUT $cmd, "\n";
1407 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1410 $cmd =~ /^$rc([^$rc].*)$/ && do {
1412 pop(@hist) if length($cmd) > 1;
1413 for ($i = $#hist; $i; --$i) {
1414 last if $hist[$i] =~ /$pat/;
1417 print $OUT "No such command!\n\n";
1421 print $OUT $cmd, "\n";
1423 $cmd =~ /^$sh$/ && do {
1424 &system($ENV{SHELL}||"/bin/sh");
1426 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1427 # XXX: using csh or tcsh destroys sigint retvals!
1428 #&system($1); # use this instead
1429 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1431 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1432 $end = $2 ? ($#hist-$2) : 0;
1433 $hist = 0 if $hist < 0;
1434 for ($i=$#hist; $i>$end; $i--) {
1435 print $OUT "$i: ",$hist[$i],"\n"
1436 unless $hist[$i] =~ /^.?$/;
1439 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1442 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1443 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1444 $cmd =~ s/^=\s*// && do {
1446 if (length $cmd == 0) {
1447 @keys = sort keys %alias;
1449 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1450 # can't use $_ or kill //g state
1451 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1452 $alias{$k} = "s\a$k\a$v\a";
1453 # squelch the sigmangler
1454 local $SIG{__DIE__};
1455 local $SIG{__WARN__};
1456 unless (eval "sub { s\a$k\a$v\a }; 1") {
1457 print $OUT "Can't alias $k to $v: $@\n";
1467 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1468 print $OUT "$k\t= $1\n";
1470 elsif (defined $alias{$k}) {
1471 print $OUT "$k\t$alias{$k}\n";
1474 print "No alias for $k\n";
1478 $cmd =~ /^\@\s*(.*\S)/ && do {
1479 if (open my $fh, $1) {
1483 &warn("Can't execute `$1': $!\n");
1486 $cmd =~ /^\|\|?\s*[^|]/ && do {
1487 if ($pager =~ /^\|/) {
1488 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1489 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1491 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1494 unless ($piped=open(OUT,$pager)) {
1495 &warn("Can't pipe output to `$pager'");
1496 if ($pager =~ /^\|/) {
1497 open(OUT,">&STDOUT") # XXX: lost message
1498 || &warn("Can't restore DB::OUT");
1499 open(STDOUT,">&SAVEOUT")
1500 || &warn("Can't restore STDOUT");
1503 open(OUT,">&STDOUT") # XXX: lost message
1504 || &warn("Can't restore DB::OUT");
1508 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1509 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1510 $selected= select(OUT);
1512 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1513 $cmd =~ s/^\|+\s*//;
1516 # XXX Local variants do not work!
1517 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1518 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1519 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1521 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1523 $onetimeDump = undef;
1524 } elsif ($term_pid == $$) {
1529 if ($pager =~ /^\|/) {
1531 # we cannot warn here: the handle is missing --tchrist
1532 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1534 # most of the $? crud was coping with broken cshisms
1536 print SAVEOUT "Pager `$pager' failed: ";
1538 print SAVEOUT "shell returned -1\n";
1541 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1542 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1544 print SAVEOUT "status ", ($? >> 8), "\n";
1548 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1549 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1550 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1551 # Will stop ignoring SIGPIPE if done like nohup(1)
1552 # does SIGINT but Perl doesn't give us a choice.
1554 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1557 select($selected), $selected= "" unless $selected eq "";
1561 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1562 foreach $evalarg (@$post) {
1565 } # if ($single || $signal)
1566 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1570 # The following code may be executed now:
1574 my ($al, $ret, @ret) = "";
1575 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1578 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1579 $#stack = $stack_depth;
1580 $stack[-1] = $single;
1582 $single |= 4 if $stack_depth == $deep;
1584 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1585 # Why -1? But it works! :-(
1586 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1587 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1590 $single |= $stack[$stack_depth--];
1592 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1593 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1594 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1595 if ($doret eq $stack_depth or $frame & 16) {
1596 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1597 print $fh ' ' x $stack_depth if $frame & 16;
1598 print $fh "list context return from $sub:\n";
1599 dumpit($fh, \@ret );
1604 if (defined wantarray) {
1609 $single |= $stack[$stack_depth--];
1611 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1612 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1613 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1614 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1615 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1616 print $fh (' ' x $stack_depth) if $frame & 16;
1617 print $fh (defined wantarray
1618 ? "scalar context return from $sub: "
1619 : "void context return from $sub\n");
1620 dumpit( $fh, $ret ) if defined wantarray;
1629 ### Functions with multiple modes of failure die on error, the rest
1630 ### returns FALSE on error.
1631 ### User-interface functions cmd_* output error message.
1635 $break_on_load{$file} = 1;
1636 $had_breakpoints{$file} |= 1;
1639 sub report_break_on_load {
1640 sort keys %break_on_load;
1648 push @files, $::INC{$file} if $::INC{$file};
1649 $file .= '.pm', redo unless $file =~ /\./;
1651 break_on_load($_) for @files;
1652 @files = report_break_on_load;
1653 print $OUT "Will stop on load of `@files'.\n";
1656 $filename_error = '';
1658 sub breakable_line {
1659 my ($from, $to) = @_;
1662 my $delta = $from < $to ? +1 : -1;
1663 my $limit = $delta > 0 ? $#dbline : 1;
1664 $limit = $to if ($limit - $to) * $delta > 0;
1665 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1667 return $i unless $dbline[$i] == 0;
1668 my ($pl, $upto) = ('', '');
1669 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1670 die "Line$pl $from$upto$filename_error not breakable\n";
1673 sub breakable_line_in_filename {
1675 local *dbline = $main::{'_<' . $f};
1676 local $filename_error = " of `$f'";
1681 my ($i, $cond) = @_;
1682 $cond = 1 unless @_ >= 2;
1686 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1687 $had_breakpoints{$filename} |= 1;
1688 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1689 else { $dbline{$i} = $cond; }
1693 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1696 sub break_on_filename_line {
1697 my ($f, $i, $cond) = @_;
1698 $cond = 1 unless @_ >= 3;
1699 local *dbline = $main::{'_<' . $f};
1700 local $filename_error = " of `$f'";
1701 local $filename = $f;
1702 break_on_line($i, $cond);
1705 sub break_on_filename_line_range {
1706 my ($f, $from, $to, $cond) = @_;
1707 my $i = breakable_line_in_filename($f, $from, $to);
1708 $cond = 1 unless @_ >= 3;
1709 break_on_filename_line($f,$i,$cond);
1712 sub subroutine_filename_lines {
1713 my ($subname,$cond) = @_;
1714 # Filename below can contain ':'
1715 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1718 sub break_subroutine {
1719 my $subname = shift;
1720 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1721 die "Subroutine $subname not found.\n";
1722 $cond = 1 unless @_ >= 2;
1723 break_on_filename_line_range($file,$s,$e,@_);
1727 my ($subname,$cond) = @_;
1728 $cond = 1 unless @_ >= 2;
1729 unless (ref $subname eq 'CODE') {
1730 $subname =~ s/\'/::/g;
1732 $subname = "${'package'}::" . $subname
1733 unless $subname =~ /::/;
1734 $subname = "CORE::GLOBAL::$s"
1735 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1736 $subname = "main".$subname if substr($subname,0,2) eq "::";
1738 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1741 sub cmd_stop { # As on ^C, but not signal-safy.
1745 sub delete_breakpoint {
1747 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1748 $dbline{$i} =~ s/^[^\0]*//;
1749 delete $dbline{$i} if $dbline{$i} eq '';
1754 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1757 ### END of the API section
1760 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1761 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1764 sub print_lineinfo {
1765 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1769 # The following takes its argument via $evalarg to preserve current @_
1772 my $subname = shift;
1773 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1774 my $offset = $1 || 0;
1775 # Filename below can contain ':'
1776 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1779 local *dbline = $main::{'_<' . $file};
1780 local $^W = 0; # != 0 is magical below
1781 $had_breakpoints{$file} |= 1;
1783 ++$i until $dbline[$i] != 0 or $i >= $max;
1784 $dbline{$i} = delete $postponed{$subname};
1786 print $OUT "Subroutine $subname not found.\n";
1790 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1791 #print $OUT "In postponed_sub for `$subname'.\n";
1795 if ($ImmediateStop) {
1799 return &postponed_sub
1800 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1801 # Cannot be done before the file is compiled
1802 local *dbline = shift;
1803 my $filename = $dbline;
1804 $filename =~ s/^_<//;
1805 $signal = 1, print $OUT "'$filename' loaded...\n"
1806 if $break_on_load{$filename};
1807 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1808 return unless $postponed_file{$filename};
1809 $had_breakpoints{$filename} |= 1;
1810 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1812 for $key (keys %{$postponed_file{$filename}}) {
1813 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1815 delete $postponed_file{$filename};
1819 local ($savout) = select(shift);
1820 my $osingle = $single;
1821 my $otrace = $trace;
1822 $single = $trace = 0;
1825 unless (defined &main::dumpValue) {
1828 if (defined &main::dumpValue) {
1829 &main::dumpValue(shift);
1831 print $OUT "dumpvar.pl not available.\n";
1838 # Tied method do not create a context, so may get wrong message:
1842 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1843 my @sub = dump_trace($_[0] + 1, $_[1]);
1844 my $short = $_[2]; # Print short report, next one for sub name
1846 for ($i=0; $i <= $#sub; $i++) {
1849 my $args = defined $sub[$i]{args}
1850 ? "(@{ $sub[$i]{args} })"
1852 $args = (substr $args, 0, $maxtrace - 3) . '...'
1853 if length $args > $maxtrace;
1854 my $file = $sub[$i]{file};
1855 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1857 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1859 my $sub = @_ >= 4 ? $_[3] : $s;
1860 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1862 print $fh "$sub[$i]{context} = $s$args" .
1863 " called from $file" .
1864 " line $sub[$i]{line}\n";
1871 my $count = shift || 1e9;
1874 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1875 my $nothard = not $frame & 8;
1876 local $frame = 0; # Do not want to trace this.
1877 my $otrace = $trace;
1880 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1885 if (not defined $arg) {
1887 } elsif ($nothard and tied $arg) {
1889 } elsif ($nothard and $type = ref $arg) {
1890 push @a, "ref($type)";
1892 local $_ = "$arg"; # Safe to stringify now - should not call f().
1895 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1896 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1897 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1901 $context = $context ? '@' : (defined $context ? "\$" : '.');
1902 $args = $h ? [@a] : undef;
1903 $e =~ s/\n\s*\;\s*\Z// if $e;
1904 $e =~ s/([\\\'])/\\$1/g if $e;
1906 $sub = "require '$e'";
1907 } elsif (defined $r) {
1909 } elsif ($sub eq '(eval)') {
1910 $sub = "eval {...}";
1912 push(@sub, {context => $context, sub => $sub, args => $args,
1913 file => $file, line => $line});
1922 while ($action =~ s/\\$//) {
1931 # i hate using globals!
1932 $balanced_brace_re ||= qr{
1935 (?> [^{}] + ) # Non-parens without backtracking
1937 (??{ $balanced_brace_re }) # Group with matching parens
1941 return $_[0] !~ m/$balanced_brace_re/;
1945 &readline("cont: ");
1949 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1950 # some non-Unix systems can do system() but have problems with fork().
1951 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1952 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1953 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1954 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1956 # XXX: using csh or tcsh destroys sigint retvals!
1958 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1959 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1964 # most of the $? crud was coping with broken cshisms
1966 &warn("(Command exited ", ($? >> 8), ")\n");
1968 &warn( "(Command died of SIG#", ($? & 127),
1969 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1979 eval { require Term::ReadLine } or die $@;
1982 my ($i, $o) = split $tty, /,/;
1983 $o = $i unless defined $o;
1984 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1985 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
1988 my $sel = select($OUT);
1992 eval "require Term::Rendezvous;" or die;
1993 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1994 my $term_rv = new Term::Rendezvous $rv;
1996 $OUT = $term_rv->OUT;
1999 if ($term_pid eq '-1') { # In a TTY with another debugger
2003 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2005 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2007 $rl_attribs = $term->Attribs;
2008 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2009 if defined $rl_attribs->{basic_word_break_characters}
2010 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2011 $rl_attribs->{special_prefixes} = '$@&%';
2012 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2013 $rl_attribs->{completion_function} = \&db_complete;
2015 $LINEINFO = $OUT unless defined $LINEINFO;
2016 $lineinfo = $console unless defined $lineinfo;
2018 if ($term->Features->{setHistory} and "@hist" ne "?") {
2019 $term->SetHistory(@hist);
2021 ornaments($ornaments) if defined $ornaments;
2025 # Example get_fork_TTY functions
2026 sub xterm_get_fork_TTY {
2027 (my $name = $0) =~ s,^.*[/\\],,s;
2028 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2032 $pidprompt = ''; # Shown anyway in titlebar
2036 # This example function resets $IN, $OUT itself
2037 sub os2_get_fork_TTY {
2038 local $^F = 40; # XXXX Fixme!
2039 my ($in1, $out1, $in2, $out2);
2040 # Having -d in PERL5OPT would lead to a disaster...
2041 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2042 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2043 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2044 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2045 (my $name = $0) =~ s,^.*[/\\],,s;
2047 if ( pipe $in1, $out1 and pipe $in2, $out2
2048 # system P_SESSION will fail if there is another process
2049 # in the same session with a "dependent" asynchronous child session.
2050 and @args = ($rl, fileno $in1, fileno $out2,
2051 "Daughter Perl debugger $pids $name") and
2052 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2055 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2057 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2058 open IN, '<&=$in' or die "open <&=$in: \$!";
2059 \$| = 1; print while sysread IN, \$_, 1<<16;
2063 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2065 require Term::ReadKey if $rl;
2066 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2067 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2069 or warn "system P_SESSION: $!, $^E" and 0)
2070 and close $in1 and close $out2 ) {
2071 $pidprompt = ''; # Shown anyway in titlebar
2072 reset_IN_OUT($in2, $out1);
2074 return ''; # Indicate that reset_IN_OUT is called
2079 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2080 my $in = &get_fork_TTY if defined &get_fork_TTY;
2081 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2082 if (not defined $in) {
2084 print_help(<<EOP) if $why == 1;
2085 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2087 print_help(<<EOP) if $why == 2;
2088 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2089 This may be an asynchronous session, so the parent debugger may be active.
2091 print_help(<<EOP) if $why != 4;
2092 Since two debuggers fight for the same TTY, input is severely entangled.
2096 I know how to switch the output to a different window in xterms
2097 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2098 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2100 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2101 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2104 } elsif ($in ne '') {
2107 $console = ''; # Indicate no need to open-from-the-console
2112 sub resetterm { # We forked, so we need a different TTY
2114 my $systemed = $in > 1 ? '-' : '';
2116 $pids =~ s/\]/$systemed->$$]/;
2118 $pids = "[$term_pid->$$]";
2122 return unless $CreateTTY & $in;
2129 my $left = @typeahead;
2130 my $got = shift @typeahead;
2131 print $OUT "auto(-$left)", shift, $got, "\n";
2132 $term->AddHistory($got)
2133 if length($got) > 1 and defined $term->Features->{addHistory};
2139 my $line = CORE::readline($cmdfhs[-1]);
2140 defined $line ? (print $OUT ">> $line" and return $line)
2141 : close pop @cmdfhs;
2143 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2144 $OUT->write(join('', @_));
2146 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2150 $term->readline(@_);
2155 my ($opt, $val)= @_;
2156 $val = option_val($opt,'N/A');
2157 $val =~ s/([\\\'])/\\$1/g;
2158 printf $OUT "%20s = '%s'\n", $opt, $val;
2162 my ($opt, $default)= @_;
2164 if (defined $optionVars{$opt}
2165 and defined ${$optionVars{$opt}}) {
2166 $val = ${$optionVars{$opt}};
2167 } elsif (defined $optionAction{$opt}
2168 and defined &{$optionAction{$opt}}) {
2169 $val = &{$optionAction{$opt}}();
2170 } elsif (defined $optionAction{$opt}
2171 and not defined $option{$opt}
2172 or defined $optionVars{$opt}
2173 and not defined ${$optionVars{$opt}}) {
2176 $val = $option{$opt};
2178 $val = $default unless defined $val;
2184 # too dangerous to let intuitive usage overwrite important things
2185 # defaultion should never be the default
2186 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2187 arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2188 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2193 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2194 my ($opt,$sep) = ($1,$2);
2197 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2199 #&dump_option($opt);
2200 } elsif ($sep !~ /\S/) {
2202 $val = "1"; # this is an evil default; make 'em set it!
2203 } elsif ($sep eq "=") {
2205 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2207 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2211 print OUT qq(Option better cleared using $opt=""\n)
2215 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2216 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2217 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2218 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2219 ($val = $1) =~ s/\\([\\$end])/$1/g;
2223 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2224 || grep( /^\Q$opt/i && ($option = $_), @options );
2226 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2227 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2229 if ($opt_needs_val{$option} && $val_defaulted) {
2230 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2234 $option{$option} = $val if defined $val;
2239 require '$optionRequire{$option}';
2241 } || die # XXX: shouldn't happen
2242 if defined $optionRequire{$option} &&
2245 ${$optionVars{$option}} = $val
2246 if defined $optionVars{$option} &&
2249 &{$optionAction{$option}} ($val)
2250 if defined $optionAction{$option} &&
2251 defined &{$optionAction{$option}} &&
2255 dump_option($option) unless $OUT eq \*STDERR;
2260 my ($stem,@list) = @_;
2262 $ENV{"${stem}_n"} = @list;
2263 for $i (0 .. $#list) {
2265 $val =~ s/\\/\\\\/g;
2266 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2267 $ENV{"${stem}_$i"} = $val;
2274 my $n = delete $ENV{"${stem}_n"};
2276 for $i (0 .. $n - 1) {
2277 $val = delete $ENV{"${stem}_$i"};
2278 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2286 return; # Put nothing on the stack - malloc/free land!
2290 my($msg)= join("",@_);
2291 $msg .= ": $!\n" unless $msg =~ /\n$/;
2296 my $switch_li = $LINEINFO eq $OUT;
2297 if ($term and $term->Features->{newTTY}) {
2298 ($IN, $OUT) = (shift, shift);
2299 $term->newTTY($IN, $OUT);
2301 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2303 ($IN, $OUT) = (shift, shift);
2305 my $o = select $OUT;
2308 $LINEINFO = $OUT if $switch_li;
2312 if (@_ and $term and $term->Features->{newTTY}) {
2313 my ($in, $out) = shift;
2315 ($in, $out) = split /,/, $in, 2;
2319 open IN, $in or die "cannot open `$in' for read: $!";
2320 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2321 reset_IN_OUT(\*IN,\*OUT);
2324 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2325 # Useful if done through PERLDB_OPTS:
2326 $console = $tty = shift if @_;
2332 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2334 $notty = shift if @_;
2340 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2348 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2350 $remoteport = shift if @_;
2355 if (${$term->Features}{tkRunning}) {
2356 return $term->tkRunning(@_);
2358 print $OUT "tkRunning not supported by current ReadLine package.\n";
2365 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2367 $runnonstop = shift if @_;
2374 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2381 $sh = quotemeta shift;
2382 $sh .= "\\b" if $sh =~ /\w$/;
2386 $psh =~ s/\\(.)/$1/g;
2391 if (defined $term) {
2392 local ($warnLevel,$dieLevel) = (0, 1);
2393 return '' unless $term->Features->{ornaments};
2394 eval { $term->ornaments(@_) } || '';
2402 $rc = quotemeta shift;
2403 $rc .= "\\b" if $rc =~ /\w$/;
2407 $prc =~ s/\\(.)/$1/g;
2412 return $lineinfo unless @_;
2414 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2415 $slave_editor = ($stream =~ /^\|/);
2416 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2417 $LINEINFO = \*LINEINFO;
2418 my $save = select($LINEINFO);
2432 s/^Term::ReadLine::readline$/readline/;
2433 if (defined ${ $_ . '::VERSION' }) {
2434 $version{$file} = "${ $_ . '::VERSION' } from ";
2436 $version{$file} .= $INC{$file};
2438 dumpit($OUT,\%version);
2442 # XXX: make sure there are tabs between the command and explanation,
2443 # or print_help will screw up your formatting if you have
2444 # eeevil ornaments enabled. This is an insane mess.
2448 B<s> [I<expr>] Single step [in I<expr>].
2449 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2450 <B<CR>> Repeat last B<n> or B<s> command.
2451 B<r> Return from current subroutine.
2452 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2453 at the specified position.
2454 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2455 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2456 B<l> I<line> List single I<line>.
2457 B<l> I<subname> List first window of lines from subroutine.
2458 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2459 B<l> List next window of lines.
2460 B<-> List previous window of lines.
2461 B<w> [I<line>] List window around I<line>.
2462 B<.> Return to the executed line.
2463 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2464 I<filename> may be either the full name of the file, or a regular
2465 expression matching the full file name:
2466 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2467 Evals (with saved bodies) are considered to be filenames:
2468 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2469 (in the order of execution).
2470 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2471 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2472 B<L> List all breakpoints and actions.
2473 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2474 B<t> Toggle trace mode.
2475 B<t> I<expr> Trace through execution of I<expr>.
2476 B<b> [I<line>] [I<condition>]
2477 Set breakpoint; I<line> defaults to the current execution line;
2478 I<condition> breaks if it evaluates to true, defaults to '1'.
2479 B<b> I<subname> [I<condition>]
2480 Set breakpoint at first line of subroutine.
2481 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2482 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2483 B<b> B<postpone> I<subname> [I<condition>]
2484 Set breakpoint at first line of subroutine after
2486 B<b> B<compile> I<subname>
2487 Stop after the subroutine is compiled.
2488 B<d> [I<line>] Delete the breakpoint for I<line>.
2489 B<D> Delete all breakpoints.
2490 B<a> [I<line>] I<command>
2491 Set an action to be done before the I<line> is executed;
2492 I<line> defaults to the current execution line.
2493 Sequence is: check for breakpoint/watchpoint, print line
2494 if necessary, do action, prompt user if necessary,
2496 B<a> [I<line>] Delete the action for I<line>.
2497 B<A> Delete all actions.
2498 B<W> I<expr> Add a global watch-expression.
2499 B<W> Delete all watch-expressions.
2500 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2501 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2502 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2503 B<x> I<expr> Evals expression in list context, dumps the result.
2504 B<m> I<expr> Evals expression in list context, prints methods callable
2505 on the first element of the result.
2506 B<m> I<class> Prints methods callable via the given class.
2508 B<<> ? List Perl commands to run before each prompt.
2509 B<<> I<expr> Define Perl command to run before each prompt.
2510 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2511 B<>> ? List Perl commands to run after each prompt.
2512 B<>> I<expr> Define Perl command to run after each prompt.
2513 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2514 B<{> I<db_command> Define debugger command to run before each prompt.
2515 B<{> ? List debugger commands to run before each prompt.
2516 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2517 B<$prc> I<number> Redo a previous command (default previous command).
2518 B<$prc> I<-number> Redo number'th-to-last command.
2519 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2520 See 'B<O> I<recallCommand>' too.
2521 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2522 . ( $rc eq $sh ? "" : "
2523 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2524 See 'B<O> I<shellBang>' too.
2525 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2526 B<H> I<-number> Display last number commands (default all).
2527 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2528 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2529 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2530 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2531 I<command> Execute as a perl statement in current package.
2532 B<v> Show versions of loaded modules.
2533 B<R> Pure-man-restart of debugger, some of debugger state
2534 and command-line options may be lost.
2535 Currently the following settings are preserved:
2536 history, breakpoints and actions, debugger B<O>ptions
2537 and the following command-line options: I<-w>, I<-I>, I<-e>.
2539 B<O> [I<opt>] ... Set boolean option to true
2540 B<O> [I<opt>B<?>] Query options
2541 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2542 Set options. Use quotes in spaces in value.
2543 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2544 I<pager> program for output of \"|cmd\";
2545 I<tkRunning> run Tk while prompting (with ReadLine);
2546 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2547 I<inhibit_exit> Allows stepping off the end of the script.
2548 I<ImmediateStop> Debugger should stop as early as possible.
2549 I<RemotePort> Remote hostname:port for remote debugging
2550 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2551 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2552 I<compactDump>, I<veryCompact> change style of array and hash dump;
2553 I<globPrint> whether to print contents of globs;
2554 I<DumpDBFiles> dump arrays holding debugged files;
2555 I<DumpPackages> dump symbol tables of packages;
2556 I<DumpReused> dump contents of \"reused\" addresses;
2557 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2558 I<bareStringify> Do not print the overload-stringified value;
2559 Other options include:
2560 I<PrintRet> affects printing of return value after B<r> command,
2561 I<frame> affects printing messages on subroutine entry/exit.
2562 I<AutoTrace> affects printing messages on possible breaking points.
2563 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2564 I<ornaments> affects screen appearance of the command line.
2565 I<CreateTTY> bits control attempts to create a new TTY on events:
2566 1: on fork() 2: debugger is started inside debugger
2568 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2569 You can put additional initialization options I<TTY>, I<noTTY>,
2570 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2571 `B<R>' after you set them).
2573 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2574 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2575 B<h h> Summary of debugger commands.
2576 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2577 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2578 Set B<\$DB::doccmd> to change viewer.
2580 Type `|h' for a paged display if this was too hard to read.
2582 "; # Fix balance of vi % matching: }}}}
2584 # note: tabs in the following section are not-so-helpful
2585 $summary = <<"END_SUM";
2586 I<List/search source lines:> I<Control script execution:>
2587 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2588 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2589 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2590 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2591 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2592 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2593 I<Debugger controls:> B<L> List break/watch/actions
2594 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2595 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2596 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2597 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2598 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2599 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2600 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2601 B<q> or B<^D> Quit B<R> Attempt a restart
2602 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2603 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2604 B<p> I<expr> Print expression (uses script's current package).
2605 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2606 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2607 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2608 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2610 # ')}}; # Fix balance of vi % matching
2616 # Restore proper alignment destroyed by eeevil I<> and B<>
2617 # ornaments: A pox on both their houses!
2619 # A help command will have everything up to and including
2620 # the first tab sequence padded into a field 16 (or if indented 20)
2621 # wide. If it's wider than that, an extra space will be added.
2623 ^ # only matters at start of line
2624 ( \040{4} | \t )* # some subcommands are indented
2625 ( < ? # so <CR> works
2626 [BI] < [^\t\n] + ) # find an eeevil ornament
2627 ( \t+ ) # original separation, discarded
2628 ( .* ) # this will now start (no earlier) than
2631 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2632 my $clean = $command;
2633 $clean =~ s/[BI]<([^>]*)>/$1/g;
2634 # replace with this whole string:
2635 ($leadwhite ? " " x 4 : "")
2637 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2642 s{ # handle bold ornaments
2643 B < ( [^>] + | > ) >
2645 $Term::ReadLine::TermCap::rl_term_set[2]
2647 . $Term::ReadLine::TermCap::rl_term_set[3]
2650 s{ # handle italic ornaments
2651 I < ( [^>] + | > ) >
2653 $Term::ReadLine::TermCap::rl_term_set[0]
2655 . $Term::ReadLine::TermCap::rl_term_set[1]
2662 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2663 my $is_less = $pager =~ /\bless\b/;
2664 if ($pager =~ /\bmore\b/) {
2665 my @st_more = stat('/usr/bin/more');
2666 my @st_less = stat('/usr/bin/less');
2667 $is_less = @st_more && @st_less
2668 && $st_more[0] == $st_less[0]
2669 && $st_more[1] == $st_less[1];
2671 # changes environment!
2672 $ENV{LESS} .= 'r' if $is_less;
2678 $SIG{'ABRT'} = 'DEFAULT';
2679 kill 'ABRT', $$ if $panic++;
2680 if (defined &Carp::longmess) {
2681 local $SIG{__WARN__} = '';
2682 local $Carp::CarpLevel = 2; # mydie + confess
2683 &warn(Carp::longmess("Signal @_"));
2686 print $DB::OUT "Got signal @_\n";
2694 local $SIG{__WARN__} = '';
2695 local $SIG{__DIE__} = '';
2696 eval { require Carp } if defined $^S; # If error/warning during compilation,
2697 # require may be broken.
2698 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2699 return unless defined &Carp::longmess;
2700 my ($mysingle,$mytrace) = ($single,$trace);
2701 $single = 0; $trace = 0;
2702 my $mess = Carp::longmess(@_);
2703 ($single,$trace) = ($mysingle,$mytrace);
2710 local $SIG{__DIE__} = '';
2711 local $SIG{__WARN__} = '';
2712 my $i = 0; my $ineval = 0; my $sub;
2713 if ($dieLevel > 2) {
2714 local $SIG{__WARN__} = \&dbwarn;
2715 &warn(@_); # Yell no matter what
2718 if ($dieLevel < 2) {
2719 die @_ if $^S; # in eval propagate
2721 # No need to check $^S, eval is much more robust nowadays
2722 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
2723 # require may be broken.
2725 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2726 unless defined &Carp::longmess;
2728 # We do not want to debug this chunk (automatic disabling works
2729 # inside DB::DB, but not in Carp).
2730 my ($mysingle,$mytrace) = ($single,$trace);
2731 $single = 0; $trace = 0;
2734 package Carp; # Do not include us in the list
2736 $mess = Carp::longmess(@_);
2739 ($single,$trace) = ($mysingle,$mytrace);
2745 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2748 $SIG{__WARN__} = \&DB::dbwarn;
2749 } elsif ($prevwarn) {
2750 $SIG{__WARN__} = $prevwarn;
2758 $prevdie = $SIG{__DIE__} unless $dieLevel;
2761 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2762 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2763 print $OUT "Stack dump during die enabled",
2764 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2766 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2767 } elsif ($prevdie) {
2768 $SIG{__DIE__} = $prevdie;
2769 print $OUT "Default die handler restored.\n";
2777 $prevsegv = $SIG{SEGV} unless $signalLevel;
2778 $prevbus = $SIG{BUS} unless $signalLevel;
2779 $signalLevel = shift;
2781 $SIG{SEGV} = \&DB::diesignal;
2782 $SIG{BUS} = \&DB::diesignal;
2784 $SIG{SEGV} = $prevsegv;
2785 $SIG{BUS} = $prevbus;
2793 my $name = CvGV_name_or_bust($in);
2794 defined $name ? $name : $in;
2797 sub CvGV_name_or_bust {
2799 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2800 return unless ref $in;
2801 $in = \&$in; # Hard reference...
2802 eval {require Devel::Peek; 1} or return;
2803 my $gv = Devel::Peek::CvGV($in) or return;
2804 *$gv{PACKAGE} . '::' . *$gv{NAME};
2810 return unless defined &$subr;
2811 my $name = CvGV_name_or_bust($subr);
2813 $data = $sub{$name} if defined $name;
2814 return $data if defined $data;
2817 $subr = \&$subr; # Hard reference
2820 $s = $_, last if $subr eq \&$_;
2828 $class = ref $class if ref $class;
2831 methods_via($class, '', 1);
2832 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2837 return if $packs{$class}++;
2839 my $prepend = $prefix ? "via $prefix: " : '';
2841 for $name (grep {defined &{${"${class}::"}{$_}}}
2842 sort keys %{"${class}::"}) {
2843 next if $seen{ $name }++;
2844 print $DB::OUT "$prepend$name\n";
2846 return unless shift; # Recurse?
2847 for $name (@{"${class}::ISA"}) {
2848 $prepend = $prefix ? $prefix . " -> $name" : $name;
2849 methods_via($name, $prepend, 1);
2854 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2855 ? "man" # O Happy Day!
2856 : "perldoc"; # Alas, poor unfortunates
2862 &system("$doccmd $doccmd");
2865 # this way user can override, like with $doccmd="man -Mwhatever"
2866 # or even just "man " to disable the path check.
2867 unless ($doccmd eq 'man') {
2868 &system("$doccmd $page");
2872 $page = 'perl' if lc($page) eq 'help';
2875 my $man1dir = $Config::Config{'man1dir'};
2876 my $man3dir = $Config::Config{'man3dir'};
2877 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2879 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2880 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2881 chop $manpath if $manpath;
2882 # harmless if missing, I figure
2883 my $oldpath = $ENV{MANPATH};
2884 $ENV{MANPATH} = $manpath if $manpath;
2885 my $nopathopt = $^O =~ /dunno what goes here/;
2886 if (CORE::system($doccmd,
2887 # I just *know* there are men without -M
2888 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2891 unless ($page =~ /^perl\w/) {
2892 if (grep { $page eq $_ } qw{
2893 5004delta 5005delta amiga api apio book boot bot call compile
2894 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2895 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2896 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2897 modinstall modlib number obj op opentut os2 os390 pod port
2898 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2899 trap unicode var vms win32 xs xstut
2903 CORE::system($doccmd,
2904 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2909 if (defined $oldpath) {
2910 $ENV{MANPATH} = $manpath;
2912 delete $ENV{MANPATH};
2916 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2918 BEGIN { # This does not compile, alas.
2919 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2920 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2924 $deep = 100; # warning if stack gets this deep
2928 $SIG{INT} = \&DB::catch;
2929 # This may be enabled to debug debugger:
2930 #$warnLevel = 1 unless defined $warnLevel;
2931 #$dieLevel = 1 unless defined $dieLevel;
2932 #$signalLevel = 1 unless defined $signalLevel;
2934 $db_stop = 0; # Compiler warning
2936 $level = 0; # Level of recursive debugging
2937 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2938 # Triggers bug (?) in perl is we postpone this until runtime:
2939 @postponed = @stack = (0);
2940 $stack_depth = 0; # Localized $#stack
2945 BEGIN {$^W = $ini_warn;} # Switch warnings back
2947 #use Carp; # This did break, left for debugging
2950 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2951 my($text, $line, $start) = @_;
2952 my ($itext, $search, $prefix, $pack) =
2953 ($text, "^\Q${'package'}::\E([^:]+)\$");
2955 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2956 (map { /$search/ ? ($1) : () } keys %sub)
2957 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2958 return sort grep /^\Q$text/, values %INC # files
2959 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2960 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2961 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2962 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2963 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2965 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2967 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2968 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2969 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2970 # We may want to complete to (eval 9), so $text may be wrong
2971 $prefix = length($1) - length($text);
2974 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2976 if ((substr $text, 0, 1) eq '&') { # subroutines
2977 $text = substr $text, 1;
2979 return sort map "$prefix$_",
2982 (map { /$search/ ? ($1) : () }
2985 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2986 $pack = ($1 eq 'main' ? '' : $1) . '::';
2987 $prefix = (substr $text, 0, 1) . $1 . '::';
2990 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2991 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2992 return db_complete($out[0], $line, $start);
2996 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2997 $pack = ($package eq 'main' ? '' : $package) . '::';
2998 $prefix = substr $text, 0, 1;
2999 $text = substr $text, 1;
3000 my @out = map "$prefix$_", grep /^\Q$text/,
3001 (grep /^_?[a-zA-Z]/, keys %$pack),
3002 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3003 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3004 return db_complete($out[0], $line, $start);
3008 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3009 my @out = grep /^\Q$text/, @options;
3010 my $val = option_val($out[0], undef);
3012 if (not defined $val or $val =~ /[\n\r]/) {
3013 # Can do nothing better
3014 } elsif ($val =~ /\s/) {
3016 foreach $l (split //, qq/\"\'\#\|/) {
3017 $out = "$l$val$l ", last if (index $val, $l) == -1;
3022 # Default to value if one completion, to question if many
3023 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3026 return $term->filename_list($text); # filenames
3030 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3034 if (defined($ini_pids)) {
3035 $ENV{PERLDB_PIDS} = $ini_pids;
3037 delete($ENV{PERLDB_PIDS});
3042 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3043 $fall_off_end = 1 unless $inhibit_exit;
3044 # Do not stop in at_exit() and destructors on exit:
3045 $DB::single = !$fall_off_end && !$runnonstop;
3046 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3052 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3055 package DB; # Do not trace this 1; below!