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 =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
602 $subname =~ s/\'/::/;
603 $subname = $package."::".$subname
604 unless $subname =~ /::/;
605 $subname = "main".$subname if substr($subname,0,2) eq "::";
606 @pieces = split(/:/,find_sub($subname));
607 $subrange = pop @pieces;
608 $file = join(':', @pieces);
609 if ($file ne $filename) {
610 print $OUT "Switching to file '$file'.\n"
612 *dbline = $main::{'_<' . $file};
617 if (eval($subrange) < -$window) {
618 $subrange =~ s/-.*/+/;
620 $cmd = "l $subrange";
622 print $OUT "Subroutine $subname not found.\n";
625 $cmd =~ /^\.$/ && do {
626 $incr = -1; # for backward motion.
628 $filename = $filename_ini;
629 *dbline = $main::{'_<' . $filename};
631 print $LINEINFO $position;
633 $cmd =~ /^w\b\s*(\d*)$/ && do {
637 #print $OUT 'l ' . $start . '-' . ($start + $incr);
638 $cmd = 'l ' . $start . '-' . ($start + $incr); };
639 $cmd =~ /^-$/ && do {
640 $start -= $incr + $window + 1;
641 $start = 1 if $start <= 0;
643 $cmd = 'l ' . ($start) . '+'; };
644 $cmd =~ /^l$/ && do {
646 $cmd = 'l ' . $start . '-' . ($start + $incr); };
647 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
650 $incr = $window - 1 unless $incr;
651 $cmd = 'l ' . $start . '-' . ($start + $incr); };
652 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
653 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
654 $end = $max if $end > $max;
656 $i = $line if $i eq '.';
660 print $OUT "\032\032$filename:$i:0\n";
663 for (; $i <= $end; $i++) {
664 ($stop,$action) = split(/\0/, $dbline{$i});
666 and $filename eq $filename_ini)
668 : ($dbline[$i]+0 ? ':' : ' ') ;
669 $arrow .= 'b' if $stop;
670 $arrow .= 'a' if $action;
671 print $OUT "$i$arrow\t", $dbline[$i];
672 $i++, last if $signal;
674 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
676 $start = $i; # remember in case they want more
677 $start = $max if $start > $max;
679 $cmd =~ /^D$/ && do {
680 print $OUT "Deleting all breakpoints...\n";
682 for $file (keys %had_breakpoints) {
683 local *dbline = $main::{'_<' . $file};
687 for ($i = 1; $i <= $max ; $i++) {
688 if (defined $dbline{$i}) {
689 $dbline{$i} =~ s/^[^\0]+//;
690 if ($dbline{$i} =~ s/^\0?$//) {
697 undef %postponed_file;
698 undef %break_on_load;
699 undef %had_breakpoints;
701 $cmd =~ /^L$/ && do {
703 for $file (keys %had_breakpoints) {
704 local *dbline = $main::{'_<' . $file};
708 for ($i = 1; $i <= $max; $i++) {
709 if (defined $dbline{$i}) {
710 print $OUT "$file:\n" unless $was++;
711 print $OUT " $i:\t", $dbline[$i];
712 ($stop,$action) = split(/\0/, $dbline{$i});
713 print $OUT " break if (", $stop, ")\n"
715 print $OUT " action: ", $action, "\n"
722 print $OUT "Postponed breakpoints in subroutines:\n";
724 for $subname (keys %postponed) {
725 print $OUT " $subname\t$postponed{$subname}\n";
729 my @have = map { # Combined keys
730 keys %{$postponed_file{$_}}
731 } keys %postponed_file;
733 print $OUT "Postponed breakpoints in files:\n";
735 for $file (keys %postponed_file) {
736 my $db = $postponed_file{$file};
737 print $OUT " $file:\n";
738 for $line (sort {$a <=> $b} keys %$db) {
739 print $OUT " $line:\n";
740 my ($stop,$action) = split(/\0/, $$db{$line});
741 print $OUT " break if (", $stop, ")\n"
743 print $OUT " action: ", $action, "\n"
750 if (%break_on_load) {
751 print $OUT "Breakpoints on load:\n";
753 for $file (keys %break_on_load) {
754 print $OUT " $file\n";
759 print $OUT "Watch-expressions:\n";
761 for $expr (@to_watch) {
762 print $OUT " $expr\n";
767 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
768 my $file = $1; $file =~ s/\s+$//;
770 $break_on_load{$file} = 1;
771 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
772 $file .= '.pm', redo unless $file =~ /\./;
774 $had_breakpoints{$file} = 1;
775 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
777 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
778 my $cond = $3 || '1';
779 my ($subname, $break) = ($2, $1 eq 'postpone');
780 $subname =~ s/\'/::/;
781 $subname = "${'package'}::" . $subname
782 unless $subname =~ /::/;
783 $subname = "main".$subname if substr($subname,0,2) eq "::";
784 $postponed{$subname} = $break
785 ? "break +0 if $cond" : "compile";
787 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
790 $subname =~ s/\'/::/;
791 $subname = "${'package'}::" . $subname
792 unless $subname =~ /::/;
793 $subname = "main".$subname if substr($subname,0,2) eq "::";
794 # Filename below can contain ':'
795 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
798 local $filename = $file;
799 local *dbline = $main::{'_<' . $filename};
800 $had_breakpoints{$filename} = 1;
802 ++$i while $dbline[$i] == 0 && $i < $max;
803 $dbline{$i} =~ s/^[^\0]*/$cond/;
805 print $OUT "Subroutine $subname not found.\n";
808 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
811 if ($dbline[$i] == 0) {
812 print $OUT "Line $i not breakable.\n";
814 $had_breakpoints{$filename} = 1;
815 $dbline{$i} =~ s/^[^\0]*/$cond/;
818 $cmd =~ /^d\b\s*(\d+)?/ && do {
820 $dbline{$i} =~ s/^[^\0]*//;
821 delete $dbline{$i} if $dbline{$i} eq '';
823 $cmd =~ /^A$/ && do {
825 for $file (keys %had_breakpoints) {
826 local *dbline = $main::{'_<' . $file};
830 for ($i = 1; $i <= $max ; $i++) {
831 if (defined $dbline{$i}) {
832 $dbline{$i} =~ s/\0[^\0]*//;
833 delete $dbline{$i} if $dbline{$i} eq '';
838 $cmd =~ /^O\s*$/ && do {
843 $cmd =~ /^O\s*(\S.*)/ && do {
846 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
847 push @$pre, action($1);
849 $cmd =~ /^>>\s*(.*)/ && do {
850 push @$post, action($1);
852 $cmd =~ /^<\s*(.*)/ && do {
853 $pre = [], next CMD unless $1;
856 $cmd =~ /^>\s*(.*)/ && do {
857 $post = [], next CMD unless $1;
858 $post = [action($1)];
860 $cmd =~ /^\{\{\s*(.*)/ && do {
863 $cmd =~ /^\{\s*(.*)/ && do {
864 $pretype = [], next CMD unless $1;
867 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
869 if ($dbline[$i] == 0) {
870 print $OUT "Line $i may not have an action.\n";
872 $dbline{$i} =~ s/\0[^\0]*//;
873 $dbline{$i} .= "\0" . action($j);
876 $cmd =~ /^n$/ && do {
877 end_report(), next CMD if $finished and $level <= 1;
881 $cmd =~ /^s$/ && do {
882 end_report(), next CMD if $finished and $level <= 1;
886 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
887 end_report(), next CMD if $finished and $level <= 1;
889 # Probably not needed, since we finish an interactive
890 # sub-session anyway...
891 # local $filename = $filename;
892 # local *dbline = *dbline; # XXX Would this work?!
893 if ($i =~ /\D/) { # subroutine name
894 $subname = $package."::".$subname
895 unless $subname =~ /::/;
896 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
900 *dbline = $main::{'_<' . $filename};
901 $had_breakpoints{$filename}++;
903 ++$i while $dbline[$i] == 0 && $i < $max;
905 print $OUT "Subroutine $subname not found.\n";
910 if ($dbline[$i] == 0) {
911 print $OUT "Line $i not breakable.\n";
914 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
916 for ($i=0; $i <= $stack_depth; ) {
920 $cmd =~ /^r$/ && do {
921 end_report(), next CMD if $finished and $level <= 1;
922 $stack[$stack_depth] |= 1;
923 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
925 $cmd =~ /^R$/ && do {
926 print $OUT "Warning: some settings and command-line options may be lost!\n";
927 my (@script, @flags, $cl);
928 push @flags, '-w' if $ini_warn;
929 # Put all the old includes at the start to get
932 push @flags, '-I', $_;
934 # Arrange for setting the old INC:
935 set_list("PERLDB_INC", @ini_INC);
937 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
938 chomp ($cl = $ {'::_<-e'}[$_]);
939 push @script, '-e', $cl;
944 set_list("PERLDB_HIST",
945 $term->Features->{getHistory}
946 ? $term->GetHistory : @hist);
947 my @had_breakpoints = keys %had_breakpoints;
948 set_list("PERLDB_VISITED", @had_breakpoints);
949 set_list("PERLDB_OPT", %option);
950 set_list("PERLDB_ON_LOAD", %break_on_load);
952 for (0 .. $#had_breakpoints) {
953 my $file = $had_breakpoints[$_];
954 *dbline = $main::{'_<' . $file};
955 next unless %dbline or $postponed_file{$file};
956 (push @hard, $file), next
957 if $file =~ /^\(eval \d+\)$/;
959 @add = %{$postponed_file{$file}}
960 if $postponed_file{$file};
961 set_list("PERLDB_FILE_$_", %dbline, @add);
963 for (@hard) { # Yes, really-really...
964 # Find the subroutines in this eval
965 *dbline = $main::{'_<' . $_};
966 my ($quoted, $sub, %subs, $line) = quotemeta $_;
967 for $sub (keys %sub) {
968 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
969 $subs{$sub} = [$1, $2];
973 "No subroutines in $_, ignoring breakpoints.\n";
976 LINES: for $line (keys %dbline) {
977 # One breakpoint per sub only:
978 my ($offset, $sub, $found);
979 SUBS: for $sub (keys %subs) {
980 if ($subs{$sub}->[1] >= $line # Not after the subroutine
981 and (not defined $offset # Not caught
982 or $offset < 0 )) { # or badly caught
984 $offset = $line - $subs{$sub}->[0];
985 $offset = "+$offset", last SUBS if $offset >= 0;
988 if (defined $offset) {
990 "break $offset if $dbline{$line}";
992 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
996 set_list("PERLDB_POSTPONE", %postponed);
997 set_list("PERLDB_PRETYPE", @$pretype);
998 set_list("PERLDB_PRE", @$pre);
999 set_list("PERLDB_POST", @$post);
1000 set_list("PERLDB_TYPEAHEAD", @typeahead);
1001 $ENV{PERLDB_RESTART} = 1;
1002 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
1003 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
1004 print $OUT "exec failed: $!\n";
1006 $cmd =~ /^T$/ && do {
1007 print_trace($OUT, 1); # skip DB
1009 $cmd =~ /^W\s*$/ && do {
1011 @to_watch = @old_watch = ();
1013 $cmd =~ /^W\b\s*(.*)/s && do {
1017 $val = (defined $val) ? "'$val'" : 'undef' ;
1018 push @old_watch, $val;
1021 $cmd =~ /^\/(.*)$/ && do {
1023 $inpat =~ s:([^\\])/$:$1:;
1025 eval '$inpat =~ m'."\a$inpat\a";
1037 $start = 1 if ($start > $max);
1038 last if ($start == $end);
1039 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1041 print $OUT "\032\032$filename:$start:0\n";
1043 print $OUT "$start:\t", $dbline[$start], "\n";
1048 print $OUT "/$pat/: not found\n" if ($start == $end);
1050 $cmd =~ /^\?(.*)$/ && do {
1052 $inpat =~ s:([^\\])\?$:$1:;
1054 eval '$inpat =~ m'."\a$inpat\a";
1066 $start = $max if ($start <= 0);
1067 last if ($start == $end);
1068 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1070 print $OUT "\032\032$filename:$start:0\n";
1072 print $OUT "$start:\t", $dbline[$start], "\n";
1077 print $OUT "?$pat?: not found\n" if ($start == $end);
1079 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1080 pop(@hist) if length($cmd) > 1;
1081 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1083 print $OUT $cmd, "\n";
1085 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1088 $cmd =~ /^$rc([^$rc].*)$/ && do {
1090 pop(@hist) if length($cmd) > 1;
1091 for ($i = $#hist; $i; --$i) {
1092 last if $hist[$i] =~ /$pat/;
1095 print $OUT "No such command!\n\n";
1099 print $OUT $cmd, "\n";
1101 $cmd =~ /^$sh$/ && do {
1102 &system($ENV{SHELL}||"/bin/sh");
1104 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1105 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1107 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1108 $end = $2?($#hist-$2):0;
1109 $hist = 0 if $hist < 0;
1110 for ($i=$#hist; $i>$end; $i--) {
1111 print $OUT "$i: ",$hist[$i],"\n"
1112 unless $hist[$i] =~ /^.?$/;
1115 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1116 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1117 $cmd =~ /^=/ && do {
1118 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1119 $alias{$k}="s~$k~$v~";
1120 print $OUT "$k = $v\n";
1121 } elsif ($cmd =~ /^=\s*$/) {
1122 foreach $k (sort keys(%alias)) {
1123 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1124 print $OUT "$k = $v\n";
1126 print $OUT "$k\t$alias{$k}\n";
1131 $cmd =~ /^\|\|?\s*[^|]/ && do {
1132 if ($pager =~ /^\|/) {
1133 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1134 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1136 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1138 unless ($piped=open(OUT,$pager)) {
1139 &warn("Can't pipe output to `$pager'");
1140 if ($pager =~ /^\|/) {
1141 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1142 open(STDOUT,">&SAVEOUT")
1143 || &warn("Can't restore STDOUT");
1146 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1150 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1151 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1152 $selected= select(OUT);
1154 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1155 $cmd =~ s/^\|+\s*//;
1157 # XXX Local variants do not work!
1158 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1159 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1160 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1162 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1164 $onetimeDump = undef;
1165 } elsif ($term_pid == $$) {
1170 if ($pager =~ /^\|/) {
1171 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1172 &warn( "Pager `$pager' failed: ",
1173 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1174 ( $? & 128 ) ? " (core dumped)" : "",
1175 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1176 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1177 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1178 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1179 # Will stop ignoring SIGPIPE if done like nohup(1)
1180 # does SIGINT but Perl doesn't give us a choice.
1182 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1185 select($selected), $selected= "" unless $selected eq "";
1189 $exiting = 1 unless defined $cmd;
1190 foreach $evalarg (@$post) {
1193 } # if ($single || $signal)
1194 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1198 # The following code may be executed now:
1202 my ($al, $ret, @ret) = "";
1203 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1206 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1207 $#stack = $stack_depth;
1208 $stack[-1] = $single;
1210 $single |= 4 if $stack_depth == $deep;
1212 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
1213 # Why -1? But it works! :-(
1214 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1215 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1218 $single |= $stack[$stack_depth--];
1220 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1221 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1222 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1223 if ($doret eq $stack_depth or $frame & 16) {
1224 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1225 print $fh ' ' x $stack_depth if $frame & 16;
1226 print $fh "list context return from $sub:\n";
1227 dumpit($fh, \@ret );
1232 if (defined wantarray) {
1237 $single |= $stack[$stack_depth--];
1239 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1240 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1241 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1242 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1243 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1244 print $fh (' ' x $stack_depth) if $frame & 16;
1245 print $fh (defined wantarray
1246 ? "scalar context return from $sub: "
1247 : "void context return from $sub\n");
1248 dumpit( $fh, $ret ) if defined wantarray;
1256 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1257 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1260 # The following takes its argument via $evalarg to preserve current @_
1263 local @res; # 'my' would make it visible from user code
1265 local $otrace = $trace;
1266 local $osingle = $single;
1268 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1274 local $saved[0]; # Preserve the old value of $@
1278 } elsif ($onetimeDump eq 'dump') {
1279 dumpit($OUT, \@res);
1280 } elsif ($onetimeDump eq 'methods') {
1287 my $subname = shift;
1288 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1289 my $offset = $1 || 0;
1290 # Filename below can contain ':'
1291 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1294 local *dbline = $main::{'_<' . $file};
1295 local $^W = 0; # != 0 is magical below
1296 $had_breakpoints{$file}++;
1298 ++$i until $dbline[$i] != 0 or $i >= $max;
1299 $dbline{$i} = delete $postponed{$subname};
1301 print $OUT "Subroutine $subname not found.\n";
1305 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1306 #print $OUT "In postponed_sub for `$subname'.\n";
1310 if ($ImmediateStop) {
1314 return &postponed_sub
1315 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1316 # Cannot be done before the file is compiled
1317 local *dbline = shift;
1318 my $filename = $dbline;
1319 $filename =~ s/^_<//;
1320 $signal = 1, print $OUT "'$filename' loaded...\n"
1321 if $break_on_load{$filename};
1322 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1323 return unless $postponed_file{$filename};
1324 $had_breakpoints{$filename}++;
1325 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1327 for $key (keys %{$postponed_file{$filename}}) {
1328 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1330 delete $postponed_file{$filename};
1334 local ($savout) = select(shift);
1335 my $osingle = $single;
1336 my $otrace = $trace;
1337 $single = $trace = 0;
1340 unless (defined &main::dumpValue) {
1343 if (defined &main::dumpValue) {
1344 &main::dumpValue(shift);
1346 print $OUT "dumpvar.pl not available.\n";
1353 # Tied method do not create a context, so may get wrong message:
1357 my @sub = dump_trace($_[0] + 1, $_[1]);
1358 my $short = $_[2]; # Print short report, next one for sub name
1360 for ($i=0; $i <= $#sub; $i++) {
1363 my $args = defined $sub[$i]{args}
1364 ? "(@{ $sub[$i]{args} })"
1366 $args = (substr $args, 0, $maxtrace - 3) . '...'
1367 if length $args > $maxtrace;
1368 my $file = $sub[$i]{file};
1369 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1371 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1373 my $sub = @_ >= 4 ? $_[3] : $s;
1374 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1376 print $fh "$sub[$i]{context} = $s$args" .
1377 " called from $file" .
1378 " line $sub[$i]{line}\n";
1385 my $count = shift || 1e9;
1388 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1389 my $nothard = not $frame & 8;
1390 local $frame = 0; # Do not want to trace this.
1391 my $otrace = $trace;
1394 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1399 if (not defined $arg) {
1401 } elsif ($nothard and tied $arg) {
1403 } elsif ($nothard and $type = ref $arg) {
1404 push @a, "ref($type)";
1406 local $_ = "$arg"; # Safe to stringify now - should not call f().
1409 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1410 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1411 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1415 $context = $context ? '@' : (defined $context ? "\$" : '.');
1416 $args = $h ? [@a] : undef;
1417 $e =~ s/\n\s*\;\s*\Z// if $e;
1418 $e =~ s/([\\\'])/\\$1/g if $e;
1420 $sub = "require '$e'";
1421 } elsif (defined $r) {
1423 } elsif ($sub eq '(eval)') {
1424 $sub = "eval {...}";
1426 push(@sub, {context => $context, sub => $sub, args => $args,
1427 file => $file, line => $line});
1436 while ($action =~ s/\\$//) {
1447 &readline("cont: ");
1451 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1452 # many non-Unix systems can do system() but have problems with fork().
1453 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1454 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1455 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1456 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1458 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1459 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1460 close(SAVEIN); close(SAVEOUT);
1461 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1462 ( $? & 128 ) ? " (core dumped)" : "",
1463 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1470 eval { require Term::ReadLine } or die $@;
1473 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1474 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1477 my $sel = select($OUT);
1481 eval "require Term::Rendezvous;" or die $@;
1482 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1483 my $term_rv = new Term::Rendezvous $rv;
1485 $OUT = $term_rv->OUT;
1489 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1491 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1493 $rl_attribs = $term->Attribs;
1494 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1495 if defined $rl_attribs->{basic_word_break_characters}
1496 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1497 $rl_attribs->{special_prefixes} = '$@&%';
1498 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1499 $rl_attribs->{completion_function} = \&db_complete;
1501 $LINEINFO = $OUT unless defined $LINEINFO;
1502 $lineinfo = $console unless defined $lineinfo;
1504 if ($term->Features->{setHistory} and "@hist" ne "?") {
1505 $term->SetHistory(@hist);
1507 ornaments($ornaments) if defined $ornaments;
1511 sub resetterm { # We forked, so we need a different TTY
1513 if (defined &get_fork_TTY) {
1515 } elsif (not defined $fork_TTY
1516 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1517 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1518 # Possibly _inside_ XTERM
1519 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1524 if (defined $fork_TTY) {
1529 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1530 Define B<\$DB::fork_TTY>
1531 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1532 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1533 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1534 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1541 my $left = @typeahead;
1542 my $got = shift @typeahead;
1543 print $OUT "auto(-$left)", shift, $got, "\n";
1544 $term->AddHistory($got)
1545 if length($got) > 1 and defined $term->Features->{addHistory};
1550 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1553 $IN->recv( $stuff, 2048 );
1557 $term->readline(@_);
1562 my ($opt, $val)= @_;
1563 $val = option_val($opt,'N/A');
1564 $val =~ s/([\\\'])/\\$1/g;
1565 printf $OUT "%20s = '%s'\n", $opt, $val;
1569 my ($opt, $default)= @_;
1571 if (defined $optionVars{$opt}
1572 and defined $ {$optionVars{$opt}}) {
1573 $val = $ {$optionVars{$opt}};
1574 } elsif (defined $optionAction{$opt}
1575 and defined &{$optionAction{$opt}}) {
1576 $val = &{$optionAction{$opt}}();
1577 } elsif (defined $optionAction{$opt}
1578 and not defined $option{$opt}
1579 or defined $optionVars{$opt}
1580 and not defined $ {$optionVars{$opt}}) {
1583 $val = $option{$opt};
1591 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1592 my ($opt,$sep) = ($1,$2);
1595 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1597 #&dump_option($opt);
1598 } elsif ($sep !~ /\S/) {
1600 } elsif ($sep eq "=") {
1603 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1604 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1605 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1606 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1608 $val =~ s/\\([\\$end])/$1/g;
1612 grep( /^\Q$opt/ && ($option = $_), @options );
1613 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1615 print $OUT "Unknown option `$opt'\n" unless $matches;
1616 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1617 $option{$option} = $val if $matches == 1 and defined $val;
1618 eval "local \$frame = 0; local \$doret = -2;
1619 require '$optionRequire{$option}'"
1620 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1621 $ {$optionVars{$option}} = $val
1623 and defined $optionVars{$option} and defined $val;
1624 & {$optionAction{$option}} ($val)
1626 and defined $optionAction{$option}
1627 and defined &{$optionAction{$option}} and defined $val;
1628 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1634 my ($stem,@list) = @_;
1636 $ENV{"$ {stem}_n"} = @list;
1637 for $i (0 .. $#list) {
1639 $val =~ s/\\/\\\\/g;
1640 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1641 $ENV{"$ {stem}_$i"} = $val;
1648 my $n = delete $ENV{"$ {stem}_n"};
1650 for $i (0 .. $n - 1) {
1651 $val = delete $ENV{"$ {stem}_$i"};
1652 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1660 return; # Put nothing on the stack - malloc/free land!
1664 my($msg)= join("",@_);
1665 $msg .= ": $!\n" unless $msg =~ /\n$/;
1670 if (@_ and $term and $term->Features->{newTTY}) {
1671 my ($in, $out) = shift;
1673 ($in, $out) = split /,/, $in, 2;
1677 open IN, $in or die "cannot open `$in' for read: $!";
1678 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1679 $term->newTTY(\*IN, \*OUT);
1683 } elsif ($term and @_) {
1684 &warn("Too late to set TTY, enabled on next `R'!\n");
1692 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1694 $notty = shift if @_;
1700 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1708 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
1710 $remoteport = shift if @_;
1715 if ($ {$term->Features}{tkRunning}) {
1716 return $term->tkRunning(@_);
1718 print $OUT "tkRunning not supported by current ReadLine package.\n";
1725 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1727 $runnonstop = shift if @_;
1734 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1741 $sh = quotemeta shift;
1742 $sh .= "\\b" if $sh =~ /\w$/;
1746 $psh =~ s/\\(.)/$1/g;
1752 if (defined $term) {
1753 local ($warnLevel,$dieLevel) = (0, 1);
1754 return '' unless $term->Features->{ornaments};
1755 eval { $term->ornaments(@_) } || '';
1763 $rc = quotemeta shift;
1764 $rc .= "\\b" if $rc =~ /\w$/;
1768 $prc =~ s/\\(.)/$1/g;
1774 return $lineinfo unless @_;
1776 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1777 $emacs = ($stream =~ /^\|/);
1778 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1779 $LINEINFO = \*LINEINFO;
1780 my $save = select($LINEINFO);
1794 s/^Term::ReadLine::readline$/readline/;
1795 if (defined $ { $_ . '::VERSION' }) {
1796 $version{$file} = "$ { $_ . '::VERSION' } from ";
1798 $version{$file} .= $INC{$file};
1800 dumpit($OUT,\%version);
1806 B<s> [I<expr>] Single step [in I<expr>].
1807 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1808 <B<CR>> Repeat last B<n> or B<s> command.
1809 B<r> Return from current subroutine.
1810 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1811 at the specified position.
1812 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1813 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1814 B<l> I<line> List single I<line>.
1815 B<l> I<subname> List first window of lines from subroutine.
1816 B<l> List next window of lines.
1817 B<-> List previous window of lines.
1818 B<w> [I<line>] List window around I<line>.
1819 B<.> Return to the executed line.
1820 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
1821 I<filename> may be either the full name of the file, or a regular
1822 expression matching the full file name:
1823 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
1824 Evals (with saved bodies) are considered to be filenames:
1825 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
1826 (in the order of execution).
1827 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1828 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1829 B<L> List all breakpoints and actions.
1830 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1831 B<t> Toggle trace mode.
1832 B<t> I<expr> Trace through execution of I<expr>.
1833 B<b> [I<line>] [I<condition>]
1834 Set breakpoint; I<line> defaults to the current execution line;
1835 I<condition> breaks if it evaluates to true, defaults to '1'.
1836 B<b> I<subname> [I<condition>]
1837 Set breakpoint at first line of subroutine.
1838 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1839 B<b> B<postpone> I<subname> [I<condition>]
1840 Set breakpoint at first line of subroutine after
1842 B<b> B<compile> I<subname>
1843 Stop after the subroutine is compiled.
1844 B<d> [I<line>] Delete the breakpoint for I<line>.
1845 B<D> Delete all breakpoints.
1846 B<a> [I<line>] I<command>
1847 Set an action to be done before the I<line> is executed.
1848 Sequence is: check for breakpoint/watchpoint, print line
1849 if necessary, do action, prompt user if necessary,
1851 B<A> Delete all actions.
1852 B<W> I<expr> Add a global watch-expression.
1853 B<W> Delete all watch-expressions.
1854 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1855 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1856 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1857 B<x> I<expr> Evals expression in array context, dumps the result.
1858 B<m> I<expr> Evals expression in array context, prints methods callable
1859 on the first element of the result.
1860 B<m> I<class> Prints methods callable via the given class.
1861 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1862 Set or query values of options. I<val> defaults to 1. I<opt> can
1863 be abbreviated. Several options can be listed.
1864 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1865 I<pager>: program for output of \"|cmd\";
1866 I<tkRunning>: run Tk while prompting (with ReadLine);
1867 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1868 I<inhibit_exit> Allows stepping off the end of the script.
1869 I<ImmediateStop> Debugger should stop as early as possible.
1870 I<RemotePort>: Remote hostname:port for remote debugging
1871 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1872 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1873 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1874 I<globPrint>: whether to print contents of globs;
1875 I<DumpDBFiles>: dump arrays holding debugged files;
1876 I<DumpPackages>: dump symbol tables of packages;
1877 I<DumpReused>: dump contents of \"reused\" addresses;
1878 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1879 I<bareStringify>: Do not print the overload-stringified value;
1880 Option I<PrintRet> affects printing of return value after B<r> command,
1881 I<frame> affects printing messages on entry and exit from subroutines.
1882 I<AutoTrace> affects printing messages on every possible breaking point.
1883 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1884 I<ornaments> affects screen appearance of the command line.
1885 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1886 You can put additional initialization options I<TTY>, I<noTTY>,
1887 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
1888 `B<R>' after you set them).
1889 B<<> I<expr> Define Perl command to run before each prompt.
1890 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1891 B<>> I<expr> Define Perl command to run after each prompt.
1892 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1893 B<{> I<db_command> Define debugger command to run before each prompt.
1894 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1895 B<$prc> I<number> Redo a previous command (default previous command).
1896 B<$prc> I<-number> Redo number'th-to-last command.
1897 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1898 See 'B<O> I<recallCommand>' too.
1899 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1900 . ( $rc eq $sh ? "" : "
1901 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1902 See 'B<O> I<shellBang>' too.
1903 B<H> I<-number> Display last number commands (default all).
1904 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1905 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1906 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1907 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1908 I<command> Execute as a perl statement in current package.
1909 B<v> Show versions of loaded modules.
1910 B<R> Pure-man-restart of debugger, some of debugger state
1911 and command-line options may be lost.
1912 Currently the following setting are preserved:
1913 history, breakpoints and actions, debugger B<O>ptions
1914 and the following command-line options: I<-w>, I<-I>, I<-e>.
1915 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1916 Complete description of debugger is available in B<perldebug>
1917 section of Perl documention
1918 B<h h> Summary of debugger commands.
1919 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1922 $summary = <<"END_SUM";
1923 I<List/search source lines:> I<Control script execution:>
1924 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1925 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1926 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1927 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
1928 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1929 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1930 I<Debugger controls:> B<L> List break/watch/actions
1931 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1932 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
1933 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1934 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1935 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1936 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1937 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1938 B<q> or B<^D> Quit B<R> Attempt a restart
1939 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1940 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1941 B<p> I<expr> Print expression (uses script's current package).
1942 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1943 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1944 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1945 I<More help for> B<db_cmd>I<:> Type B<h> I<cmd_letter> Run B<perldoc perldebug> for more help.
1947 # ')}}; # Fix balance of Emacs parsing
1951 my $message = shift;
1952 if (@Term::ReadLine::TermCap::rl_term_set) {
1953 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1954 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1956 print $OUT $message;
1962 $SIG{'ABRT'} = 'DEFAULT';
1963 kill 'ABRT', $$ if $panic++;
1964 if (defined &Carp::longmess) {
1965 local $SIG{__WARN__} = '';
1966 local $Carp::CarpLevel = 2; # mydie + confess
1967 &warn(Carp::longmess("Signal @_"));
1970 print $DB::OUT "Got signal @_\n";
1978 local $SIG{__WARN__} = '';
1979 local $SIG{__DIE__} = '';
1980 eval { require Carp } if defined $^S; # If error/warning during compilation,
1981 # require may be broken.
1982 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1983 return unless defined &Carp::longmess;
1984 my ($mysingle,$mytrace) = ($single,$trace);
1985 $single = 0; $trace = 0;
1986 my $mess = Carp::longmess(@_);
1987 ($single,$trace) = ($mysingle,$mytrace);
1994 local $SIG{__DIE__} = '';
1995 local $SIG{__WARN__} = '';
1996 my $i = 0; my $ineval = 0; my $sub;
1997 if ($dieLevel > 2) {
1998 local $SIG{__WARN__} = \&dbwarn;
1999 &warn(@_); # Yell no matter what
2002 if ($dieLevel < 2) {
2003 die @_ if $^S; # in eval propagate
2005 eval { require Carp } if defined $^S; # If error/warning during compilation,
2006 # require may be broken.
2007 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2008 unless defined &Carp::longmess;
2009 # We do not want to debug this chunk (automatic disabling works
2010 # inside DB::DB, but not in Carp).
2011 my ($mysingle,$mytrace) = ($single,$trace);
2012 $single = 0; $trace = 0;
2013 my $mess = Carp::longmess(@_);
2014 ($single,$trace) = ($mysingle,$mytrace);
2020 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2023 $SIG{__WARN__} = \&DB::dbwarn;
2025 $SIG{__WARN__} = $prevwarn;
2033 $prevdie = $SIG{__DIE__} unless $dieLevel;
2036 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2037 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2038 print $OUT "Stack dump during die enabled",
2039 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2041 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2043 $SIG{__DIE__} = $prevdie;
2044 print $OUT "Default die handler restored.\n";
2052 $prevsegv = $SIG{SEGV} unless $signalLevel;
2053 $prevbus = $SIG{BUS} unless $signalLevel;
2054 $signalLevel = shift;
2056 $SIG{SEGV} = \&DB::diesignal;
2057 $SIG{BUS} = \&DB::diesignal;
2059 $SIG{SEGV} = $prevsegv;
2060 $SIG{BUS} = $prevbus;
2068 return unless defined &$subr;
2070 $subr = \&$subr; # Hard reference
2073 $s = $_, last if $subr eq \&$_;
2081 $class = ref $class if ref $class;
2084 methods_via($class, '', 1);
2085 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2090 return if $packs{$class}++;
2092 my $prepend = $prefix ? "via $prefix: " : '';
2094 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2095 sort keys %{"$ {class}::"}) {
2096 next if $seen{ $name }++;
2097 print $DB::OUT "$prepend$name\n";
2099 return unless shift; # Recurse?
2100 for $name (@{"$ {class}::ISA"}) {
2101 $prepend = $prefix ? $prefix . " -> $name" : $name;
2102 methods_via($name, $prepend, 1);
2106 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2108 BEGIN { # This does not compile, alas.
2109 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2110 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2114 $deep = 100; # warning if stack gets this deep
2118 $SIG{INT} = \&DB::catch;
2119 # This may be enabled to debug debugger:
2120 #$warnLevel = 1 unless defined $warnLevel;
2121 #$dieLevel = 1 unless defined $dieLevel;
2122 #$signalLevel = 1 unless defined $signalLevel;
2124 $db_stop = 0; # Compiler warning
2126 $level = 0; # Level of recursive debugging
2127 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2128 # Triggers bug (?) in perl is we postpone this until runtime:
2129 @postponed = @stack = (0);
2130 $stack_depth = 0; # Localized $#stack
2135 BEGIN {$^W = $ini_warn;} # Switch warnings back
2137 #use Carp; # This did break, left for debuggin
2140 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2141 my($text, $line, $start) = @_;
2142 my ($itext, $search, $prefix, $pack) =
2143 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2145 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2146 (map { /$search/ ? ($1) : () } keys %sub)
2147 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2148 return sort grep /^\Q$text/, values %INC # files
2149 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2150 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2151 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2152 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2153 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2155 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2157 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2158 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2159 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2160 # We may want to complete to (eval 9), so $text may be wrong
2161 $prefix = length($1) - length($text);
2164 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2166 if ((substr $text, 0, 1) eq '&') { # subroutines
2167 $text = substr $text, 1;
2169 return sort map "$prefix$_",
2172 (map { /$search/ ? ($1) : () }
2175 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2176 $pack = ($1 eq 'main' ? '' : $1) . '::';
2177 $prefix = (substr $text, 0, 1) . $1 . '::';
2180 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2181 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2182 return db_complete($out[0], $line, $start);
2186 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2187 $pack = ($package eq 'main' ? '' : $package) . '::';
2188 $prefix = substr $text, 0, 1;
2189 $text = substr $text, 1;
2190 my @out = map "$prefix$_", grep /^\Q$text/,
2191 (grep /^_?[a-zA-Z]/, keys %$pack),
2192 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2193 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2194 return db_complete($out[0], $line, $start);
2198 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2199 my @out = grep /^\Q$text/, @options;
2200 my $val = option_val($out[0], undef);
2202 if (not defined $val or $val =~ /[\n\r]/) {
2203 # Can do nothing better
2204 } elsif ($val =~ /\s/) {
2206 foreach $l (split //, qq/\"\'\#\|/) {
2207 $out = "$l$val$l ", last if (index $val, $l) == -1;
2212 # Default to value if one completion, to question if many
2213 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2216 return $term->filename_list($text); # filenames
2220 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2224 $finished = $inhibit_exit; # So that some keys may be disabled.
2225 # Do not stop in at_exit() and destructors on exit:
2226 $DB::single = !$exiting && !$runnonstop;
2227 DB::fake::at_exit() unless $exiting or $runnonstop;
2233 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2236 package DB; # Do not trace this 1; below!