3 # Debugger for Perl 5.00x; perl5db.pl patch level:
6 $header = "perl5db.pl version $VERSION";
8 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
9 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
11 # modified Perl debugger, to be run from Emacs in perldb-mode
12 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
13 # Johan Vromans -- upgrade to 4.0 pl 10
14 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
17 # This file is automatically included if you do perl -d.
18 # It's probably not useful to include this yourself.
20 # Perl supplies the values for %sub. It effectively inserts
21 # a &DB'DB(); in front of every place that can have a
22 # breakpoint. Instead of a subroutine call it calls &DB::sub with
23 # $DB::sub being the called subroutine. It also inserts a BEGIN
24 # {require 'perl5db.pl'} before the first line.
26 # After each `require'd file is compiled, but before it is executed, a
27 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
28 # $filename is the expanded name of the `require'd file (as found as
31 # Additional services from Perl interpreter:
33 # if caller() is called from the package DB, it provides some
36 # The array @{$main::{'_<'.$filename} is the line-by-line contents of
39 # The hash %{'_<'.$filename} contains breakpoints and action (it is
40 # keyed by line number), and individual entries are settable (as
41 # opposed to the whole hash). Only true/false is important to the
42 # interpreter, though the values used by perl5db.pl have the form
43 # "$break_condition\0$action". Values are magical in numeric context.
45 # The scalar ${'_<'.$filename} contains "_<$filename".
47 # Note that no subroutine call is possible until &DB::sub is defined
48 # (for subroutines defined outside of the package DB). In fact the same is
49 # true if $deep is not defined.
54 # At start reads $rcfile that may set important options. This file
55 # may define a subroutine &afterinit that will be executed after the
56 # debugger is initialized.
58 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
59 # it as a rest of `O ...' line in debugger prompt.
61 # The options that can be specified only at startup:
62 # [To set in $rcfile, call &parse_options("optionName=new_value").]
64 # TTY - the TTY to use for debugging i/o.
66 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
67 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
68 # Term::Rendezvous. Current variant is to have the name of TTY in this
71 # ReadLine - If false, dummy ReadLine is used, so you can debug
72 # ReadLine applications.
74 # NonStop - if true, no i/o is performed until interrupt.
76 # LineInfo - file or pipe to print line number info to. If it is a
77 # pipe, a short "emacs like" message is used.
79 # RemotePort - host:port to connect to on remote host for remote debugging.
81 # Example $rcfile: (delete leading hashes!)
83 # &parse_options("NonStop=1 LineInfo=db.out");
84 # sub afterinit { $trace = 1; }
86 # The script will run without human intervention, putting trace
87 # information into db.out. (If you interrupt it, you would better
88 # reset LineInfo to something "interactive"!)
90 ##################################################################
93 # A lot of things changed after 0.94. First of all, core now informs
94 # debugger about entry into XSUBs, overloaded operators, tied operations,
95 # BEGIN and END. Handy with `O f=2'.
97 # This can make debugger a little bit too verbose, please be patient
98 # and report your problems promptly.
100 # Now the option frame has 3 values: 0,1,2.
102 # Note that if DESTROY returns a reference to the object (or object),
103 # the deletion of data may be postponed until the next function call,
104 # due to the need to examine the return value.
106 # Changes: 0.95: `v' command shows versions.
107 # Changes: 0.96: `v' command shows version of readline.
108 # primitive completion works (dynamic variables, subs for `b' and `l',
109 # options). Can `p %var'
110 # Better help (`h <' now works). New commands <<, >>, {, {{.
111 # {dump|print}_trace() coded (to be able to do it from <<cmd).
112 # `c sub' documented.
113 # At last enough magic combined to stop after the end of debuggee.
114 # !! should work now (thanks to Emacs bracket matching an extra
115 # `]' in a regexp is caught).
116 # `L', `D' and `A' span files now (as documented).
117 # Breakpoints in `require'd code are possible (used in `R').
118 # Some additional words on internal work of debugger.
119 # `b load filename' implemented.
120 # `b postpone subr' implemented.
121 # now only `q' exits debugger (overwriteable on $inhibit_exit).
122 # When restarting debugger breakpoints/actions persist.
123 # Buglet: When restarting debugger only one breakpoint/action per
124 # autoloaded function persists.
125 # Changes: 0.97: NonStop will not stop in at_exit().
126 # Option AutoTrace implemented.
127 # Trace printed differently if frames are printed too.
128 # new `inhibitExit' option.
129 # printing of a very long statement interruptible.
130 # Changes: 0.98: New command `m' for printing possible methods
131 # 'l -' is a synonim for `-'.
132 # Cosmetic bugs in printing stack trace.
133 # `frame' & 8 to print "expanded args" in stack trace.
134 # Can list/break in imported subs.
135 # new `maxTraceLen' option.
136 # frame & 4 and frame & 8 granted.
138 # nonstoppable lines do not have `:' near the line number.
139 # `b compile subname' implemented.
140 # Will not use $` any more.
141 # `-' behaves sane now.
142 # Changes: 0.99: Completion for `f', `m'.
143 # `m' will remove duplicate names instead of duplicate functions.
144 # `b load' strips trailing whitespace.
145 # completion ignores leading `|'; takes into account current package
146 # when completing a subroutine name (same for `l').
148 ####################################################################
150 # Needed for the statement after exec():
152 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
153 local($^W) = 0; # Switch run-time warnings off during init.
156 $dumpvar::arrayDepth,
157 $dumpvar::dumpDBFiles,
158 $dumpvar::dumpPackages,
159 $dumpvar::quoteHighBit,
160 $dumpvar::printUndef,
169 # Command-line + PERLLIB:
172 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
174 $trace = $signal = $single = 0; # Uninitialized warning suppression
175 # (local $^W cannot help - other packages!).
176 $inhibit_exit = $option{PrintRet} = 1;
178 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
179 compactDump veryCompact quote HighBit undefPrint
180 globPrint PrintRet UsageOnly frame AutoTrace
181 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
182 recallCommand ShellBang pager tkRunning ornaments
183 signalLevel warnLevel dieLevel inhibit_exit
184 ImmediateStop bareStringify
188 hashDepth => \$dumpvar::hashDepth,
189 arrayDepth => \$dumpvar::arrayDepth,
190 DumpDBFiles => \$dumpvar::dumpDBFiles,
191 DumpPackages => \$dumpvar::dumpPackages,
192 DumpReused => \$dumpvar::dumpReused,
193 HighBit => \$dumpvar::quoteHighBit,
194 undefPrint => \$dumpvar::printUndef,
195 globPrint => \$dumpvar::globPrint,
196 UsageOnly => \$dumpvar::usageOnly,
197 bareStringify => \$dumpvar::bareStringify,
199 AutoTrace => \$trace,
200 inhibit_exit => \$inhibit_exit,
201 maxTraceLen => \$maxtrace,
202 ImmediateStop => \$ImmediateStop,
203 RemotePort => \$remoteport,
207 compactDump => \&dumpvar::compactDump,
208 veryCompact => \&dumpvar::veryCompact,
209 quote => \&dumpvar::quote,
212 ReadLine => \&ReadLine,
213 NonStop => \&NonStop,
214 LineInfo => \&LineInfo,
215 recallCommand => \&recallCommand,
216 ShellBang => \&shellBang,
218 signalLevel => \&signalLevel,
219 warnLevel => \&warnLevel,
220 dieLevel => \&dieLevel,
221 tkRunning => \&tkRunning,
222 ornaments => \&ornaments,
223 RemotePort => \&RemotePort,
227 compactDump => 'dumpvar.pl',
228 veryCompact => 'dumpvar.pl',
229 quote => 'dumpvar.pl',
232 # These guys may be defined in $ENV{PERL5DB} :
233 $rl = 1 unless defined $rl;
234 $warnLevel = 1 unless defined $warnLevel;
235 $dieLevel = 1 unless defined $dieLevel;
236 $signalLevel = 1 unless defined $signalLevel;
237 $pre = [] unless defined $pre;
238 $post = [] unless defined $post;
239 $pretype = [] unless defined $pretype;
240 warnLevel($warnLevel);
242 signalLevel($signalLevel);
243 &pager((defined($ENV{PAGER})
247 : 'more'))) unless defined $pager;
248 &recallCommand("!") unless defined $prc;
249 &shellBang("!") unless defined $psh;
250 $maxtrace = 400 unless defined $maxtrace;
255 $rcfile="perldb.ini";
260 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
261 do "$ENV{LOGDIR}/$rcfile";
262 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
263 do "$ENV{HOME}/$rcfile";
266 if (defined $ENV{PERLDB_OPTS}) {
267 parse_options($ENV{PERLDB_OPTS});
270 if (exists $ENV{PERLDB_RESTART}) {
271 delete $ENV{PERLDB_RESTART};
273 @hist = get_list('PERLDB_HIST');
274 %break_on_load = get_list("PERLDB_ON_LOAD");
275 %postponed = get_list("PERLDB_POSTPONE");
276 my @had_breakpoints= get_list("PERLDB_VISITED");
277 for (0 .. $#had_breakpoints) {
278 my %pf = get_list("PERLDB_FILE_$_");
279 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
281 my %opt = get_list("PERLDB_OPT");
283 while (($opt,$val) = each %opt) {
284 $val =~ s/[\\\']/\\$1/g;
285 parse_options("$opt'$val'");
287 @INC = get_list("PERLDB_INC");
289 $pretype = [get_list("PERLDB_PRETYPE")];
290 $pre = [get_list("PERLDB_PRE")];
291 $post = [get_list("PERLDB_POST")];
292 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
298 # Is Perl being run from Emacs?
299 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
300 $rl = 0, shift(@main::ARGV) if $emacs;
302 #require Term::ReadLine;
304 if ($^O eq 'cygwin') {
305 # /dev/tty is binary. use stdin for textmode
307 } elsif (-e "/dev/tty") {
308 $console = "/dev/tty";
309 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
312 $console = "sys\$command";
315 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
320 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
328 $console = $tty if defined $tty;
330 if (defined $remoteport) {
332 $OUT = new IO::Socket::INET( Timeout => '10',
333 PeerAddr => $remoteport,
336 if (!$OUT) { die "Could not create socket to connect to remote host."; }
340 if (defined $console) {
341 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
342 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
343 || open(OUT,">&STDOUT"); # so we don't dongle stdout
346 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
347 $console = 'STDIN/OUT';
349 # so open("|more") can read from STDOUT and so we don't dingle stdin
355 $| = 1; # for DB::OUT
358 $LINEINFO = $OUT unless defined $LINEINFO;
359 $lineinfo = $console unless defined $lineinfo;
361 $| = 1; # for real STDOUT
363 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
364 unless ($runnonstop) {
365 print $OUT "\nLoading DB routines from $header\n";
366 print $OUT ("Emacs support ",
367 $emacs ? "enabled" : "available",
369 print $OUT "\nEnter h or `h h' for help, run `perldoc perldebug' for more help.\n\n";
376 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
379 if (defined &afterinit) { # May be defined in $rcfile
385 ############################################################ Subroutines
388 # _After_ the perl program is compiled, $single is set to 1:
389 if ($single and not $second_time++) {
390 if ($runnonstop) { # Disable until signal
391 for ($i=0; $i <= $stack_depth; ) {
395 # return; # Would not print trace!
396 } elsif ($ImmediateStop) {
401 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
403 ($package, $filename, $line) = caller;
404 $filename_ini = $filename;
405 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
406 "package $package;"; # this won't let them modify, alas
407 local(*dbline) = $main::{'_<' . $filename};
409 if (($stop,$action) = split(/\0/,$dbline{$line})) {
413 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
414 $dbline{$line} =~ s/;9($|\0)/$1/;
417 my $was_signal = $signal;
419 for (my $n = 0; $n <= $#to_watch; $n++) {
420 $evalarg = $to_watch[$n];
421 local $onetimeDump; # Do not output results
422 my ($val) = &eval; # Fix context (&eval is doing array)?
423 $val = ( (defined $val) ? "'$val'" : 'undef' );
424 if ($val ne $old_watch[$n]) {
427 Watchpoint $n:\t$to_watch[$n] changed:
428 old value:\t$old_watch[$n]
431 $old_watch[$n] = $val;
435 if ($trace & 4) { # User-installed watch
436 return if watchfunction($package, $filename, $line)
437 and not $single and not $was_signal and not ($trace & ~4);
439 $was_signal = $signal;
441 if ($single || ($trace & 1) || $was_signal) {
443 $position = "\032\032$filename:$line:0\n";
444 print $LINEINFO $position;
445 } elsif ($package eq 'DB::fake') {
448 Debugged program terminated. Use B<q> to quit or B<R> to restart,
449 use B<O> I<inhibit_exit> to avoid stopping after program termination,
450 B<h q>, B<h R> or B<h O> to get additional info.
453 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
454 "package $package;"; # this won't let them modify, alas
457 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
458 $prefix .= "$sub($filename:";
459 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
460 if (length($prefix) > 30) {
461 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
466 $position = "$prefix$line$infix$dbline[$line]$after";
469 print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
471 print $LINEINFO $position;
473 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
474 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
476 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
477 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
478 $position .= $incr_pos;
480 print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
482 print $LINEINFO $incr_pos;
487 $evalarg = $action, &eval if $action;
488 if ($single || $was_signal) {
489 local $level = $level + 1;
490 foreach $evalarg (@$pre) {
493 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
496 $incr = -1; # for backward motion.
497 @typeahead = (@$pretype, @typeahead);
499 while (($term || &setterm),
500 ($term_pid == $$ or &resetterm),
501 defined ($cmd=&readline(" DB" . ('<' x $level) .
502 ($#hist+1) . ('>' x $level) .
506 $cmd =~ s/\\$/\n/ && do {
507 $cmd .= &readline(" cont: ");
510 $cmd =~ /^$/ && ($cmd = $laststep);
511 push(@hist,$cmd) if length($cmd) > 1;
513 ($i) = split(/\s+/,$cmd);
514 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
515 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
516 $cmd =~ /^h$/ && do {
519 $cmd =~ /^h\s+h$/ && do {
520 print_help($summary);
522 $cmd =~ /^h\s+(\S)$/ && do {
524 if ($help =~ /^(?:[IB]<)$asked/m) {
525 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
529 print_help("B<$asked> is not a debugger command.\n");
532 $cmd =~ /^t$/ && do {
534 print $OUT "Trace = " .
535 (($trace & 1) ? "on" : "off" ) . "\n";
537 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
538 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
539 foreach $subname (sort(keys %sub)) {
540 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
541 print $OUT $subname,"\n";
545 $cmd =~ /^v$/ && do {
546 list_versions(); next CMD};
547 $cmd =~ s/^X\b/V $package/;
548 $cmd =~ /^V$/ && do {
549 $cmd = "V $package"; };
550 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
551 local ($savout) = select($OUT);
553 @vars = split(' ',$2);
554 do 'dumpvar.pl' unless defined &main::dumpvar;
555 if (defined &main::dumpvar) {
558 &main::dumpvar($packname,@vars);
560 print $OUT "dumpvar.pl not available.\n";
564 $cmd =~ s/^x\b/ / && do { # So that will be evaled
565 $onetimeDump = 'dump'; };
566 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
567 methods($1); next CMD};
568 $cmd =~ s/^m\b/ / && do { # So this will be evaled
569 $onetimeDump = 'methods'; };
570 $cmd =~ /^f\b\s*(.*)/ && do {
574 print $OUT "The old f command is now the r command.\n";
575 print $OUT "The new f command switches filenames.\n";
578 if (!defined $main::{'_<' . $file}) {
579 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
580 $try = substr($try,2);
581 print $OUT "Choosing $try matching `$file':\n";
585 if (!defined $main::{'_<' . $file}) {
586 print $OUT "No file matching `$file' is loaded.\n";
588 } elsif ($file ne $filename) {
589 *dbline = $main::{'_<' . $file};
595 print $OUT "Already in $file.\n";
599 $cmd =~ s/^l\s+-\s*$/-/;
600 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
603 print($OUT "Error: $@\n"), next CMD if $@;
605 print($OUT "Interpreted as: $1 $s\n");
608 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
610 $subname =~ s/\'/::/;
611 $subname = $package."::".$subname
612 unless $subname =~ /::/;
613 $subname = "main".$subname if substr($subname,0,2) eq "::";
614 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
615 $subrange = pop @pieces;
616 $file = join(':', @pieces);
617 if ($file ne $filename) {
618 print $OUT "Switching to file '$file'.\n"
620 *dbline = $main::{'_<' . $file};
625 if (eval($subrange) < -$window) {
626 $subrange =~ s/-.*/+/;
628 $cmd = "l $subrange";
630 print $OUT "Subroutine $subname not found.\n";
633 $cmd =~ /^\.$/ && do {
634 $incr = -1; # for backward motion.
636 $filename = $filename_ini;
637 *dbline = $main::{'_<' . $filename};
639 print $LINEINFO $position;
641 $cmd =~ /^w\b\s*(\d*)$/ && do {
645 #print $OUT 'l ' . $start . '-' . ($start + $incr);
646 $cmd = 'l ' . $start . '-' . ($start + $incr); };
647 $cmd =~ /^-$/ && do {
648 $start -= $incr + $window + 1;
649 $start = 1 if $start <= 0;
651 $cmd = 'l ' . ($start) . '+'; };
652 $cmd =~ /^l$/ && do {
654 $cmd = 'l ' . $start . '-' . ($start + $incr); };
655 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
658 $incr = $window - 1 unless $incr;
659 $cmd = 'l ' . $start . '-' . ($start + $incr); };
660 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
661 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
662 $end = $max if $end > $max;
664 $i = $line if $i eq '.';
668 print $OUT "\032\032$filename:$i:0\n";
671 for (; $i <= $end; $i++) {
672 ($stop,$action) = split(/\0/, $dbline{$i});
674 and $filename eq $filename_ini)
676 : ($dbline[$i]+0 ? ':' : ' ') ;
677 $arrow .= 'b' if $stop;
678 $arrow .= 'a' if $action;
679 print $OUT "$i$arrow\t", $dbline[$i];
680 $i++, last if $signal;
682 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
684 $start = $i; # remember in case they want more
685 $start = $max if $start > $max;
687 $cmd =~ /^D$/ && do {
688 print $OUT "Deleting all breakpoints...\n";
690 for $file (keys %had_breakpoints) {
691 local *dbline = $main::{'_<' . $file};
695 for ($i = 1; $i <= $max ; $i++) {
696 if (defined $dbline{$i}) {
697 $dbline{$i} =~ s/^[^\0]+//;
698 if ($dbline{$i} =~ s/^\0?$//) {
704 if (not $had_breakpoints{$file} &= ~1) {
705 delete $had_breakpoints{$file};
709 undef %postponed_file;
710 undef %break_on_load;
712 $cmd =~ /^L$/ && do {
714 for $file (keys %had_breakpoints) {
715 local *dbline = $main::{'_<' . $file};
719 for ($i = 1; $i <= $max; $i++) {
720 if (defined $dbline{$i}) {
721 print $OUT "$file:\n" unless $was++;
722 print $OUT " $i:\t", $dbline[$i];
723 ($stop,$action) = split(/\0/, $dbline{$i});
724 print $OUT " break if (", $stop, ")\n"
726 print $OUT " action: ", $action, "\n"
733 print $OUT "Postponed breakpoints in subroutines:\n";
735 for $subname (keys %postponed) {
736 print $OUT " $subname\t$postponed{$subname}\n";
740 my @have = map { # Combined keys
741 keys %{$postponed_file{$_}}
742 } keys %postponed_file;
744 print $OUT "Postponed breakpoints in files:\n";
746 for $file (keys %postponed_file) {
747 my $db = $postponed_file{$file};
748 print $OUT " $file:\n";
749 for $line (sort {$a <=> $b} keys %$db) {
750 print $OUT " $line:\n";
751 my ($stop,$action) = split(/\0/, $$db{$line});
752 print $OUT " break if (", $stop, ")\n"
754 print $OUT " action: ", $action, "\n"
761 if (%break_on_load) {
762 print $OUT "Breakpoints on load:\n";
764 for $file (keys %break_on_load) {
765 print $OUT " $file\n";
770 print $OUT "Watch-expressions:\n";
772 for $expr (@to_watch) {
773 print $OUT " $expr\n";
778 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
779 my $file = $1; $file =~ s/\s+$//;
781 $break_on_load{$file} = 1;
782 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
783 $file .= '.pm', redo unless $file =~ /\./;
785 $had_breakpoints{$file} |= 1;
786 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
788 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
789 my $cond = $3 || '1';
790 my ($subname, $break) = ($2, $1 eq 'postpone');
791 $subname =~ s/\'/::/;
792 $subname = "${'package'}::" . $subname
793 unless $subname =~ /::/;
794 $subname = "main".$subname if substr($subname,0,2) eq "::";
795 $postponed{$subname} = $break
796 ? "break +0 if $cond" : "compile";
798 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
801 $subname =~ s/\'/::/;
802 $subname = "${'package'}::" . $subname
803 unless $subname =~ /::/;
804 $subname = "main".$subname if substr($subname,0,2) eq "::";
805 # Filename below can contain ':'
806 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
809 local $filename = $file;
810 local *dbline = $main::{'_<' . $filename};
811 $had_breakpoints{$filename} |= 1;
813 ++$i while $dbline[$i] == 0 && $i < $max;
814 $dbline{$i} =~ s/^[^\0]*/$cond/;
816 print $OUT "Subroutine $subname not found.\n";
819 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
822 if ($dbline[$i] == 0) {
823 print $OUT "Line $i not breakable.\n";
825 $had_breakpoints{$filename} |= 1;
826 $dbline{$i} =~ s/^[^\0]*/$cond/;
829 $cmd =~ /^d\b\s*(\d*)/ && do {
831 $dbline{$i} =~ s/^[^\0]*//;
832 delete $dbline{$i} if $dbline{$i} eq '';
834 $cmd =~ /^A$/ && do {
835 print $OUT "Deleting all actions...\n";
837 for $file (keys %had_breakpoints) {
838 local *dbline = $main::{'_<' . $file};
842 for ($i = 1; $i <= $max ; $i++) {
843 if (defined $dbline{$i}) {
844 $dbline{$i} =~ s/\0[^\0]*//;
845 delete $dbline{$i} if $dbline{$i} eq '';
849 if (not $had_breakpoints{$file} &= ~2) {
850 delete $had_breakpoints{$file};
854 $cmd =~ /^O\s*$/ && do {
859 $cmd =~ /^O\s*(\S.*)/ && do {
862 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
863 push @$pre, action($1);
865 $cmd =~ /^>>\s*(.*)/ && do {
866 push @$post, action($1);
868 $cmd =~ /^<\s*(.*)/ && do {
869 $pre = [], next CMD unless $1;
872 $cmd =~ /^>\s*(.*)/ && do {
873 $post = [], next CMD unless $1;
874 $post = [action($1)];
876 $cmd =~ /^\{\{\s*(.*)/ && do {
879 $cmd =~ /^\{\s*(.*)/ && do {
880 $pretype = [], next CMD unless $1;
883 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
884 $i = $1 || $line; $j = $2;
886 if ($dbline[$i] == 0) {
887 print $OUT "Line $i may not have an action.\n";
889 $had_breakpoints{$filename} |= 2;
890 $dbline{$i} =~ s/\0[^\0]*//;
891 $dbline{$i} .= "\0" . action($j);
894 $dbline{$i} =~ s/\0[^\0]*//;
895 delete $dbline{$i} if $dbline{$i} eq '';
898 $cmd =~ /^n$/ && do {
899 end_report(), next CMD if $finished and $level <= 1;
903 $cmd =~ /^s$/ && do {
904 end_report(), next CMD if $finished and $level <= 1;
908 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
909 end_report(), next CMD if $finished and $level <= 1;
911 # Probably not needed, since we finish an interactive
912 # sub-session anyway...
913 # local $filename = $filename;
914 # local *dbline = *dbline; # XXX Would this work?!
915 if ($i =~ /\D/) { # subroutine name
916 $subname = $package."::".$subname
917 unless $subname =~ /::/;
918 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
922 *dbline = $main::{'_<' . $filename};
923 $had_breakpoints{$filename} |= 1;
925 ++$i while $dbline[$i] == 0 && $i < $max;
927 print $OUT "Subroutine $subname not found.\n";
932 if ($dbline[$i] == 0) {
933 print $OUT "Line $i not breakable.\n";
936 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
938 for ($i=0; $i <= $stack_depth; ) {
942 $cmd =~ /^r$/ && do {
943 end_report(), next CMD if $finished and $level <= 1;
944 $stack[$stack_depth] |= 1;
945 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
947 $cmd =~ /^R$/ && do {
948 print $OUT "Warning: some settings and command-line options may be lost!\n";
949 my (@script, @flags, $cl);
950 push @flags, '-w' if $ini_warn;
951 # Put all the old includes at the start to get
954 push @flags, '-I', $_;
956 # Arrange for setting the old INC:
957 set_list("PERLDB_INC", @ini_INC);
959 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
960 chomp ($cl = $ {'::_<-e'}[$_]);
961 push @script, '-e', $cl;
966 set_list("PERLDB_HIST",
967 $term->Features->{getHistory}
968 ? $term->GetHistory : @hist);
969 my @had_breakpoints = keys %had_breakpoints;
970 set_list("PERLDB_VISITED", @had_breakpoints);
971 set_list("PERLDB_OPT", %option);
972 set_list("PERLDB_ON_LOAD", %break_on_load);
974 for (0 .. $#had_breakpoints) {
975 my $file = $had_breakpoints[$_];
976 *dbline = $main::{'_<' . $file};
977 next unless %dbline or $postponed_file{$file};
978 (push @hard, $file), next
979 if $file =~ /^\(eval \d+\)$/;
981 @add = %{$postponed_file{$file}}
982 if $postponed_file{$file};
983 set_list("PERLDB_FILE_$_", %dbline, @add);
985 for (@hard) { # Yes, really-really...
986 # Find the subroutines in this eval
987 *dbline = $main::{'_<' . $_};
988 my ($quoted, $sub, %subs, $line) = quotemeta $_;
989 for $sub (keys %sub) {
990 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
991 $subs{$sub} = [$1, $2];
995 "No subroutines in $_, ignoring breakpoints.\n";
998 LINES: for $line (keys %dbline) {
999 # One breakpoint per sub only:
1000 my ($offset, $sub, $found);
1001 SUBS: for $sub (keys %subs) {
1002 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1003 and (not defined $offset # Not caught
1004 or $offset < 0 )) { # or badly caught
1006 $offset = $line - $subs{$sub}->[0];
1007 $offset = "+$offset", last SUBS if $offset >= 0;
1010 if (defined $offset) {
1011 $postponed{$found} =
1012 "break $offset if $dbline{$line}";
1014 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1018 set_list("PERLDB_POSTPONE", %postponed);
1019 set_list("PERLDB_PRETYPE", @$pretype);
1020 set_list("PERLDB_PRE", @$pre);
1021 set_list("PERLDB_POST", @$post);
1022 set_list("PERLDB_TYPEAHEAD", @typeahead);
1023 $ENV{PERLDB_RESTART} = 1;
1024 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
1025 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
1026 print $OUT "exec failed: $!\n";
1028 $cmd =~ /^T$/ && do {
1029 print_trace($OUT, 1); # skip DB
1031 $cmd =~ /^W\s*$/ && do {
1033 @to_watch = @old_watch = ();
1035 $cmd =~ /^W\b\s*(.*)/s && do {
1039 $val = (defined $val) ? "'$val'" : 'undef' ;
1040 push @old_watch, $val;
1043 $cmd =~ /^\/(.*)$/ && do {
1045 $inpat =~ s:([^\\])/$:$1:;
1047 eval '$inpat =~ m'."\a$inpat\a";
1059 $start = 1 if ($start > $max);
1060 last if ($start == $end);
1061 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1063 print $OUT "\032\032$filename:$start:0\n";
1065 print $OUT "$start:\t", $dbline[$start], "\n";
1070 print $OUT "/$pat/: not found\n" if ($start == $end);
1072 $cmd =~ /^\?(.*)$/ && do {
1074 $inpat =~ s:([^\\])\?$:$1:;
1076 eval '$inpat =~ m'."\a$inpat\a";
1088 $start = $max if ($start <= 0);
1089 last if ($start == $end);
1090 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1092 print $OUT "\032\032$filename:$start:0\n";
1094 print $OUT "$start:\t", $dbline[$start], "\n";
1099 print $OUT "?$pat?: not found\n" if ($start == $end);
1101 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1102 pop(@hist) if length($cmd) > 1;
1103 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1105 print $OUT $cmd, "\n";
1107 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1110 $cmd =~ /^$rc([^$rc].*)$/ && do {
1112 pop(@hist) if length($cmd) > 1;
1113 for ($i = $#hist; $i; --$i) {
1114 last if $hist[$i] =~ /$pat/;
1117 print $OUT "No such command!\n\n";
1121 print $OUT $cmd, "\n";
1123 $cmd =~ /^$sh$/ && do {
1124 &system($ENV{SHELL}||"/bin/sh");
1126 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1127 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1129 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1130 $end = $2?($#hist-$2):0;
1131 $hist = 0 if $hist < 0;
1132 for ($i=$#hist; $i>$end; $i--) {
1133 print $OUT "$i: ",$hist[$i],"\n"
1134 unless $hist[$i] =~ /^.?$/;
1137 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1138 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1139 $cmd =~ /^=/ && do {
1140 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1141 $alias{$k}="s~$k~$v~";
1142 print $OUT "$k = $v\n";
1143 } elsif ($cmd =~ /^=\s*$/) {
1144 foreach $k (sort keys(%alias)) {
1145 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1146 print $OUT "$k = $v\n";
1148 print $OUT "$k\t$alias{$k}\n";
1153 $cmd =~ /^\|\|?\s*[^|]/ && do {
1154 if ($pager =~ /^\|/) {
1155 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1156 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1158 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1160 unless ($piped=open(OUT,$pager)) {
1161 &warn("Can't pipe output to `$pager'");
1162 if ($pager =~ /^\|/) {
1163 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1164 open(STDOUT,">&SAVEOUT")
1165 || &warn("Can't restore STDOUT");
1168 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1172 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1173 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1174 $selected= select(OUT);
1176 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1177 $cmd =~ s/^\|+\s*//;
1179 # XXX Local variants do not work!
1180 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1181 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1182 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1184 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1186 $onetimeDump = undef;
1187 } elsif ($term_pid == $$) {
1192 if ($pager =~ /^\|/) {
1193 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1194 &warn( "Pager `$pager' failed: ",
1195 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1196 ( $? & 128 ) ? " (core dumped)" : "",
1197 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1198 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1199 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1200 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1201 # Will stop ignoring SIGPIPE if done like nohup(1)
1202 # does SIGINT but Perl doesn't give us a choice.
1204 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1207 select($selected), $selected= "" unless $selected eq "";
1211 $exiting = 1 unless defined $cmd;
1212 foreach $evalarg (@$post) {
1215 } # if ($single || $signal)
1216 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1220 # The following code may be executed now:
1224 my ($al, $ret, @ret) = "";
1225 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1228 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1229 $#stack = $stack_depth;
1230 $stack[-1] = $single;
1232 $single |= 4 if $stack_depth == $deep;
1234 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
1235 # Why -1? But it works! :-(
1236 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1237 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1240 $single |= $stack[$stack_depth--];
1242 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1243 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1244 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1245 if ($doret eq $stack_depth or $frame & 16) {
1246 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1247 print $fh ' ' x $stack_depth if $frame & 16;
1248 print $fh "list context return from $sub:\n";
1249 dumpit($fh, \@ret );
1254 if (defined wantarray) {
1259 $single |= $stack[$stack_depth--];
1261 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1262 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1263 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1264 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1265 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1266 print $fh (' ' x $stack_depth) if $frame & 16;
1267 print $fh (defined wantarray
1268 ? "scalar context return from $sub: "
1269 : "void context return from $sub\n");
1270 dumpit( $fh, $ret ) if defined wantarray;
1278 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1279 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1282 # The following takes its argument via $evalarg to preserve current @_
1285 local @res; # 'my' would make it visible from user code
1287 local $otrace = $trace;
1288 local $osingle = $single;
1290 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1296 local $saved[0]; # Preserve the old value of $@
1300 } elsif ($onetimeDump eq 'dump') {
1301 dumpit($OUT, \@res);
1302 } elsif ($onetimeDump eq 'methods') {
1309 my $subname = shift;
1310 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1311 my $offset = $1 || 0;
1312 # Filename below can contain ':'
1313 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1316 local *dbline = $main::{'_<' . $file};
1317 local $^W = 0; # != 0 is magical below
1318 $had_breakpoints{$file} |= 1;
1320 ++$i until $dbline[$i] != 0 or $i >= $max;
1321 $dbline{$i} = delete $postponed{$subname};
1323 print $OUT "Subroutine $subname not found.\n";
1327 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1328 #print $OUT "In postponed_sub for `$subname'.\n";
1332 if ($ImmediateStop) {
1336 return &postponed_sub
1337 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1338 # Cannot be done before the file is compiled
1339 local *dbline = shift;
1340 my $filename = $dbline;
1341 $filename =~ s/^_<//;
1342 $signal = 1, print $OUT "'$filename' loaded...\n"
1343 if $break_on_load{$filename};
1344 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1345 return unless $postponed_file{$filename};
1346 $had_breakpoints{$filename} |= 1;
1347 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1349 for $key (keys %{$postponed_file{$filename}}) {
1350 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1352 delete $postponed_file{$filename};
1356 local ($savout) = select(shift);
1357 my $osingle = $single;
1358 my $otrace = $trace;
1359 $single = $trace = 0;
1362 unless (defined &main::dumpValue) {
1365 if (defined &main::dumpValue) {
1366 &main::dumpValue(shift);
1368 print $OUT "dumpvar.pl not available.\n";
1375 # Tied method do not create a context, so may get wrong message:
1379 my @sub = dump_trace($_[0] + 1, $_[1]);
1380 my $short = $_[2]; # Print short report, next one for sub name
1382 for ($i=0; $i <= $#sub; $i++) {
1385 my $args = defined $sub[$i]{args}
1386 ? "(@{ $sub[$i]{args} })"
1388 $args = (substr $args, 0, $maxtrace - 3) . '...'
1389 if length $args > $maxtrace;
1390 my $file = $sub[$i]{file};
1391 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1393 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1395 my $sub = @_ >= 4 ? $_[3] : $s;
1396 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1398 print $fh "$sub[$i]{context} = $s$args" .
1399 " called from $file" .
1400 " line $sub[$i]{line}\n";
1407 my $count = shift || 1e9;
1410 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1411 my $nothard = not $frame & 8;
1412 local $frame = 0; # Do not want to trace this.
1413 my $otrace = $trace;
1416 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1421 if (not defined $arg) {
1423 } elsif ($nothard and tied $arg) {
1425 } elsif ($nothard and $type = ref $arg) {
1426 push @a, "ref($type)";
1428 local $_ = "$arg"; # Safe to stringify now - should not call f().
1431 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1432 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1433 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1437 $context = $context ? '@' : (defined $context ? "\$" : '.');
1438 $args = $h ? [@a] : undef;
1439 $e =~ s/\n\s*\;\s*\Z// if $e;
1440 $e =~ s/([\\\'])/\\$1/g if $e;
1442 $sub = "require '$e'";
1443 } elsif (defined $r) {
1445 } elsif ($sub eq '(eval)') {
1446 $sub = "eval {...}";
1448 push(@sub, {context => $context, sub => $sub, args => $args,
1449 file => $file, line => $line});
1458 while ($action =~ s/\\$//) {
1469 &readline("cont: ");
1473 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1474 # many non-Unix systems can do system() but have problems with fork().
1475 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1476 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1477 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1478 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1480 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1481 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1482 close(SAVEIN); close(SAVEOUT);
1483 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1484 ( $? & 128 ) ? " (core dumped)" : "",
1485 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1492 eval { require Term::ReadLine } or die $@;
1495 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1496 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1499 my $sel = select($OUT);
1503 eval "require Term::Rendezvous;" or die $@;
1504 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1505 my $term_rv = new Term::Rendezvous $rv;
1507 $OUT = $term_rv->OUT;
1511 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1513 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1515 $rl_attribs = $term->Attribs;
1516 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1517 if defined $rl_attribs->{basic_word_break_characters}
1518 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1519 $rl_attribs->{special_prefixes} = '$@&%';
1520 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1521 $rl_attribs->{completion_function} = \&db_complete;
1523 $LINEINFO = $OUT unless defined $LINEINFO;
1524 $lineinfo = $console unless defined $lineinfo;
1526 if ($term->Features->{setHistory} and "@hist" ne "?") {
1527 $term->SetHistory(@hist);
1529 ornaments($ornaments) if defined $ornaments;
1533 sub resetterm { # We forked, so we need a different TTY
1535 if (defined &get_fork_TTY) {
1537 } elsif (not defined $fork_TTY
1538 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1539 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1540 # Possibly _inside_ XTERM
1541 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1546 if (defined $fork_TTY) {
1551 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1552 Define B<\$DB::fork_TTY>
1553 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1554 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1555 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1556 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1563 my $left = @typeahead;
1564 my $got = shift @typeahead;
1565 print $OUT "auto(-$left)", shift, $got, "\n";
1566 $term->AddHistory($got)
1567 if length($got) > 1 and defined $term->Features->{addHistory};
1572 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1575 $IN->recv( $stuff, 2048 );
1579 $term->readline(@_);
1584 my ($opt, $val)= @_;
1585 $val = option_val($opt,'N/A');
1586 $val =~ s/([\\\'])/\\$1/g;
1587 printf $OUT "%20s = '%s'\n", $opt, $val;
1591 my ($opt, $default)= @_;
1593 if (defined $optionVars{$opt}
1594 and defined $ {$optionVars{$opt}}) {
1595 $val = $ {$optionVars{$opt}};
1596 } elsif (defined $optionAction{$opt}
1597 and defined &{$optionAction{$opt}}) {
1598 $val = &{$optionAction{$opt}}();
1599 } elsif (defined $optionAction{$opt}
1600 and not defined $option{$opt}
1601 or defined $optionVars{$opt}
1602 and not defined $ {$optionVars{$opt}}) {
1605 $val = $option{$opt};
1613 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1614 my ($opt,$sep) = ($1,$2);
1617 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1619 #&dump_option($opt);
1620 } elsif ($sep !~ /\S/) {
1622 } elsif ($sep eq "=") {
1625 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1626 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1627 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1628 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1630 $val =~ s/\\([\\$end])/$1/g;
1634 grep( /^\Q$opt/ && ($option = $_), @options );
1635 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1637 print $OUT "Unknown option `$opt'\n" unless $matches;
1638 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1639 $option{$option} = $val if $matches == 1 and defined $val;
1640 eval "local \$frame = 0; local \$doret = -2;
1641 require '$optionRequire{$option}'"
1642 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1643 $ {$optionVars{$option}} = $val
1645 and defined $optionVars{$option} and defined $val;
1646 & {$optionAction{$option}} ($val)
1648 and defined $optionAction{$option}
1649 and defined &{$optionAction{$option}} and defined $val;
1650 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1656 my ($stem,@list) = @_;
1658 $ENV{"$ {stem}_n"} = @list;
1659 for $i (0 .. $#list) {
1661 $val =~ s/\\/\\\\/g;
1662 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1663 $ENV{"$ {stem}_$i"} = $val;
1670 my $n = delete $ENV{"$ {stem}_n"};
1672 for $i (0 .. $n - 1) {
1673 $val = delete $ENV{"$ {stem}_$i"};
1674 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1682 return; # Put nothing on the stack - malloc/free land!
1686 my($msg)= join("",@_);
1687 $msg .= ": $!\n" unless $msg =~ /\n$/;
1692 if (@_ and $term and $term->Features->{newTTY}) {
1693 my ($in, $out) = shift;
1695 ($in, $out) = split /,/, $in, 2;
1699 open IN, $in or die "cannot open `$in' for read: $!";
1700 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1701 $term->newTTY(\*IN, \*OUT);
1705 } elsif ($term and @_) {
1706 &warn("Too late to set TTY, enabled on next `R'!\n");
1714 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1716 $notty = shift if @_;
1722 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1730 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
1732 $remoteport = shift if @_;
1737 if ($ {$term->Features}{tkRunning}) {
1738 return $term->tkRunning(@_);
1740 print $OUT "tkRunning not supported by current ReadLine package.\n";
1747 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1749 $runnonstop = shift if @_;
1756 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1763 $sh = quotemeta shift;
1764 $sh .= "\\b" if $sh =~ /\w$/;
1768 $psh =~ s/\\(.)/$1/g;
1774 if (defined $term) {
1775 local ($warnLevel,$dieLevel) = (0, 1);
1776 return '' unless $term->Features->{ornaments};
1777 eval { $term->ornaments(@_) } || '';
1785 $rc = quotemeta shift;
1786 $rc .= "\\b" if $rc =~ /\w$/;
1790 $prc =~ s/\\(.)/$1/g;
1796 return $lineinfo unless @_;
1798 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1799 $emacs = ($stream =~ /^\|/);
1800 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1801 $LINEINFO = \*LINEINFO;
1802 my $save = select($LINEINFO);
1816 s/^Term::ReadLine::readline$/readline/;
1817 if (defined $ { $_ . '::VERSION' }) {
1818 $version{$file} = "$ { $_ . '::VERSION' } from ";
1820 $version{$file} .= $INC{$file};
1822 dumpit($OUT,\%version);
1828 B<s> [I<expr>] Single step [in I<expr>].
1829 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1830 <B<CR>> Repeat last B<n> or B<s> command.
1831 B<r> Return from current subroutine.
1832 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1833 at the specified position.
1834 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1835 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1836 B<l> I<line> List single I<line>.
1837 B<l> I<subname> List first window of lines from subroutine.
1838 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
1839 B<l> List next window of lines.
1840 B<-> List previous window of lines.
1841 B<w> [I<line>] List window around I<line>.
1842 B<.> Return to the executed line.
1843 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
1844 I<filename> may be either the full name of the file, or a regular
1845 expression matching the full file name:
1846 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
1847 Evals (with saved bodies) are considered to be filenames:
1848 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
1849 (in the order of execution).
1850 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1851 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1852 B<L> List all breakpoints and actions.
1853 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1854 B<t> Toggle trace mode.
1855 B<t> I<expr> Trace through execution of I<expr>.
1856 B<b> [I<line>] [I<condition>]
1857 Set breakpoint; I<line> defaults to the current execution line;
1858 I<condition> breaks if it evaluates to true, defaults to '1'.
1859 B<b> I<subname> [I<condition>]
1860 Set breakpoint at first line of subroutine.
1861 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
1862 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1863 B<b> B<postpone> I<subname> [I<condition>]
1864 Set breakpoint at first line of subroutine after
1866 B<b> B<compile> I<subname>
1867 Stop after the subroutine is compiled.
1868 B<d> [I<line>] Delete the breakpoint for I<line>.
1869 B<D> Delete all breakpoints.
1870 B<a> [I<line>] I<command>
1871 Set an action to be done before the I<line> is executed;
1872 I<line> defaults to the current execution line.
1873 Sequence is: check for breakpoint/watchpoint, print line
1874 if necessary, do action, prompt user if necessary,
1876 B<a> [I<line>] Delete the action for I<line>.
1877 B<A> Delete all actions.
1878 B<W> I<expr> Add a global watch-expression.
1879 B<W> Delete all watch-expressions.
1880 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1881 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1882 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1883 B<x> I<expr> Evals expression in array context, dumps the result.
1884 B<m> I<expr> Evals expression in array context, prints methods callable
1885 on the first element of the result.
1886 B<m> I<class> Prints methods callable via the given class.
1887 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1888 Set or query values of options. I<val> defaults to 1. I<opt> can
1889 be abbreviated. Several options can be listed.
1890 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1891 I<pager>: program for output of \"|cmd\";
1892 I<tkRunning>: run Tk while prompting (with ReadLine);
1893 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1894 I<inhibit_exit> Allows stepping off the end of the script.
1895 I<ImmediateStop> Debugger should stop as early as possible.
1896 I<RemotePort>: Remote hostname:port for remote debugging
1897 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1898 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1899 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1900 I<globPrint>: whether to print contents of globs;
1901 I<DumpDBFiles>: dump arrays holding debugged files;
1902 I<DumpPackages>: dump symbol tables of packages;
1903 I<DumpReused>: dump contents of \"reused\" addresses;
1904 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1905 I<bareStringify>: Do not print the overload-stringified value;
1906 Option I<PrintRet> affects printing of return value after B<r> command,
1907 I<frame> affects printing messages on entry and exit from subroutines.
1908 I<AutoTrace> affects printing messages on every possible breaking point.
1909 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1910 I<ornaments> affects screen appearance of the command line.
1911 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1912 You can put additional initialization options I<TTY>, I<noTTY>,
1913 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
1914 `B<R>' after you set them).
1915 B<<> I<expr> Define Perl command to run before each prompt.
1916 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1917 B<>> I<expr> Define Perl command to run after each prompt.
1918 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1919 B<{> I<db_command> Define debugger command to run before each prompt.
1920 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1921 B<$prc> I<number> Redo a previous command (default previous command).
1922 B<$prc> I<-number> Redo number'th-to-last command.
1923 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1924 See 'B<O> I<recallCommand>' too.
1925 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1926 . ( $rc eq $sh ? "" : "
1927 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1928 See 'B<O> I<shellBang>' too.
1929 B<H> I<-number> Display last number commands (default all).
1930 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1931 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1932 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1933 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1934 I<command> Execute as a perl statement in current package.
1935 B<v> Show versions of loaded modules.
1936 B<R> Pure-man-restart of debugger, some of debugger state
1937 and command-line options may be lost.
1938 Currently the following setting are preserved:
1939 history, breakpoints and actions, debugger B<O>ptions
1940 and the following command-line options: I<-w>, I<-I>, I<-e>.
1941 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1942 Complete description of debugger is available in B<perldebug>
1943 section of Perl documention
1944 B<h h> Summary of debugger commands.
1945 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1948 $summary = <<"END_SUM";
1949 I<List/search source lines:> I<Control script execution:>
1950 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1951 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1952 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1953 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
1954 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1955 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1956 I<Debugger controls:> B<L> List break/watch/actions
1957 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1958 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
1959 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1960 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1961 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1962 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1963 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1964 B<q> or B<^D> Quit B<R> Attempt a restart
1965 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1966 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1967 B<p> I<expr> Print expression (uses script's current package).
1968 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1969 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1970 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1971 I<More help for> B<db_cmd>I<:> Type B<h> I<cmd_letter> Run B<perldoc perldebug> for more help.
1973 # ')}}; # Fix balance of Emacs parsing
1977 my $message = shift;
1978 if (@Term::ReadLine::TermCap::rl_term_set) {
1979 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1980 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1982 print $OUT $message;
1988 $SIG{'ABRT'} = 'DEFAULT';
1989 kill 'ABRT', $$ if $panic++;
1990 if (defined &Carp::longmess) {
1991 local $SIG{__WARN__} = '';
1992 local $Carp::CarpLevel = 2; # mydie + confess
1993 &warn(Carp::longmess("Signal @_"));
1996 print $DB::OUT "Got signal @_\n";
2004 local $SIG{__WARN__} = '';
2005 local $SIG{__DIE__} = '';
2006 eval { require Carp } if defined $^S; # If error/warning during compilation,
2007 # require may be broken.
2008 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2009 return unless defined &Carp::longmess;
2010 my ($mysingle,$mytrace) = ($single,$trace);
2011 $single = 0; $trace = 0;
2012 my $mess = Carp::longmess(@_);
2013 ($single,$trace) = ($mysingle,$mytrace);
2020 local $SIG{__DIE__} = '';
2021 local $SIG{__WARN__} = '';
2022 my $i = 0; my $ineval = 0; my $sub;
2023 if ($dieLevel > 2) {
2024 local $SIG{__WARN__} = \&dbwarn;
2025 &warn(@_); # Yell no matter what
2028 if ($dieLevel < 2) {
2029 die @_ if $^S; # in eval propagate
2031 eval { require Carp } if defined $^S; # If error/warning during compilation,
2032 # require may be broken.
2033 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2034 unless defined &Carp::longmess;
2035 # We do not want to debug this chunk (automatic disabling works
2036 # inside DB::DB, but not in Carp).
2037 my ($mysingle,$mytrace) = ($single,$trace);
2038 $single = 0; $trace = 0;
2039 my $mess = Carp::longmess(@_);
2040 ($single,$trace) = ($mysingle,$mytrace);
2046 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2049 $SIG{__WARN__} = \&DB::dbwarn;
2051 $SIG{__WARN__} = $prevwarn;
2059 $prevdie = $SIG{__DIE__} unless $dieLevel;
2062 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2063 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2064 print $OUT "Stack dump during die enabled",
2065 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2067 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2069 $SIG{__DIE__} = $prevdie;
2070 print $OUT "Default die handler restored.\n";
2078 $prevsegv = $SIG{SEGV} unless $signalLevel;
2079 $prevbus = $SIG{BUS} unless $signalLevel;
2080 $signalLevel = shift;
2082 $SIG{SEGV} = \&DB::diesignal;
2083 $SIG{BUS} = \&DB::diesignal;
2085 $SIG{SEGV} = $prevsegv;
2086 $SIG{BUS} = $prevbus;
2094 my $name = CvGV_name_or_bust($in);
2095 defined $name ? $name : $in;
2098 sub CvGV_name_or_bust {
2100 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2101 $in = \&$in; # Hard reference...
2102 eval {require Devel::Peek; 1} or return;
2103 my $gv = Devel::Peek::CvGV($in) or return;
2104 *$gv{PACKAGE} . '::' . *$gv{NAME};
2110 return unless defined &$subr;
2111 my $name = CvGV_name_or_bust($subr);
2113 $data = $sub{$name} if defined $name;
2114 return $data if defined $data;
2117 $subr = \&$subr; # Hard reference
2120 $s = $_, last if $subr eq \&$_;
2128 $class = ref $class if ref $class;
2131 methods_via($class, '', 1);
2132 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2137 return if $packs{$class}++;
2139 my $prepend = $prefix ? "via $prefix: " : '';
2141 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2142 sort keys %{"$ {class}::"}) {
2143 next if $seen{ $name }++;
2144 print $DB::OUT "$prepend$name\n";
2146 return unless shift; # Recurse?
2147 for $name (@{"$ {class}::ISA"}) {
2148 $prepend = $prefix ? $prefix . " -> $name" : $name;
2149 methods_via($name, $prepend, 1);
2153 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2155 BEGIN { # This does not compile, alas.
2156 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2157 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2161 $deep = 100; # warning if stack gets this deep
2165 $SIG{INT} = \&DB::catch;
2166 # This may be enabled to debug debugger:
2167 #$warnLevel = 1 unless defined $warnLevel;
2168 #$dieLevel = 1 unless defined $dieLevel;
2169 #$signalLevel = 1 unless defined $signalLevel;
2171 $db_stop = 0; # Compiler warning
2173 $level = 0; # Level of recursive debugging
2174 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2175 # Triggers bug (?) in perl is we postpone this until runtime:
2176 @postponed = @stack = (0);
2177 $stack_depth = 0; # Localized $#stack
2182 BEGIN {$^W = $ini_warn;} # Switch warnings back
2184 #use Carp; # This did break, left for debuggin
2187 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2188 my($text, $line, $start) = @_;
2189 my ($itext, $search, $prefix, $pack) =
2190 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2192 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2193 (map { /$search/ ? ($1) : () } keys %sub)
2194 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2195 return sort grep /^\Q$text/, values %INC # files
2196 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2197 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2198 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2199 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2200 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2202 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2204 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2205 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2206 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2207 # We may want to complete to (eval 9), so $text may be wrong
2208 $prefix = length($1) - length($text);
2211 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2213 if ((substr $text, 0, 1) eq '&') { # subroutines
2214 $text = substr $text, 1;
2216 return sort map "$prefix$_",
2219 (map { /$search/ ? ($1) : () }
2222 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2223 $pack = ($1 eq 'main' ? '' : $1) . '::';
2224 $prefix = (substr $text, 0, 1) . $1 . '::';
2227 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2228 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2229 return db_complete($out[0], $line, $start);
2233 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2234 $pack = ($package eq 'main' ? '' : $package) . '::';
2235 $prefix = substr $text, 0, 1;
2236 $text = substr $text, 1;
2237 my @out = map "$prefix$_", grep /^\Q$text/,
2238 (grep /^_?[a-zA-Z]/, keys %$pack),
2239 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2240 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2241 return db_complete($out[0], $line, $start);
2245 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2246 my @out = grep /^\Q$text/, @options;
2247 my $val = option_val($out[0], undef);
2249 if (not defined $val or $val =~ /[\n\r]/) {
2250 # Can do nothing better
2251 } elsif ($val =~ /\s/) {
2253 foreach $l (split //, qq/\"\'\#\|/) {
2254 $out = "$l$val$l ", last if (index $val, $l) == -1;
2259 # Default to value if one completion, to question if many
2260 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2263 return $term->filename_list($text); # filenames
2267 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2271 $finished = $inhibit_exit; # So that some keys may be disabled.
2272 # Do not stop in at_exit() and destructors on exit:
2273 $DB::single = !$exiting && !$runnonstop;
2274 DB::fake::at_exit() unless $exiting or $runnonstop;
2280 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2283 package DB; # Do not trace this 1; below!