3 # Debugger for Perl 5.00x; perl5db.pl patch level:
5 $header = 'perl5db.pl patch level 0.94';
7 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
8 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
10 # modified Perl debugger, to be run from Emacs in perldb-mode
11 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
12 # Johan Vromans -- upgrade to 4.0 pl 10
13 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
16 # This file is automatically included if you do perl -d.
17 # It's probably not useful to include this yourself.
19 # Perl supplies the values for @line and %sub. It effectively inserts
20 # a &DB'DB(<linenum>); in front of every place that can have a
21 # breakpoint. Instead of a subroutine call it calls &DB::sub with
22 # $DB::sub being the called subroutine. It also inserts a BEGIN
23 # {require 'perl5db.pl'} before the first line.
25 # Note that no subroutine call is possible until &DB::sub is defined
26 # (for subroutines defined outside this file). In fact the same is
27 # true if $deep is not defined.
32 # At start reads $rcfile that may set important options. This file
33 # may define a subroutine &afterinit that will be executed after the
34 # debugger is initialized.
36 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
37 # it as a rest of `O ...' line in debugger prompt.
39 # The options that can be specified only at startup:
40 # [To set in $rcfile, call &parse_options("optionName=new_value").]
42 # TTY - the TTY to use for debugging i/o.
44 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
45 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
46 # Term::Rendezvous. Current variant is to have the name of TTY in this
49 # ReadLine - If false, dummy ReadLine is used, so you can debug
50 # ReadLine applications.
52 # NonStop - if true, no i/o is performed until interrupt.
54 # LineInfo - file or pipe to print line number info to. If it is a
55 # pipe, a short "emacs like" message is used.
57 # Example $rcfile: (delete leading hashes!)
59 # &parse_options("NonStop=1 LineInfo=db.out");
60 # sub afterinit { $trace = 1; }
62 # The script will run without human intervention, putting trace
63 # information into db.out. (If you interrupt it, you would better
64 # reset LineInfo to something "interactive"!)
67 # Needed for the statement after exec():
69 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
70 local($^W) = 0; # Switch run-time warnings off during init.
74 $dumpvar::dumpDBFiles,
75 $dumpvar::dumpPackages,
76 $dumpvar::quoteHighBit,
87 # Command-line + PERLLIB:
90 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
92 $trace = $signal = $single = 0; # Uninitialized warning suppression
93 # (local $^W cannot help - other packages!).
96 $option{PrintRet} = 1;
98 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
99 compactDump veryCompact quote HighBit undefPrint
100 globPrint PrintRet UsageOnly frame
101 TTY noTTY ReadLine NonStop LineInfo
102 recallCommand ShellBang pager tkRunning
103 signalLevel warnLevel dieLevel);
106 hashDepth => \$dumpvar::hashDepth,
107 arrayDepth => \$dumpvar::arrayDepth,
108 DumpDBFiles => \$dumpvar::dumpDBFiles,
109 DumpPackages => \$dumpvar::dumpPackages,
110 HighBit => \$dumpvar::quoteHighBit,
111 undefPrint => \$dumpvar::printUndef,
112 globPrint => \$dumpvar::globPrint,
113 tkRunning => \$readline::Tk_toloop,
114 UsageOnly => \$dumpvar::usageOnly,
119 compactDump => \&dumpvar::compactDump,
120 veryCompact => \&dumpvar::veryCompact,
121 quote => \&dumpvar::quote,
124 ReadLine => \&ReadLine,
125 NonStop => \&NonStop,
126 LineInfo => \&LineInfo,
127 recallCommand => \&recallCommand,
128 ShellBang => \&shellBang,
130 signalLevel => \&signalLevel,
131 warnLevel => \&warnLevel,
132 dieLevel => \&dieLevel,
136 compactDump => 'dumpvar.pl',
137 veryCompact => 'dumpvar.pl',
138 quote => 'dumpvar.pl',
141 # These guys may be defined in $ENV{PERL5DB} :
142 $rl = 1 unless defined $rl;
143 warnLevel($warnLevel);
145 signalLevel($signalLevel);
146 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
147 &recallCommand("!") unless defined $prc;
148 &shellBang("!") unless defined $psh;
153 $rcfile="perldb.ini";
158 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
159 do "$ENV{LOGDIR}/$rcfile";
160 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
161 do "$ENV{HOME}/$rcfile";
164 if (defined $ENV{PERLDB_OPTS}) {
165 parse_options($ENV{PERLDB_OPTS});
168 if (exists $ENV{PERLDB_RESTART}) {
169 delete $ENV{PERLDB_RESTART};
171 @hist = get_list('PERLDB_HIST');
172 my @visited = get_list("PERLDB_VISITED");
173 for (0 .. $#visited) {
174 %{$postponed{$visited[$_]}} = get_list("PERLDB_FILE_$_");
176 my %opt = get_list("PERLDB_OPT");
178 while (($opt,$val) = each %opt) {
179 $val =~ s/[\\\']/\\$1/g;
180 parse_options("$opt'$val'");
182 @INC = get_list("PERLDB_INC");
189 # Is Perl being run from Emacs?
190 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
191 $rl = 0, shift(@main::ARGV) if $emacs;
193 #require Term::ReadLine;
196 $console = "/dev/tty";
200 $console = "sys\$command";
204 if (defined $ENV{OS2_SHELL} and $emacs) { # In OS/2
208 $console = $tty if defined $tty;
210 if (defined $console) {
211 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
212 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
213 || open(OUT,">&STDOUT"); # so we don't dongle stdout
216 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
217 $console = 'STDIN/OUT';
219 # so open("|more") can read from STDOUT and so we don't dingle stdin
224 $| = 1; # for DB::OUT
227 $LINEINFO = $OUT unless defined $LINEINFO;
228 $lineinfo = $console unless defined $lineinfo;
230 $| = 1; # for real STDOUT
232 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
233 unless ($runnonstop) {
234 print $OUT "\nLoading DB routines from $header\n";
235 print $OUT ("Emacs support ",
236 $emacs ? "enabled" : "available",
238 print $OUT "\nEnter h or `h h' for help.\n\n";
245 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
248 if (defined &afterinit) { # May be defined in $rcfile
252 ############################################################ Subroutines
255 unless ($first_time++) { # Do when-running init
256 if ($runnonstop) { # Disable until signal
257 for ($i=0; $i <= $#stack; ) {
263 # Define a subroutine in which we will stop
265 # sub at_end::db {"Debuggee terminating";}
268 # print $OUT "Debuggee terminating.\n";
275 if ($option{PrintRet}) {
276 print $OUT "$retctx context return from $lastsub:",
277 ($retctx eq 'list') ? "\n" : " " ;
278 dumpit( ($retctx eq 'list') ? \@ret : $ret );
281 ($package, $filename, $line) = caller;
282 $filename_ini = $filename;
283 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
284 "package $package;"; # this won't let them modify, alas
285 local(*dbline) = "::_<$filename";
286 install_breakpoints($filename) unless $visited{$filename}++;
288 if (($stop,$action) = split(/\0/,$dbline{$line})) {
292 $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
293 $dbline{$line} =~ s/;9($|\0)/$1/;
296 if ($single || $trace || $signal) {
299 $position = "\032\032$filename:$line:0\n";
300 print $LINEINFO $position;
303 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
304 $prefix .= "$sub($filename:";
305 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
306 if (length($prefix) > 30) {
307 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
308 print $LINEINFO $position;
313 $position = "$prefix$line$infix$dbline[$line]$after";
314 print $LINEINFO $position;
316 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
317 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
318 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
319 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
320 print $LINEINFO $incr_pos;
321 $position .= $incr_pos;
325 $evalarg = $action, &eval if $action;
326 if ($single || $signal) {
327 local $level = $level + 1;
328 $evalarg = $pre, &eval if $pre;
329 print $OUT $#stack . " levels deep in subroutine calls!\n"
333 while (($term || &setterm),
334 defined ($cmd=&readline(" DB" . ('<' x $level) .
335 ($#hist+1) . ('>' x $level) .
337 #{ # <-- Do we know what this brace is for?
340 $cmd =~ s/\\$/\n/ && do {
341 $cmd .= &readline(" cont: ");
344 $cmd =~ /^q$/ && exit 0;
345 $cmd =~ /^$/ && ($cmd = $laststep);
346 push(@hist,$cmd) if length($cmd) > 1;
348 ($i) = split(/\s+/,$cmd);
349 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
350 $cmd =~ /^h$/ && do {
353 $cmd =~ /^h\s+h$/ && do {
356 $cmd =~ /^h\s+(\S)$/ && do {
358 if ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/m) {
361 print $OUT "`$asked' is not a debugger command.\n";
364 $cmd =~ /^t$/ && do {
366 print $OUT "Trace = ".($trace?"on":"off")."\n";
368 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
369 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
370 foreach $subname (sort(keys %sub)) {
371 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
372 print $OUT $subname,"\n";
376 $cmd =~ s/^X\b/V $package/;
377 $cmd =~ /^V$/ && do {
378 $cmd = "V $package"; };
379 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
380 local ($savout) = select($OUT);
382 @vars = split(' ',$2);
383 do 'dumpvar.pl' unless defined &main::dumpvar;
384 if (defined &main::dumpvar) {
386 &main::dumpvar($packname,@vars);
388 print $OUT "dumpvar.pl not available.\n";
392 $cmd =~ s/^x\b/ / && do { # So that will be evaled
394 $cmd =~ /^f\b\s*(.*)/ && do {
397 print $OUT "The old f command is now the r command.\n";
398 print $OUT "The new f command switches filenames.\n";
401 if (!defined $main::{'_<' . $file}) {
402 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
403 $file = substr($try,2);
407 if (!defined $main::{'_<' . $file}) {
408 print $OUT "There's no code here matching $file.\n";
410 } elsif ($file ne $filename) {
411 *dbline = "::_<$file";
418 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
420 $subname =~ s/\'/::/;
421 $subname = "main::".$subname unless $subname =~ /::/;
422 $subname = "main".$subname if substr($subname,0,2) eq "::";
423 @pieces = split(/:/,$sub{$subname});
424 $subrange = pop @pieces;
425 $file = join(':', @pieces);
426 if ($file ne $filename) {
427 *dbline = "::_<$file";
433 if (eval($subrange) < -$window) {
434 $subrange =~ s/-.*/+/;
436 $cmd = "l $subrange";
438 print $OUT "Subroutine $subname not found.\n";
441 $cmd =~ /^\.$/ && do {
443 $filename = $filename_ini;
444 *dbline = "::_<$filename";
446 print $LINEINFO $position;
448 $cmd =~ /^w\b\s*(\d*)$/ && do {
452 #print $OUT 'l ' . $start . '-' . ($start + $incr);
453 $cmd = 'l ' . $start . '-' . ($start + $incr); };
454 $cmd =~ /^-$/ && do {
456 $cmd = 'l ' . ($start-$window*2) . '+'; };
457 $cmd =~ /^l$/ && do {
459 $cmd = 'l ' . $start . '-' . ($start + $incr); };
460 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
463 $incr = $window - 1 unless $incr;
464 $cmd = 'l ' . $start . '-' . ($start + $incr); };
465 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
466 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
467 $end = $max if $end > $max;
469 $i = $line if $i eq '.';
472 print $OUT "\032\032$filename:$i:0\n";
475 for (; $i <= $end; $i++) {
476 ($stop,$action) = split(/\0/, $dbline{$i});
478 and $filename eq $filename_ini)
481 $arrow .= 'b' if $stop;
482 $arrow .= 'a' if $action;
483 print $OUT "$i$arrow\t", $dbline[$i];
487 $start = $i; # remember in case they want more
488 $start = $max if $start > $max;
490 $cmd =~ /^D$/ && do {
491 print $OUT "Deleting all breakpoints...\n";
492 for ($i = 1; $i <= $max ; $i++) {
493 if (defined $dbline{$i}) {
494 $dbline{$i} =~ s/^[^\0]+//;
495 if ($dbline{$i} =~ s/^\0?$//) {
501 $cmd =~ /^L$/ && do {
502 for ($i = 1; $i <= $max; $i++) {
503 if (defined $dbline{$i}) {
504 print $OUT "$i:\t", $dbline[$i];
505 ($stop,$action) = split(/\0/, $dbline{$i});
506 print $OUT " break if (", $stop, ")\n"
508 print $OUT " action: ", $action, "\n"
514 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
517 $subname =~ s/\'/::/;
518 $subname = "${'package'}::" . $subname
519 unless $subname =~ /::/;
520 $subname = "main".$subname if substr($subname,0,2) eq "::";
521 # Filename below can contain ':'
522 ($file,$i) = ($sub{$subname} =~ /^(.*):(.*)$/);
526 *dbline = "::_<$filename";
527 $visited{$filename}++;
529 ++$i while $dbline[$i] == 0 && $i < $max;
530 $dbline{$i} =~ s/^[^\0]*/$cond/;
532 print $OUT "Subroutine $subname not found.\n";
535 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
538 if ($dbline[$i] == 0) {
539 print $OUT "Line $i not breakable.\n";
541 $dbline{$i} =~ s/^[^\0]*/$cond/;
544 $cmd =~ /^d\b\s*(\d+)?/ && do {
546 $dbline{$i} =~ s/^[^\0]*//;
547 delete $dbline{$i} if $dbline{$i} eq '';
549 $cmd =~ /^A$/ && do {
550 for ($i = 1; $i <= $max ; $i++) {
551 if (defined $dbline{$i}) {
552 $dbline{$i} =~ s/\0[^\0]*//;
553 delete $dbline{$i} if $dbline{$i} eq '';
557 $cmd =~ /^O\s*$/ && do {
562 $cmd =~ /^O\s*(\S.*)/ && do {
565 $cmd =~ /^<\s*(.*)/ && do {
568 $cmd =~ /^>\s*(.*)/ && do {
571 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
573 if ($dbline[$i] == 0) {
574 print $OUT "Line $i may not have an action.\n";
576 $dbline{$i} =~ s/\0[^\0]*//;
577 $dbline{$i} .= "\0" . action($j);
580 $cmd =~ /^n$/ && do {
584 $cmd =~ /^s$/ && do {
588 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
590 if ($i =~ /\D/) { # subroutine name
591 ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/);
595 *dbline = "::_<$filename";
596 $visited{$filename}++;
598 ++$i while $dbline[$i] == 0 && $i < $max;
600 print $OUT "Subroutine $subname not found.\n";
605 if ($dbline[$i] == 0) {
606 print $OUT "Line $i not breakable.\n";
609 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
611 for ($i=0; $i <= $#stack; ) {
615 $cmd =~ /^r$/ && do {
616 $stack[$#stack] |= 1;
619 $cmd =~ /^R$/ && do {
620 print $OUT "Warning: a lot of settings and command-line options may be lost!\n";
621 my (@script, @flags, $cl);
622 push @flags, '-w' if $ini_warn;
623 # Put all the old includes at the start to get
626 push @flags, '-I', $_;
628 # Arrange for setting the old INC:
629 set_list("PERLDB_INC", @ini_INC);
631 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
632 chomp ($cl = $ {'::_<-e'}[$_]);
633 push @script, '-e', $cl;
638 set_list("PERLDB_HIST",
639 $term->Features->{getHistory}
640 ? $term->GetHistory : @hist);
641 my @visited = keys %visited;
642 set_list("PERLDB_VISITED", @visited);
643 set_list("PERLDB_OPT", %option);
644 for (0 .. $#visited) {
645 *dbline = "::_<$visited[$_]";
646 set_list("PERLDB_FILE_$_", %dbline);
648 $ENV{PERLDB_RESTART} = 1;
649 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
650 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
651 print $OUT "exec failed: $!\n";
653 $cmd =~ /^T$/ && do {
654 local($p,$f,$l,$s,$h,$a,$e,$r,@a,@sub);
656 ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i);
663 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
664 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
665 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
668 $w = $w ? '@ = ' : '$ = ';
669 $a = $h ? '(' . join(', ', @a) . ')' : '';
670 $e =~ s/\n\s*\;\s*\Z// if $e;
671 $e =~ s/[\\\']/\\$1/g if $e;
674 } elsif (defined $r) {
676 } elsif ($s eq '(eval)') {
679 $f = "file `$f'" unless $f eq '-e';
680 push(@sub, "$w$s$a called from $f line $l\n");
683 for ($i=0; $i <= $#sub; $i++) {
688 $cmd =~ /^\/(.*)$/ && do {
690 $inpat =~ s:([^\\])/$:$1:;
692 eval '$inpat =~ m'."\a$inpat\a";
703 $start = 1 if ($start > $max);
704 last if ($start == $end);
705 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
707 print $OUT "\032\032$filename:$start:0\n";
709 print $OUT "$start:\t", $dbline[$start], "\n";
714 print $OUT "/$pat/: not found\n" if ($start == $end);
716 $cmd =~ /^\?(.*)$/ && do {
718 $inpat =~ s:([^\\])\?$:$1:;
720 eval '$inpat =~ m'."\a$inpat\a";
731 $start = $max if ($start <= 0);
732 last if ($start == $end);
733 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
735 print $OUT "\032\032$filename:$start:0\n";
737 print $OUT "$start:\t", $dbline[$start], "\n";
742 print $OUT "?$pat?: not found\n" if ($start == $end);
744 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
745 pop(@hist) if length($cmd) > 1;
746 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
747 $cmd = $hist[$i] . "\n";
750 $cmd =~ /^$sh$sh\s*/ && do {
753 $cmd =~ /^$rc([^$rc].*)$/ && do {
755 pop(@hist) if length($cmd) > 1;
756 for ($i = $#hist; $i; --$i) {
757 last if $hist[$i] =~ /$pat/;
760 print $OUT "No such command!\n\n";
763 $cmd = $hist[$i] . "\n";
766 $cmd =~ /^$sh$/ && do {
767 &system($ENV{SHELL}||"/bin/sh");
769 $cmd =~ /^$sh\s*/ && do {
770 &system($ENV{SHELL}||"/bin/sh","-c",$');
772 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
773 $end = $2?($#hist-$2):0;
774 $hist = 0 if $hist < 0;
775 for ($i=$#hist; $i>$end; $i--) {
776 print $OUT "$i: ",$hist[$i],"\n"
777 unless $hist[$i] =~ /^.?$/;
780 $cmd =~ s/^p$/print \$DB::OUT \$_/;
781 $cmd =~ s/^p\b/print \$DB::OUT /;
783 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
784 $alias{$k}="s~$k~$v~";
785 print $OUT "$k = $v\n";
786 } elsif ($cmd =~ /^=\s*$/) {
787 foreach $k (sort keys(%alias)) {
788 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
789 print $OUT "$k = $v\n";
791 print $OUT "$k\t$alias{$k}\n";
796 $cmd =~ /^\|\|?\s*[^|]/ && do {
797 if ($pager =~ /^\|/) {
798 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
799 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
801 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
803 unless ($piped=open(OUT,$pager)) {
804 &warn("Can't pipe output to `$pager'");
805 if ($pager =~ /^\|/) {
806 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
807 open(STDOUT,">&SAVEOUT")
808 || &warn("Can't restore STDOUT");
811 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
815 $SIG{PIPE}= "DB::catch" if $pager =~ /^\|/
816 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
817 $selected= select(OUT);
819 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
822 # XXX Local variants do not work!
823 $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
824 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
825 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
827 #} # <-- Do we know what this brace is for?
828 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
830 $onetimeDump = undef;
836 if ($pager =~ /^\|/) {
837 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
838 &warn( "Pager `$pager' failed: ",
839 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
840 ( $? & 128 ) ? " (core dumped)" : "",
841 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
842 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
843 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
844 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq "DB::catch";
845 # Will stop ignoring SIGPIPE if done like nohup(1)
846 # does SIGINT but Perl doesn't give us a choice.
848 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
851 select($selected), $selected= "" unless $selected eq "";
856 $evalarg = $post; &eval;
858 } # if ($single || $signal)
859 ($@, $!, $,, $/, $\, $^W) = @saved;
863 # The following code may be executed now:
867 print $LINEINFO ' ' x $#stack, "entering $sub\n" if $frame;
868 push(@stack, $single);
870 $single |= 4 if $#stack == $deep;
873 $single |= pop(@stack);
876 print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
880 $single |= pop(@stack);
883 print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
889 @saved = ($@, $!, $,, $/, $\, $^W);
890 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
893 # The following takes its argument via $evalarg to preserve current @_
898 local (@stack) = @stack; # guard against recursive debugging
900 my $osingle = $single;
902 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
911 } elsif ($onetimeDump) {
916 sub install_breakpoints {
917 my $filename = shift;
918 return unless exists $postponed{$filename};
919 my %break = %{$postponed{$filename}};
922 #if (/\D/) { # Subroutine name
924 $dbline{$i} = $break{$_}; # Cannot be done before the file is around
929 local ($savout) = select($OUT);
930 do 'dumpvar.pl' unless defined &main::dumpValue;
931 if (defined &main::dumpValue) {
933 &main::dumpValue(shift);
935 print $OUT "dumpvar.pl not available.\n";
942 while ($action =~ s/\\$//) {
957 # We save, change, then restore STDIN and STDOUT to avoid fork() since
958 # many non-Unix systems can do system() but have problems with fork().
959 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
960 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
961 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
962 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
964 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
965 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
966 close(SAVEIN); close(SAVEOUT);
967 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
968 ( $? & 128 ) ? " (core dumped)" : "",
969 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
975 eval "require Term::ReadLine;" or die $@;
978 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
979 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
982 my $sel = select($OUT);
986 eval "require Term::Rendezvous;" or die $@;
987 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
988 my $term_rv = new Term::Rendezvous $rv;
990 $OUT = $term_rv->OUT;
994 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
996 $term = new Term::ReadLine 'perldb', $IN, $OUT;
998 $readline::rl_basic_word_break_characters .= "[:"
999 if defined $readline::rl_basic_word_break_characters
1000 and index($readline::rl_basic_word_break_characters, ":") == -1;
1002 $LINEINFO = $OUT unless defined $LINEINFO;
1003 $lineinfo = $console unless defined $lineinfo;
1005 if ($term->Features->{setHistory} and "@hist" ne "?") {
1006 $term->SetHistory(@hist);
1012 my $left = @typeahead;
1013 my $got = shift @typeahead;
1014 print $OUT "auto(-$left)", shift, $got, "\n";
1015 $term->AddHistory($got)
1016 if length($got) > 1 and defined $term->Features->{addHistory};
1020 $term->readline(@_);
1024 my ($opt, $val)= @_;
1025 if (defined $optionVars{$opt}
1026 and defined $ {$optionVars{$opt}}) {
1027 $val = $ {$optionVars{$opt}};
1028 } elsif (defined $optionAction{$opt}
1029 and defined &{$optionAction{$opt}}) {
1030 $val = &{$optionAction{$opt}}();
1031 } elsif (defined $optionAction{$opt}
1032 and not defined $option{$opt}
1033 or defined $optionVars{$opt}
1034 and not defined $ {$optionVars{$opt}}) {
1037 $val = $option{$opt};
1039 $val =~ s/[\\\']/\\$&/g;
1040 printf $OUT "%20s = '%s'\n", $opt, $val;
1046 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1047 my ($opt,$sep) = ($1,$2);
1050 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1052 #&dump_option($opt);
1053 } elsif ($sep !~ /\S/) {
1055 } elsif ($sep eq "=") {
1058 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1059 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1060 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1061 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1063 $val =~ s/\\([\\$end])/$1/g;
1067 grep( /^\Q$opt/ && ($option = $_), @options );
1068 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1070 print $OUT "Unknown option `$opt'\n" unless $matches;
1071 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1072 $option{$option} = $val if $matches == 1 and defined $val;
1073 eval "local \$frame = 0; require '$optionRequire{$option}'"
1074 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1075 $ {$optionVars{$option}} = $val
1077 and defined $optionVars{$option} and defined $val;
1078 & {$optionAction{$option}} ($val)
1080 and defined $optionAction{$option}
1081 and defined &{$optionAction{$option}} and defined $val;
1082 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1088 my ($stem,@list) = @_;
1090 $ENV{"$ {stem}_n"} = @list;
1091 for $i (0 .. $#list) {
1093 $val =~ s/\\/\\\\/g;
1094 $val =~ s/[\0-\37\177\200-\377]/"\\0x" . unpack('H2',$&)/eg;
1095 $ENV{"$ {stem}_$i"} = $val;
1102 my $n = delete $ENV{"$ {stem}_n"};
1104 for $i (0 .. $n - 1) {
1105 $val = delete $ENV{"$ {stem}_$i"};
1106 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1117 my($msg)= join("",@_);
1118 $msg .= ": $!\n" unless $msg =~ /\n$/;
1124 &warn("Too late to set TTY!\n") if @_;
1133 &warn("Too late to set noTTY!\n") if @_;
1135 $notty = shift if @_;
1142 &warn("Too late to set ReadLine!\n") if @_;
1151 &warn("Too late to set up NonStop mode!\n") if @_;
1153 $runnonstop = shift if @_;
1161 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1168 $sh = quotemeta shift;
1169 $sh .= "\\b" if $sh =~ /\w$/;
1173 $psh =~ s/\\(.)/$1/g;
1180 $rc = quotemeta shift;
1181 $rc .= "\\b" if $rc =~ /\w$/;
1185 $prc =~ s/\\(.)/$1/g;
1191 return $lineinfo unless @_;
1193 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1194 $emacs = ($stream =~ /^\|/);
1195 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1196 $LINEINFO = \*LINEINFO;
1197 my $save = select($LINEINFO);
1206 s [expr] Single step [in expr].
1207 n [expr] Next, steps over subroutine calls [in expr].
1208 <CR> Repeat last n or s command.
1209 r Return from current subroutine.
1210 c [line] Continue; optionally inserts a one-time-only breakpoint
1211 at the specified line.
1212 l min+incr List incr+1 lines starting at min.
1213 l min-max List lines min through max.
1214 l line List single line.
1215 l subname List first window of lines from subroutine.
1216 l List next window of lines.
1217 - List previous window of lines.
1218 w [line] List window around line.
1219 . Return to the executed line.
1220 f filename Switch to viewing filename.
1221 /pattern/ Search forwards for pattern; final / is optional.
1222 ?pattern? Search backwards for pattern; final ? is optional.
1223 L List all breakpoints and actions for the current file.
1224 S [[!]pattern] List subroutine names [not] matching pattern.
1225 t Toggle trace mode.
1226 t expr Trace through execution of expr.
1227 b [line] [condition]
1228 Set breakpoint; line defaults to the current execution line;
1229 condition breaks if it evaluates to true, defaults to '1'.
1230 b subname [condition]
1231 Set breakpoint at first line of subroutine.
1232 d [line] Delete the breakpoint for line.
1233 D Delete all breakpoints.
1235 Set an action to be done before the line is executed.
1236 Sequence is: check for breakpoint, print line if necessary,
1237 do action, prompt user if breakpoint or step, evaluate line.
1238 A Delete all actions.
1239 V [pkg [vars]] List some (default all) variables in package (default current).
1240 Use ~pattern and !pattern for positive and negative regexps.
1241 X [vars] Same as \"V currentpackage [vars]\".
1242 x expr Evals expression in array context, dumps the result.
1243 O [opt[=val]] [opt\"val\"] [opt?]...
1244 Set or query values of options. val defaults to 1. opt can
1245 be abbreviated. Several options can be listed.
1246 recallCommand, ShellBang: chars used to recall command or spawn shell;
1247 pager: program for output of \"|cmd\";
1248 The following options affect what happens with V, X, and x commands:
1249 arrayDepth, hashDepth: print only first N elements ('' for all);
1250 compactDump, veryCompact: change style of array and hash dump;
1251 globPrint: whether to print contents of globs;
1252 DumpDBFiles: dump arrays holding debugged files;
1253 DumpPackages: dump symbol tables of packages;
1254 quote, HighBit, undefPrint: change style of string dump;
1255 tkRunning: run Tk while prompting (with ReadLine);
1256 signalLevel warnLevel dieLevel: level of verbosity;
1257 Option PrintRet affects printing of return value after r command,
1258 frame affects printing messages on entry and exit from subroutines.
1259 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1260 You can put additional initialization options TTY, noTTY,
1261 ReadLine, and NonStop there.
1262 < command Define command to run before each prompt.
1263 > command Define command to run after each prompt.
1264 $prc number Redo a previous command (default previous command).
1265 $prc -number Redo number'th-to-last command.
1266 $prc pattern Redo last command that started with pattern.
1267 See 'O recallCommand' too.
1268 $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1269 . ( $rc eq $sh ? "" : "
1270 $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1271 See 'O shellBang' too.
1272 H -number Display last number commands (default all).
1273 p expr Same as \"print DB::OUT expr\" in current package.
1274 |dbcmd Run debugger command, piping DB::OUT to current pager.
1275 ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1276 \= [alias value] Define a command alias, or list current aliases.
1277 command Execute as a perl statement in current package.
1278 R Pure-man-restart of debugger, debugger state and command-line
1280 h [db_command] Get help [on a specific debugger command], enter |h to page.
1281 h h Summary of debugger commands.
1285 $summary = <<"END_SUM";
1286 List/search source lines: Control script execution:
1287 l [ln|sub] List source code T Stack trace
1288 - or . List previous/current line s [expr] Single step [in expr]
1289 w [line] List around line n [expr] Next, steps over subs
1290 f filename View source in file <CR> Repeat last n or s
1291 /pattern/ Search forward r Return from subroutine
1292 ?pattern? Search backward c [line] Continue until line
1293 Debugger controls: L List break pts & actions
1294 O [...] Set debugger options t [expr] Toggle trace [trace expr]
1295 < command Command for before prompt b [ln] [c] Set breakpoint
1296 > command Command for after prompt b sub [c] Set breakpoint for sub
1297 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1298 H [-num] Display last num commands D Delete all breakpoints
1299 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1300 h [db_cmd] Get help on command A Delete all actions
1301 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
1302 q or ^D Quit R Attempt a restart
1303 Data Examination: expr Execute perl code, also see: s,n,t expr
1304 S [[!]pat] List subroutine names [not] matching pattern
1305 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1306 X [Vars] Same as \"V current_package [Vars]\".
1307 x expr Evals expression in array context, dumps the result.
1308 p expr Print expression (uses script's current package).
1310 # '); # Fix balance of Emacs parsing
1315 $SIG{'ABRT'} = DEFAULT;
1316 kill 'ABRT', $$ if $panic++;
1317 print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue
1318 local $SIG{__WARN__} = '';
1320 local $Carp::CarpLevel = 2; # mydie + confess
1321 &warn(Carp::longmess("Signal @_"));
1327 local $SIG{__WARN__} = '';
1329 #&warn("Entering dbwarn\n");
1330 my ($mysingle,$mytrace) = ($single,$trace);
1331 $single = 0; $trace = 0;
1332 my $mess = Carp::longmess(@_);
1333 ($single,$trace) = ($mysingle,$mytrace);
1334 #&warn("Warning in dbwarn\n");
1336 #&warn("Exiting dbwarn\n");
1341 local $SIG{__DIE__} = '';
1342 local $SIG{__WARN__} = '';
1343 my $i = 0; my $ineval = 0; my $sub;
1344 #&warn("Entering dbdie\n");
1345 if ($dieLevel != 2) {
1346 while ((undef,undef,undef,$sub) = caller(++$i)) {
1347 $ineval = 1, last if $sub eq '(eval)';
1350 local $SIG{__WARN__} = \&dbwarn;
1351 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1353 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1354 die @_ if $ineval and $dieLevel < 2;
1357 # We do not want to debug this chunk (automatic disabling works
1358 # inside DB::DB, but not in Carp).
1359 my ($mysingle,$mytrace) = ($single,$trace);
1360 $single = 0; $trace = 0;
1361 my $mess = Carp::longmess(@_);
1362 ($single,$trace) = ($mysingle,$mytrace);
1363 #&warn("dieing loudly in dbdie\n");
1369 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1372 $SIG{__WARN__} = 'DB::dbwarn';
1374 $SIG{__WARN__} = $prevwarn;
1382 $prevdie = $SIG{__DIE__} unless $dieLevel;
1385 $SIG{__DIE__} = 'DB::dbdie'; # if $dieLevel < 2;
1386 #$SIG{__DIE__} = 'DB::diehard' if $dieLevel >= 2;
1387 print $OUT "Stack dump during die enabled",
1388 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1389 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1391 $SIG{__DIE__} = $prevdie;
1392 print $OUT "Default die handler restored.\n";
1400 $prevsegv = $SIG{SEGV} unless $signalLevel;
1401 $prevbus = $SIG{BUS} unless $signalLevel;
1402 $signalLevel = shift;
1404 $SIG{SEGV} = 'DB::diesignal';
1405 $SIG{BUS} = 'DB::diesignal';
1407 $SIG{SEGV} = $prevsegv;
1408 $SIG{BUS} = $prevbus;
1414 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1416 BEGIN { # This does not compile, alas.
1417 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1418 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1422 $deep = 100; # warning if stack gets this deep
1426 #$SIG{__WARN__} = "DB::dbwarn";
1427 #$SIG{__DIE__} = 'DB::dbdie';
1428 #$SIG{SEGV} = "DB::diesignal";
1429 #$SIG{BUS} = "DB::diesignal";
1430 $SIG{INT} = "DB::catch";
1431 #$SIG{FPE} = "DB::catch";
1432 #warn "SIGFPE installed";
1433 $warnLevel = 1 unless defined $warnLevel;
1434 $dieLevel = 1 unless defined $dieLevel;
1435 $signalLevel = 1 unless defined $signalLevel;
1437 $db_stop = 0; # Compiler warning
1439 $level = 0; # Level of recursive debugging
1442 BEGIN {$^W = $ini_warn;} # Switch warnings back
1444 #use Carp; # This did break, left for debuggin