3 # Debugger for Perl 5.00x; perl5db.pl patch level:
6 $header = "perl5db.pl patch level $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 @line and %sub. It effectively inserts
21 # a &DB'DB(<linenum>); 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(*{"_<$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 @{"_<$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 this file). 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 # Example $rcfile: (delete leading hashes!)
81 # &parse_options("NonStop=1 LineInfo=db.out");
82 # sub afterinit { $trace = 1; }
84 # The script will run without human intervention, putting trace
85 # information into db.out. (If you interrupt it, you would better
86 # reset LineInfo to something "interactive"!)
88 ##################################################################
91 # A lot of things changed after 0.94. First of all, core now informs
92 # debugger about entry into XSUBs, overloaded operators, tied operations,
93 # BEGIN and END. Handy with `O f=2'.
95 # This can make debugger a little bit too verbose, please be patient
96 # and report your problems promptly.
98 # Now the option frame has 3 values: 0,1,2.
100 # Note that if DESTROY returns a reference to the object (or object),
101 # the deletion of data may be postponed until the next function call,
102 # due to the need to examine the return value.
104 # Changes: 0.95: `v' command shows versions.
105 # Changes: 0.96: `v' command shows version of readline.
106 # primitive completion works (dynamic variables, subs for `b' and `l',
107 # options). Can `p %var'
108 # Better help (`h <' now works). New commands <<, >>, {, {{.
109 # {dump|print}_trace() coded (to be able to do it from <<cmd).
110 # `c sub' documented.
111 # At last enough magic combined to stop after the end of debuggee.
112 # !! should work now (thanks to Emacs bracket matching an extra
113 # `]' in a regexp is caught).
114 # `L', `D' and `A' span files now (as documented).
115 # Breakpoints in `require'd code are possible (used in `R').
116 # Some additional words on internal work of debugger.
117 # `b load filename' implemented.
118 # `b postpone subr' implemented.
119 # now only `q' exits debugger (overwriteable on $inhibit_exit).
120 # When restarting debugger breakpoints/actions persist.
121 # Buglet: When restarting debugger only one breakpoint/action per
122 # autoloaded function persists.
124 ####################################################################
126 # Needed for the statement after exec():
128 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
129 local($^W) = 0; # Switch run-time warnings off during init.
132 $dumpvar::arrayDepth,
133 $dumpvar::dumpDBFiles,
134 $dumpvar::dumpPackages,
135 $dumpvar::quoteHighBit,
136 $dumpvar::printUndef,
138 $readline::Tk_toloop,
146 # Command-line + PERLLIB:
149 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
151 $trace = $signal = $single = 0; # Uninitialized warning suppression
152 # (local $^W cannot help - other packages!).
153 $inhibit_exit = $option{PrintRet} = 1;
155 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
156 compactDump veryCompact quote HighBit undefPrint
157 globPrint PrintRet UsageOnly frame
158 TTY noTTY ReadLine NonStop LineInfo
159 recallCommand ShellBang pager tkRunning
160 signalLevel warnLevel dieLevel);
163 hashDepth => \$dumpvar::hashDepth,
164 arrayDepth => \$dumpvar::arrayDepth,
165 DumpDBFiles => \$dumpvar::dumpDBFiles,
166 DumpPackages => \$dumpvar::dumpPackages,
167 HighBit => \$dumpvar::quoteHighBit,
168 undefPrint => \$dumpvar::printUndef,
169 globPrint => \$dumpvar::globPrint,
170 tkRunning => \$readline::Tk_toloop,
171 UsageOnly => \$dumpvar::usageOnly,
176 compactDump => \&dumpvar::compactDump,
177 veryCompact => \&dumpvar::veryCompact,
178 quote => \&dumpvar::quote,
181 ReadLine => \&ReadLine,
182 NonStop => \&NonStop,
183 LineInfo => \&LineInfo,
184 recallCommand => \&recallCommand,
185 ShellBang => \&shellBang,
187 signalLevel => \&signalLevel,
188 warnLevel => \&warnLevel,
189 dieLevel => \&dieLevel,
193 compactDump => 'dumpvar.pl',
194 veryCompact => 'dumpvar.pl',
195 quote => 'dumpvar.pl',
198 # These guys may be defined in $ENV{PERL5DB} :
199 $rl = 1 unless defined $rl;
200 $warnLevel = 1 unless defined $warnLevel;
201 $dieLevel = 1 unless defined $dieLevel;
202 $signalLevel = 1 unless defined $signalLevel;
203 $pre = [] unless defined $pre;
204 $post = [] unless defined $post;
205 $pretype = [] unless defined $pretype;
206 warnLevel($warnLevel);
208 signalLevel($signalLevel);
209 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
210 &recallCommand("!") unless defined $prc;
211 &shellBang("!") unless defined $psh;
216 $rcfile="perldb.ini";
221 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
222 do "$ENV{LOGDIR}/$rcfile";
223 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
224 do "$ENV{HOME}/$rcfile";
227 if (defined $ENV{PERLDB_OPTS}) {
228 parse_options($ENV{PERLDB_OPTS});
231 if (exists $ENV{PERLDB_RESTART}) {
232 delete $ENV{PERLDB_RESTART};
234 @hist = get_list('PERLDB_HIST');
235 %break_on_load = get_list("PERLDB_ON_LOAD");
236 %postponed = get_list("PERLDB_POSTPONE");
237 my @had_breakpoints= get_list("PERLDB_VISITED");
238 for (0 .. $#had_breakpoints) {
239 %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_");
241 my %opt = get_list("PERLDB_OPT");
243 while (($opt,$val) = each %opt) {
244 $val =~ s/[\\\']/\\$1/g;
245 parse_options("$opt'$val'");
247 @INC = get_list("PERLDB_INC");
254 # Is Perl being run from Emacs?
255 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
256 $rl = 0, shift(@main::ARGV) if $emacs;
258 #require Term::ReadLine;
261 $console = "/dev/tty";
265 $console = "sys\$command";
269 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
273 $console = $tty if defined $tty;
275 if (defined $console) {
276 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
277 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
278 || open(OUT,">&STDOUT"); # so we don't dongle stdout
281 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
282 $console = 'STDIN/OUT';
284 # so open("|more") can read from STDOUT and so we don't dingle stdin
289 $| = 1; # for DB::OUT
292 $LINEINFO = $OUT unless defined $LINEINFO;
293 $lineinfo = $console unless defined $lineinfo;
295 $| = 1; # for real STDOUT
297 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
298 unless ($runnonstop) {
299 print $OUT "\nLoading DB routines from $header\n";
300 print $OUT ("Emacs support ",
301 $emacs ? "enabled" : "available",
303 print $OUT "\nEnter h or `h h' for help.\n\n";
310 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
313 if (defined &afterinit) { # May be defined in $rcfile
317 ############################################################ Subroutines
320 unless ($first_time++) { # Do when-running init
321 if ($runnonstop) { # Disable until signal
322 for ($i=0; $i <= $#stack; ) {
330 ($package, $filename, $line) = caller;
331 $filename_ini = $filename;
332 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
333 "package $package;"; # this won't let them modify, alas
334 local(*dbline) = "::_<$filename";
336 if (($stop,$action) = split(/\0/,$dbline{$line})) {
340 $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
341 $dbline{$line} =~ s/;9($|\0)/$1/;
344 if ($single || $trace || $signal) {
347 $position = "\032\032$filename:$line:0\n";
348 print $LINEINFO $position;
351 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
352 $prefix .= "$sub($filename:";
353 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
354 if (length($prefix) > 30) {
355 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
356 print $LINEINFO $position;
361 $position = "$prefix$line$infix$dbline[$line]$after";
362 print $LINEINFO $position;
364 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
365 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
366 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
367 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
368 print $LINEINFO $incr_pos;
369 $position .= $incr_pos;
373 $evalarg = $action, &eval if $action;
374 if ($single || $signal) {
375 local $level = $level + 1;
376 map {$evalarg = $_, &eval} @$pre;
377 print $OUT $#stack . " levels deep in subroutine calls!\n"
380 @typeahead = @$pretype, @typeahead;
382 while (($term || &setterm),
383 defined ($cmd=&readline(" DB" . ('<' x $level) .
384 ($#hist+1) . ('>' x $level) .
388 $cmd =~ s/\\$/\n/ && do {
389 $cmd .= &readline(" cont: ");
392 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
393 $cmd =~ /^$/ && ($cmd = $laststep);
394 push(@hist,$cmd) if length($cmd) > 1;
396 ($i) = split(/\s+/,$cmd);
397 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
398 $cmd =~ /^h$/ && do {
401 $cmd =~ /^h\s+h$/ && do {
404 $cmd =~ /^h\s+(\S)$/ && do {
406 if ($help =~ /^$asked/m) {
407 while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
411 print $OUT "`$asked' is not a debugger command.\n";
414 $cmd =~ /^t$/ && do {
416 print $OUT "Trace = ".($trace?"on":"off")."\n";
418 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
419 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
420 foreach $subname (sort(keys %sub)) {
421 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
422 print $OUT $subname,"\n";
426 $cmd =~ /^v$/ && do {
427 list_versions(); next CMD};
428 $cmd =~ s/^X\b/V $package/;
429 $cmd =~ /^V$/ && do {
430 $cmd = "V $package"; };
431 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
432 local ($savout) = select($OUT);
434 @vars = split(' ',$2);
435 do 'dumpvar.pl' unless defined &main::dumpvar;
436 if (defined &main::dumpvar) {
439 &main::dumpvar($packname,@vars);
441 print $OUT "dumpvar.pl not available.\n";
445 $cmd =~ s/^x\b/ / && do { # So that will be evaled
447 $cmd =~ /^f\b\s*(.*)/ && do {
450 print $OUT "The old f command is now the r command.\n";
451 print $OUT "The new f command switches filenames.\n";
454 if (!defined $main::{'_<' . $file}) {
455 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
456 $file = substr($try,2);
460 if (!defined $main::{'_<' . $file}) {
461 print $OUT "There's no code here matching $file.\n";
463 } elsif ($file ne $filename) {
464 *dbline = "::_<$file";
470 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
472 $subname =~ s/\'/::/;
473 $subname = "main::".$subname unless $subname =~ /::/;
474 $subname = "main".$subname if substr($subname,0,2) eq "::";
475 @pieces = split(/:/,$sub{$subname});
476 $subrange = pop @pieces;
477 $file = join(':', @pieces);
478 if ($file ne $filename) {
479 *dbline = "::_<$file";
484 if (eval($subrange) < -$window) {
485 $subrange =~ s/-.*/+/;
487 $cmd = "l $subrange";
489 print $OUT "Subroutine $subname not found.\n";
492 $cmd =~ /^\.$/ && do {
494 $filename = $filename_ini;
495 *dbline = "::_<$filename";
497 print $LINEINFO $position;
499 $cmd =~ /^w\b\s*(\d*)$/ && do {
503 #print $OUT 'l ' . $start . '-' . ($start + $incr);
504 $cmd = 'l ' . $start . '-' . ($start + $incr); };
505 $cmd =~ /^-$/ && do {
507 $cmd = 'l ' . ($start-$window*2) . '+'; };
508 $cmd =~ /^l$/ && do {
510 $cmd = 'l ' . $start . '-' . ($start + $incr); };
511 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
514 $incr = $window - 1 unless $incr;
515 $cmd = 'l ' . $start . '-' . ($start + $incr); };
516 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
517 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
518 $end = $max if $end > $max;
520 $i = $line if $i eq '.';
523 print $OUT "\032\032$filename:$i:0\n";
526 for (; $i <= $end; $i++) {
527 ($stop,$action) = split(/\0/, $dbline{$i});
529 and $filename eq $filename_ini)
532 $arrow .= 'b' if $stop;
533 $arrow .= 'a' if $action;
534 print $OUT "$i$arrow\t", $dbline[$i];
538 $start = $i; # remember in case they want more
539 $start = $max if $start > $max;
541 $cmd =~ /^D$/ && do {
542 print $OUT "Deleting all breakpoints...\n";
544 for $file (keys %had_breakpoints) {
545 local *dbline = "::_<$file";
549 for ($i = 1; $i <= $max ; $i++) {
550 if (defined $dbline{$i}) {
551 $dbline{$i} =~ s/^[^\0]+//;
552 if ($dbline{$i} =~ s/^\0?$//) {
559 undef %postponed_file;
560 undef %break_on_load;
561 undef %had_breakpoints;
563 $cmd =~ /^L$/ && do {
565 for $file (keys %had_breakpoints) {
566 local *dbline = "::_<$file";
570 for ($i = 1; $i <= $max; $i++) {
571 if (defined $dbline{$i}) {
572 print "$file:\n" unless $was++;
573 print $OUT " $i:\t", $dbline[$i];
574 ($stop,$action) = split(/\0/, $dbline{$i});
575 print $OUT " break if (", $stop, ")\n"
577 print $OUT " action: ", $action, "\n"
584 print $OUT "Postponed breakpoints in subroutines:\n";
586 for $subname (keys %postponed) {
587 print $OUT " $subname\t$postponed{$subname}\n";
591 my @have = map { # Combined keys
592 keys %{$postponed_file{$_}}
593 } keys %postponed_file;
595 print $OUT "Postponed breakpoints in files:\n";
597 for $file (keys %postponed_file) {
598 my %db = %{$postponed_file{$file}};
599 next unless keys %db;
600 print $OUT " $file:\n";
601 for $line (sort {$a <=> $b} keys %db) {
603 my ($stop,$action) = split(/\0/, $db{$line});
604 print $OUT " break if (", $stop, ")\n"
606 print $OUT " action: ", $action, "\n"
613 if (%break_on_load) {
614 print $OUT "Breakpoints on load:\n";
616 for $file (keys %break_on_load) {
617 print $OUT " $file\n";
622 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
625 $break_on_load{$file} = 1;
626 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
627 $file .= '.pm', redo unless $file =~ /\./;
629 $had_breakpoints{$file} = 1;
630 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
632 $cmd =~ /^b\b\s*postpone\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
633 my $cond = $2 || '1';
635 $subname =~ s/\'/::/;
636 $subname = "${'package'}::" . $subname
637 unless $subname =~ /::/;
638 $subname = "main".$subname if substr($subname,0,2) eq "::";
639 $postponed{$subname} = "break +0 if $cond";
641 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
644 $subname =~ s/\'/::/;
645 $subname = "${'package'}::" . $subname
646 unless $subname =~ /::/;
647 $subname = "main".$subname if substr($subname,0,2) eq "::";
648 # Filename below can contain ':'
649 ($file,$i) = ($sub{$subname} =~ /^(.*):(.*)$/);
653 *dbline = "::_<$filename";
654 $had_breakpoints{$filename} = 1;
656 ++$i while $dbline[$i] == 0 && $i < $max;
657 $dbline{$i} =~ s/^[^\0]*/$cond/;
659 print $OUT "Subroutine $subname not found.\n";
662 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
665 if ($dbline[$i] == 0) {
666 print $OUT "Line $i not breakable.\n";
668 $had_breakpoints{$filename} = 1;
669 $dbline{$i} =~ s/^[^\0]*/$cond/;
672 $cmd =~ /^d\b\s*(\d+)?/ && do {
674 $dbline{$i} =~ s/^[^\0]*//;
675 delete $dbline{$i} if $dbline{$i} eq '';
677 $cmd =~ /^A$/ && do {
679 for $file (keys %had_breakpoints) {
680 local *dbline = "::_<$file";
684 for ($i = 1; $i <= $max ; $i++) {
685 if (defined $dbline{$i}) {
686 $dbline{$i} =~ s/\0[^\0]*//;
687 delete $dbline{$i} if $dbline{$i} eq '';
692 $cmd =~ /^O\s*$/ && do {
697 $cmd =~ /^O\s*(\S.*)/ && do {
700 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
701 push @$pre, action($1);
703 $cmd =~ /^>>\s*(.*)/ && do {
704 push @$post, action($1);
706 $cmd =~ /^<\s*(.*)/ && do {
707 $pre = [], next CMD unless $1;
710 $cmd =~ /^>\s*(.*)/ && do {
711 $post = [], next CMD unless $1;
712 $post = [action($1)];
714 $cmd =~ /^\{\{\s*(.*)/ && do {
717 $cmd =~ /^\{\s*(.*)/ && do {
718 $pretype = [], next CMD unless $1;
721 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
723 if ($dbline[$i] == 0) {
724 print $OUT "Line $i may not have an action.\n";
726 $dbline{$i} =~ s/\0[^\0]*//;
727 $dbline{$i} .= "\0" . action($j);
730 $cmd =~ /^n$/ && do {
731 next CMD if $finished and $level <= 1;
735 $cmd =~ /^s$/ && do {
736 next CMD if $finished and $level <= 1;
740 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
741 next CMD if $finished and $level <= 1;
743 if ($i =~ /\D/) { # subroutine name
744 ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/);
748 *dbline = "::_<$filename";
749 $had_breakpoints{$filename}++;
751 ++$i while $dbline[$i] == 0 && $i < $max;
753 print $OUT "Subroutine $subname not found.\n";
758 if ($dbline[$i] == 0) {
759 print $OUT "Line $i not breakable.\n";
762 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
764 for ($i=0; $i <= $#stack; ) {
768 $cmd =~ /^r$/ && do {
769 next CMD if $finished and $level <= 1;
770 $stack[$#stack] |= 1;
771 $doret = $option{PrintRet} ? $#stack - 1 : -2;
773 $cmd =~ /^R$/ && do {
774 print $OUT "Warning: some settings and command-line options may be lost!\n";
775 my (@script, @flags, $cl);
776 push @flags, '-w' if $ini_warn;
777 # Put all the old includes at the start to get
780 push @flags, '-I', $_;
782 # Arrange for setting the old INC:
783 set_list("PERLDB_INC", @ini_INC);
785 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
786 chomp ($cl = $ {'::_<-e'}[$_]);
787 push @script, '-e', $cl;
792 set_list("PERLDB_HIST",
793 $term->Features->{getHistory}
794 ? $term->GetHistory : @hist);
795 my @had_breakpoints = keys %had_breakpoints;
796 set_list("PERLDB_VISITED", @had_breakpoints);
797 set_list("PERLDB_OPT", %option);
798 set_list("PERLDB_ON_LOAD", %break_on_load);
800 for (0 .. $#had_breakpoints) {
801 my $file = $had_breakpoints[$_];
802 *dbline = "::_<$file";
803 next unless %dbline or %{$postponed_file{$file}};
804 (push @hard, $file), next
805 if $file =~ /^\(eval \d+\)$/;
807 @add = %{$postponed_file{$file}}
808 if %{$postponed_file{$file}};
809 set_list("PERLDB_FILE_$_", %dbline, @add);
811 for (@hard) { # Yes, really-really...
812 # Find the subroutines in this eval
814 my ($quoted, $sub, %subs, $line) = quotemeta $_;
815 for $sub (keys %sub) {
816 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
817 $subs{$sub} = [$1, $2];
821 "No subroutines in $_, ignoring breakpoints.\n";
824 LINES: for $line (keys %dbline) {
825 # One breakpoint per sub only:
826 my ($offset, $sub, $found);
827 SUBS: for $sub (keys %subs) {
828 if ($subs{$sub}->[1] >= $line # Not after the subroutine
829 and (not defined $offset # Not caught
830 or $offset < 0 )) { # or badly caught
832 $offset = $line - $subs{$sub}->[0];
833 $offset = "+$offset", last SUBS if $offset >= 0;
836 if (defined $offset) {
838 "break $offset if $dbline{$line}";
840 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
844 set_list("PERLDB_POSTPONE", %postponed);
845 $ENV{PERLDB_RESTART} = 1;
846 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
847 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
848 print $OUT "exec failed: $!\n";
850 $cmd =~ /^T$/ && do {
851 print_trace($OUT, 3); # skip DB print_trace dump_trace
853 $cmd =~ /^\/(.*)$/ && do {
855 $inpat =~ s:([^\\])/$:$1:;
857 eval '$inpat =~ m'."\a$inpat\a";
868 $start = 1 if ($start > $max);
869 last if ($start == $end);
870 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
872 print $OUT "\032\032$filename:$start:0\n";
874 print $OUT "$start:\t", $dbline[$start], "\n";
879 print $OUT "/$pat/: not found\n" if ($start == $end);
881 $cmd =~ /^\?(.*)$/ && do {
883 $inpat =~ s:([^\\])\?$:$1:;
885 eval '$inpat =~ m'."\a$inpat\a";
896 $start = $max if ($start <= 0);
897 last if ($start == $end);
898 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
900 print $OUT "\032\032$filename:$start:0\n";
902 print $OUT "$start:\t", $dbline[$start], "\n";
907 print $OUT "?$pat?: not found\n" if ($start == $end);
909 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
910 pop(@hist) if length($cmd) > 1;
911 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
912 $cmd = $hist[$i] . "\n";
915 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
918 $cmd =~ /^$rc([^$rc].*)$/ && do {
920 pop(@hist) if length($cmd) > 1;
921 for ($i = $#hist; $i; --$i) {
922 last if $hist[$i] =~ /$pat/;
925 print $OUT "No such command!\n\n";
928 $cmd = $hist[$i] . "\n";
931 $cmd =~ /^$sh$/ && do {
932 &system($ENV{SHELL}||"/bin/sh");
934 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
935 &system($ENV{SHELL}||"/bin/sh","-c",$1);
937 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
938 $end = $2?($#hist-$2):0;
939 $hist = 0 if $hist < 0;
940 for ($i=$#hist; $i>$end; $i--) {
941 print $OUT "$i: ",$hist[$i],"\n"
942 unless $hist[$i] =~ /^.?$/;
945 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
946 $cmd =~ s/^p\b/print {\$DB::OUT} /;
948 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
949 $alias{$k}="s~$k~$v~";
950 print $OUT "$k = $v\n";
951 } elsif ($cmd =~ /^=\s*$/) {
952 foreach $k (sort keys(%alias)) {
953 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
954 print $OUT "$k = $v\n";
956 print $OUT "$k\t$alias{$k}\n";
961 $cmd =~ /^\|\|?\s*[^|]/ && do {
962 if ($pager =~ /^\|/) {
963 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
964 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
966 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
968 unless ($piped=open(OUT,$pager)) {
969 &warn("Can't pipe output to `$pager'");
970 if ($pager =~ /^\|/) {
971 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
972 open(STDOUT,">&SAVEOUT")
973 || &warn("Can't restore STDOUT");
976 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
980 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
981 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
982 $selected= select(OUT);
984 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
987 # XXX Local variants do not work!
988 $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
989 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
990 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
992 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
994 $onetimeDump = undef;
1000 if ($pager =~ /^\|/) {
1001 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1002 &warn( "Pager `$pager' failed: ",
1003 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1004 ( $? & 128 ) ? " (core dumped)" : "",
1005 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1006 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1007 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1008 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1009 # Will stop ignoring SIGPIPE if done like nohup(1)
1010 # does SIGINT but Perl doesn't give us a choice.
1012 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1015 select($selected), $selected= "" unless $selected eq "";
1019 map {$evalarg = $_; &eval} @$post;
1020 } # if ($single || $signal)
1021 ($@, $!, $,, $/, $\, $^W) = @saved;
1025 # The following code may be executed now:
1029 my ($al, $ret, @ret) = "";
1030 if ($sub =~ /::AUTOLOAD$/) {
1031 $al = " for $ {$` . '::AUTOLOAD'}";
1033 print $LINEINFO ' ' x $#stack, "entering $sub$al\n" if $frame;
1034 push(@stack, $single);
1036 $single |= 4 if $#stack == $deep;
1039 $single |= pop(@stack);
1040 print ($OUT "list context return from $sub:\n"), dumpit( \@ret ),
1041 $doret = -2 if $doret eq $#stack;
1042 print $LINEINFO ' ' x $#stack, "exited $sub$al\n" if $frame > 1;
1046 $single |= pop(@stack);
1047 print ($OUT "scalar context return from $sub: "), dumpit( $ret ),
1048 $doret = -2 if $doret eq $#stack;
1049 print $LINEINFO ' ' x $#stack, "exited $sub$al\n" if $frame > 1;
1055 @saved = ($@, $!, $,, $/, $\, $^W);
1056 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1059 # The following takes its argument via $evalarg to preserve current @_
1064 local (@stack) = @stack; # guard against recursive debugging
1065 my $otrace = $trace;
1066 my $osingle = $single;
1068 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1077 } elsif ($onetimeDump) {
1083 my $subname = shift;
1084 if ($postponed{$subname} =~ s/break\s([+-]?\d+)\s+if\s//) {
1085 my $offset = $1 || 0;
1086 # Filename below can contain ':'
1087 my ($file,$i) = ($sub{$subname} =~ /^(.*):(\d+)-.*$/);
1090 local *dbline = "::_<$file";
1091 local $^W = 0; # != 0 is magical below
1092 $had_breakpoints{$file}++;
1094 ++$i until $dbline[$i] != 0 or $i >= $max;
1095 $dbline{$i} = delete $postponed{$subname};
1097 print $OUT "Subroutine $subname not found.\n";
1101 print $OUT "In postponed_sub for `$subname'.\n";
1105 return &postponed_sub
1106 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1107 # Cannot be done before the file is compiled
1108 local *dbline = shift;
1109 my $filename = $dbline;
1110 $filename =~ s/^_<//;
1111 $signal = 1, print $OUT "'$filename' loaded...\n" if $break_on_load{$filename};
1112 return unless %{$postponed_file{$filename}};
1113 $had_breakpoints{$filename}++;
1114 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1116 for $key (keys %{$postponed_file{$filename}}) {
1117 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1119 undef %{$postponed_file{$filename}};
1123 local ($savout) = select($OUT);
1124 my $osingle = $single;
1125 my $otrace = $trace;
1126 $single = $trace = 0;
1129 unless (defined &main::dumpValue) {
1132 if (defined &main::dumpValue) {
1133 &main::dumpValue(shift);
1135 print $OUT "dumpvar.pl not available.\n";
1144 my @sub = dump_trace(@_);
1145 for ($i=0; $i <= $#sub; $i++) {
1148 my $args = defined $sub[$i]{args}
1149 ? "(@{ $sub[$i]{args} })"
1151 $file = $sub[$i]{file} eq '-e' ? $sub[$i]{file} :
1152 "file `$sub[$i]{file}'";
1153 print $fh "$sub[$i]{context}$sub[$i]{sub}$args" .
1154 " called from $file" .
1155 " line $sub[$i]{line}\n";
1161 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1163 ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1170 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1171 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1172 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1175 $context = $context ? '@ = ' : '$ = ';
1176 $args = $h ? [@a] : undef;
1177 $e =~ s/\n\s*\;\s*\Z// if $e;
1178 $e =~ s/[\\\']/\\$1/g if $e;
1180 $sub = "require '$e'";
1181 } elsif (defined $r) {
1183 } elsif ($sub eq '(eval)') {
1184 $sub = "eval {...}";
1186 push(@sub, {context => $context, sub => $sub, args => $args,
1187 file => $file, line => $line});
1195 while ($action =~ s/\\$//) {
1206 &readline("cont: ");
1210 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1211 # many non-Unix systems can do system() but have problems with fork().
1212 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1213 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1214 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1215 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1217 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1218 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1219 close(SAVEIN); close(SAVEOUT);
1220 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1221 ( $? & 128 ) ? " (core dumped)" : "",
1222 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1229 local @stack = @stack; # Prevent growth by failing `use'.
1230 eval { require Term::ReadLine } or die $@;
1233 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1234 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1237 my $sel = select($OUT);
1241 eval "require Term::Rendezvous;" or die $@;
1242 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1243 my $term_rv = new Term::Rendezvous $rv;
1245 $OUT = $term_rv->OUT;
1249 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1251 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1253 $readline::rl_basic_word_break_characters .= "[:"
1254 if defined $readline::rl_basic_word_break_characters
1255 and index($readline::rl_basic_word_break_characters, ":") == -1;
1256 $readline::rl_special_prefixes =
1257 $readline::rl_special_prefixes = '$@&%';
1258 $readline::rl_completer_word_break_characters =
1259 $readline::rl_completer_word_break_characters . '$@&%';
1260 $readline::rl_completion_function =
1261 $readline::rl_completion_function = \&db_complete;
1263 $LINEINFO = $OUT unless defined $LINEINFO;
1264 $lineinfo = $console unless defined $lineinfo;
1266 if ($term->Features->{setHistory} and "@hist" ne "?") {
1267 $term->SetHistory(@hist);
1273 my $left = @typeahead;
1274 my $got = shift @typeahead;
1275 print $OUT "auto(-$left)", shift, $got, "\n";
1276 $term->AddHistory($got)
1277 if length($got) > 1 and defined $term->Features->{addHistory};
1282 $term->readline(@_);
1286 my ($opt, $val)= @_;
1287 $val = option_val($opt,'N/A');
1288 $val =~ s/([\\\'])/\\$1/g;
1289 printf $OUT "%20s = '%s'\n", $opt, $val;
1293 my ($opt, $default)= @_;
1295 if (defined $optionVars{$opt}
1296 and defined $ {$optionVars{$opt}}) {
1297 $val = $ {$optionVars{$opt}};
1298 } elsif (defined $optionAction{$opt}
1299 and defined &{$optionAction{$opt}}) {
1300 $val = &{$optionAction{$opt}}();
1301 } elsif (defined $optionAction{$opt}
1302 and not defined $option{$opt}
1303 or defined $optionVars{$opt}
1304 and not defined $ {$optionVars{$opt}}) {
1307 $val = $option{$opt};
1315 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1316 my ($opt,$sep) = ($1,$2);
1319 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1321 #&dump_option($opt);
1322 } elsif ($sep !~ /\S/) {
1324 } elsif ($sep eq "=") {
1327 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1328 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1329 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1330 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1332 $val =~ s/\\([\\$end])/$1/g;
1336 grep( /^\Q$opt/ && ($option = $_), @options );
1337 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1339 print $OUT "Unknown option `$opt'\n" unless $matches;
1340 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1341 $option{$option} = $val if $matches == 1 and defined $val;
1342 eval "local \$frame = 0; local \$doret = -2;
1343 require '$optionRequire{$option}'"
1344 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1345 $ {$optionVars{$option}} = $val
1347 and defined $optionVars{$option} and defined $val;
1348 & {$optionAction{$option}} ($val)
1350 and defined $optionAction{$option}
1351 and defined &{$optionAction{$option}} and defined $val;
1352 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1358 my ($stem,@list) = @_;
1360 $ENV{"$ {stem}_n"} = @list;
1361 for $i (0 .. $#list) {
1363 $val =~ s/\\/\\\\/g;
1364 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1365 $ENV{"$ {stem}_$i"} = $val;
1372 my $n = delete $ENV{"$ {stem}_n"};
1374 for $i (0 .. $n - 1) {
1375 $val = delete $ENV{"$ {stem}_$i"};
1376 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1387 my($msg)= join("",@_);
1388 $msg .= ": $!\n" unless $msg =~ /\n$/;
1394 &warn("Too late to set TTY!\n") if @_;
1403 &warn("Too late to set noTTY!\n") if @_;
1405 $notty = shift if @_;
1412 &warn("Too late to set ReadLine!\n") if @_;
1421 &warn("Too late to set up NonStop mode!\n") if @_;
1423 $runnonstop = shift if @_;
1431 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1438 $sh = quotemeta shift;
1439 $sh .= "\\b" if $sh =~ /\w$/;
1443 $psh =~ s/\\(.)/$1/g;
1450 $rc = quotemeta shift;
1451 $rc .= "\\b" if $rc =~ /\w$/;
1455 $prc =~ s/\\(.)/$1/g;
1461 return $lineinfo unless @_;
1463 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1464 $emacs = ($stream =~ /^\|/);
1465 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1466 $LINEINFO = \*LINEINFO;
1467 my $save = select($LINEINFO);
1481 s/^Term::ReadLine::readline$/readline/;
1482 if (defined $ { $_ . '::VERSION' }) {
1483 $version{$file} = "$ { $_ . '::VERSION' } from ";
1485 $version{$file} .= $INC{$file};
1487 do 'dumpvar.pl' unless defined &main::dumpValue;
1488 if (defined &main::dumpValue) {
1490 &main::dumpValue(\%version);
1492 print $OUT "dumpvar.pl not available.\n";
1499 s [expr] Single step [in expr].
1500 n [expr] Next, steps over subroutine calls [in expr].
1501 <CR> Repeat last n or s command.
1502 r Return from current subroutine.
1503 c [line|sub] Continue; optionally inserts a one-time-only breakpoint
1504 at the specified position.
1505 l min+incr List incr+1 lines starting at min.
1506 l min-max List lines min through max.
1507 l line List single line.
1508 l subname List first window of lines from subroutine.
1509 l List next window of lines.
1510 - List previous window of lines.
1511 w [line] List window around line.
1512 . Return to the executed line.
1513 f filename Switch to viewing filename.
1514 /pattern/ Search forwards for pattern; final / is optional.
1515 ?pattern? Search backwards for pattern; final ? is optional.
1516 L List all breakpoints and actions for the current file.
1517 S [[!]pattern] List subroutine names [not] matching pattern.
1518 t Toggle trace mode.
1519 t expr Trace through execution of expr.
1520 b [line] [condition]
1521 Set breakpoint; line defaults to the current execution line;
1522 condition breaks if it evaluates to true, defaults to '1'.
1523 b subname [condition]
1524 Set breakpoint at first line of subroutine.
1525 b load filename Set breakpoint on `require'ing the given file.
1526 b postpone subname [condition]
1527 Set breakpoint at first line of subroutine after
1529 d [line] Delete the breakpoint for line.
1530 D Delete all breakpoints.
1532 Set an action to be done before the line is executed.
1533 Sequence is: check for breakpoint, print line if necessary,
1534 do action, prompt user if breakpoint or step, evaluate line.
1535 A Delete all actions.
1536 V [pkg [vars]] List some (default all) variables in package (default current).
1537 Use ~pattern and !pattern for positive and negative regexps.
1538 X [vars] Same as \"V currentpackage [vars]\".
1539 x expr Evals expression in array context, dumps the result.
1540 O [opt[=val]] [opt\"val\"] [opt?]...
1541 Set or query values of options. val defaults to 1. opt can
1542 be abbreviated. Several options can be listed.
1543 recallCommand, ShellBang: chars used to recall command or spawn shell;
1544 pager: program for output of \"|cmd\";
1545 The following options affect what happens with V, X, and x commands:
1546 arrayDepth, hashDepth: print only first N elements ('' for all);
1547 compactDump, veryCompact: change style of array and hash dump;
1548 globPrint: whether to print contents of globs;
1549 DumpDBFiles: dump arrays holding debugged files;
1550 DumpPackages: dump symbol tables of packages;
1551 quote, HighBit, undefPrint: change style of string dump;
1552 tkRunning: run Tk while prompting (with ReadLine);
1553 signalLevel warnLevel dieLevel: level of verbosity;
1554 Option PrintRet affects printing of return value after r command,
1555 frame affects printing messages on entry and exit from subroutines.
1556 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1557 You can put additional initialization options TTY, noTTY,
1558 ReadLine, and NonStop there.
1559 < command Define Perl command to run before each prompt.
1560 << command Add to the list of Perl commands to run before each prompt.
1561 > command Define Perl command to run after each prompt.
1562 >> command Add to the list of Perl commands to run after each prompt.
1563 \{ commandline Define debugger command to run before each prompt.
1564 \{{ commandline Add to the list of debugger commands to run before each prompt.
1565 $prc number Redo a previous command (default previous command).
1566 $prc -number Redo number'th-to-last command.
1567 $prc pattern Redo last command that started with pattern.
1568 See 'O recallCommand' too.
1569 $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1570 . ( $rc eq $sh ? "" : "
1571 $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1572 See 'O shellBang' too.
1573 H -number Display last number commands (default all).
1574 p expr Same as \"print {DB::OUT} expr\" in current package.
1575 |dbcmd Run debugger command, piping DB::OUT to current pager.
1576 ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1577 \= [alias value] Define a command alias, or list current aliases.
1578 command Execute as a perl statement in current package.
1579 v Show versions of loaded modules.
1580 R Pure-man-restart of debugger, some of debugger state
1581 and command-line options may be lost.
1582 h [db_command] Get help [on a specific debugger command], enter |h to page.
1583 h h Summary of debugger commands.
1587 $summary = <<"END_SUM";
1588 List/search source lines: Control script execution:
1589 l [ln|sub] List source code T Stack trace
1590 - or . List previous/current line s [expr] Single step [in expr]
1591 w [line] List around line n [expr] Next, steps over subs
1592 f filename View source in file <CR> Repeat last n or s
1593 /pattern/ ?patt? Search forw/backw r Return from subroutine
1594 v Show versions of modules c [ln|sub] Continue until position
1595 Debugger controls: L List break pts & actions
1596 O [...] Set debugger options t [expr] Toggle trace [trace expr]
1597 <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
1598 >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
1599 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1600 H [-num] Display last num commands D Delete all breakpoints
1601 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1602 h [db_cmd] Get help on command A Delete all actions
1603 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
1604 q or ^D Quit R Attempt a restart
1605 Data Examination: expr Execute perl code, also see: s,n,t expr
1606 x expr Evals expression in array context, dumps the result.
1607 p expr Print expression (uses script's current package).
1608 S [[!]pat] List subroutine names [not] matching pattern
1609 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1610 X [Vars] Same as \"V current_package [Vars]\".
1612 # ')}}; # Fix balance of Emacs parsing
1618 $SIG{'ABRT'} = 'DEFAULT';
1619 kill 'ABRT', $$ if $panic++;
1620 print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue
1621 local $SIG{__WARN__} = '';
1623 local $Carp::CarpLevel = 2; # mydie + confess
1624 &warn(Carp::longmess("Signal @_"));
1631 local $SIG{__WARN__} = '';
1632 local $SIG{__DIE__} = '';
1633 eval { require Carp }; # If error/warning during compilation,
1634 # require may be broken.
1635 warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1636 unless defined &Carp::longmess;
1637 #&warn("Entering dbwarn\n");
1638 my ($mysingle,$mytrace) = ($single,$trace);
1639 $single = 0; $trace = 0;
1640 my $mess = Carp::longmess(@_);
1641 ($single,$trace) = ($mysingle,$mytrace);
1642 #&warn("Warning in dbwarn\n");
1644 #&warn("Exiting dbwarn\n");
1650 local $SIG{__DIE__} = '';
1651 local $SIG{__WARN__} = '';
1652 my $i = 0; my $ineval = 0; my $sub;
1653 #&warn("Entering dbdie\n");
1654 if ($dieLevel != 2) {
1655 while ((undef,undef,undef,$sub) = caller(++$i)) {
1656 $ineval = 1, last if $sub eq '(eval)';
1659 local $SIG{__WARN__} = \&dbwarn;
1660 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1662 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1663 die @_ if $ineval and $dieLevel < 2;
1665 eval { require Carp }; # If error/warning during compilation,
1666 # require may be broken.
1667 die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1668 # We do not want to debug this chunk (automatic disabling works
1669 # inside DB::DB, but not in Carp).
1670 my ($mysingle,$mytrace) = ($single,$trace);
1671 $single = 0; $trace = 0;
1672 my $mess = Carp::longmess(@_);
1673 ($single,$trace) = ($mysingle,$mytrace);
1674 #&warn("dieing loudly in dbdie\n");
1680 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1683 $SIG{__WARN__} = \&DB::dbwarn;
1685 $SIG{__WARN__} = $prevwarn;
1693 $prevdie = $SIG{__DIE__} unless $dieLevel;
1696 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1697 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1698 print $OUT "Stack dump during die enabled",
1699 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1700 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1702 $SIG{__DIE__} = $prevdie;
1703 print $OUT "Default die handler restored.\n";
1711 $prevsegv = $SIG{SEGV} unless $signalLevel;
1712 $prevbus = $SIG{BUS} unless $signalLevel;
1713 $signalLevel = shift;
1715 $SIG{SEGV} = \&DB::diesignal;
1716 $SIG{BUS} = \&DB::diesignal;
1718 $SIG{SEGV} = $prevsegv;
1719 $SIG{BUS} = $prevbus;
1725 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1727 BEGIN { # This does not compile, alas.
1728 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1729 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1733 $deep = 100; # warning if stack gets this deep
1737 $SIG{INT} = \&DB::catch;
1738 # This may be enabled to debug debugger:
1739 #$warnLevel = 1 unless defined $warnLevel;
1740 #$dieLevel = 1 unless defined $dieLevel;
1741 #$signalLevel = 1 unless defined $signalLevel;
1743 $db_stop = 0; # Compiler warning
1745 $level = 0; # Level of recursive debugging
1746 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1747 # Triggers bug (?) in perl is we postpone this until runtime:
1748 @postponed = @stack = (0);
1753 BEGIN {$^W = $ini_warn;} # Switch warnings back
1755 #use Carp; # This did break, left for debuggin
1758 my($text, $line, $start) = @_;
1759 my ($itext, $prefix, $pack) = $text;
1761 if ((substr $text, 0, 1) eq '&') { # subroutines
1762 $text = substr $text, 1;
1764 return map "$prefix$_", grep /^\Q$text/, keys %sub;
1766 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
1767 $pack = ($1 eq 'main' ? '' : $1) . '::';
1768 $prefix = (substr $text, 0, 1) . $1 . '::';
1771 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
1772 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1773 return db_complete($out[0], $line, $start);
1777 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
1778 $pack = ($package eq 'main' ? '' : $package) . '::';
1779 $prefix = substr $text, 0, 1;
1780 $text = substr $text, 1;
1781 my @out = map "$prefix$_", grep /^\Q$text/,
1782 (grep /^_?[a-zA-Z]/, keys %$pack),
1783 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
1784 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1785 return db_complete($out[0], $line, $start);
1789 return grep /^\Q$text/, (keys %sub), qw(postpone load) # subroutines
1790 if (substr $line, 0, $start) =~ /^[bl]\s+(postpone\s+)?$/;
1791 return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages
1792 if (substr $line, 0, $start) =~ /^V\s+$/;
1793 if ((substr $line, 0, $start) =~ /^O\b.*\s$/) { # Options after a space
1794 my @out = grep /^\Q$text/, @options;
1795 my $val = option_val($out[0], undef);
1797 if (not defined $val or $val =~ /[\n\r]/) {
1798 # Can do nothing better
1799 } elsif ($val =~ /\s/) {
1801 foreach $l (split //, qq/\"\'\#\|/) {
1802 $out = "$l$val$l ", last if (index $val, $l) == -1;
1807 # Default to value if one completion, to question if many
1808 $readline::rl_completer_terminator_character
1809 = $readline::rl_completer_terminator_character
1810 = (@out == 1 ? $out : '? ');
1813 return &readline::rl_filename_list($text); # filenames
1817 $finished = $inhibit_exit; # So that some keys may be disabled.
1819 DB::fake::at_exit() unless $exiting;
1825 "Debuggee terminated. Use `q' to quit and `R' to restart.";