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 %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(*{"_<$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 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 # 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.
123 # Changes: 0.97: NonStop will not stop in at_exit().
124 # Option AutoTrace implemented.
125 # Trace printed differently if frames are printed too.
127 ####################################################################
129 # Needed for the statement after exec():
131 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
132 local($^W) = 0; # Switch run-time warnings off during init.
135 $dumpvar::arrayDepth,
136 $dumpvar::dumpDBFiles,
137 $dumpvar::dumpPackages,
138 $dumpvar::quoteHighBit,
139 $dumpvar::printUndef,
141 $readline::Tk_toloop,
149 # Command-line + PERLLIB:
152 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
154 $trace = $signal = $single = 0; # Uninitialized warning suppression
155 # (local $^W cannot help - other packages!).
156 $inhibit_exit = $option{PrintRet} = 1;
158 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
159 compactDump veryCompact quote HighBit undefPrint
160 globPrint PrintRet UsageOnly frame AutoTrace
161 TTY noTTY ReadLine NonStop LineInfo
162 recallCommand ShellBang pager tkRunning
163 signalLevel warnLevel dieLevel inhibit_exit);
166 hashDepth => \$dumpvar::hashDepth,
167 arrayDepth => \$dumpvar::arrayDepth,
168 DumpDBFiles => \$dumpvar::dumpDBFiles,
169 DumpPackages => \$dumpvar::dumpPackages,
170 HighBit => \$dumpvar::quoteHighBit,
171 undefPrint => \$dumpvar::printUndef,
172 globPrint => \$dumpvar::globPrint,
173 tkRunning => \$readline::Tk_toloop,
174 UsageOnly => \$dumpvar::usageOnly,
176 AutoTrace => \$trace,
177 inhibit_exit => \$inhibit_exit,
181 compactDump => \&dumpvar::compactDump,
182 veryCompact => \&dumpvar::veryCompact,
183 quote => \&dumpvar::quote,
186 ReadLine => \&ReadLine,
187 NonStop => \&NonStop,
188 LineInfo => \&LineInfo,
189 recallCommand => \&recallCommand,
190 ShellBang => \&shellBang,
192 signalLevel => \&signalLevel,
193 warnLevel => \&warnLevel,
194 dieLevel => \&dieLevel,
198 compactDump => 'dumpvar.pl',
199 veryCompact => 'dumpvar.pl',
200 quote => 'dumpvar.pl',
203 # These guys may be defined in $ENV{PERL5DB} :
204 $rl = 1 unless defined $rl;
205 $warnLevel = 1 unless defined $warnLevel;
206 $dieLevel = 1 unless defined $dieLevel;
207 $signalLevel = 1 unless defined $signalLevel;
208 $pre = [] unless defined $pre;
209 $post = [] unless defined $post;
210 $pretype = [] unless defined $pretype;
211 warnLevel($warnLevel);
213 signalLevel($signalLevel);
214 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
215 &recallCommand("!") unless defined $prc;
216 &shellBang("!") unless defined $psh;
221 $rcfile="perldb.ini";
226 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
227 do "$ENV{LOGDIR}/$rcfile";
228 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
229 do "$ENV{HOME}/$rcfile";
232 if (defined $ENV{PERLDB_OPTS}) {
233 parse_options($ENV{PERLDB_OPTS});
236 if (exists $ENV{PERLDB_RESTART}) {
237 delete $ENV{PERLDB_RESTART};
239 @hist = get_list('PERLDB_HIST');
240 %break_on_load = get_list("PERLDB_ON_LOAD");
241 %postponed = get_list("PERLDB_POSTPONE");
242 my @had_breakpoints= get_list("PERLDB_VISITED");
243 for (0 .. $#had_breakpoints) {
244 %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_");
246 my %opt = get_list("PERLDB_OPT");
248 while (($opt,$val) = each %opt) {
249 $val =~ s/[\\\']/\\$1/g;
250 parse_options("$opt'$val'");
252 @INC = get_list("PERLDB_INC");
259 # Is Perl being run from Emacs?
260 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
261 $rl = 0, shift(@main::ARGV) if $emacs;
263 #require Term::ReadLine;
266 $console = "/dev/tty";
270 $console = "sys\$command";
274 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
278 $console = $tty if defined $tty;
280 if (defined $console) {
281 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
282 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
283 || open(OUT,">&STDOUT"); # so we don't dongle stdout
286 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
287 $console = 'STDIN/OUT';
289 # so open("|more") can read from STDOUT and so we don't dingle stdin
294 $| = 1; # for DB::OUT
297 $LINEINFO = $OUT unless defined $LINEINFO;
298 $lineinfo = $console unless defined $lineinfo;
300 $| = 1; # for real STDOUT
302 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
303 unless ($runnonstop) {
304 print $OUT "\nLoading DB routines from $header\n";
305 print $OUT ("Emacs support ",
306 $emacs ? "enabled" : "available",
308 print $OUT "\nEnter h or `h h' for help.\n\n";
315 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
318 if (defined &afterinit) { # May be defined in $rcfile
322 ############################################################ Subroutines
325 # _After_ the perl program is compiled, $single is set to 1:
326 if ($single and not $second_time++) {
327 if ($runnonstop) { # Disable until signal
328 for ($i=0; $i <= $#stack; ) {
332 # return; # Would not print trace!
335 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
337 ($package, $filename, $line) = caller;
338 $filename_ini = $filename;
339 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
340 "package $package;"; # this won't let them modify, alas
341 local(*dbline) = "::_<$filename";
343 if (($stop,$action) = split(/\0/,$dbline{$line})) {
347 $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
348 $dbline{$line} =~ s/;9($|\0)/$1/;
351 my $was_signal = $signal;
353 if ($single || $trace || $was_signal) {
356 $position = "\032\032$filename:$line:0\n";
357 print $LINEINFO $position;
360 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
361 $prefix .= "$sub($filename:";
362 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
363 if (length($prefix) > 30) {
364 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
369 $position = "$prefix$line$infix$dbline[$line]$after";
372 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
374 print $LINEINFO $position;
376 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
377 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
379 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
380 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
381 $position .= $incr_pos;
383 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
385 print $LINEINFO $incr_pos;
390 $evalarg = $action, &eval if $action;
391 if ($single || $was_signal) {
392 local $level = $level + 1;
393 map {$evalarg = $_, &eval} @$pre;
394 print $OUT $#stack . " levels deep in subroutine calls!\n"
397 @typeahead = @$pretype, @typeahead;
399 while (($term || &setterm),
400 defined ($cmd=&readline(" DB" . ('<' x $level) .
401 ($#hist+1) . ('>' x $level) .
405 $cmd =~ s/\\$/\n/ && do {
406 $cmd .= &readline(" cont: ");
409 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
410 $cmd =~ /^$/ && ($cmd = $laststep);
411 push(@hist,$cmd) if length($cmd) > 1;
413 ($i) = split(/\s+/,$cmd);
414 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
415 $cmd =~ /^h$/ && do {
418 $cmd =~ /^h\s+h$/ && do {
421 $cmd =~ /^h\s+(\S)$/ && do {
423 if ($help =~ /^$asked/m) {
424 while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
428 print $OUT "`$asked' is not a debugger command.\n";
431 $cmd =~ /^t$/ && do {
433 print $OUT "Trace = ".($trace?"on":"off")."\n";
435 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
436 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
437 foreach $subname (sort(keys %sub)) {
438 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
439 print $OUT $subname,"\n";
443 $cmd =~ /^v$/ && do {
444 list_versions(); next CMD};
445 $cmd =~ s/^X\b/V $package/;
446 $cmd =~ /^V$/ && do {
447 $cmd = "V $package"; };
448 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
449 local ($savout) = select($OUT);
451 @vars = split(' ',$2);
452 do 'dumpvar.pl' unless defined &main::dumpvar;
453 if (defined &main::dumpvar) {
456 &main::dumpvar($packname,@vars);
458 print $OUT "dumpvar.pl not available.\n";
462 $cmd =~ s/^x\b/ / && do { # So that will be evaled
464 $cmd =~ /^f\b\s*(.*)/ && do {
467 print $OUT "The old f command is now the r command.\n";
468 print $OUT "The new f command switches filenames.\n";
471 if (!defined $main::{'_<' . $file}) {
472 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
473 $file = substr($try,2);
477 if (!defined $main::{'_<' . $file}) {
478 print $OUT "No file matching `$file' is loaded.\n";
480 } elsif ($file ne $filename) {
481 *dbline = "::_<$file";
487 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
489 $subname =~ s/\'/::/;
490 $subname = "main::".$subname unless $subname =~ /::/;
491 $subname = "main".$subname if substr($subname,0,2) eq "::";
492 @pieces = split(/:/,$sub{$subname});
493 $subrange = pop @pieces;
494 $file = join(':', @pieces);
495 if ($file ne $filename) {
496 *dbline = "::_<$file";
501 if (eval($subrange) < -$window) {
502 $subrange =~ s/-.*/+/;
504 $cmd = "l $subrange";
506 print $OUT "Subroutine $subname not found.\n";
509 $cmd =~ /^\.$/ && do {
511 $filename = $filename_ini;
512 *dbline = "::_<$filename";
514 print $LINEINFO $position;
516 $cmd =~ /^w\b\s*(\d*)$/ && do {
520 #print $OUT 'l ' . $start . '-' . ($start + $incr);
521 $cmd = 'l ' . $start . '-' . ($start + $incr); };
522 $cmd =~ /^-$/ && do {
524 $cmd = 'l ' . ($start-$window*2) . '+'; };
525 $cmd =~ /^l$/ && do {
527 $cmd = 'l ' . $start . '-' . ($start + $incr); };
528 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
531 $incr = $window - 1 unless $incr;
532 $cmd = 'l ' . $start . '-' . ($start + $incr); };
533 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
534 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
535 $end = $max if $end > $max;
537 $i = $line if $i eq '.';
540 print $OUT "\032\032$filename:$i:0\n";
543 for (; $i <= $end; $i++) {
544 ($stop,$action) = split(/\0/, $dbline{$i});
546 and $filename eq $filename_ini)
548 : ($dbline[$i]+0 ? ':' : ' ') ;
549 $arrow .= 'b' if $stop;
550 $arrow .= 'a' if $action;
551 print $OUT "$i$arrow\t", $dbline[$i];
555 $start = $i; # remember in case they want more
556 $start = $max if $start > $max;
558 $cmd =~ /^D$/ && do {
559 print $OUT "Deleting all breakpoints...\n";
561 for $file (keys %had_breakpoints) {
562 local *dbline = "::_<$file";
566 for ($i = 1; $i <= $max ; $i++) {
567 if (defined $dbline{$i}) {
568 $dbline{$i} =~ s/^[^\0]+//;
569 if ($dbline{$i} =~ s/^\0?$//) {
576 undef %postponed_file;
577 undef %break_on_load;
578 undef %had_breakpoints;
580 $cmd =~ /^L$/ && do {
582 for $file (keys %had_breakpoints) {
583 local *dbline = "::_<$file";
587 for ($i = 1; $i <= $max; $i++) {
588 if (defined $dbline{$i}) {
589 print "$file:\n" unless $was++;
590 print $OUT " $i:\t", $dbline[$i];
591 ($stop,$action) = split(/\0/, $dbline{$i});
592 print $OUT " break if (", $stop, ")\n"
594 print $OUT " action: ", $action, "\n"
601 print $OUT "Postponed breakpoints in subroutines:\n";
603 for $subname (keys %postponed) {
604 print $OUT " $subname\t$postponed{$subname}\n";
608 my @have = map { # Combined keys
609 keys %{$postponed_file{$_}}
610 } keys %postponed_file;
612 print $OUT "Postponed breakpoints in files:\n";
614 for $file (keys %postponed_file) {
615 my %db = %{$postponed_file{$file}};
616 next unless keys %db;
617 print $OUT " $file:\n";
618 for $line (sort {$a <=> $b} keys %db) {
620 my ($stop,$action) = split(/\0/, $db{$line});
621 print $OUT " break if (", $stop, ")\n"
623 print $OUT " action: ", $action, "\n"
630 if (%break_on_load) {
631 print $OUT "Breakpoints on load:\n";
633 for $file (keys %break_on_load) {
634 print $OUT " $file\n";
639 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
642 $break_on_load{$file} = 1;
643 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
644 $file .= '.pm', redo unless $file =~ /\./;
646 $had_breakpoints{$file} = 1;
647 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
649 $cmd =~ /^b\b\s*postpone\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
650 my $cond = $2 || '1';
652 $subname =~ s/\'/::/;
653 $subname = "${'package'}::" . $subname
654 unless $subname =~ /::/;
655 $subname = "main".$subname if substr($subname,0,2) eq "::";
656 $postponed{$subname} = "break +0 if $cond";
658 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
661 $subname =~ s/\'/::/;
662 $subname = "${'package'}::" . $subname
663 unless $subname =~ /::/;
664 $subname = "main".$subname if substr($subname,0,2) eq "::";
665 # Filename below can contain ':'
666 ($file,$i) = ($sub{$subname} =~ /^(.*):(.*)$/);
670 *dbline = "::_<$filename";
671 $had_breakpoints{$filename} = 1;
673 ++$i while $dbline[$i] == 0 && $i < $max;
674 $dbline{$i} =~ s/^[^\0]*/$cond/;
676 print $OUT "Subroutine $subname not found.\n";
679 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
682 if ($dbline[$i] == 0) {
683 print $OUT "Line $i not breakable.\n";
685 $had_breakpoints{$filename} = 1;
686 $dbline{$i} =~ s/^[^\0]*/$cond/;
689 $cmd =~ /^d\b\s*(\d+)?/ && do {
691 $dbline{$i} =~ s/^[^\0]*//;
692 delete $dbline{$i} if $dbline{$i} eq '';
694 $cmd =~ /^A$/ && do {
696 for $file (keys %had_breakpoints) {
697 local *dbline = "::_<$file";
701 for ($i = 1; $i <= $max ; $i++) {
702 if (defined $dbline{$i}) {
703 $dbline{$i} =~ s/\0[^\0]*//;
704 delete $dbline{$i} if $dbline{$i} eq '';
709 $cmd =~ /^O\s*$/ && do {
714 $cmd =~ /^O\s*(\S.*)/ && do {
717 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
718 push @$pre, action($1);
720 $cmd =~ /^>>\s*(.*)/ && do {
721 push @$post, action($1);
723 $cmd =~ /^<\s*(.*)/ && do {
724 $pre = [], next CMD unless $1;
727 $cmd =~ /^>\s*(.*)/ && do {
728 $post = [], next CMD unless $1;
729 $post = [action($1)];
731 $cmd =~ /^\{\{\s*(.*)/ && do {
734 $cmd =~ /^\{\s*(.*)/ && do {
735 $pretype = [], next CMD unless $1;
738 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
740 if ($dbline[$i] == 0) {
741 print $OUT "Line $i may not have an action.\n";
743 $dbline{$i} =~ s/\0[^\0]*//;
744 $dbline{$i} .= "\0" . action($j);
747 $cmd =~ /^n$/ && do {
748 end_report(), next CMD if $finished and $level <= 1;
752 $cmd =~ /^s$/ && do {
753 end_report(), next CMD if $finished and $level <= 1;
757 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
758 end_report(), next CMD if $finished and $level <= 1;
760 if ($i =~ /\D/) { # subroutine name
761 ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/);
765 *dbline = "::_<$filename";
766 $had_breakpoints{$filename}++;
768 ++$i while $dbline[$i] == 0 && $i < $max;
770 print $OUT "Subroutine $subname not found.\n";
775 if ($dbline[$i] == 0) {
776 print $OUT "Line $i not breakable.\n";
779 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
781 for ($i=0; $i <= $#stack; ) {
785 $cmd =~ /^r$/ && do {
786 end_report(), next CMD if $finished and $level <= 1;
787 $stack[$#stack] |= 1;
788 $doret = $option{PrintRet} ? $#stack - 1 : -2;
790 $cmd =~ /^R$/ && do {
791 print $OUT "Warning: some settings and command-line options may be lost!\n";
792 my (@script, @flags, $cl);
793 push @flags, '-w' if $ini_warn;
794 # Put all the old includes at the start to get
797 push @flags, '-I', $_;
799 # Arrange for setting the old INC:
800 set_list("PERLDB_INC", @ini_INC);
802 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
803 chomp ($cl = $ {'::_<-e'}[$_]);
804 push @script, '-e', $cl;
809 set_list("PERLDB_HIST",
810 $term->Features->{getHistory}
811 ? $term->GetHistory : @hist);
812 my @had_breakpoints = keys %had_breakpoints;
813 set_list("PERLDB_VISITED", @had_breakpoints);
814 set_list("PERLDB_OPT", %option);
815 set_list("PERLDB_ON_LOAD", %break_on_load);
817 for (0 .. $#had_breakpoints) {
818 my $file = $had_breakpoints[$_];
819 *dbline = "::_<$file";
820 next unless %dbline or %{$postponed_file{$file}};
821 (push @hard, $file), next
822 if $file =~ /^\(eval \d+\)$/;
824 @add = %{$postponed_file{$file}}
825 if %{$postponed_file{$file}};
826 set_list("PERLDB_FILE_$_", %dbline, @add);
828 for (@hard) { # Yes, really-really...
829 # Find the subroutines in this eval
831 my ($quoted, $sub, %subs, $line) = quotemeta $_;
832 for $sub (keys %sub) {
833 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
834 $subs{$sub} = [$1, $2];
838 "No subroutines in $_, ignoring breakpoints.\n";
841 LINES: for $line (keys %dbline) {
842 # One breakpoint per sub only:
843 my ($offset, $sub, $found);
844 SUBS: for $sub (keys %subs) {
845 if ($subs{$sub}->[1] >= $line # Not after the subroutine
846 and (not defined $offset # Not caught
847 or $offset < 0 )) { # or badly caught
849 $offset = $line - $subs{$sub}->[0];
850 $offset = "+$offset", last SUBS if $offset >= 0;
853 if (defined $offset) {
855 "break $offset if $dbline{$line}";
857 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
861 set_list("PERLDB_POSTPONE", %postponed);
862 $ENV{PERLDB_RESTART} = 1;
863 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
864 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
865 print $OUT "exec failed: $!\n";
867 $cmd =~ /^T$/ && do {
868 print_trace($OUT, 1); # skip DB
870 $cmd =~ /^\/(.*)$/ && do {
872 $inpat =~ s:([^\\])/$:$1:;
874 eval '$inpat =~ m'."\a$inpat\a";
885 $start = 1 if ($start > $max);
886 last if ($start == $end);
887 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
889 print $OUT "\032\032$filename:$start:0\n";
891 print $OUT "$start:\t", $dbline[$start], "\n";
896 print $OUT "/$pat/: not found\n" if ($start == $end);
898 $cmd =~ /^\?(.*)$/ && do {
900 $inpat =~ s:([^\\])\?$:$1:;
902 eval '$inpat =~ m'."\a$inpat\a";
913 $start = $max if ($start <= 0);
914 last if ($start == $end);
915 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
917 print $OUT "\032\032$filename:$start:0\n";
919 print $OUT "$start:\t", $dbline[$start], "\n";
924 print $OUT "?$pat?: not found\n" if ($start == $end);
926 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
927 pop(@hist) if length($cmd) > 1;
928 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
929 $cmd = $hist[$i] . "\n";
932 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
935 $cmd =~ /^$rc([^$rc].*)$/ && do {
937 pop(@hist) if length($cmd) > 1;
938 for ($i = $#hist; $i; --$i) {
939 last if $hist[$i] =~ /$pat/;
942 print $OUT "No such command!\n\n";
945 $cmd = $hist[$i] . "\n";
948 $cmd =~ /^$sh$/ && do {
949 &system($ENV{SHELL}||"/bin/sh");
951 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
952 &system($ENV{SHELL}||"/bin/sh","-c",$1);
954 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
955 $end = $2?($#hist-$2):0;
956 $hist = 0 if $hist < 0;
957 for ($i=$#hist; $i>$end; $i--) {
958 print $OUT "$i: ",$hist[$i],"\n"
959 unless $hist[$i] =~ /^.?$/;
962 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
963 $cmd =~ s/^p\b/print {\$DB::OUT} /;
965 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
966 $alias{$k}="s~$k~$v~";
967 print $OUT "$k = $v\n";
968 } elsif ($cmd =~ /^=\s*$/) {
969 foreach $k (sort keys(%alias)) {
970 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
971 print $OUT "$k = $v\n";
973 print $OUT "$k\t$alias{$k}\n";
978 $cmd =~ /^\|\|?\s*[^|]/ && do {
979 if ($pager =~ /^\|/) {
980 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
981 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
983 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
985 unless ($piped=open(OUT,$pager)) {
986 &warn("Can't pipe output to `$pager'");
987 if ($pager =~ /^\|/) {
988 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
989 open(STDOUT,">&SAVEOUT")
990 || &warn("Can't restore STDOUT");
993 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
997 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
998 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
999 $selected= select(OUT);
1001 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1002 $cmd =~ s/^\|+\s*//;
1004 # XXX Local variants do not work!
1005 $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
1006 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1007 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1009 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1011 $onetimeDump = undef;
1017 if ($pager =~ /^\|/) {
1018 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1019 &warn( "Pager `$pager' failed: ",
1020 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1021 ( $? & 128 ) ? " (core dumped)" : "",
1022 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1023 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1024 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1025 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1026 # Will stop ignoring SIGPIPE if done like nohup(1)
1027 # does SIGINT but Perl doesn't give us a choice.
1029 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1032 select($selected), $selected= "" unless $selected eq "";
1036 $exiting = 1 unless defined $cmd;
1037 map {$evalarg = $_; &eval} @$post;
1038 } # if ($single || $signal)
1039 ($@, $!, $,, $/, $\, $^W) = @saved;
1043 # The following code may be executed now:
1047 my ($al, $ret, @ret) = "";
1048 if ($sub =~ /::AUTOLOAD$/) {
1049 $al = " for $ {$` . '::AUTOLOAD'}";
1051 push(@stack, $single);
1053 $single |= 4 if $#stack == $deep;
1055 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1056 # Why -1? But it works! :-(
1057 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1058 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1061 $single |= pop(@stack);
1062 print ($OUT "list context return from $sub:\n"), dumpit( \@ret ),
1063 $doret = -2 if $doret eq $#stack;
1065 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1066 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1067 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1071 $single |= pop(@stack);
1072 print ($OUT "scalar context return from $sub: "), dumpit( $ret ),
1073 $doret = -2 if $doret eq $#stack;
1075 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1076 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1077 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1083 @saved = ($@, $!, $,, $/, $\, $^W);
1084 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1087 # The following takes its argument via $evalarg to preserve current @_
1092 local (@stack) = @stack; # guard against recursive debugging
1093 my $otrace = $trace;
1094 my $osingle = $single;
1096 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1102 local $saved[0]; # Preserve the old value of $@
1106 } elsif ($onetimeDump) {
1112 my $subname = shift;
1113 if ($postponed{$subname} =~ s/break\s([+-]?\d+)\s+if\s//) {
1114 my $offset = $1 || 0;
1115 # Filename below can contain ':'
1116 my ($file,$i) = ($sub{$subname} =~ /^(.*):(\d+)-.*$/);
1119 local *dbline = "::_<$file";
1120 local $^W = 0; # != 0 is magical below
1121 $had_breakpoints{$file}++;
1123 ++$i until $dbline[$i] != 0 or $i >= $max;
1124 $dbline{$i} = delete $postponed{$subname};
1126 print $OUT "Subroutine $subname not found.\n";
1130 #print $OUT "In postponed_sub for `$subname'.\n";
1134 return &postponed_sub
1135 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1136 # Cannot be done before the file is compiled
1137 local *dbline = shift;
1138 my $filename = $dbline;
1139 $filename =~ s/^_<//;
1140 $signal = 1, print $OUT "'$filename' loaded...\n"
1141 if $break_on_load{$filename};
1142 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1143 return unless %{$postponed_file{$filename}};
1144 $had_breakpoints{$filename}++;
1145 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1147 for $key (keys %{$postponed_file{$filename}}) {
1148 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1150 undef %{$postponed_file{$filename}};
1154 local ($savout) = select($OUT);
1155 my $osingle = $single;
1156 my $otrace = $trace;
1157 $single = $trace = 0;
1160 unless (defined &main::dumpValue) {
1163 if (defined &main::dumpValue) {
1164 &main::dumpValue(shift);
1166 print $OUT "dumpvar.pl not available.\n";
1173 # Tied method do not create a context, so may get wrong message:
1177 my @sub = dump_trace($_[0] + 1, $_[1]);
1178 my $short = $_[2]; # Print short report, next one for sub name
1179 for ($i=0; $i <= $#sub; $i++) {
1182 my $args = defined $sub[$i]{args}
1183 ? "(@{ $sub[$i]{args} })"
1185 my $file = $sub[$i]{file};
1186 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1188 my $sub = @_ >= 4 ? $_[3] : $sub[$i]{sub};
1189 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1191 print $fh "$sub[$i]{context} = $sub[$i]{sub}$args" .
1192 " called from $file" .
1193 " line $sub[$i]{line}\n";
1200 my $count = shift || 1e9;
1203 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1204 my $nothard = not $frame & 8;
1205 local $frame = 0; # Do not want to trace this.
1206 my $otrace = $trace;
1209 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1214 if (not defined $arg) {
1216 } elsif ($nothard and tied $arg) {
1218 } elsif ($nothard and $type = ref $arg) {
1219 push @a, "ref($type)";
1221 local $_ = "$arg"; # Safe to stringify now - should not call f().
1224 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1225 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1226 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1230 $context = $context ? '@' : "\$";
1231 $args = $h ? [@a] : undef;
1232 $e =~ s/\n\s*\;\s*\Z// if $e;
1233 $e =~ s/[\\\']/\\$1/g if $e;
1235 $sub = "require '$e'";
1236 } elsif (defined $r) {
1238 } elsif ($sub eq '(eval)') {
1239 $sub = "eval {...}";
1241 push(@sub, {context => $context, sub => $sub, args => $args,
1242 file => $file, line => $line});
1251 while ($action =~ s/\\$//) {
1262 &readline("cont: ");
1266 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1267 # many non-Unix systems can do system() but have problems with fork().
1268 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1269 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1270 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1271 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1273 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1274 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1275 close(SAVEIN); close(SAVEOUT);
1276 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1277 ( $? & 128 ) ? " (core dumped)" : "",
1278 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1285 local @stack = @stack; # Prevent growth by failing `use'.
1286 eval { require Term::ReadLine } or die $@;
1289 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1290 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1293 my $sel = select($OUT);
1297 eval "require Term::Rendezvous;" or die $@;
1298 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1299 my $term_rv = new Term::Rendezvous $rv;
1301 $OUT = $term_rv->OUT;
1305 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1307 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1309 $readline::rl_basic_word_break_characters .= "[:"
1310 if defined $readline::rl_basic_word_break_characters
1311 and index($readline::rl_basic_word_break_characters, ":") == -1;
1312 $readline::rl_special_prefixes =
1313 $readline::rl_special_prefixes = '$@&%';
1314 $readline::rl_completer_word_break_characters =
1315 $readline::rl_completer_word_break_characters . '$@&%';
1316 $readline::rl_completion_function =
1317 $readline::rl_completion_function = \&db_complete;
1319 $LINEINFO = $OUT unless defined $LINEINFO;
1320 $lineinfo = $console unless defined $lineinfo;
1322 if ($term->Features->{setHistory} and "@hist" ne "?") {
1323 $term->SetHistory(@hist);
1329 my $left = @typeahead;
1330 my $got = shift @typeahead;
1331 print $OUT "auto(-$left)", shift, $got, "\n";
1332 $term->AddHistory($got)
1333 if length($got) > 1 and defined $term->Features->{addHistory};
1338 $term->readline(@_);
1342 my ($opt, $val)= @_;
1343 $val = option_val($opt,'N/A');
1344 $val =~ s/([\\\'])/\\$1/g;
1345 printf $OUT "%20s = '%s'\n", $opt, $val;
1349 my ($opt, $default)= @_;
1351 if (defined $optionVars{$opt}
1352 and defined $ {$optionVars{$opt}}) {
1353 $val = $ {$optionVars{$opt}};
1354 } elsif (defined $optionAction{$opt}
1355 and defined &{$optionAction{$opt}}) {
1356 $val = &{$optionAction{$opt}}();
1357 } elsif (defined $optionAction{$opt}
1358 and not defined $option{$opt}
1359 or defined $optionVars{$opt}
1360 and not defined $ {$optionVars{$opt}}) {
1363 $val = $option{$opt};
1371 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1372 my ($opt,$sep) = ($1,$2);
1375 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1377 #&dump_option($opt);
1378 } elsif ($sep !~ /\S/) {
1380 } elsif ($sep eq "=") {
1383 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1384 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1385 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1386 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1388 $val =~ s/\\([\\$end])/$1/g;
1392 grep( /^\Q$opt/ && ($option = $_), @options );
1393 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1395 print $OUT "Unknown option `$opt'\n" unless $matches;
1396 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1397 $option{$option} = $val if $matches == 1 and defined $val;
1398 eval "local \$frame = 0; local \$doret = -2;
1399 require '$optionRequire{$option}'"
1400 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1401 $ {$optionVars{$option}} = $val
1403 and defined $optionVars{$option} and defined $val;
1404 & {$optionAction{$option}} ($val)
1406 and defined $optionAction{$option}
1407 and defined &{$optionAction{$option}} and defined $val;
1408 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1414 my ($stem,@list) = @_;
1416 $ENV{"$ {stem}_n"} = @list;
1417 for $i (0 .. $#list) {
1419 $val =~ s/\\/\\\\/g;
1420 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1421 $ENV{"$ {stem}_$i"} = $val;
1428 my $n = delete $ENV{"$ {stem}_n"};
1430 for $i (0 .. $n - 1) {
1431 $val = delete $ENV{"$ {stem}_$i"};
1432 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1440 return; # Put nothing on the stack - malloc/free land!
1444 my($msg)= join("",@_);
1445 $msg .= ": $!\n" unless $msg =~ /\n$/;
1451 &warn("Too late to set TTY!\n") if @_;
1460 &warn("Too late to set noTTY!\n") if @_;
1462 $notty = shift if @_;
1469 &warn("Too late to set ReadLine!\n") if @_;
1478 &warn("Too late to set up NonStop mode!\n") if @_;
1480 $runnonstop = shift if @_;
1488 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1495 $sh = quotemeta shift;
1496 $sh .= "\\b" if $sh =~ /\w$/;
1500 $psh =~ s/\\(.)/$1/g;
1507 $rc = quotemeta shift;
1508 $rc .= "\\b" if $rc =~ /\w$/;
1512 $prc =~ s/\\(.)/$1/g;
1518 return $lineinfo unless @_;
1520 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1521 $emacs = ($stream =~ /^\|/);
1522 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1523 $LINEINFO = \*LINEINFO;
1524 my $save = select($LINEINFO);
1538 s/^Term::ReadLine::readline$/readline/;
1539 if (defined $ { $_ . '::VERSION' }) {
1540 $version{$file} = "$ { $_ . '::VERSION' } from ";
1542 $version{$file} .= $INC{$file};
1544 do 'dumpvar.pl' unless defined &main::dumpValue;
1545 if (defined &main::dumpValue) {
1547 &main::dumpValue(\%version);
1549 print $OUT "dumpvar.pl not available.\n";
1556 s [expr] Single step [in expr].
1557 n [expr] Next, steps over subroutine calls [in expr].
1558 <CR> Repeat last n or s command.
1559 r Return from current subroutine.
1560 c [line|sub] Continue; optionally inserts a one-time-only breakpoint
1561 at the specified position.
1562 l min+incr List incr+1 lines starting at min.
1563 l min-max List lines min through max.
1564 l line List single line.
1565 l subname List first window of lines from subroutine.
1566 l List next window of lines.
1567 - List previous window of lines.
1568 w [line] List window around line.
1569 . Return to the executed line.
1570 f filename Switch to viewing filename. Must be loaded.
1571 /pattern/ Search forwards for pattern; final / is optional.
1572 ?pattern? Search backwards for pattern; final ? is optional.
1573 L List all breakpoints and actions.
1574 S [[!]pattern] List subroutine names [not] matching pattern.
1575 t Toggle trace mode.
1576 t expr Trace through execution of expr.
1577 b [line] [condition]
1578 Set breakpoint; line defaults to the current execution line;
1579 condition breaks if it evaluates to true, defaults to '1'.
1580 b subname [condition]
1581 Set breakpoint at first line of subroutine.
1582 b load filename Set breakpoint on `require'ing the given file.
1583 b postpone subname [condition]
1584 Set breakpoint at first line of subroutine after
1586 d [line] Delete the breakpoint for line.
1587 D Delete all breakpoints.
1589 Set an action to be done before the line is executed.
1590 Sequence is: check for breakpoint, print line if necessary,
1591 do action, prompt user if breakpoint or step, evaluate line.
1592 A Delete all actions.
1593 V [pkg [vars]] List some (default all) variables in package (default current).
1594 Use ~pattern and !pattern for positive and negative regexps.
1595 X [vars] Same as \"V currentpackage [vars]\".
1596 x expr Evals expression in array context, dumps the result.
1597 O [opt[=val]] [opt\"val\"] [opt?]...
1598 Set or query values of options. val defaults to 1. opt can
1599 be abbreviated. Several options can be listed.
1600 recallCommand, ShellBang: chars used to recall command or spawn shell;
1601 pager: program for output of \"|cmd\";
1602 tkRunning: run Tk while prompting (with ReadLine);
1603 signalLevel warnLevel dieLevel: level of verbosity;
1604 inhibit_exit Allows stepping off the end of the script.
1605 The following options affect what happens with V, X, and x commands:
1606 arrayDepth, hashDepth: print only first N elements ('' for all);
1607 compactDump, veryCompact: change style of array and hash dump;
1608 globPrint: whether to print contents of globs;
1609 DumpDBFiles: dump arrays holding debugged files;
1610 DumpPackages: dump symbol tables of packages;
1611 quote, HighBit, undefPrint: change style of string dump;
1612 Option PrintRet affects printing of return value after r command,
1613 frame affects printing messages on entry and exit from subroutines.
1614 AutoTrace affects printing messages on every possible breaking point.
1615 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1616 You can put additional initialization options TTY, noTTY,
1617 ReadLine, and NonStop there.
1618 < command Define Perl command to run before each prompt.
1619 << command Add to the list of Perl commands to run before each prompt.
1620 > command Define Perl command to run after each prompt.
1621 >> command Add to the list of Perl commands to run after each prompt.
1622 \{ commandline Define debugger command to run before each prompt.
1623 \{{ commandline Add to the list of debugger commands to run before each prompt.
1624 $prc number Redo a previous command (default previous command).
1625 $prc -number Redo number'th-to-last command.
1626 $prc pattern Redo last command that started with pattern.
1627 See 'O recallCommand' too.
1628 $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1629 . ( $rc eq $sh ? "" : "
1630 $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1631 See 'O shellBang' too.
1632 H -number Display last number commands (default all).
1633 p expr Same as \"print {DB::OUT} expr\" in current package.
1634 |dbcmd Run debugger command, piping DB::OUT to current pager.
1635 ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1636 \= [alias value] Define a command alias, or list current aliases.
1637 command Execute as a perl statement in current package.
1638 v Show versions of loaded modules.
1639 R Pure-man-restart of debugger, some of debugger state
1640 and command-line options may be lost.
1641 Currently the following setting are preserved:
1642 history, breakpoints and actions, debugger Options
1643 and the following command-line options: -w, -I, -e.
1644 h [db_command] Get help [on a specific debugger command], enter |h to page.
1645 h h Summary of debugger commands.
1646 q or ^D Quit. Set \$DB::finished to 0 to debug global destruction.
1649 $summary = <<"END_SUM";
1650 List/search source lines: Control script execution:
1651 l [ln|sub] List source code T Stack trace
1652 - or . List previous/current line s [expr] Single step [in expr]
1653 w [line] List around line n [expr] Next, steps over subs
1654 f filename View source in file <CR> Repeat last n or s
1655 /pattern/ ?patt? Search forw/backw r Return from subroutine
1656 v Show versions of modules c [ln|sub] Continue until position
1657 Debugger controls: L List break pts & actions
1658 O [...] Set debugger options t [expr] Toggle trace [trace expr]
1659 <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
1660 >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
1661 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1662 H [-num] Display last num commands D Delete all breakpoints
1663 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1664 h [db_cmd] Get help on command A Delete all actions
1665 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
1666 q or ^D Quit R Attempt a restart
1667 Data Examination: expr Execute perl code, also see: s,n,t expr
1668 x expr Evals expression in array context, dumps the result.
1669 p expr Print expression (uses script's current package).
1670 S [[!]pat] List subroutine names [not] matching pattern
1671 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1672 X [Vars] Same as \"V current_package [Vars]\".
1674 # ')}}; # Fix balance of Emacs parsing
1680 $SIG{'ABRT'} = 'DEFAULT';
1681 kill 'ABRT', $$ if $panic++;
1682 print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue
1683 local $SIG{__WARN__} = '';
1685 local $Carp::CarpLevel = 2; # mydie + confess
1686 &warn(Carp::longmess("Signal @_"));
1693 local $SIG{__WARN__} = '';
1694 local $SIG{__DIE__} = '';
1695 eval { require Carp }; # If error/warning during compilation,
1696 # require may be broken.
1697 warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1698 unless defined &Carp::longmess;
1699 #&warn("Entering dbwarn\n");
1700 my ($mysingle,$mytrace) = ($single,$trace);
1701 $single = 0; $trace = 0;
1702 my $mess = Carp::longmess(@_);
1703 ($single,$trace) = ($mysingle,$mytrace);
1704 #&warn("Warning in dbwarn\n");
1706 #&warn("Exiting dbwarn\n");
1712 local $SIG{__DIE__} = '';
1713 local $SIG{__WARN__} = '';
1714 my $i = 0; my $ineval = 0; my $sub;
1715 #&warn("Entering dbdie\n");
1716 if ($dieLevel != 2) {
1717 while ((undef,undef,undef,$sub) = caller(++$i)) {
1718 $ineval = 1, last if $sub eq '(eval)';
1721 local $SIG{__WARN__} = \&dbwarn;
1722 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1724 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1725 die @_ if $ineval and $dieLevel < 2;
1727 eval { require Carp }; # If error/warning during compilation,
1728 # require may be broken.
1729 die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1730 # We do not want to debug this chunk (automatic disabling works
1731 # inside DB::DB, but not in Carp).
1732 my ($mysingle,$mytrace) = ($single,$trace);
1733 $single = 0; $trace = 0;
1734 my $mess = Carp::longmess(@_);
1735 ($single,$trace) = ($mysingle,$mytrace);
1736 #&warn("dieing loudly in dbdie\n");
1742 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1745 $SIG{__WARN__} = \&DB::dbwarn;
1747 $SIG{__WARN__} = $prevwarn;
1755 $prevdie = $SIG{__DIE__} unless $dieLevel;
1758 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1759 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1760 print $OUT "Stack dump during die enabled",
1761 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1762 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1764 $SIG{__DIE__} = $prevdie;
1765 print $OUT "Default die handler restored.\n";
1773 $prevsegv = $SIG{SEGV} unless $signalLevel;
1774 $prevbus = $SIG{BUS} unless $signalLevel;
1775 $signalLevel = shift;
1777 $SIG{SEGV} = \&DB::diesignal;
1778 $SIG{BUS} = \&DB::diesignal;
1780 $SIG{SEGV} = $prevsegv;
1781 $SIG{BUS} = $prevbus;
1787 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1789 BEGIN { # This does not compile, alas.
1790 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1791 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1795 $deep = 100; # warning if stack gets this deep
1799 $SIG{INT} = \&DB::catch;
1800 # This may be enabled to debug debugger:
1801 #$warnLevel = 1 unless defined $warnLevel;
1802 #$dieLevel = 1 unless defined $dieLevel;
1803 #$signalLevel = 1 unless defined $signalLevel;
1805 $db_stop = 0; # Compiler warning
1807 $level = 0; # Level of recursive debugging
1808 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1809 # Triggers bug (?) in perl is we postpone this until runtime:
1810 @postponed = @stack = (0);
1815 BEGIN {$^W = $ini_warn;} # Switch warnings back
1817 #use Carp; # This did break, left for debuggin
1820 my($text, $line, $start) = @_;
1821 my ($itext, $prefix, $pack) = $text;
1823 if ((substr $text, 0, 1) eq '&') { # subroutines
1824 $text = substr $text, 1;
1826 return map "$prefix$_", grep /^\Q$text/, keys %sub;
1828 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
1829 $pack = ($1 eq 'main' ? '' : $1) . '::';
1830 $prefix = (substr $text, 0, 1) . $1 . '::';
1833 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
1834 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1835 return db_complete($out[0], $line, $start);
1839 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
1840 $pack = ($package eq 'main' ? '' : $package) . '::';
1841 $prefix = substr $text, 0, 1;
1842 $text = substr $text, 1;
1843 my @out = map "$prefix$_", grep /^\Q$text/,
1844 (grep /^_?[a-zA-Z]/, keys %$pack),
1845 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
1846 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1847 return db_complete($out[0], $line, $start);
1851 return grep /^\Q$text/, (keys %sub), qw(postpone load) # subroutines
1852 if (substr $line, 0, $start) =~ /^[bl]\s+(postpone\s+)?$/;
1853 return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages
1854 if (substr $line, 0, $start) =~ /^V\s+$/;
1855 if ((substr $line, 0, $start) =~ /^O\b.*\s$/) { # Options after a space
1856 my @out = grep /^\Q$text/, @options;
1857 my $val = option_val($out[0], undef);
1859 if (not defined $val or $val =~ /[\n\r]/) {
1860 # Can do nothing better
1861 } elsif ($val =~ /\s/) {
1863 foreach $l (split //, qq/\"\'\#\|/) {
1864 $out = "$l$val$l ", last if (index $val, $l) == -1;
1869 # Default to value if one completion, to question if many
1870 $readline::rl_completer_terminator_character
1871 = $readline::rl_completer_terminator_character
1872 = (@out == 1 ? $out : '? ');
1875 return &readline::rl_filename_list($text); # filenames
1878 sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
1881 $finished = $inhibit_exit; # So that some keys may be disabled.
1882 # Do not stop in at_exit() and destructors on exit:
1883 $DB::single = !$exiting && !$runnonstop;
1884 DB::fake::at_exit() unless $exiting or $runnonstop;
1890 "Debuggee terminated. Use `q' to quit and `R' to restart.";
1893 package DB; # Do not trace this 1; below!