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 if ($onetimeDump eq 'dump') {
27 local $option{dumpDepth} = $onetimedumpDepth
28 if defined $onetimedumpDepth;
30 } elsif ($onetimeDump eq 'methods') {
37 # After this point it is safe to introduce lexicals
38 # However, one should not overdo it: leave as much control from outside as possible
41 $header = "perl5db.pl version $VERSION";
44 # This file is automatically included if you do perl -d.
45 # It's probably not useful to include this yourself.
47 # Before venturing further into these twisty passages, it is
48 # wise to read the perldebguts man page or risk the ire of dragons.
50 # Perl supplies the values for %sub. It effectively inserts
51 # a &DB'DB(); in front of every place that can have a
52 # breakpoint. Instead of a subroutine call it calls &DB::sub with
53 # $DB::sub being the called subroutine. It also inserts a BEGIN
54 # {require 'perl5db.pl'} before the first line.
56 # After each `require'd file is compiled, but before it is executed, a
57 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
58 # $filename is the expanded name of the `require'd file (as found as
61 # Additional services from Perl interpreter:
63 # if caller() is called from the package DB, it provides some
66 # The array @{$main::{'_<'.$filename}} (herein called @dbline) is the
67 # line-by-line contents of $filename.
69 # The hash %{'_<'.$filename} (herein called %dbline) contains
70 # breakpoints and action (it is keyed by line number), and individual
71 # entries are settable (as opposed to the whole hash). Only true/false
72 # is important to the interpreter, though the values used by
73 # perl5db.pl have the form "$break_condition\0$action". Values are
74 # magical in numeric context.
76 # The scalar ${'_<'.$filename} contains $filename.
78 # Note that no subroutine call is possible until &DB::sub is defined
79 # (for subroutines defined outside of the package DB). In fact the same is
80 # true if $deep is not defined.
85 # At start reads $rcfile that may set important options. This file
86 # may define a subroutine &afterinit that will be executed after the
87 # debugger is initialized.
89 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
90 # it as a rest of `O ...' line in debugger prompt.
92 # The options that can be specified only at startup:
93 # [To set in $rcfile, call &parse_options("optionName=new_value").]
95 # TTY - the TTY to use for debugging i/o.
97 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
98 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
99 # Term::Rendezvous. Current variant is to have the name of TTY in this
102 # ReadLine - If false, dummy ReadLine is used, so you can debug
103 # ReadLine applications.
105 # NonStop - if true, no i/o is performed until interrupt.
107 # LineInfo - file or pipe to print line number info to. If it is a
108 # pipe, a short "emacs like" message is used.
110 # RemotePort - host:port to connect to on remote host for remote debugging.
112 # Example $rcfile: (delete leading hashes!)
114 # &parse_options("NonStop=1 LineInfo=db.out");
115 # sub afterinit { $trace = 1; }
117 # The script will run without human intervention, putting trace
118 # information into db.out. (If you interrupt it, you would better
119 # reset LineInfo to something "interactive"!)
121 ##################################################################
123 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
125 # modified Perl debugger, to be run from Emacs in perldb-mode
126 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
127 # Johan Vromans -- upgrade to 4.0 pl 10
128 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
132 # A lot of things changed after 0.94. First of all, core now informs
133 # debugger about entry into XSUBs, overloaded operators, tied operations,
134 # BEGIN and END. Handy with `O f=2'.
136 # This can make debugger a little bit too verbose, please be patient
137 # and report your problems promptly.
139 # Now the option frame has 3 values: 0,1,2.
141 # Note that if DESTROY returns a reference to the object (or object),
142 # the deletion of data may be postponed until the next function call,
143 # due to the need to examine the return value.
145 # Changes: 0.95: `v' command shows versions.
146 # Changes: 0.96: `v' command shows version of readline.
147 # primitive completion works (dynamic variables, subs for `b' and `l',
148 # options). Can `p %var'
149 # Better help (`h <' now works). New commands <<, >>, {, {{.
150 # {dump|print}_trace() coded (to be able to do it from <<cmd).
151 # `c sub' documented.
152 # At last enough magic combined to stop after the end of debuggee.
153 # !! should work now (thanks to Emacs bracket matching an extra
154 # `]' in a regexp is caught).
155 # `L', `D' and `A' span files now (as documented).
156 # Breakpoints in `require'd code are possible (used in `R').
157 # Some additional words on internal work of debugger.
158 # `b load filename' implemented.
159 # `b postpone subr' implemented.
160 # now only `q' exits debugger (overwritable on $inhibit_exit).
161 # When restarting debugger breakpoints/actions persist.
162 # Buglet: When restarting debugger only one breakpoint/action per
163 # autoloaded function persists.
164 # Changes: 0.97: NonStop will not stop in at_exit().
165 # Option AutoTrace implemented.
166 # Trace printed differently if frames are printed too.
167 # new `inhibitExit' option.
168 # printing of a very long statement interruptible.
169 # Changes: 0.98: New command `m' for printing possible methods
170 # 'l -' is a synonym for `-'.
171 # Cosmetic bugs in printing stack trace.
172 # `frame' & 8 to print "expanded args" in stack trace.
173 # Can list/break in imported subs.
174 # new `maxTraceLen' option.
175 # frame & 4 and frame & 8 granted.
177 # nonstoppable lines do not have `:' near the line number.
178 # `b compile subname' implemented.
179 # Will not use $` any more.
180 # `-' behaves sane now.
181 # Changes: 0.99: Completion for `f', `m'.
182 # `m' will remove duplicate names instead of duplicate functions.
183 # `b load' strips trailing whitespace.
184 # completion ignores leading `|'; takes into account current package
185 # when completing a subroutine name (same for `l').
186 # Changes: 1.07: Many fixed by tchrist 13-March-2000
188 # + Added bare minimal security checks on perldb rc files, plus
189 # comments on what else is needed.
190 # + Fixed the ornaments that made "|h" completely unusable.
191 # They are not used in print_help if they will hurt. Strip pod
192 # if we're paging to less.
193 # + Fixed mis-formatting of help messages caused by ornaments
194 # to restore Larry's original formatting.
195 # + Fixed many other formatting errors. The code is still suboptimal,
196 # and needs a lot of work at restructuring. It's also misindented
198 # + Fixed bug where trying to look at an option like your pager
200 # + Fixed some $? processing. Note: if you use csh or tcsh, you will
201 # lose. You should consider shell escapes not using their shell,
202 # or else not caring about detailed status. This should really be
203 # unified into one place, too.
204 # + Fixed bug where invisible trailing whitespace on commands hoses you,
205 # tricking Perl into thinking you weren't calling a debugger command!
206 # + Fixed bug where leading whitespace on commands hoses you. (One
207 # suggests a leading semicolon or any other irrelevant non-whitespace
208 # to indicate literal Perl code.)
209 # + Fixed bugs that ate warnings due to wrong selected handle.
210 # + Fixed a precedence bug on signal stuff.
211 # + Fixed some unseemly wording.
212 # + Fixed bug in help command trying to call perl method code.
213 # + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
215 # + Added some comments. This code is still nasty spaghetti.
216 # + Added message if you clear your pre/post command stacks which was
217 # very easy to do if you just typed a bare >, <, or {. (A command
218 # without an argument should *never* be a destructive action; this
219 # API is fundamentally screwed up; likewise option setting, which
220 # is equally buggered.)
221 # + Added command stack dump on argument of "?" for >, <, or {.
222 # + Added a semi-built-in doc viewer command that calls man with the
223 # proper %Config::Config path (and thus gets caching, man -k, etc),
224 # or else perldoc on obstreperous platforms.
225 # + Added to and rearranged the help information.
226 # + Detected apparent misuse of { ... } to declare a block; this used
227 # to work but now is a command, and mysteriously gave no complaint.
229 # Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
231 # + This patch to perl5db.pl cleans up formatting issues on the help
232 # summary (h h) screen in the debugger. Mostly columnar alignment
233 # issues, plus converted the printed text to use all spaces, since
234 # tabs don't seem to help much here.
236 # Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
237 # 0) Minor bugs corrected;
238 # a) Support for auto-creation of new TTY window on startup, either
239 # unconditionally, or if started as a kid of another debugger session;
240 # b) New `O'ption CreateTTY
241 # I<CreateTTY> bits control attempts to create a new TTY on events:
242 # 1: on fork() 2: debugger is started inside debugger
244 # c) Code to auto-create a new TTY window on OS/2 (currently one
245 # extra window per session - need named pipes to have more...);
246 # d) Simplified interface for custom createTTY functions (with a backward
247 # compatibility hack); now returns the TTY name to use; return of ''
248 # means that the function reset the I/O handles itself;
249 # d') Better message on the semantic of custom createTTY function;
250 # e) Convert the existing code to create a TTY into a custom createTTY
252 # f) Consistent support for TTY names of the form "TTYin,TTYout";
253 # g) Switch line-tracing output too to the created TTY window;
254 # h) make `b fork' DWIM with CORE::GLOBAL::fork;
255 # i) High-level debugger API cmd_*():
256 # cmd_b_load($filenamepart) # b load filenamepart
257 # cmd_b_line($lineno [, $cond]) # b lineno [cond]
258 # cmd_b_sub($sub [, $cond]) # b sub [cond]
259 # cmd_stop() # Control-C
260 # cmd_d($lineno) # d lineno
261 # The cmd_*() API returns FALSE on failure; in this case it outputs
262 # the error message to the debugging output.
263 # j) Low-level debugger API
264 # break_on_load($filename) # b load filename
265 # @files = report_break_on_load() # List files with load-breakpoints
266 # breakable_line_in_filename($name, $from [, $to])
267 # # First breakable line in the
268 # # range $from .. $to. $to defaults
269 # # to $from, and may be less than $to
270 # breakable_line($from [, $to]) # Same for the current file
271 # break_on_filename_line($name, $lineno [, $cond])
272 # # Set breakpoint,$cond defaults to 1
273 # break_on_filename_line_range($name, $from, $to [, $cond])
274 # # As above, on the first
275 # # breakable line in range
276 # break_on_line($lineno [, $cond]) # As above, in the current file
277 # break_subroutine($sub [, $cond]) # break on the first breakable line
278 # ($name, $from, $to) = subroutine_filename_lines($sub)
279 # # The range of lines of the text
280 # The low-level API returns TRUE on success, and die()s on failure.
282 # Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
284 # + Fixed warnings generated by "perl -dWe 42"
285 # + Corrected spelling errors
286 # + Squeezed Help (h) output into 80 columns
288 # Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
289 # + Made "x @INC" work like it used to
291 # Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
292 # + Fixed warnings generated by "O" (Show debugger options)
293 # + Fixed warnings generated by "p 42" (Print expression)
294 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
295 # + Added windowSize option
296 # Changes: 1.14: Oct 9, 2001 multiple
297 # + Clean up after itself on VMS (Charles Lane in 12385)
298 # + Adding "@ file" syntax (Peter Scott in 12014)
299 # + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
300 # + $^S and other debugger fixes (Ilya Zakharevich in 11120)
301 # + Forgot a my() declaration (Ilya Zakharevich in 11085)
302 # Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern@pobox.com>
303 # + Updated 1.14 change log
304 # + Added *dbline explainatory comments
305 # + Mentioning perldebguts man page
306 ####################################################################
308 # Needed for the statement after exec():
310 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
311 local($^W) = 0; # Switch run-time warnings off during init.
314 $dumpvar::arrayDepth,
315 $dumpvar::dumpDBFiles,
316 $dumpvar::dumpPackages,
317 $dumpvar::quoteHighBit,
318 $dumpvar::printUndef,
327 # Command-line + PERLLIB:
330 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
332 $trace = $signal = $single = 0; # Uninitialized warning suppression
333 # (local $^W cannot help - other packages!).
334 $inhibit_exit = $option{PrintRet} = 1;
336 @options = qw(hashDepth arrayDepth dumpDepth
337 DumpDBFiles DumpPackages DumpReused
338 compactDump veryCompact quote HighBit undefPrint
339 globPrint PrintRet UsageOnly frame AutoTrace
340 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
341 recallCommand ShellBang pager tkRunning ornaments
342 signalLevel warnLevel dieLevel inhibit_exit
343 ImmediateStop bareStringify CreateTTY
344 RemotePort windowSize);
347 hashDepth => \$dumpvar::hashDepth,
348 arrayDepth => \$dumpvar::arrayDepth,
349 DumpDBFiles => \$dumpvar::dumpDBFiles,
350 DumpPackages => \$dumpvar::dumpPackages,
351 DumpReused => \$dumpvar::dumpReused,
352 HighBit => \$dumpvar::quoteHighBit,
353 undefPrint => \$dumpvar::printUndef,
354 globPrint => \$dumpvar::globPrint,
355 UsageOnly => \$dumpvar::usageOnly,
356 CreateTTY => \$CreateTTY,
357 bareStringify => \$dumpvar::bareStringify,
359 AutoTrace => \$trace,
360 inhibit_exit => \$inhibit_exit,
361 maxTraceLen => \$maxtrace,
362 ImmediateStop => \$ImmediateStop,
363 RemotePort => \$remoteport,
364 windowSize => \$window,
368 compactDump => \&dumpvar::compactDump,
369 veryCompact => \&dumpvar::veryCompact,
370 quote => \&dumpvar::quote,
373 ReadLine => \&ReadLine,
374 NonStop => \&NonStop,
375 LineInfo => \&LineInfo,
376 recallCommand => \&recallCommand,
377 ShellBang => \&shellBang,
379 signalLevel => \&signalLevel,
380 warnLevel => \&warnLevel,
381 dieLevel => \&dieLevel,
382 tkRunning => \&tkRunning,
383 ornaments => \&ornaments,
384 RemotePort => \&RemotePort,
388 compactDump => 'dumpvar.pl',
389 veryCompact => 'dumpvar.pl',
390 quote => 'dumpvar.pl',
393 # These guys may be defined in $ENV{PERL5DB} :
394 $rl = 1 unless defined $rl;
395 $warnLevel = 1 unless defined $warnLevel;
396 $dieLevel = 1 unless defined $dieLevel;
397 $signalLevel = 1 unless defined $signalLevel;
398 $pre = [] unless defined $pre;
399 $post = [] unless defined $post;
400 $pretype = [] unless defined $pretype;
401 $CreateTTY = 3 unless defined $CreateTTY;
403 warnLevel($warnLevel);
405 signalLevel($signalLevel);
408 defined $ENV{PAGER} ? $ENV{PAGER} :
409 eval { require Config } &&
410 defined $Config::Config{pager} ? $Config::Config{pager}
412 ) unless defined $pager;
414 &recallCommand("!") unless defined $prc;
415 &shellBang("!") unless defined $psh;
417 $maxtrace = 400 unless defined $maxtrace;
418 $ini_pids = $ENV{PERLDB_PIDS};
419 if (defined $ENV{PERLDB_PIDS}) {
420 $pids = "[$ENV{PERLDB_PIDS}]";
421 $ENV{PERLDB_PIDS} .= "->$$";
424 $ENV{PERLDB_PIDS} = "$$";
429 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
431 if (-e "/dev/tty") { # this is the wrong metric!
434 $rcfile="perldb.ini";
437 # This isn't really safe, because there's a race
438 # between checking and opening. The solution is to
439 # open and fstat the handle, but then you have to read and
440 # eval the contents. But then the silly thing gets
441 # your lexical scope, which is unfortunately at best.
445 # Just exactly what part of the word "CORE::" don't you understand?
446 local $SIG{__WARN__};
449 unless (is_safe_file($file)) {
450 CORE::warn <<EO_GRIPE;
451 perldb: Must not source insecure rcfile $file.
452 You or the superuser must be the owner, and it must not
453 be writable by anyone but its owner.
459 CORE::warn("perldb: couldn't parse $file: $@") if $@;
463 # Verifies that owner is either real user or superuser and that no
464 # one but owner may write to it. This function is of limited use
465 # when called on a path instead of upon a handle, because there are
466 # no guarantees that filename (by dirent) whose file (by ino) is
467 # eventually accessed is the same as the one tested.
468 # Assumes that the file's existence is not in doubt.
471 stat($path) || return; # mysteriously vaporized
472 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
474 return 0 if $uid != 0 && $uid != $<;
475 return 0 if $mode & 022;
480 safe_do("./$rcfile");
482 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
483 safe_do("$ENV{HOME}/$rcfile");
485 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
486 safe_do("$ENV{LOGDIR}/$rcfile");
489 if (defined $ENV{PERLDB_OPTS}) {
490 parse_options($ENV{PERLDB_OPTS});
493 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
494 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
495 *get_fork_TTY = \&xterm_get_fork_TTY;
496 } elsif ($^O eq 'os2') {
497 *get_fork_TTY = \&os2_get_fork_TTY;
500 # Here begin the unreadable code. It needs fixing.
502 if (exists $ENV{PERLDB_RESTART}) {
503 delete $ENV{PERLDB_RESTART};
505 @hist = get_list('PERLDB_HIST');
506 %break_on_load = get_list("PERLDB_ON_LOAD");
507 %postponed = get_list("PERLDB_POSTPONE");
508 my @had_breakpoints= get_list("PERLDB_VISITED");
509 for (0 .. $#had_breakpoints) {
510 my %pf = get_list("PERLDB_FILE_$_");
511 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
513 my %opt = get_list("PERLDB_OPT");
515 while (($opt,$val) = each %opt) {
516 $val =~ s/[\\\']/\\$1/g;
517 parse_options("$opt'$val'");
519 @INC = get_list("PERLDB_INC");
521 $pretype = [get_list("PERLDB_PRETYPE")];
522 $pre = [get_list("PERLDB_PRE")];
523 $post = [get_list("PERLDB_POST")];
524 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
530 # Is Perl being run from a slave editor or graphical debugger?
531 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
532 $rl = 0, shift(@main::ARGV) if $slave_editor;
534 #require Term::ReadLine;
536 if ($^O eq 'cygwin') {
537 # /dev/tty is binary. use stdin for textmode
539 } elsif (-e "/dev/tty") {
540 $console = "/dev/tty";
541 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
543 } elsif ($^O eq 'MacOS') {
544 if ($MacPerl::Version !~ /MPW/) {
545 $console = "Dev:Console:Perl Debug"; # Separate window for application
547 $console = "Dev:Console";
550 $console = "sys\$command";
553 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
557 if ($^O eq 'NetWare') {
562 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
570 $console = $tty if defined $tty;
572 if (defined $remoteport) {
574 $OUT = new IO::Socket::INET( Timeout => '10',
575 PeerAddr => $remoteport,
578 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
581 create_IN_OUT(4) if $CreateTTY & 4;
583 my ($i, $o) = split /,/, $console;
584 $o = $i unless defined $o;
585 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
586 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
587 || open(OUT,">&STDOUT"); # so we don't dongle stdout
588 } elsif (not defined $console) {
590 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
591 $console = 'STDIN/OUT';
593 # so open("|more") can read from STDOUT and so we don't dingle stdin
594 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
596 my $previous = select($OUT);
597 $| = 1; # for DB::OUT
600 $LINEINFO = $OUT unless defined $LINEINFO;
601 $lineinfo = $console unless defined $lineinfo;
603 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
604 unless ($runnonstop) {
605 if ($term_pid eq '-1') {
606 print $OUT "\nDaughter DB session started...\n";
608 print $OUT "\nLoading DB routines from $header\n";
609 print $OUT ("Editor support ",
610 $slave_editor ? "enabled" : "available",
612 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
620 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
623 if (defined &afterinit) { # May be defined in $rcfile
629 ############################################################ Subroutines
632 # _After_ the perl program is compiled, $single is set to 1:
633 if ($single and not $second_time++) {
634 if ($runnonstop) { # Disable until signal
635 for ($i=0; $i <= $stack_depth; ) {
639 # return; # Would not print trace!
640 } elsif ($ImmediateStop) {
645 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
647 ($package, $filename, $line) = caller;
648 $filename_ini = $filename;
649 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
650 "package $package;"; # this won't let them modify, alas
651 local(*dbline) = $main::{'_<' . $filename};
653 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
657 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
658 $dbline{$line} =~ s/;9($|\0)/$1/;
661 my $was_signal = $signal;
663 for (my $n = 0; $n <= $#to_watch; $n++) {
664 $evalarg = $to_watch[$n];
665 local $onetimeDump; # Do not output results
666 my ($val) = &eval; # Fix context (&eval is doing array)?
667 $val = ( (defined $val) ? "'$val'" : 'undef' );
668 if ($val ne $old_watch[$n]) {
671 Watchpoint $n:\t$to_watch[$n] changed:
672 old value:\t$old_watch[$n]
675 $old_watch[$n] = $val;
679 if ($trace & 4) { # User-installed watch
680 return if watchfunction($package, $filename, $line)
681 and not $single and not $was_signal and not ($trace & ~4);
683 $was_signal = $signal;
685 if ($single || ($trace & 1) || $was_signal) {
687 $position = "\032\032$filename:$line:0\n";
688 print_lineinfo($position);
689 } elsif ($package eq 'DB::fake') {
692 Debugged program terminated. Use B<q> to quit or B<R> to restart,
693 use B<O> I<inhibit_exit> to avoid stopping after program termination,
694 B<h q>, B<h R> or B<h O> to get additional info.
697 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
698 "package $package;"; # this won't let them modify, alas
701 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
702 $prefix .= "$sub($filename:";
703 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
704 if (length($prefix) > 30) {
705 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
710 $position = "$prefix$line$infix$dbline[$line]$after";
713 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
715 print_lineinfo($position);
717 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
718 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
720 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
721 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
722 $position .= $incr_pos;
724 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
726 print_lineinfo($incr_pos);
731 $evalarg = $action, &eval if $action;
732 if ($single || $was_signal) {
733 local $level = $level + 1;
734 foreach $evalarg (@$pre) {
737 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
740 $incr = -1; # for backward motion.
741 @typeahead = (@$pretype, @typeahead);
743 while (($term || &setterm),
744 ($term_pid == $$ or resetterm(1)),
745 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
746 ($#hist+1) . ('>' x $level) .
751 $cmd =~ s/\\$/\n/ && do {
752 $cmd .= &readline(" cont: ");
755 $cmd =~ /^$/ && ($cmd = $laststep);
756 push(@hist,$cmd) if length($cmd) > 1;
758 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
759 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
760 ($i) = split(/\s+/,$cmd);
762 # squelch the sigmangler
764 local $SIG{__WARN__};
765 eval "\$cmd =~ $alias{$i}";
767 print $OUT "Couldn't evaluate `$i' alias: $@";
771 $cmd =~ /^q$/ && ($fall_off_end = 1) && clean_ENV() && exit $?;
772 $cmd =~ /^h$/ && do {
775 $cmd =~ /^h\s+h$/ && do {
776 print_help($summary);
778 # support long commands; otherwise bogus errors
779 # happen when you ask for h on <CR> for example
780 $cmd =~ /^h\s+(\S.*)$/ && do {
781 my $asked = $1; # for proper errmsg
782 my $qasked = quotemeta($asked); # for searching
783 # XXX: finds CR but not <CR>
784 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
785 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
789 print_help("B<$asked> is not a debugger command.\n");
792 $cmd =~ /^t$/ && do {
794 print $OUT "Trace = " .
795 (($trace & 1) ? "on" : "off" ) . "\n";
797 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
798 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
799 foreach $subname (sort(keys %sub)) {
800 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
801 print $OUT $subname,"\n";
805 $cmd =~ /^v$/ && do {
806 list_versions(); next CMD};
807 $cmd =~ s/^X\b/V $package/;
808 $cmd =~ /^V$/ && do {
809 $cmd = "V $package"; };
810 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
811 local ($savout) = select($OUT);
813 @vars = split(' ',$2);
814 do 'dumpvar.pl' unless defined &main::dumpvar;
815 if (defined &main::dumpvar) {
818 # must detect sigpipe failures
819 eval { &main::dumpvar($packname,@vars) };
821 die unless $@ =~ /dumpvar print failed/;
824 print $OUT "dumpvar.pl not available.\n";
828 $cmd =~ s/^x\b/ / && do { # So that will be evaled
829 $onetimeDump = 'dump';
830 # handle special "x 3 blah" syntax
831 if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
832 $onetimedumpDepth = $1;
835 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
836 methods($1); next CMD};
837 $cmd =~ s/^m\b/ / && do { # So this will be evaled
838 $onetimeDump = 'methods'; };
839 $cmd =~ /^f\b\s*(.*)/ && do {
843 print $OUT "The old f command is now the r command.\n";
844 print $OUT "The new f command switches filenames.\n";
847 if (!defined $main::{'_<' . $file}) {
848 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
849 $try = substr($try,2);
850 print $OUT "Choosing $try matching `$file':\n";
854 if (!defined $main::{'_<' . $file}) {
855 print $OUT "No file matching `$file' is loaded.\n";
857 } elsif ($file ne $filename) {
858 *dbline = $main::{'_<' . $file};
864 print $OUT "Already in $file.\n";
868 $cmd =~ s/^l\s+-\s*$/-/;
869 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
872 print($OUT "Error: $@\n"), next CMD if $@;
874 print($OUT "Interpreted as: $1 $s\n");
877 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
878 my $s = $subname = $1;
879 $subname =~ s/\'/::/;
880 $subname = $package."::".$subname
881 unless $subname =~ /::/;
882 $subname = "CORE::GLOBAL::$s"
883 if not defined &$subname and $s !~ /::/
884 and defined &{"CORE::GLOBAL::$s"};
885 $subname = "main".$subname if substr($subname,0,2) eq "::";
886 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
887 $subrange = pop @pieces;
888 $file = join(':', @pieces);
889 if ($file ne $filename) {
890 print $OUT "Switching to file '$file'.\n"
891 unless $slave_editor;
892 *dbline = $main::{'_<' . $file};
897 if (eval($subrange) < -$window) {
898 $subrange =~ s/-.*/+/;
900 $cmd = "l $subrange";
902 print $OUT "Subroutine $subname not found.\n";
905 $cmd =~ /^\.$/ && do {
906 $incr = -1; # for backward motion.
908 $filename = $filename_ini;
909 *dbline = $main::{'_<' . $filename};
911 print_lineinfo($position);
913 $cmd =~ /^w\b\s*(\d*)$/ && do {
917 #print $OUT 'l ' . $start . '-' . ($start + $incr);
918 $cmd = 'l ' . $start . '-' . ($start + $incr); };
919 $cmd =~ /^-$/ && do {
920 $start -= $incr + $window + 1;
921 $start = 1 if $start <= 0;
923 $cmd = 'l ' . ($start) . '+'; };
924 $cmd =~ /^l$/ && do {
926 $cmd = 'l ' . $start . '-' . ($start + $incr); };
927 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
930 $incr = $window - 1 unless $incr;
931 $cmd = 'l ' . $start . '-' . ($start + $incr); };
932 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
933 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
934 $end = $max if $end > $max;
936 $i = $line if $i eq '.';
940 print $OUT "\032\032$filename:$i:0\n";
943 for (; $i <= $end; $i++) {
945 ($stop,$action) = split(/\0/, $dbline{$i}) if
948 and $filename eq $filename_ini)
950 : ($dbline[$i]+0 ? ':' : ' ') ;
951 $arrow .= 'b' if $stop;
952 $arrow .= 'a' if $action;
953 print $OUT "$i$arrow\t", $dbline[$i];
954 $i++, last if $signal;
956 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
958 $start = $i; # remember in case they want more
959 $start = $max if $start > $max;
961 $cmd =~ /^D$/ && do {
962 print $OUT "Deleting all breakpoints...\n";
964 for $file (keys %had_breakpoints) {
965 local *dbline = $main::{'_<' . $file};
969 for ($i = 1; $i <= $max ; $i++) {
970 if (defined $dbline{$i}) {
971 $dbline{$i} =~ s/^[^\0]+//;
972 if ($dbline{$i} =~ s/^\0?$//) {
978 if (not $had_breakpoints{$file} &= ~1) {
979 delete $had_breakpoints{$file};
983 undef %postponed_file;
984 undef %break_on_load;
986 $cmd =~ /^L$/ && do {
988 for $file (keys %had_breakpoints) {
989 local *dbline = $main::{'_<' . $file};
993 for ($i = 1; $i <= $max; $i++) {
994 if (defined $dbline{$i}) {
995 print $OUT "$file:\n" unless $was++;
996 print $OUT " $i:\t", $dbline[$i];
997 ($stop,$action) = split(/\0/, $dbline{$i});
998 print $OUT " break if (", $stop, ")\n"
1000 print $OUT " action: ", $action, "\n"
1007 print $OUT "Postponed breakpoints in subroutines:\n";
1009 for $subname (keys %postponed) {
1010 print $OUT " $subname\t$postponed{$subname}\n";
1014 my @have = map { # Combined keys
1015 keys %{$postponed_file{$_}}
1016 } keys %postponed_file;
1018 print $OUT "Postponed breakpoints in files:\n";
1020 for $file (keys %postponed_file) {
1021 my $db = $postponed_file{$file};
1022 print $OUT " $file:\n";
1023 for $line (sort {$a <=> $b} keys %$db) {
1024 print $OUT " $line:\n";
1025 my ($stop,$action) = split(/\0/, $$db{$line});
1026 print $OUT " break if (", $stop, ")\n"
1028 print $OUT " action: ", $action, "\n"
1035 if (%break_on_load) {
1036 print $OUT "Breakpoints on load:\n";
1038 for $file (keys %break_on_load) {
1039 print $OUT " $file\n";
1044 print $OUT "Watch-expressions:\n";
1046 for $expr (@to_watch) {
1047 print $OUT " $expr\n";
1052 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
1053 my $file = $1; $file =~ s/\s+$//;
1056 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
1057 my $cond = length $3 ? $3 : '1';
1058 my ($subname, $break) = ($2, $1 eq 'postpone');
1059 $subname =~ s/\'/::/g;
1060 $subname = "${'package'}::" . $subname
1061 unless $subname =~ /::/;
1062 $subname = "main".$subname if substr($subname,0,2) eq "::";
1063 $postponed{$subname} = $break
1064 ? "break +0 if $cond" : "compile";
1066 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
1068 $cond = length $2 ? $2 : '1';
1069 cmd_b_sub($subname, $cond);
1071 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
1073 $cond = length $2 ? $2 : '1';
1074 cmd_b_line($i, $cond);
1076 $cmd =~ /^d\b\s*(\d*)/ && do {
1079 $cmd =~ /^A$/ && do {
1080 print $OUT "Deleting all actions...\n";
1082 for $file (keys %had_breakpoints) {
1083 local *dbline = $main::{'_<' . $file};
1087 for ($i = 1; $i <= $max ; $i++) {
1088 if (defined $dbline{$i}) {
1089 $dbline{$i} =~ s/\0[^\0]*//;
1090 delete $dbline{$i} if $dbline{$i} eq '';
1094 unless ($had_breakpoints{$file} &= ~2) {
1095 delete $had_breakpoints{$file};
1099 $cmd =~ /^O\s*$/ && do {
1104 $cmd =~ /^O\s*(\S.*)/ && do {
1107 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1108 push @$pre, action($1);
1110 $cmd =~ /^>>\s*(.*)/ && do {
1111 push @$post, action($1);
1113 $cmd =~ /^<\s*(.*)/ && do {
1115 print $OUT "All < actions cleared.\n";
1121 print $OUT "No pre-prompt Perl actions.\n";
1124 print $OUT "Perl commands run before each prompt:\n";
1125 for my $action ( @$pre ) {
1126 print $OUT "\t< -- $action\n";
1130 $pre = [action($1)];
1132 $cmd =~ /^>\s*(.*)/ && do {
1134 print $OUT "All > actions cleared.\n";
1140 print $OUT "No post-prompt Perl actions.\n";
1143 print $OUT "Perl commands run after each prompt:\n";
1144 for my $action ( @$post ) {
1145 print $OUT "\t> -- $action\n";
1149 $post = [action($1)];
1151 $cmd =~ /^\{\{\s*(.*)/ && do {
1152 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1153 print $OUT "{{ is now a debugger command\n",
1154 "use `;{{' if you mean Perl code\n";
1160 $cmd =~ /^\{\s*(.*)/ && do {
1162 print $OUT "All { actions cleared.\n";
1167 unless (@$pretype) {
1168 print $OUT "No pre-prompt debugger actions.\n";
1171 print $OUT "Debugger commands run before each prompt:\n";
1172 for my $action ( @$pretype ) {
1173 print $OUT "\t{ -- $action\n";
1177 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1178 print $OUT "{ is now a debugger command\n",
1179 "use `;{' if you mean Perl code\n";
1185 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1186 $i = $1 || $line; $j = $2;
1188 if ($dbline[$i] == 0) {
1189 print $OUT "Line $i may not have an action.\n";
1191 $had_breakpoints{$filename} |= 2;
1192 $dbline{$i} =~ s/\0[^\0]*//;
1193 $dbline{$i} .= "\0" . action($j);
1196 $dbline{$i} =~ s/\0[^\0]*//;
1197 delete $dbline{$i} if $dbline{$i} eq '';
1200 $cmd =~ /^n$/ && do {
1201 end_report(), next CMD if $finished and $level <= 1;
1205 $cmd =~ /^s$/ && do {
1206 end_report(), next CMD if $finished and $level <= 1;
1210 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1211 end_report(), next CMD if $finished and $level <= 1;
1213 # Probably not needed, since we finish an interactive
1214 # sub-session anyway...
1215 # local $filename = $filename;
1216 # local *dbline = *dbline; # XXX Would this work?!
1217 if ($i =~ /\D/) { # subroutine name
1218 $subname = $package."::".$subname
1219 unless $subname =~ /::/;
1220 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1224 *dbline = $main::{'_<' . $filename};
1225 $had_breakpoints{$filename} |= 1;
1227 ++$i while $dbline[$i] == 0 && $i < $max;
1229 print $OUT "Subroutine $subname not found.\n";
1234 if ($dbline[$i] == 0) {
1235 print $OUT "Line $i not breakable.\n";
1238 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1240 for ($i=0; $i <= $stack_depth; ) {
1244 $cmd =~ /^r$/ && do {
1245 end_report(), next CMD if $finished and $level <= 1;
1246 $stack[$stack_depth] |= 1;
1247 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1249 $cmd =~ /^R$/ && do {
1250 print $OUT "Warning: some settings and command-line options may be lost!\n";
1251 my (@script, @flags, $cl);
1252 push @flags, '-w' if $ini_warn;
1253 # Put all the old includes at the start to get
1254 # the same debugger.
1256 push @flags, '-I', $_;
1258 push @flags, '-T' if ${^TAINT};
1259 # Arrange for setting the old INC:
1260 set_list("PERLDB_INC", @ini_INC);
1262 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1263 chomp ($cl = ${'::_<-e'}[$_]);
1264 push @script, '-e', $cl;
1269 set_list("PERLDB_HIST",
1270 $term->Features->{getHistory}
1271 ? $term->GetHistory : @hist);
1272 my @had_breakpoints = keys %had_breakpoints;
1273 set_list("PERLDB_VISITED", @had_breakpoints);
1274 set_list("PERLDB_OPT", %option);
1275 set_list("PERLDB_ON_LOAD", %break_on_load);
1277 for (0 .. $#had_breakpoints) {
1278 my $file = $had_breakpoints[$_];
1279 *dbline = $main::{'_<' . $file};
1280 next unless %dbline or $postponed_file{$file};
1281 (push @hard, $file), next
1282 if $file =~ /^\(\w*eval/;
1284 @add = %{$postponed_file{$file}}
1285 if $postponed_file{$file};
1286 set_list("PERLDB_FILE_$_", %dbline, @add);
1288 for (@hard) { # Yes, really-really...
1289 # Find the subroutines in this eval
1290 *dbline = $main::{'_<' . $_};
1291 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1292 for $sub (keys %sub) {
1293 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1294 $subs{$sub} = [$1, $2];
1298 "No subroutines in $_, ignoring breakpoints.\n";
1301 LINES: for $line (keys %dbline) {
1302 # One breakpoint per sub only:
1303 my ($offset, $sub, $found);
1304 SUBS: for $sub (keys %subs) {
1305 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1306 and (not defined $offset # Not caught
1307 or $offset < 0 )) { # or badly caught
1309 $offset = $line - $subs{$sub}->[0];
1310 $offset = "+$offset", last SUBS if $offset >= 0;
1313 if (defined $offset) {
1314 $postponed{$found} =
1315 "break $offset if $dbline{$line}";
1317 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1321 set_list("PERLDB_POSTPONE", %postponed);
1322 set_list("PERLDB_PRETYPE", @$pretype);
1323 set_list("PERLDB_PRE", @$pre);
1324 set_list("PERLDB_POST", @$post);
1325 set_list("PERLDB_TYPEAHEAD", @typeahead);
1326 $ENV{PERLDB_RESTART} = 1;
1327 delete $ENV{PERLDB_PIDS}; # Restore ini state
1328 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1329 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1330 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1331 print $OUT "exec failed: $!\n";
1333 $cmd =~ /^T$/ && do {
1334 print_trace($OUT, 1); # skip DB
1336 $cmd =~ /^W\s*$/ && do {
1338 @to_watch = @old_watch = ();
1340 $cmd =~ /^W\b\s*(.*)/s && do {
1344 $val = (defined $val) ? "'$val'" : 'undef' ;
1345 push @old_watch, $val;
1348 $cmd =~ /^\/(.*)$/ && do {
1350 $inpat =~ s:([^\\])/$:$1:;
1352 # squelch the sigmangler
1353 local $SIG{__DIE__};
1354 local $SIG{__WARN__};
1355 eval '$inpat =~ m'."\a$inpat\a";
1367 $start = 1 if ($start > $max);
1368 last if ($start == $end);
1369 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1370 if ($slave_editor) {
1371 print $OUT "\032\032$filename:$start:0\n";
1373 print $OUT "$start:\t", $dbline[$start], "\n";
1378 print $OUT "/$pat/: not found\n" if ($start == $end);
1380 $cmd =~ /^\?(.*)$/ && do {
1382 $inpat =~ s:([^\\])\?$:$1:;
1384 # squelch the sigmangler
1385 local $SIG{__DIE__};
1386 local $SIG{__WARN__};
1387 eval '$inpat =~ m'."\a$inpat\a";
1399 $start = $max if ($start <= 0);
1400 last if ($start == $end);
1401 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1402 if ($slave_editor) {
1403 print $OUT "\032\032$filename:$start:0\n";
1405 print $OUT "$start:\t", $dbline[$start], "\n";
1410 print $OUT "?$pat?: not found\n" if ($start == $end);
1412 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1413 pop(@hist) if length($cmd) > 1;
1414 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1416 print $OUT $cmd, "\n";
1418 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1421 $cmd =~ /^$rc([^$rc].*)$/ && do {
1423 pop(@hist) if length($cmd) > 1;
1424 for ($i = $#hist; $i; --$i) {
1425 last if $hist[$i] =~ /$pat/;
1428 print $OUT "No such command!\n\n";
1432 print $OUT $cmd, "\n";
1434 $cmd =~ /^$sh$/ && do {
1435 &system($ENV{SHELL}||"/bin/sh");
1437 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1438 # XXX: using csh or tcsh destroys sigint retvals!
1439 #&system($1); # use this instead
1440 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1442 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1443 $end = $2 ? ($#hist-$2) : 0;
1444 $hist = 0 if $hist < 0;
1445 for ($i=$#hist; $i>$end; $i--) {
1446 print $OUT "$i: ",$hist[$i],"\n"
1447 unless $hist[$i] =~ /^.?$/;
1450 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1453 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1454 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1455 $cmd =~ s/^=\s*// && do {
1457 if (length $cmd == 0) {
1458 @keys = sort keys %alias;
1460 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1461 # can't use $_ or kill //g state
1462 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1463 $alias{$k} = "s\a$k\a$v\a";
1464 # squelch the sigmangler
1465 local $SIG{__DIE__};
1466 local $SIG{__WARN__};
1467 unless (eval "sub { s\a$k\a$v\a }; 1") {
1468 print $OUT "Can't alias $k to $v: $@\n";
1478 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1479 print $OUT "$k\t= $1\n";
1481 elsif (defined $alias{$k}) {
1482 print $OUT "$k\t$alias{$k}\n";
1485 print "No alias for $k\n";
1489 $cmd =~ /^\@\s*(.*\S)/ && do {
1490 if (open my $fh, $1) {
1494 &warn("Can't execute `$1': $!\n");
1497 $cmd =~ /^\|\|?\s*[^|]/ && do {
1498 if ($pager =~ /^\|/) {
1499 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1500 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1502 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1505 unless ($piped=open(OUT,$pager)) {
1506 &warn("Can't pipe output to `$pager'");
1507 if ($pager =~ /^\|/) {
1508 open(OUT,">&STDOUT") # XXX: lost message
1509 || &warn("Can't restore DB::OUT");
1510 open(STDOUT,">&SAVEOUT")
1511 || &warn("Can't restore STDOUT");
1514 open(OUT,">&STDOUT") # XXX: lost message
1515 || &warn("Can't restore DB::OUT");
1519 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1520 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1521 $selected= select(OUT);
1523 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1524 $cmd =~ s/^\|+\s*//;
1527 # XXX Local variants do not work!
1528 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1529 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1530 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1532 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1534 $onetimeDump = undef;
1535 $onetimedumpDepth = undef;
1536 } elsif ($term_pid == $$) {
1541 if ($pager =~ /^\|/) {
1543 # we cannot warn here: the handle is missing --tchrist
1544 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1546 # most of the $? crud was coping with broken cshisms
1548 print SAVEOUT "Pager `$pager' failed: ";
1550 print SAVEOUT "shell returned -1\n";
1553 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1554 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1556 print SAVEOUT "status ", ($? >> 8), "\n";
1560 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1561 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1562 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1563 # Will stop ignoring SIGPIPE if done like nohup(1)
1564 # does SIGINT but Perl doesn't give us a choice.
1566 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1569 select($selected), $selected= "" unless $selected eq "";
1573 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1574 foreach $evalarg (@$post) {
1577 } # if ($single || $signal)
1578 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1582 # The following code may be executed now:
1586 my ($al, $ret, @ret) = "";
1587 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1590 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1591 $#stack = $stack_depth;
1592 $stack[-1] = $single;
1594 $single |= 4 if $stack_depth == $deep;
1596 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1597 # Why -1? But it works! :-(
1598 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1599 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1602 $single |= $stack[$stack_depth--];
1604 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1605 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1606 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1607 if ($doret eq $stack_depth or $frame & 16) {
1608 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1609 print $fh ' ' x $stack_depth if $frame & 16;
1610 print $fh "list context return from $sub:\n";
1611 dumpit($fh, \@ret );
1616 if (defined wantarray) {
1621 $single |= $stack[$stack_depth--];
1623 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1624 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1625 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1626 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1627 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1628 print $fh (' ' x $stack_depth) if $frame & 16;
1629 print $fh (defined wantarray
1630 ? "scalar context return from $sub: "
1631 : "void context return from $sub\n");
1632 dumpit( $fh, $ret ) if defined wantarray;
1641 ### Functions with multiple modes of failure die on error, the rest
1642 ### returns FALSE on error.
1643 ### User-interface functions cmd_* output error message.
1647 $break_on_load{$file} = 1;
1648 $had_breakpoints{$file} |= 1;
1651 sub report_break_on_load {
1652 sort keys %break_on_load;
1660 push @files, $::INC{$file} if $::INC{$file};
1661 $file .= '.pm', redo unless $file =~ /\./;
1663 break_on_load($_) for @files;
1664 @files = report_break_on_load;
1665 print $OUT "Will stop on load of `@files'.\n";
1668 $filename_error = '';
1670 sub breakable_line {
1671 my ($from, $to) = @_;
1674 my $delta = $from < $to ? +1 : -1;
1675 my $limit = $delta > 0 ? $#dbline : 1;
1676 $limit = $to if ($limit - $to) * $delta > 0;
1677 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1679 return $i unless $dbline[$i] == 0;
1680 my ($pl, $upto) = ('', '');
1681 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1682 die "Line$pl $from$upto$filename_error not breakable\n";
1685 sub breakable_line_in_filename {
1687 local *dbline = $main::{'_<' . $f};
1688 local $filename_error = " of `$f'";
1693 my ($i, $cond) = @_;
1694 $cond = 1 unless @_ >= 2;
1698 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1699 $had_breakpoints{$filename} |= 1;
1700 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1701 else { $dbline{$i} = $cond; }
1705 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1708 sub break_on_filename_line {
1709 my ($f, $i, $cond) = @_;
1710 $cond = 1 unless @_ >= 3;
1711 local *dbline = $main::{'_<' . $f};
1712 local $filename_error = " of `$f'";
1713 local $filename = $f;
1714 break_on_line($i, $cond);
1717 sub break_on_filename_line_range {
1718 my ($f, $from, $to, $cond) = @_;
1719 my $i = breakable_line_in_filename($f, $from, $to);
1720 $cond = 1 unless @_ >= 3;
1721 break_on_filename_line($f,$i,$cond);
1724 sub subroutine_filename_lines {
1725 my ($subname,$cond) = @_;
1726 # Filename below can contain ':'
1727 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1730 sub break_subroutine {
1731 my $subname = shift;
1732 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1733 die "Subroutine $subname not found.\n";
1734 $cond = 1 unless @_ >= 2;
1735 break_on_filename_line_range($file,$s,$e,@_);
1739 my ($subname,$cond) = @_;
1740 $cond = 1 unless @_ >= 2;
1741 unless (ref $subname eq 'CODE') {
1742 $subname =~ s/\'/::/g;
1744 $subname = "${'package'}::" . $subname
1745 unless $subname =~ /::/;
1746 $subname = "CORE::GLOBAL::$s"
1747 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1748 $subname = "main".$subname if substr($subname,0,2) eq "::";
1750 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1753 sub cmd_stop { # As on ^C, but not signal-safy.
1757 sub delete_breakpoint {
1759 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1760 $dbline{$i} =~ s/^[^\0]*//;
1761 delete $dbline{$i} if $dbline{$i} eq '';
1766 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1769 ### END of the API section
1772 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1773 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1776 sub print_lineinfo {
1777 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1781 # The following takes its argument via $evalarg to preserve current @_
1784 my $subname = shift;
1785 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1786 my $offset = $1 || 0;
1787 # Filename below can contain ':'
1788 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1791 local *dbline = $main::{'_<' . $file};
1792 local $^W = 0; # != 0 is magical below
1793 $had_breakpoints{$file} |= 1;
1795 ++$i until $dbline[$i] != 0 or $i >= $max;
1796 $dbline{$i} = delete $postponed{$subname};
1798 print $OUT "Subroutine $subname not found.\n";
1802 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1803 #print $OUT "In postponed_sub for `$subname'.\n";
1807 if ($ImmediateStop) {
1811 return &postponed_sub
1812 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1813 # Cannot be done before the file is compiled
1814 local *dbline = shift;
1815 my $filename = $dbline;
1816 $filename =~ s/^_<//;
1817 $signal = 1, print $OUT "'$filename' loaded...\n"
1818 if $break_on_load{$filename};
1819 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1820 return unless $postponed_file{$filename};
1821 $had_breakpoints{$filename} |= 1;
1822 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1824 for $key (keys %{$postponed_file{$filename}}) {
1825 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1827 delete $postponed_file{$filename};
1831 local ($savout) = select(shift);
1832 my $osingle = $single;
1833 my $otrace = $trace;
1834 $single = $trace = 0;
1837 unless (defined &main::dumpValue) {
1840 if (defined &main::dumpValue) {
1842 my $maxdepth = shift || $option{dumpDepth};
1843 $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
1844 &main::dumpValue($v, $maxdepth);
1846 print $OUT "dumpvar.pl not available.\n";
1853 # Tied method do not create a context, so may get wrong message:
1857 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
1858 my @sub = dump_trace($_[0] + 1, $_[1]);
1859 my $short = $_[2]; # Print short report, next one for sub name
1861 for ($i=0; $i <= $#sub; $i++) {
1864 my $args = defined $sub[$i]{args}
1865 ? "(@{ $sub[$i]{args} })"
1867 $args = (substr $args, 0, $maxtrace - 3) . '...'
1868 if length $args > $maxtrace;
1869 my $file = $sub[$i]{file};
1870 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1872 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1874 my $sub = @_ >= 4 ? $_[3] : $s;
1875 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1877 print $fh "$sub[$i]{context} = $s$args" .
1878 " called from $file" .
1879 " line $sub[$i]{line}\n";
1886 my $count = shift || 1e9;
1889 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1890 my $nothard = not $frame & 8;
1891 local $frame = 0; # Do not want to trace this.
1892 my $otrace = $trace;
1895 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1900 if (not defined $arg) {
1902 } elsif ($nothard and tied $arg) {
1904 } elsif ($nothard and $type = ref $arg) {
1905 push @a, "ref($type)";
1907 local $_ = "$arg"; # Safe to stringify now - should not call f().
1910 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1911 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1912 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1916 $context = $context ? '@' : (defined $context ? "\$" : '.');
1917 $args = $h ? [@a] : undef;
1918 $e =~ s/\n\s*\;\s*\Z// if $e;
1919 $e =~ s/([\\\'])/\\$1/g if $e;
1921 $sub = "require '$e'";
1922 } elsif (defined $r) {
1924 } elsif ($sub eq '(eval)') {
1925 $sub = "eval {...}";
1927 push(@sub, {context => $context, sub => $sub, args => $args,
1928 file => $file, line => $line});
1937 while ($action =~ s/\\$//) {
1946 # i hate using globals!
1947 $balanced_brace_re ||= qr{
1950 (?> [^{}] + ) # Non-parens without backtracking
1952 (??{ $balanced_brace_re }) # Group with matching parens
1956 return $_[0] !~ m/$balanced_brace_re/;
1960 &readline("cont: ");
1964 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1965 # some non-Unix systems can do system() but have problems with fork().
1966 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1967 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1968 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1969 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1971 # XXX: using csh or tcsh destroys sigint retvals!
1973 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1974 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1979 # most of the $? crud was coping with broken cshisms
1981 &warn("(Command exited ", ($? >> 8), ")\n");
1983 &warn( "(Command died of SIG#", ($? & 127),
1984 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1994 eval { require Term::ReadLine } or die $@;
1997 my ($i, $o) = split $tty, /,/;
1998 $o = $i unless defined $o;
1999 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
2000 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
2003 my $sel = select($OUT);
2007 eval "require Term::Rendezvous;" or die;
2008 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
2009 my $term_rv = new Term::Rendezvous $rv;
2011 $OUT = $term_rv->OUT;
2014 if ($term_pid eq '-1') { # In a TTY with another debugger
2018 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2020 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2022 $rl_attribs = $term->Attribs;
2023 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2024 if defined $rl_attribs->{basic_word_break_characters}
2025 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2026 $rl_attribs->{special_prefixes} = '$@&%';
2027 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2028 $rl_attribs->{completion_function} = \&db_complete;
2030 $LINEINFO = $OUT unless defined $LINEINFO;
2031 $lineinfo = $console unless defined $lineinfo;
2033 if ($term->Features->{setHistory} and "@hist" ne "?") {
2034 $term->SetHistory(@hist);
2036 ornaments($ornaments) if defined $ornaments;
2040 # Example get_fork_TTY functions
2041 sub xterm_get_fork_TTY {
2042 (my $name = $0) =~ s,^.*[/\\],,s;
2043 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2047 $pidprompt = ''; # Shown anyway in titlebar
2051 # This example function resets $IN, $OUT itself
2052 sub os2_get_fork_TTY {
2053 local $^F = 40; # XXXX Fixme!
2054 my ($in1, $out1, $in2, $out2);
2055 # Having -d in PERL5OPT would lead to a disaster...
2056 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2057 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2058 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2059 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2060 (my $name = $0) =~ s,^.*[/\\],,s;
2062 if ( pipe $in1, $out1 and pipe $in2, $out2
2063 # system P_SESSION will fail if there is another process
2064 # in the same session with a "dependent" asynchronous child session.
2065 and @args = ($rl, fileno $in1, fileno $out2,
2066 "Daughter Perl debugger $pids $name") and
2067 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2070 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2072 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2073 open IN, '<&=$in' or die "open <&=$in: \$!";
2074 \$| = 1; print while sysread IN, \$_, 1<<16;
2078 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2080 require Term::ReadKey if $rl;
2081 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2082 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2084 or warn "system P_SESSION: $!, $^E" and 0)
2085 and close $in1 and close $out2 ) {
2086 $pidprompt = ''; # Shown anyway in titlebar
2087 reset_IN_OUT($in2, $out1);
2089 return ''; # Indicate that reset_IN_OUT is called
2094 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2095 my $in = &get_fork_TTY if defined &get_fork_TTY;
2096 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2097 if (not defined $in) {
2099 print_help(<<EOP) if $why == 1;
2100 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2102 print_help(<<EOP) if $why == 2;
2103 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2104 This may be an asynchronous session, so the parent debugger may be active.
2106 print_help(<<EOP) if $why != 4;
2107 Since two debuggers fight for the same TTY, input is severely entangled.
2111 I know how to switch the output to a different window in xterms
2112 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2113 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2115 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2116 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2119 } elsif ($in ne '') {
2122 $console = ''; # Indicate no need to open-from-the-console
2127 sub resetterm { # We forked, so we need a different TTY
2129 my $systemed = $in > 1 ? '-' : '';
2131 $pids =~ s/\]/$systemed->$$]/;
2133 $pids = "[$term_pid->$$]";
2137 return unless $CreateTTY & $in;
2144 my $left = @typeahead;
2145 my $got = shift @typeahead;
2146 print $OUT "auto(-$left)", shift, $got, "\n";
2147 $term->AddHistory($got)
2148 if length($got) > 1 and defined $term->Features->{addHistory};
2154 my $line = CORE::readline($cmdfhs[-1]);
2155 defined $line ? (print $OUT ">> $line" and return $line)
2156 : close pop @cmdfhs;
2158 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2159 $OUT->write(join('', @_));
2161 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2165 $term->readline(@_);
2170 my ($opt, $val)= @_;
2171 $val = option_val($opt,'N/A');
2172 $val =~ s/([\\\'])/\\$1/g;
2173 printf $OUT "%20s = '%s'\n", $opt, $val;
2177 my ($opt, $default)= @_;
2179 if (defined $optionVars{$opt}
2180 and defined ${$optionVars{$opt}}) {
2181 $val = ${$optionVars{$opt}};
2182 } elsif (defined $optionAction{$opt}
2183 and defined &{$optionAction{$opt}}) {
2184 $val = &{$optionAction{$opt}}();
2185 } elsif (defined $optionAction{$opt}
2186 and not defined $option{$opt}
2187 or defined $optionVars{$opt}
2188 and not defined ${$optionVars{$opt}}) {
2191 $val = $option{$opt};
2193 $val = $default unless defined $val;
2199 # too dangerous to let intuitive usage overwrite important things
2200 # defaultion should never be the default
2201 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2202 dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2203 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2208 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2209 my ($opt,$sep) = ($1,$2);
2212 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2214 #&dump_option($opt);
2215 } elsif ($sep !~ /\S/) {
2217 $val = "1"; # this is an evil default; make 'em set it!
2218 } elsif ($sep eq "=") {
2220 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2222 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2226 print OUT qq(Option better cleared using $opt=""\n)
2230 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2231 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2232 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2233 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2234 ($val = $1) =~ s/\\([\\$end])/$1/g;
2238 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2239 || grep( /^\Q$opt/i && ($option = $_), @options );
2241 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2242 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2244 if ($opt_needs_val{$option} && $val_defaulted) {
2245 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2249 $option{$option} = $val if defined $val;
2254 require '$optionRequire{$option}';
2256 } || die # XXX: shouldn't happen
2257 if defined $optionRequire{$option} &&
2260 ${$optionVars{$option}} = $val
2261 if defined $optionVars{$option} &&
2264 &{$optionAction{$option}} ($val)
2265 if defined $optionAction{$option} &&
2266 defined &{$optionAction{$option}} &&
2270 dump_option($option) unless $OUT eq \*STDERR;
2275 my ($stem,@list) = @_;
2277 $ENV{"${stem}_n"} = @list;
2278 for $i (0 .. $#list) {
2280 $val =~ s/\\/\\\\/g;
2281 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2282 $ENV{"${stem}_$i"} = $val;
2289 my $n = delete $ENV{"${stem}_n"};
2291 for $i (0 .. $n - 1) {
2292 $val = delete $ENV{"${stem}_$i"};
2293 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2301 return; # Put nothing on the stack - malloc/free land!
2305 my($msg)= join("",@_);
2306 $msg .= ": $!\n" unless $msg =~ /\n$/;
2311 my $switch_li = $LINEINFO eq $OUT;
2312 if ($term and $term->Features->{newTTY}) {
2313 ($IN, $OUT) = (shift, shift);
2314 $term->newTTY($IN, $OUT);
2316 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2318 ($IN, $OUT) = (shift, shift);
2320 my $o = select $OUT;
2323 $LINEINFO = $OUT if $switch_li;
2327 if (@_ and $term and $term->Features->{newTTY}) {
2328 my ($in, $out) = shift;
2330 ($in, $out) = split /,/, $in, 2;
2334 open IN, $in or die "cannot open `$in' for read: $!";
2335 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2336 reset_IN_OUT(\*IN,\*OUT);
2339 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2340 # Useful if done through PERLDB_OPTS:
2341 $console = $tty = shift if @_;
2347 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2349 $notty = shift if @_;
2355 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2363 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2365 $remoteport = shift if @_;
2370 if (${$term->Features}{tkRunning}) {
2371 return $term->tkRunning(@_);
2373 print $OUT "tkRunning not supported by current ReadLine package.\n";
2380 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2382 $runnonstop = shift if @_;
2389 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2396 $sh = quotemeta shift;
2397 $sh .= "\\b" if $sh =~ /\w$/;
2401 $psh =~ s/\\(.)/$1/g;
2406 if (defined $term) {
2407 local ($warnLevel,$dieLevel) = (0, 1);
2408 return '' unless $term->Features->{ornaments};
2409 eval { $term->ornaments(@_) } || '';
2417 $rc = quotemeta shift;
2418 $rc .= "\\b" if $rc =~ /\w$/;
2422 $prc =~ s/\\(.)/$1/g;
2427 return $lineinfo unless @_;
2429 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2430 $slave_editor = ($stream =~ /^\|/);
2431 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2432 $LINEINFO = \*LINEINFO;
2433 my $save = select($LINEINFO);
2447 s/^Term::ReadLine::readline$/readline/;
2448 if (defined ${ $_ . '::VERSION' }) {
2449 $version{$file} = "${ $_ . '::VERSION' } from ";
2451 $version{$file} .= $INC{$file};
2453 dumpit($OUT,\%version);
2457 # XXX: make sure there are tabs between the command and explanation,
2458 # or print_help will screw up your formatting if you have
2459 # eeevil ornaments enabled. This is an insane mess.
2463 B<s> [I<expr>] Single step [in I<expr>].
2464 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2465 <B<CR>> Repeat last B<n> or B<s> command.
2466 B<r> Return from current subroutine.
2467 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2468 at the specified position.
2469 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2470 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2471 B<l> I<line> List single I<line>.
2472 B<l> I<subname> List first window of lines from subroutine.
2473 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2474 B<l> List next window of lines.
2475 B<-> List previous window of lines.
2476 B<w> [I<line>] List window around I<line>.
2477 B<.> Return to the executed line.
2478 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2479 I<filename> may be either the full name of the file, or a regular
2480 expression matching the full file name:
2481 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2482 Evals (with saved bodies) are considered to be filenames:
2483 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2484 (in the order of execution).
2485 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2486 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2487 B<L> List all breakpoints and actions.
2488 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2489 B<t> Toggle trace mode.
2490 B<t> I<expr> Trace through execution of I<expr>.
2491 B<b> [I<line>] [I<condition>]
2492 Set breakpoint; I<line> defaults to the current execution line;
2493 I<condition> breaks if it evaluates to true, defaults to '1'.
2494 B<b> I<subname> [I<condition>]
2495 Set breakpoint at first line of subroutine.
2496 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2497 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2498 B<b> B<postpone> I<subname> [I<condition>]
2499 Set breakpoint at first line of subroutine after
2501 B<b> B<compile> I<subname>
2502 Stop after the subroutine is compiled.
2503 B<d> [I<line>] Delete the breakpoint for I<line>.
2504 B<D> Delete all breakpoints.
2505 B<a> [I<line>] I<command>
2506 Set an action to be done before the I<line> is executed;
2507 I<line> defaults to the current execution line.
2508 Sequence is: check for breakpoint/watchpoint, print line
2509 if necessary, do action, prompt user if necessary,
2511 B<a> [I<line>] Delete the action for I<line>.
2512 B<A> Delete all actions.
2513 B<W> I<expr> Add a global watch-expression.
2514 B<W> Delete all watch-expressions.
2515 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2516 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2517 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2518 B<x> I<expr> Evals expression in list context, dumps the result.
2519 B<m> I<expr> Evals expression in list context, prints methods callable
2520 on the first element of the result.
2521 B<m> I<class> Prints methods callable via the given class.
2523 B<<> ? List Perl commands to run before each prompt.
2524 B<<> I<expr> Define Perl command to run before each prompt.
2525 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2526 B<>> ? List Perl commands to run after each prompt.
2527 B<>> I<expr> Define Perl command to run after each prompt.
2528 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2529 B<{> I<db_command> Define debugger command to run before each prompt.
2530 B<{> ? List debugger commands to run before each prompt.
2531 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2532 B<$prc> I<number> Redo a previous command (default previous command).
2533 B<$prc> I<-number> Redo number'th-to-last command.
2534 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2535 See 'B<O> I<recallCommand>' too.
2536 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2537 . ( $rc eq $sh ? "" : "
2538 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2539 See 'B<O> I<shellBang>' too.
2540 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2541 B<H> I<-number> Display last number commands (default all).
2542 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2543 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2544 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2545 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2546 I<command> Execute as a perl statement in current package.
2547 B<v> Show versions of loaded modules.
2548 B<R> Pure-man-restart of debugger, some of debugger state
2549 and command-line options may be lost.
2550 Currently the following settings are preserved:
2551 history, breakpoints and actions, debugger B<O>ptions
2552 and the following command-line options: I<-w>, I<-I>, I<-e>.
2554 B<O> [I<opt>] ... Set boolean option to true
2555 B<O> [I<opt>B<?>] Query options
2556 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2557 Set options. Use quotes in spaces in value.
2558 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2559 I<pager> program for output of \"|cmd\";
2560 I<tkRunning> run Tk while prompting (with ReadLine);
2561 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2562 I<inhibit_exit> Allows stepping off the end of the script.
2563 I<ImmediateStop> Debugger should stop as early as possible.
2564 I<RemotePort> Remote hostname:port for remote debugging
2565 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2566 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2567 I<compactDump>, I<veryCompact> change style of array and hash dump;
2568 I<globPrint> whether to print contents of globs;
2569 I<DumpDBFiles> dump arrays holding debugged files;
2570 I<DumpPackages> dump symbol tables of packages;
2571 I<DumpReused> dump contents of \"reused\" addresses;
2572 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2573 I<bareStringify> Do not print the overload-stringified value;
2574 Other options include:
2575 I<PrintRet> affects printing of return value after B<r> command,
2576 I<frame> affects printing messages on subroutine entry/exit.
2577 I<AutoTrace> affects printing messages on possible breaking points.
2578 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2579 I<ornaments> affects screen appearance of the command line.
2580 I<CreateTTY> bits control attempts to create a new TTY on events:
2581 1: on fork() 2: debugger is started inside debugger
2583 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2584 You can put additional initialization options I<TTY>, I<noTTY>,
2585 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2586 `B<R>' after you set them).
2588 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2589 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2590 B<h h> Summary of debugger commands.
2591 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2592 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2593 Set B<\$DB::doccmd> to change viewer.
2595 Type `|h' for a paged display if this was too hard to read.
2597 "; # Fix balance of vi % matching: }}}}
2599 # note: tabs in the following section are not-so-helpful
2600 $summary = <<"END_SUM";
2601 I<List/search source lines:> I<Control script execution:>
2602 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2603 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2604 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2605 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2606 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2607 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2608 I<Debugger controls:> B<L> List break/watch/actions
2609 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2610 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2611 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2612 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2613 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2614 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2615 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2616 B<q> or B<^D> Quit B<R> Attempt a restart
2617 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2618 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2619 B<p> I<expr> Print expression (uses script's current package).
2620 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2621 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2622 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2623 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2625 # ')}}; # Fix balance of vi % matching
2631 # Restore proper alignment destroyed by eeevil I<> and B<>
2632 # ornaments: A pox on both their houses!
2634 # A help command will have everything up to and including
2635 # the first tab sequence padded into a field 16 (or if indented 20)
2636 # wide. If it's wider than that, an extra space will be added.
2638 ^ # only matters at start of line
2639 ( \040{4} | \t )* # some subcommands are indented
2640 ( < ? # so <CR> works
2641 [BI] < [^\t\n] + ) # find an eeevil ornament
2642 ( \t+ ) # original separation, discarded
2643 ( .* ) # this will now start (no earlier) than
2646 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2647 my $clean = $command;
2648 $clean =~ s/[BI]<([^>]*)>/$1/g;
2649 # replace with this whole string:
2650 ($leadwhite ? " " x 4 : "")
2652 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2657 s{ # handle bold ornaments
2658 B < ( [^>] + | > ) >
2660 $Term::ReadLine::TermCap::rl_term_set[2]
2662 . $Term::ReadLine::TermCap::rl_term_set[3]
2665 s{ # handle italic ornaments
2666 I < ( [^>] + | > ) >
2668 $Term::ReadLine::TermCap::rl_term_set[0]
2670 . $Term::ReadLine::TermCap::rl_term_set[1]
2677 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2678 my $is_less = $pager =~ /\bless\b/;
2679 if ($pager =~ /\bmore\b/) {
2680 my @st_more = stat('/usr/bin/more');
2681 my @st_less = stat('/usr/bin/less');
2682 $is_less = @st_more && @st_less
2683 && $st_more[0] == $st_less[0]
2684 && $st_more[1] == $st_less[1];
2686 # changes environment!
2687 $ENV{LESS} .= 'r' if $is_less;
2693 $SIG{'ABRT'} = 'DEFAULT';
2694 kill 'ABRT', $$ if $panic++;
2695 if (defined &Carp::longmess) {
2696 local $SIG{__WARN__} = '';
2697 local $Carp::CarpLevel = 2; # mydie + confess
2698 &warn(Carp::longmess("Signal @_"));
2701 print $DB::OUT "Got signal @_\n";
2709 local $SIG{__WARN__} = '';
2710 local $SIG{__DIE__} = '';
2711 eval { require Carp } if defined $^S; # If error/warning during compilation,
2712 # require may be broken.
2713 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2714 return unless defined &Carp::longmess;
2715 my ($mysingle,$mytrace) = ($single,$trace);
2716 $single = 0; $trace = 0;
2717 my $mess = Carp::longmess(@_);
2718 ($single,$trace) = ($mysingle,$mytrace);
2725 local $SIG{__DIE__} = '';
2726 local $SIG{__WARN__} = '';
2727 my $i = 0; my $ineval = 0; my $sub;
2728 if ($dieLevel > 2) {
2729 local $SIG{__WARN__} = \&dbwarn;
2730 &warn(@_); # Yell no matter what
2733 if ($dieLevel < 2) {
2734 die @_ if $^S; # in eval propagate
2736 # No need to check $^S, eval is much more robust nowadays
2737 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
2738 # require may be broken.
2740 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2741 unless defined &Carp::longmess;
2743 # We do not want to debug this chunk (automatic disabling works
2744 # inside DB::DB, but not in Carp).
2745 my ($mysingle,$mytrace) = ($single,$trace);
2746 $single = 0; $trace = 0;
2749 package Carp; # Do not include us in the list
2751 $mess = Carp::longmess(@_);
2754 ($single,$trace) = ($mysingle,$mytrace);
2760 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2763 $SIG{__WARN__} = \&DB::dbwarn;
2764 } elsif ($prevwarn) {
2765 $SIG{__WARN__} = $prevwarn;
2773 $prevdie = $SIG{__DIE__} unless $dieLevel;
2776 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2777 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2778 print $OUT "Stack dump during die enabled",
2779 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2781 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2782 } elsif ($prevdie) {
2783 $SIG{__DIE__} = $prevdie;
2784 print $OUT "Default die handler restored.\n";
2792 $prevsegv = $SIG{SEGV} unless $signalLevel;
2793 $prevbus = $SIG{BUS} unless $signalLevel;
2794 $signalLevel = shift;
2796 $SIG{SEGV} = \&DB::diesignal;
2797 $SIG{BUS} = \&DB::diesignal;
2799 $SIG{SEGV} = $prevsegv;
2800 $SIG{BUS} = $prevbus;
2808 my $name = CvGV_name_or_bust($in);
2809 defined $name ? $name : $in;
2812 sub CvGV_name_or_bust {
2814 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2815 return unless ref $in;
2816 $in = \&$in; # Hard reference...
2817 eval {require Devel::Peek; 1} or return;
2818 my $gv = Devel::Peek::CvGV($in) or return;
2819 *$gv{PACKAGE} . '::' . *$gv{NAME};
2825 return unless defined &$subr;
2826 my $name = CvGV_name_or_bust($subr);
2828 $data = $sub{$name} if defined $name;
2829 return $data if defined $data;
2832 $subr = \&$subr; # Hard reference
2835 $s = $_, last if $subr eq \&$_;
2843 $class = ref $class if ref $class;
2846 methods_via($class, '', 1);
2847 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2852 return if $packs{$class}++;
2854 my $prepend = $prefix ? "via $prefix: " : '';
2856 for $name (grep {defined &{${"${class}::"}{$_}}}
2857 sort keys %{"${class}::"}) {
2858 next if $seen{ $name }++;
2859 print $DB::OUT "$prepend$name\n";
2861 return unless shift; # Recurse?
2862 for $name (@{"${class}::ISA"}) {
2863 $prepend = $prefix ? $prefix . " -> $name" : $name;
2864 methods_via($name, $prepend, 1);
2869 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
2870 ? "man" # O Happy Day!
2871 : "perldoc"; # Alas, poor unfortunates
2877 &system("$doccmd $doccmd");
2880 # this way user can override, like with $doccmd="man -Mwhatever"
2881 # or even just "man " to disable the path check.
2882 unless ($doccmd eq 'man') {
2883 &system("$doccmd $page");
2887 $page = 'perl' if lc($page) eq 'help';
2890 my $man1dir = $Config::Config{'man1dir'};
2891 my $man3dir = $Config::Config{'man3dir'};
2892 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2894 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2895 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2896 chop $manpath if $manpath;
2897 # harmless if missing, I figure
2898 my $oldpath = $ENV{MANPATH};
2899 $ENV{MANPATH} = $manpath if $manpath;
2900 my $nopathopt = $^O =~ /dunno what goes here/;
2901 if (CORE::system($doccmd,
2902 # I just *know* there are men without -M
2903 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2906 unless ($page =~ /^perl\w/) {
2907 if (grep { $page eq $_ } qw{
2908 5004delta 5005delta amiga api apio book boot bot call compile
2909 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2910 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2911 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2912 modinstall modlib number obj op opentut os2 os390 pod port
2913 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2914 trap unicode var vms win32 xs xstut
2918 CORE::system($doccmd,
2919 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2924 if (defined $oldpath) {
2925 $ENV{MANPATH} = $manpath;
2927 delete $ENV{MANPATH};
2931 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2933 BEGIN { # This does not compile, alas.
2934 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2935 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2939 $deep = 100; # warning if stack gets this deep
2943 $SIG{INT} = \&DB::catch;
2944 # This may be enabled to debug debugger:
2945 #$warnLevel = 1 unless defined $warnLevel;
2946 #$dieLevel = 1 unless defined $dieLevel;
2947 #$signalLevel = 1 unless defined $signalLevel;
2949 $db_stop = 0; # Compiler warning
2951 $level = 0; # Level of recursive debugging
2952 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2953 # Triggers bug (?) in perl is we postpone this until runtime:
2954 @postponed = @stack = (0);
2955 $stack_depth = 0; # Localized $#stack
2960 BEGIN {$^W = $ini_warn;} # Switch warnings back
2962 #use Carp; # This did break, left for debugging
2965 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2966 my($text, $line, $start) = @_;
2967 my ($itext, $search, $prefix, $pack) =
2968 ($text, "^\Q${'package'}::\E([^:]+)\$");
2970 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2971 (map { /$search/ ? ($1) : () } keys %sub)
2972 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2973 return sort grep /^\Q$text/, values %INC # files
2974 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2975 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2976 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2977 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2978 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2980 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2982 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2983 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2984 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2985 # We may want to complete to (eval 9), so $text may be wrong
2986 $prefix = length($1) - length($text);
2989 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2991 if ((substr $text, 0, 1) eq '&') { # subroutines
2992 $text = substr $text, 1;
2994 return sort map "$prefix$_",
2997 (map { /$search/ ? ($1) : () }
3000 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
3001 $pack = ($1 eq 'main' ? '' : $1) . '::';
3002 $prefix = (substr $text, 0, 1) . $1 . '::';
3005 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
3006 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3007 return db_complete($out[0], $line, $start);
3011 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3012 $pack = ($package eq 'main' ? '' : $package) . '::';
3013 $prefix = substr $text, 0, 1;
3014 $text = substr $text, 1;
3015 my @out = map "$prefix$_", grep /^\Q$text/,
3016 (grep /^_?[a-zA-Z]/, keys %$pack),
3017 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3018 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3019 return db_complete($out[0], $line, $start);
3023 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3024 my @out = grep /^\Q$text/, @options;
3025 my $val = option_val($out[0], undef);
3027 if (not defined $val or $val =~ /[\n\r]/) {
3028 # Can do nothing better
3029 } elsif ($val =~ /\s/) {
3031 foreach $l (split //, qq/\"\'\#\|/) {
3032 $out = "$l$val$l ", last if (index $val, $l) == -1;
3037 # Default to value if one completion, to question if many
3038 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3041 return $term->filename_list($text); # filenames
3045 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3049 if (defined($ini_pids)) {
3050 $ENV{PERLDB_PIDS} = $ini_pids;
3052 delete($ENV{PERLDB_PIDS});
3057 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3058 $fall_off_end = 1 unless $inhibit_exit;
3059 # Do not stop in at_exit() and destructors on exit:
3060 $DB::single = !$fall_off_end && !$runnonstop;
3061 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3067 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3070 package DB; # Do not trace this 1; below!