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 {
533 ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
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?$//) {
705 undef %postponed_file;
706 undef %break_on_load;
707 undef %had_breakpoints;
709 $cmd =~ /^L$/ && do {
711 for $file (keys %had_breakpoints) {
712 local *dbline = $main::{'_<' . $file};
716 for ($i = 1; $i <= $max; $i++) {
717 if (defined $dbline{$i}) {
718 print $OUT "$file:\n" unless $was++;
719 print $OUT " $i:\t", $dbline[$i];
720 ($stop,$action) = split(/\0/, $dbline{$i});
721 print $OUT " break if (", $stop, ")\n"
723 print $OUT " action: ", $action, "\n"
730 print $OUT "Postponed breakpoints in subroutines:\n";
732 for $subname (keys %postponed) {
733 print $OUT " $subname\t$postponed{$subname}\n";
737 my @have = map { # Combined keys
738 keys %{$postponed_file{$_}}
739 } keys %postponed_file;
741 print $OUT "Postponed breakpoints in files:\n";
743 for $file (keys %postponed_file) {
744 my $db = $postponed_file{$file};
745 print $OUT " $file:\n";
746 for $line (sort {$a <=> $b} keys %$db) {
747 print $OUT " $line:\n";
748 my ($stop,$action) = split(/\0/, $$db{$line});
749 print $OUT " break if (", $stop, ")\n"
751 print $OUT " action: ", $action, "\n"
758 if (%break_on_load) {
759 print $OUT "Breakpoints on load:\n";
761 for $file (keys %break_on_load) {
762 print $OUT " $file\n";
767 print $OUT "Watch-expressions:\n";
769 for $expr (@to_watch) {
770 print $OUT " $expr\n";
775 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
776 my $file = $1; $file =~ s/\s+$//;
778 $break_on_load{$file} = 1;
779 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
780 $file .= '.pm', redo unless $file =~ /\./;
782 $had_breakpoints{$file} = 1;
783 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
785 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
786 my $cond = $3 || '1';
787 my ($subname, $break) = ($2, $1 eq 'postpone');
788 $subname =~ s/\'/::/;
789 $subname = "${'package'}::" . $subname
790 unless $subname =~ /::/;
791 $subname = "main".$subname if substr($subname,0,2) eq "::";
792 $postponed{$subname} = $break
793 ? "break +0 if $cond" : "compile";
795 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
798 $subname =~ s/\'/::/;
799 $subname = "${'package'}::" . $subname
800 unless $subname =~ /::/;
801 $subname = "main".$subname if substr($subname,0,2) eq "::";
802 # Filename below can contain ':'
803 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
806 local $filename = $file;
807 local *dbline = $main::{'_<' . $filename};
808 $had_breakpoints{$filename} = 1;
810 ++$i while $dbline[$i] == 0 && $i < $max;
811 $dbline{$i} =~ s/^[^\0]*/$cond/;
813 print $OUT "Subroutine $subname not found.\n";
816 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
819 if ($dbline[$i] == 0) {
820 print $OUT "Line $i not breakable.\n";
822 $had_breakpoints{$filename} = 1;
823 $dbline{$i} =~ s/^[^\0]*/$cond/;
826 $cmd =~ /^d\b\s*(\d+)?/ && do {
828 $dbline{$i} =~ s/^[^\0]*//;
829 delete $dbline{$i} if $dbline{$i} eq '';
831 $cmd =~ /^A$/ && do {
833 for $file (keys %had_breakpoints) {
834 local *dbline = $main::{'_<' . $file};
838 for ($i = 1; $i <= $max ; $i++) {
839 if (defined $dbline{$i}) {
840 $dbline{$i} =~ s/\0[^\0]*//;
841 delete $dbline{$i} if $dbline{$i} eq '';
846 $cmd =~ /^O\s*$/ && do {
851 $cmd =~ /^O\s*(\S.*)/ && do {
854 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
855 push @$pre, action($1);
857 $cmd =~ /^>>\s*(.*)/ && do {
858 push @$post, action($1);
860 $cmd =~ /^<\s*(.*)/ && do {
861 $pre = [], next CMD unless $1;
864 $cmd =~ /^>\s*(.*)/ && do {
865 $post = [], next CMD unless $1;
866 $post = [action($1)];
868 $cmd =~ /^\{\{\s*(.*)/ && do {
871 $cmd =~ /^\{\s*(.*)/ && do {
872 $pretype = [], next CMD unless $1;
875 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
877 if ($dbline[$i] == 0) {
878 print $OUT "Line $i may not have an action.\n";
880 $dbline{$i} =~ s/\0[^\0]*//;
881 $dbline{$i} .= "\0" . action($j);
884 $cmd =~ /^n$/ && do {
885 end_report(), next CMD if $finished and $level <= 1;
889 $cmd =~ /^s$/ && do {
890 end_report(), next CMD if $finished and $level <= 1;
894 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
895 end_report(), next CMD if $finished and $level <= 1;
897 # Probably not needed, since we finish an interactive
898 # sub-session anyway...
899 # local $filename = $filename;
900 # local *dbline = *dbline; # XXX Would this work?!
901 if ($i =~ /\D/) { # subroutine name
902 $subname = $package."::".$subname
903 unless $subname =~ /::/;
904 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
908 *dbline = $main::{'_<' . $filename};
909 $had_breakpoints{$filename}++;
911 ++$i while $dbline[$i] == 0 && $i < $max;
913 print $OUT "Subroutine $subname not found.\n";
918 if ($dbline[$i] == 0) {
919 print $OUT "Line $i not breakable.\n";
922 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
924 for ($i=0; $i <= $stack_depth; ) {
928 $cmd =~ /^r$/ && do {
929 end_report(), next CMD if $finished and $level <= 1;
930 $stack[$stack_depth] |= 1;
931 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
933 $cmd =~ /^R$/ && do {
934 print $OUT "Warning: some settings and command-line options may be lost!\n";
935 my (@script, @flags, $cl);
936 push @flags, '-w' if $ini_warn;
937 # Put all the old includes at the start to get
940 push @flags, '-I', $_;
942 # Arrange for setting the old INC:
943 set_list("PERLDB_INC", @ini_INC);
945 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
946 chomp ($cl = $ {'::_<-e'}[$_]);
947 push @script, '-e', $cl;
952 set_list("PERLDB_HIST",
953 $term->Features->{getHistory}
954 ? $term->GetHistory : @hist);
955 my @had_breakpoints = keys %had_breakpoints;
956 set_list("PERLDB_VISITED", @had_breakpoints);
957 set_list("PERLDB_OPT", %option);
958 set_list("PERLDB_ON_LOAD", %break_on_load);
960 for (0 .. $#had_breakpoints) {
961 my $file = $had_breakpoints[$_];
962 *dbline = $main::{'_<' . $file};
963 next unless %dbline or $postponed_file{$file};
964 (push @hard, $file), next
965 if $file =~ /^\(eval \d+\)$/;
967 @add = %{$postponed_file{$file}}
968 if $postponed_file{$file};
969 set_list("PERLDB_FILE_$_", %dbline, @add);
971 for (@hard) { # Yes, really-really...
972 # Find the subroutines in this eval
973 *dbline = $main::{'_<' . $_};
974 my ($quoted, $sub, %subs, $line) = quotemeta $_;
975 for $sub (keys %sub) {
976 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
977 $subs{$sub} = [$1, $2];
981 "No subroutines in $_, ignoring breakpoints.\n";
984 LINES: for $line (keys %dbline) {
985 # One breakpoint per sub only:
986 my ($offset, $sub, $found);
987 SUBS: for $sub (keys %subs) {
988 if ($subs{$sub}->[1] >= $line # Not after the subroutine
989 and (not defined $offset # Not caught
990 or $offset < 0 )) { # or badly caught
992 $offset = $line - $subs{$sub}->[0];
993 $offset = "+$offset", last SUBS if $offset >= 0;
996 if (defined $offset) {
998 "break $offset if $dbline{$line}";
1000 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1004 set_list("PERLDB_POSTPONE", %postponed);
1005 set_list("PERLDB_PRETYPE", @$pretype);
1006 set_list("PERLDB_PRE", @$pre);
1007 set_list("PERLDB_POST", @$post);
1008 set_list("PERLDB_TYPEAHEAD", @typeahead);
1009 $ENV{PERLDB_RESTART} = 1;
1010 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
1011 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
1012 print $OUT "exec failed: $!\n";
1014 $cmd =~ /^T$/ && do {
1015 print_trace($OUT, 1); # skip DB
1017 $cmd =~ /^W\s*$/ && do {
1019 @to_watch = @old_watch = ();
1021 $cmd =~ /^W\b\s*(.*)/s && do {
1025 $val = (defined $val) ? "'$val'" : 'undef' ;
1026 push @old_watch, $val;
1029 $cmd =~ /^\/(.*)$/ && do {
1031 $inpat =~ s:([^\\])/$:$1:;
1033 eval '$inpat =~ m'."\a$inpat\a";
1045 $start = 1 if ($start > $max);
1046 last if ($start == $end);
1047 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1049 print $OUT "\032\032$filename:$start:0\n";
1051 print $OUT "$start:\t", $dbline[$start], "\n";
1056 print $OUT "/$pat/: not found\n" if ($start == $end);
1058 $cmd =~ /^\?(.*)$/ && do {
1060 $inpat =~ s:([^\\])\?$:$1:;
1062 eval '$inpat =~ m'."\a$inpat\a";
1074 $start = $max if ($start <= 0);
1075 last if ($start == $end);
1076 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1078 print $OUT "\032\032$filename:$start:0\n";
1080 print $OUT "$start:\t", $dbline[$start], "\n";
1085 print $OUT "?$pat?: not found\n" if ($start == $end);
1087 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1088 pop(@hist) if length($cmd) > 1;
1089 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1091 print $OUT $cmd, "\n";
1093 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1096 $cmd =~ /^$rc([^$rc].*)$/ && do {
1098 pop(@hist) if length($cmd) > 1;
1099 for ($i = $#hist; $i; --$i) {
1100 last if $hist[$i] =~ /$pat/;
1103 print $OUT "No such command!\n\n";
1107 print $OUT $cmd, "\n";
1109 $cmd =~ /^$sh$/ && do {
1110 &system($ENV{SHELL}||"/bin/sh");
1112 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1113 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1115 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1116 $end = $2?($#hist-$2):0;
1117 $hist = 0 if $hist < 0;
1118 for ($i=$#hist; $i>$end; $i--) {
1119 print $OUT "$i: ",$hist[$i],"\n"
1120 unless $hist[$i] =~ /^.?$/;
1123 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1124 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1125 $cmd =~ /^=/ && do {
1126 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1127 $alias{$k}="s~$k~$v~";
1128 print $OUT "$k = $v\n";
1129 } elsif ($cmd =~ /^=\s*$/) {
1130 foreach $k (sort keys(%alias)) {
1131 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1132 print $OUT "$k = $v\n";
1134 print $OUT "$k\t$alias{$k}\n";
1139 $cmd =~ /^\|\|?\s*[^|]/ && do {
1140 if ($pager =~ /^\|/) {
1141 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1142 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1144 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1146 unless ($piped=open(OUT,$pager)) {
1147 &warn("Can't pipe output to `$pager'");
1148 if ($pager =~ /^\|/) {
1149 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1150 open(STDOUT,">&SAVEOUT")
1151 || &warn("Can't restore STDOUT");
1154 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1158 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1159 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1160 $selected= select(OUT);
1162 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1163 $cmd =~ s/^\|+\s*//;
1165 # XXX Local variants do not work!
1166 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1167 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1168 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1170 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1172 $onetimeDump = undef;
1173 } elsif ($term_pid == $$) {
1178 if ($pager =~ /^\|/) {
1179 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1180 &warn( "Pager `$pager' failed: ",
1181 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1182 ( $? & 128 ) ? " (core dumped)" : "",
1183 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1184 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1185 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1186 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1187 # Will stop ignoring SIGPIPE if done like nohup(1)
1188 # does SIGINT but Perl doesn't give us a choice.
1190 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1193 select($selected), $selected= "" unless $selected eq "";
1197 $exiting = 1 unless defined $cmd;
1198 foreach $evalarg (@$post) {
1201 } # if ($single || $signal)
1202 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1206 # The following code may be executed now:
1210 my ($al, $ret, @ret) = "";
1211 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1214 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1215 $#stack = $stack_depth;
1216 $stack[-1] = $single;
1218 $single |= 4 if $stack_depth == $deep;
1220 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
1221 # Why -1? But it works! :-(
1222 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1223 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1226 $single |= $stack[$stack_depth--];
1228 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1229 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1230 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1231 if ($doret eq $stack_depth or $frame & 16) {
1232 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1233 print $fh ' ' x $stack_depth if $frame & 16;
1234 print $fh "list context return from $sub:\n";
1235 dumpit($fh, \@ret );
1240 if (defined wantarray) {
1245 $single |= $stack[$stack_depth--];
1247 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1248 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1249 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1250 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1251 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1252 print $fh (' ' x $stack_depth) if $frame & 16;
1253 print $fh (defined wantarray
1254 ? "scalar context return from $sub: "
1255 : "void context return from $sub\n");
1256 dumpit( $fh, $ret ) if defined wantarray;
1264 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1265 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1268 # The following takes its argument via $evalarg to preserve current @_
1271 local @res; # 'my' would make it visible from user code
1273 local $otrace = $trace;
1274 local $osingle = $single;
1276 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1282 local $saved[0]; # Preserve the old value of $@
1286 } elsif ($onetimeDump eq 'dump') {
1287 dumpit($OUT, \@res);
1288 } elsif ($onetimeDump eq 'methods') {
1295 my $subname = shift;
1296 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1297 my $offset = $1 || 0;
1298 # Filename below can contain ':'
1299 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1302 local *dbline = $main::{'_<' . $file};
1303 local $^W = 0; # != 0 is magical below
1304 $had_breakpoints{$file}++;
1306 ++$i until $dbline[$i] != 0 or $i >= $max;
1307 $dbline{$i} = delete $postponed{$subname};
1309 print $OUT "Subroutine $subname not found.\n";
1313 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1314 #print $OUT "In postponed_sub for `$subname'.\n";
1318 if ($ImmediateStop) {
1322 return &postponed_sub
1323 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1324 # Cannot be done before the file is compiled
1325 local *dbline = shift;
1326 my $filename = $dbline;
1327 $filename =~ s/^_<//;
1328 $signal = 1, print $OUT "'$filename' loaded...\n"
1329 if $break_on_load{$filename};
1330 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1331 return unless $postponed_file{$filename};
1332 $had_breakpoints{$filename}++;
1333 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1335 for $key (keys %{$postponed_file{$filename}}) {
1336 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1338 delete $postponed_file{$filename};
1342 local ($savout) = select(shift);
1343 my $osingle = $single;
1344 my $otrace = $trace;
1345 $single = $trace = 0;
1348 unless (defined &main::dumpValue) {
1351 if (defined &main::dumpValue) {
1352 &main::dumpValue(shift);
1354 print $OUT "dumpvar.pl not available.\n";
1361 # Tied method do not create a context, so may get wrong message:
1365 my @sub = dump_trace($_[0] + 1, $_[1]);
1366 my $short = $_[2]; # Print short report, next one for sub name
1368 for ($i=0; $i <= $#sub; $i++) {
1371 my $args = defined $sub[$i]{args}
1372 ? "(@{ $sub[$i]{args} })"
1374 $args = (substr $args, 0, $maxtrace - 3) . '...'
1375 if length $args > $maxtrace;
1376 my $file = $sub[$i]{file};
1377 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1379 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1381 my $sub = @_ >= 4 ? $_[3] : $s;
1382 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1384 print $fh "$sub[$i]{context} = $s$args" .
1385 " called from $file" .
1386 " line $sub[$i]{line}\n";
1393 my $count = shift || 1e9;
1396 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1397 my $nothard = not $frame & 8;
1398 local $frame = 0; # Do not want to trace this.
1399 my $otrace = $trace;
1402 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1407 if (not defined $arg) {
1409 } elsif ($nothard and tied $arg) {
1411 } elsif ($nothard and $type = ref $arg) {
1412 push @a, "ref($type)";
1414 local $_ = "$arg"; # Safe to stringify now - should not call f().
1417 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1418 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1419 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1423 $context = $context ? '@' : (defined $context ? "\$" : '.');
1424 $args = $h ? [@a] : undef;
1425 $e =~ s/\n\s*\;\s*\Z// if $e;
1426 $e =~ s/([\\\'])/\\$1/g if $e;
1428 $sub = "require '$e'";
1429 } elsif (defined $r) {
1431 } elsif ($sub eq '(eval)') {
1432 $sub = "eval {...}";
1434 push(@sub, {context => $context, sub => $sub, args => $args,
1435 file => $file, line => $line});
1444 while ($action =~ s/\\$//) {
1455 &readline("cont: ");
1459 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1460 # many non-Unix systems can do system() but have problems with fork().
1461 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1462 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1463 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1464 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1466 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1467 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1468 close(SAVEIN); close(SAVEOUT);
1469 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1470 ( $? & 128 ) ? " (core dumped)" : "",
1471 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1478 eval { require Term::ReadLine } or die $@;
1481 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1482 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1485 my $sel = select($OUT);
1489 eval "require Term::Rendezvous;" or die $@;
1490 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1491 my $term_rv = new Term::Rendezvous $rv;
1493 $OUT = $term_rv->OUT;
1497 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1499 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1501 $rl_attribs = $term->Attribs;
1502 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1503 if defined $rl_attribs->{basic_word_break_characters}
1504 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1505 $rl_attribs->{special_prefixes} = '$@&%';
1506 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1507 $rl_attribs->{completion_function} = \&db_complete;
1509 $LINEINFO = $OUT unless defined $LINEINFO;
1510 $lineinfo = $console unless defined $lineinfo;
1512 if ($term->Features->{setHistory} and "@hist" ne "?") {
1513 $term->SetHistory(@hist);
1515 ornaments($ornaments) if defined $ornaments;
1519 sub resetterm { # We forked, so we need a different TTY
1521 if (defined &get_fork_TTY) {
1523 } elsif (not defined $fork_TTY
1524 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1525 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1526 # Possibly _inside_ XTERM
1527 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1532 if (defined $fork_TTY) {
1537 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1538 Define B<\$DB::fork_TTY>
1539 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1540 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1541 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1542 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1549 my $left = @typeahead;
1550 my $got = shift @typeahead;
1551 print $OUT "auto(-$left)", shift, $got, "\n";
1552 $term->AddHistory($got)
1553 if length($got) > 1 and defined $term->Features->{addHistory};
1558 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1561 $IN->recv( $stuff, 2048 );
1565 $term->readline(@_);
1570 my ($opt, $val)= @_;
1571 $val = option_val($opt,'N/A');
1572 $val =~ s/([\\\'])/\\$1/g;
1573 printf $OUT "%20s = '%s'\n", $opt, $val;
1577 my ($opt, $default)= @_;
1579 if (defined $optionVars{$opt}
1580 and defined $ {$optionVars{$opt}}) {
1581 $val = $ {$optionVars{$opt}};
1582 } elsif (defined $optionAction{$opt}
1583 and defined &{$optionAction{$opt}}) {
1584 $val = &{$optionAction{$opt}}();
1585 } elsif (defined $optionAction{$opt}
1586 and not defined $option{$opt}
1587 or defined $optionVars{$opt}
1588 and not defined $ {$optionVars{$opt}}) {
1591 $val = $option{$opt};
1599 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1600 my ($opt,$sep) = ($1,$2);
1603 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1605 #&dump_option($opt);
1606 } elsif ($sep !~ /\S/) {
1608 } elsif ($sep eq "=") {
1611 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1612 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1613 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1614 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1616 $val =~ s/\\([\\$end])/$1/g;
1620 grep( /^\Q$opt/ && ($option = $_), @options );
1621 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1623 print $OUT "Unknown option `$opt'\n" unless $matches;
1624 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1625 $option{$option} = $val if $matches == 1 and defined $val;
1626 eval "local \$frame = 0; local \$doret = -2;
1627 require '$optionRequire{$option}'"
1628 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1629 $ {$optionVars{$option}} = $val
1631 and defined $optionVars{$option} and defined $val;
1632 & {$optionAction{$option}} ($val)
1634 and defined $optionAction{$option}
1635 and defined &{$optionAction{$option}} and defined $val;
1636 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1642 my ($stem,@list) = @_;
1644 $ENV{"$ {stem}_n"} = @list;
1645 for $i (0 .. $#list) {
1647 $val =~ s/\\/\\\\/g;
1648 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1649 $ENV{"$ {stem}_$i"} = $val;
1656 my $n = delete $ENV{"$ {stem}_n"};
1658 for $i (0 .. $n - 1) {
1659 $val = delete $ENV{"$ {stem}_$i"};
1660 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1668 return; # Put nothing on the stack - malloc/free land!
1672 my($msg)= join("",@_);
1673 $msg .= ": $!\n" unless $msg =~ /\n$/;
1678 if (@_ and $term and $term->Features->{newTTY}) {
1679 my ($in, $out) = shift;
1681 ($in, $out) = split /,/, $in, 2;
1685 open IN, $in or die "cannot open `$in' for read: $!";
1686 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1687 $term->newTTY(\*IN, \*OUT);
1691 } elsif ($term and @_) {
1692 &warn("Too late to set TTY, enabled on next `R'!\n");
1700 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1702 $notty = shift if @_;
1708 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1716 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
1718 $remoteport = shift if @_;
1723 if ($ {$term->Features}{tkRunning}) {
1724 return $term->tkRunning(@_);
1726 print $OUT "tkRunning not supported by current ReadLine package.\n";
1733 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1735 $runnonstop = shift if @_;
1742 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1749 $sh = quotemeta shift;
1750 $sh .= "\\b" if $sh =~ /\w$/;
1754 $psh =~ s/\\(.)/$1/g;
1760 if (defined $term) {
1761 local ($warnLevel,$dieLevel) = (0, 1);
1762 return '' unless $term->Features->{ornaments};
1763 eval { $term->ornaments(@_) } || '';
1771 $rc = quotemeta shift;
1772 $rc .= "\\b" if $rc =~ /\w$/;
1776 $prc =~ s/\\(.)/$1/g;
1782 return $lineinfo unless @_;
1784 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1785 $emacs = ($stream =~ /^\|/);
1786 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1787 $LINEINFO = \*LINEINFO;
1788 my $save = select($LINEINFO);
1802 s/^Term::ReadLine::readline$/readline/;
1803 if (defined $ { $_ . '::VERSION' }) {
1804 $version{$file} = "$ { $_ . '::VERSION' } from ";
1806 $version{$file} .= $INC{$file};
1808 dumpit($OUT,\%version);
1814 B<s> [I<expr>] Single step [in I<expr>].
1815 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1816 <B<CR>> Repeat last B<n> or B<s> command.
1817 B<r> Return from current subroutine.
1818 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1819 at the specified position.
1820 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1821 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1822 B<l> I<line> List single I<line>.
1823 B<l> I<subname> List first window of lines from subroutine.
1824 B<l> I<$var> List first window of lines from subroutine referenced by I<$var>.
1825 B<l> List next window of lines.
1826 B<-> List previous window of lines.
1827 B<w> [I<line>] List window around I<line>.
1828 B<.> Return to the executed line.
1829 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
1830 I<filename> may be either the full name of the file, or a regular
1831 expression matching the full file name:
1832 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
1833 Evals (with saved bodies) are considered to be filenames:
1834 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
1835 (in the order of execution).
1836 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1837 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1838 B<L> List all breakpoints and actions.
1839 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1840 B<t> Toggle trace mode.
1841 B<t> I<expr> Trace through execution of I<expr>.
1842 B<b> [I<line>] [I<condition>]
1843 Set breakpoint; I<line> defaults to the current execution line;
1844 I<condition> breaks if it evaluates to true, defaults to '1'.
1845 B<b> I<subname> [I<condition>]
1846 Set breakpoint at first line of subroutine.
1847 B<b> I<$var> Set breakpoint at first line of subroutine referenced by I<$var>.
1848 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1849 B<b> B<postpone> I<subname> [I<condition>]
1850 Set breakpoint at first line of subroutine after
1852 B<b> B<compile> I<subname>
1853 Stop after the subroutine is compiled.
1854 B<d> [I<line>] Delete the breakpoint for I<line>.
1855 B<D> Delete all breakpoints.
1856 B<a> [I<line>] I<command>
1857 Set an action to be done before the I<line> is executed.
1858 Sequence is: check for breakpoint/watchpoint, print line
1859 if necessary, do action, prompt user if necessary,
1861 B<A> Delete all actions.
1862 B<W> I<expr> Add a global watch-expression.
1863 B<W> Delete all watch-expressions.
1864 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1865 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1866 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1867 B<x> I<expr> Evals expression in array context, dumps the result.
1868 B<m> I<expr> Evals expression in array context, prints methods callable
1869 on the first element of the result.
1870 B<m> I<class> Prints methods callable via the given class.
1871 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1872 Set or query values of options. I<val> defaults to 1. I<opt> can
1873 be abbreviated. Several options can be listed.
1874 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1875 I<pager>: program for output of \"|cmd\";
1876 I<tkRunning>: run Tk while prompting (with ReadLine);
1877 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1878 I<inhibit_exit> Allows stepping off the end of the script.
1879 I<ImmediateStop> Debugger should stop as early as possible.
1880 I<RemotePort>: Remote hostname:port for remote debugging
1881 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1882 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1883 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1884 I<globPrint>: whether to print contents of globs;
1885 I<DumpDBFiles>: dump arrays holding debugged files;
1886 I<DumpPackages>: dump symbol tables of packages;
1887 I<DumpReused>: dump contents of \"reused\" addresses;
1888 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1889 I<bareStringify>: Do not print the overload-stringified value;
1890 Option I<PrintRet> affects printing of return value after B<r> command,
1891 I<frame> affects printing messages on entry and exit from subroutines.
1892 I<AutoTrace> affects printing messages on every possible breaking point.
1893 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1894 I<ornaments> affects screen appearance of the command line.
1895 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1896 You can put additional initialization options I<TTY>, I<noTTY>,
1897 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
1898 `B<R>' after you set them).
1899 B<<> I<expr> Define Perl command to run before each prompt.
1900 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1901 B<>> I<expr> Define Perl command to run after each prompt.
1902 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1903 B<{> I<db_command> Define debugger command to run before each prompt.
1904 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1905 B<$prc> I<number> Redo a previous command (default previous command).
1906 B<$prc> I<-number> Redo number'th-to-last command.
1907 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1908 See 'B<O> I<recallCommand>' too.
1909 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1910 . ( $rc eq $sh ? "" : "
1911 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1912 See 'B<O> I<shellBang>' too.
1913 B<H> I<-number> Display last number commands (default all).
1914 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1915 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1916 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1917 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1918 I<command> Execute as a perl statement in current package.
1919 B<v> Show versions of loaded modules.
1920 B<R> Pure-man-restart of debugger, some of debugger state
1921 and command-line options may be lost.
1922 Currently the following setting are preserved:
1923 history, breakpoints and actions, debugger B<O>ptions
1924 and the following command-line options: I<-w>, I<-I>, I<-e>.
1925 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1926 Complete description of debugger is available in B<perldebug>
1927 section of Perl documention
1928 B<h h> Summary of debugger commands.
1929 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1932 $summary = <<"END_SUM";
1933 I<List/search source lines:> I<Control script execution:>
1934 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1935 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1936 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1937 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
1938 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1939 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1940 I<Debugger controls:> B<L> List break/watch/actions
1941 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1942 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
1943 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1944 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1945 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1946 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1947 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1948 B<q> or B<^D> Quit B<R> Attempt a restart
1949 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1950 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1951 B<p> I<expr> Print expression (uses script's current package).
1952 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1953 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1954 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1955 I<More help for> B<db_cmd>I<:> Type B<h> I<cmd_letter> Run B<perldoc perldebug> for more help.
1957 # ')}}; # Fix balance of Emacs parsing
1961 my $message = shift;
1962 if (@Term::ReadLine::TermCap::rl_term_set) {
1963 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1964 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1966 print $OUT $message;
1972 $SIG{'ABRT'} = 'DEFAULT';
1973 kill 'ABRT', $$ if $panic++;
1974 if (defined &Carp::longmess) {
1975 local $SIG{__WARN__} = '';
1976 local $Carp::CarpLevel = 2; # mydie + confess
1977 &warn(Carp::longmess("Signal @_"));
1980 print $DB::OUT "Got signal @_\n";
1988 local $SIG{__WARN__} = '';
1989 local $SIG{__DIE__} = '';
1990 eval { require Carp } if defined $^S; # If error/warning during compilation,
1991 # require may be broken.
1992 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1993 return unless defined &Carp::longmess;
1994 my ($mysingle,$mytrace) = ($single,$trace);
1995 $single = 0; $trace = 0;
1996 my $mess = Carp::longmess(@_);
1997 ($single,$trace) = ($mysingle,$mytrace);
2004 local $SIG{__DIE__} = '';
2005 local $SIG{__WARN__} = '';
2006 my $i = 0; my $ineval = 0; my $sub;
2007 if ($dieLevel > 2) {
2008 local $SIG{__WARN__} = \&dbwarn;
2009 &warn(@_); # Yell no matter what
2012 if ($dieLevel < 2) {
2013 die @_ if $^S; # in eval propagate
2015 eval { require Carp } if defined $^S; # If error/warning during compilation,
2016 # require may be broken.
2017 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2018 unless defined &Carp::longmess;
2019 # We do not want to debug this chunk (automatic disabling works
2020 # inside DB::DB, but not in Carp).
2021 my ($mysingle,$mytrace) = ($single,$trace);
2022 $single = 0; $trace = 0;
2023 my $mess = Carp::longmess(@_);
2024 ($single,$trace) = ($mysingle,$mytrace);
2030 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2033 $SIG{__WARN__} = \&DB::dbwarn;
2035 $SIG{__WARN__} = $prevwarn;
2043 $prevdie = $SIG{__DIE__} unless $dieLevel;
2046 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2047 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2048 print $OUT "Stack dump during die enabled",
2049 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2051 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2053 $SIG{__DIE__} = $prevdie;
2054 print $OUT "Default die handler restored.\n";
2062 $prevsegv = $SIG{SEGV} unless $signalLevel;
2063 $prevbus = $SIG{BUS} unless $signalLevel;
2064 $signalLevel = shift;
2066 $SIG{SEGV} = \&DB::diesignal;
2067 $SIG{BUS} = \&DB::diesignal;
2069 $SIG{SEGV} = $prevsegv;
2070 $SIG{BUS} = $prevbus;
2078 my $name = CvGV_name_or_bust($in);
2079 defined $name ? $name : $in;
2082 sub CvGV_name_or_bust {
2084 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2085 $in = \&$in; # Hard reference...
2086 eval {require Devel::Peek; 1} or return;
2087 my $gv = Devel::Peek::CvGV($in) or return;
2088 *$gv{PACKAGE} . '::' . *$gv{NAME};
2094 return unless defined &$subr;
2095 my $name = CvGV_name_or_bust($subr);
2097 $data = $sub{$name} if defined $name;
2098 return $data if defined $data;
2101 $subr = \&$subr; # Hard reference
2104 $s = $_, last if $subr eq \&$_;
2112 $class = ref $class if ref $class;
2115 methods_via($class, '', 1);
2116 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2121 return if $packs{$class}++;
2123 my $prepend = $prefix ? "via $prefix: " : '';
2125 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2126 sort keys %{"$ {class}::"}) {
2127 next if $seen{ $name }++;
2128 print $DB::OUT "$prepend$name\n";
2130 return unless shift; # Recurse?
2131 for $name (@{"$ {class}::ISA"}) {
2132 $prepend = $prefix ? $prefix . " -> $name" : $name;
2133 methods_via($name, $prepend, 1);
2137 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2139 BEGIN { # This does not compile, alas.
2140 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2141 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2145 $deep = 100; # warning if stack gets this deep
2149 $SIG{INT} = \&DB::catch;
2150 # This may be enabled to debug debugger:
2151 #$warnLevel = 1 unless defined $warnLevel;
2152 #$dieLevel = 1 unless defined $dieLevel;
2153 #$signalLevel = 1 unless defined $signalLevel;
2155 $db_stop = 0; # Compiler warning
2157 $level = 0; # Level of recursive debugging
2158 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2159 # Triggers bug (?) in perl is we postpone this until runtime:
2160 @postponed = @stack = (0);
2161 $stack_depth = 0; # Localized $#stack
2166 BEGIN {$^W = $ini_warn;} # Switch warnings back
2168 #use Carp; # This did break, left for debuggin
2171 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2172 my($text, $line, $start) = @_;
2173 my ($itext, $search, $prefix, $pack) =
2174 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2176 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2177 (map { /$search/ ? ($1) : () } keys %sub)
2178 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2179 return sort grep /^\Q$text/, values %INC # files
2180 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2181 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2182 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2183 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2184 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2186 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2188 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2189 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2190 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2191 # We may want to complete to (eval 9), so $text may be wrong
2192 $prefix = length($1) - length($text);
2195 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2197 if ((substr $text, 0, 1) eq '&') { # subroutines
2198 $text = substr $text, 1;
2200 return sort map "$prefix$_",
2203 (map { /$search/ ? ($1) : () }
2206 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2207 $pack = ($1 eq 'main' ? '' : $1) . '::';
2208 $prefix = (substr $text, 0, 1) . $1 . '::';
2211 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2212 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2213 return db_complete($out[0], $line, $start);
2217 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2218 $pack = ($package eq 'main' ? '' : $package) . '::';
2219 $prefix = substr $text, 0, 1;
2220 $text = substr $text, 1;
2221 my @out = map "$prefix$_", grep /^\Q$text/,
2222 (grep /^_?[a-zA-Z]/, keys %$pack),
2223 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2224 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2225 return db_complete($out[0], $line, $start);
2229 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2230 my @out = grep /^\Q$text/, @options;
2231 my $val = option_val($out[0], undef);
2233 if (not defined $val or $val =~ /[\n\r]/) {
2234 # Can do nothing better
2235 } elsif ($val =~ /\s/) {
2237 foreach $l (split //, qq/\"\'\#\|/) {
2238 $out = "$l$val$l ", last if (index $val, $l) == -1;
2243 # Default to value if one completion, to question if many
2244 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2247 return $term->filename_list($text); # filenames
2251 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2255 $finished = $inhibit_exit; # So that some keys may be disabled.
2256 # Do not stop in at_exit() and destructors on exit:
2257 $DB::single = !$exiting && !$runnonstop;
2258 DB::fake::at_exit() unless $exiting or $runnonstop;
2264 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2267 package DB; # Do not trace this 1; below!