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($main::{'_<'.$filename}) is emulated. Here the
28 # $filename is the expanded name of the `require'd file (as found as
31 # Additional services from Perl interpreter:
33 # if caller() is called from the package DB, it provides some
36 # The array @{$main::{'_<'.$filename} is the line-by-line contents of
39 # The hash %{'_<'.$filename} contains breakpoints and action (it is
40 # keyed by line number), and individual entries are settable (as
41 # opposed to the whole hash). Only true/false is important to the
42 # interpreter, though the values used by perl5db.pl have the form
43 # "$break_condition\0$action". Values are magical in numeric context.
45 # The scalar ${'_<'.$filename} contains "_<$filename".
47 # Note that no subroutine call is possible until &DB::sub is defined
48 # (for subroutines defined outside of the package DB). In fact the same is
49 # true if $deep is not defined.
54 # At start reads $rcfile that may set important options. This file
55 # may define a subroutine &afterinit that will be executed after the
56 # debugger is initialized.
58 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
59 # it as a rest of `O ...' line in debugger prompt.
61 # The options that can be specified only at startup:
62 # [To set in $rcfile, call &parse_options("optionName=new_value").]
64 # TTY - the TTY to use for debugging i/o.
66 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
67 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
68 # Term::Rendezvous. Current variant is to have the name of TTY in this
71 # ReadLine - If false, dummy ReadLine is used, so you can debug
72 # ReadLine applications.
74 # NonStop - if true, no i/o is performed until interrupt.
76 # LineInfo - file or pipe to print line number info to. If it is a
77 # pipe, a short "emacs like" message is used.
79 # 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.
126 # new `inhibitExit' option.
127 # printing of a very long statement interruptible.
128 # Changes: 0.98: New command `m' for printing possible methods
129 # 'l -' is a synonim for `-'.
130 # Cosmetic bugs in printing stack trace.
131 # `frame' & 8 to print "expanded args" in stack trace.
132 # Can list/break in imported subs.
133 # new `maxTraceLen' option.
134 # frame & 4 and frame & 8 granted.
136 # nonstoppable lines do not have `:' near the line number.
137 # `b compile subname' implemented.
138 # Will not use $` any more.
139 # `-' behaves sane now.
140 # Changes: 0.99: Completion for `f', `m'.
141 # `m' will remove duplicate names instead of duplicate functions.
142 # `b load' strips trailing whitespace.
143 # completion ignores leading `|'; takes into account current package
144 # when completing a subroutine name (same for `l').
146 ####################################################################
148 # Needed for the statement after exec():
150 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
151 local($^W) = 0; # Switch run-time warnings off during init.
154 $dumpvar::arrayDepth,
155 $dumpvar::dumpDBFiles,
156 $dumpvar::dumpPackages,
157 $dumpvar::quoteHighBit,
158 $dumpvar::printUndef,
160 $readline::Tk_toloop,
168 # Command-line + PERLLIB:
171 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
173 $trace = $signal = $single = 0; # Uninitialized warning suppression
174 # (local $^W cannot help - other packages!).
175 $inhibit_exit = $option{PrintRet} = 1;
177 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
178 compactDump veryCompact quote HighBit undefPrint
179 globPrint PrintRet UsageOnly frame AutoTrace
180 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
181 recallCommand ShellBang pager tkRunning
182 signalLevel warnLevel dieLevel inhibit_exit);
185 hashDepth => \$dumpvar::hashDepth,
186 arrayDepth => \$dumpvar::arrayDepth,
187 DumpDBFiles => \$dumpvar::dumpDBFiles,
188 DumpPackages => \$dumpvar::dumpPackages,
189 HighBit => \$dumpvar::quoteHighBit,
190 undefPrint => \$dumpvar::printUndef,
191 globPrint => \$dumpvar::globPrint,
192 tkRunning => \$readline::Tk_toloop,
193 UsageOnly => \$dumpvar::usageOnly,
195 AutoTrace => \$trace,
196 inhibit_exit => \$inhibit_exit,
197 maxTraceLen => \$maxtrace,
201 compactDump => \&dumpvar::compactDump,
202 veryCompact => \&dumpvar::veryCompact,
203 quote => \&dumpvar::quote,
206 ReadLine => \&ReadLine,
207 NonStop => \&NonStop,
208 LineInfo => \&LineInfo,
209 recallCommand => \&recallCommand,
210 ShellBang => \&shellBang,
212 signalLevel => \&signalLevel,
213 warnLevel => \&warnLevel,
214 dieLevel => \&dieLevel,
218 compactDump => 'dumpvar.pl',
219 veryCompact => 'dumpvar.pl',
220 quote => 'dumpvar.pl',
223 # These guys may be defined in $ENV{PERL5DB} :
224 $rl = 1 unless defined $rl;
225 $warnLevel = 1 unless defined $warnLevel;
226 $dieLevel = 1 unless defined $dieLevel;
227 $signalLevel = 1 unless defined $signalLevel;
228 $pre = [] unless defined $pre;
229 $post = [] unless defined $post;
230 $pretype = [] unless defined $pretype;
231 warnLevel($warnLevel);
233 signalLevel($signalLevel);
234 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
235 &recallCommand("!") unless defined $prc;
236 &shellBang("!") unless defined $psh;
237 $maxtrace = 400 unless defined $maxtrace;
242 $rcfile="perldb.ini";
247 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
248 do "$ENV{LOGDIR}/$rcfile";
249 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
250 do "$ENV{HOME}/$rcfile";
253 if (defined $ENV{PERLDB_OPTS}) {
254 parse_options($ENV{PERLDB_OPTS});
257 if (exists $ENV{PERLDB_RESTART}) {
258 delete $ENV{PERLDB_RESTART};
260 @hist = get_list('PERLDB_HIST');
261 %break_on_load = get_list("PERLDB_ON_LOAD");
262 %postponed = get_list("PERLDB_POSTPONE");
263 my @had_breakpoints= get_list("PERLDB_VISITED");
264 for (0 .. $#had_breakpoints) {
265 %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_");
267 my %opt = get_list("PERLDB_OPT");
269 while (($opt,$val) = each %opt) {
270 $val =~ s/[\\\']/\\$1/g;
271 parse_options("$opt'$val'");
273 @INC = get_list("PERLDB_INC");
280 # Is Perl being run from Emacs?
281 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
282 $rl = 0, shift(@main::ARGV) if $emacs;
284 #require Term::ReadLine;
287 $console = "/dev/tty";
291 $console = "sys\$command";
295 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
299 $console = $tty if defined $tty;
301 if (defined $console) {
302 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
303 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
304 || open(OUT,">&STDOUT"); # so we don't dongle stdout
307 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
308 $console = 'STDIN/OUT';
310 # so open("|more") can read from STDOUT and so we don't dingle stdin
315 $| = 1; # for DB::OUT
318 $LINEINFO = $OUT unless defined $LINEINFO;
319 $lineinfo = $console unless defined $lineinfo;
321 $| = 1; # for real STDOUT
323 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
324 unless ($runnonstop) {
325 print $OUT "\nLoading DB routines from $header\n";
326 print $OUT ("Emacs support ",
327 $emacs ? "enabled" : "available",
329 print $OUT "\nEnter h or `h h' for help.\n\n";
336 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
339 if (defined &afterinit) { # May be defined in $rcfile
343 ############################################################ Subroutines
346 # _After_ the perl program is compiled, $single is set to 1:
347 if ($single and not $second_time++) {
348 if ($runnonstop) { # Disable until signal
349 for ($i=0; $i <= $#stack; ) {
353 # return; # Would not print trace!
356 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
358 ($package, $filename, $line) = caller;
359 $filename_ini = $filename;
360 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
361 "package $package;"; # this won't let them modify, alas
362 local(*dbline) = $main::{'_<' . $filename};
364 if (($stop,$action) = split(/\0/,$dbline{$line})) {
368 $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
369 $dbline{$line} =~ s/;9($|\0)/$1/;
372 my $was_signal = $signal;
374 if ($single || $trace || $was_signal) {
377 $position = "\032\032$filename:$line:0\n";
378 print $LINEINFO $position;
381 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
382 $prefix .= "$sub($filename:";
383 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
384 if (length($prefix) > 30) {
385 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
390 $position = "$prefix$line$infix$dbline[$line]$after";
393 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
395 print $LINEINFO $position;
397 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
398 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
400 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
401 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
402 $position .= $incr_pos;
404 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
406 print $LINEINFO $incr_pos;
411 $evalarg = $action, &eval if $action;
412 if ($single || $was_signal) {
413 local $level = $level + 1;
414 map {$evalarg = $_, &eval} @$pre;
415 print $OUT $#stack . " levels deep in subroutine calls!\n"
418 $incr = -1; # for backward motion.
419 @typeahead = @$pretype, @typeahead;
421 while (($term || &setterm),
422 defined ($cmd=&readline(" DB" . ('<' x $level) .
423 ($#hist+1) . ('>' x $level) .
427 $cmd =~ s/\\$/\n/ && do {
428 $cmd .= &readline(" cont: ");
431 $cmd =~ /^$/ && ($cmd = $laststep);
432 push(@hist,$cmd) if length($cmd) > 1;
434 ($i) = split(/\s+/,$cmd);
435 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
436 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
437 $cmd =~ /^h$/ && do {
440 $cmd =~ /^h\s+h$/ && do {
443 $cmd =~ /^h\s+(\S)$/ && do {
445 if ($help =~ /^$asked/m) {
446 while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
450 print $OUT "`$asked' is not a debugger command.\n";
453 $cmd =~ /^t$/ && do {
455 print $OUT "Trace = ".($trace?"on":"off")."\n";
457 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
458 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
459 foreach $subname (sort(keys %sub)) {
460 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
461 print $OUT $subname,"\n";
465 $cmd =~ /^v$/ && do {
466 list_versions(); next CMD};
467 $cmd =~ s/^X\b/V $package/;
468 $cmd =~ /^V$/ && do {
469 $cmd = "V $package"; };
470 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
471 local ($savout) = select($OUT);
473 @vars = split(' ',$2);
474 do 'dumpvar.pl' unless defined &main::dumpvar;
475 if (defined &main::dumpvar) {
478 &main::dumpvar($packname,@vars);
480 print $OUT "dumpvar.pl not available.\n";
484 $cmd =~ s/^x\b/ / && do { # So that will be evaled
485 $onetimeDump = 'dump'; };
486 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
487 methods($1); next CMD};
488 $cmd =~ s/^m\b/ / && do { # So this will be evaled
489 $onetimeDump = 'methods'; };
490 $cmd =~ /^f\b\s*(.*)/ && do {
494 print $OUT "The old f command is now the r command.\n";
495 print $OUT "The new f command switches filenames.\n";
498 if (!defined $main::{'_<' . $file}) {
499 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
500 $try = substr($try,2);
501 print $OUT "Choosing $try matching `$file':\n";
505 if (!defined $main::{'_<' . $file}) {
506 print $OUT "No file matching `$file' is loaded.\n";
508 } elsif ($file ne $filename) {
509 *dbline = $main::{'_<' . $file};
515 print $OUT "Already in $file.\n";
519 $cmd =~ s/^l\s+-\s*$/-/;
520 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
522 $subname =~ s/\'/::/;
523 $subname = $package."::".$subname
524 unless $subname =~ /::/;
525 $subname = "main".$subname if substr($subname,0,2) eq "::";
526 @pieces = split(/:/,find_sub($subname));
527 $subrange = pop @pieces;
528 $file = join(':', @pieces);
529 if ($file ne $filename) {
530 *dbline = $main::{'_<' . $file};
535 if (eval($subrange) < -$window) {
536 $subrange =~ s/-.*/+/;
538 $cmd = "l $subrange";
540 print $OUT "Subroutine $subname not found.\n";
543 $cmd =~ /^\.$/ && do {
544 $incr = -1; # for backward motion.
546 $filename = $filename_ini;
547 *dbline = $main::{'_<' . $filename};
549 print $LINEINFO $position;
551 $cmd =~ /^w\b\s*(\d*)$/ && do {
555 #print $OUT 'l ' . $start . '-' . ($start + $incr);
556 $cmd = 'l ' . $start . '-' . ($start + $incr); };
557 $cmd =~ /^-$/ && do {
558 $start -= $incr + $window + 1;
559 $start = 1 if $start <= 0;
561 $cmd = 'l ' . ($start) . '+'; };
562 $cmd =~ /^l$/ && do {
564 $cmd = 'l ' . $start . '-' . ($start + $incr); };
565 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
568 $incr = $window - 1 unless $incr;
569 $cmd = 'l ' . $start . '-' . ($start + $incr); };
570 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
571 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
572 $end = $max if $end > $max;
574 $i = $line if $i eq '.';
578 print $OUT "\032\032$filename:$i:0\n";
581 for (; $i <= $end; $i++) {
582 ($stop,$action) = split(/\0/, $dbline{$i});
584 and $filename eq $filename_ini)
586 : ($dbline[$i]+0 ? ':' : ' ') ;
587 $arrow .= 'b' if $stop;
588 $arrow .= 'a' if $action;
589 print $OUT "$i$arrow\t", $dbline[$i];
593 $start = $i; # remember in case they want more
594 $start = $max if $start > $max;
596 $cmd =~ /^D$/ && do {
597 print $OUT "Deleting all breakpoints...\n";
599 for $file (keys %had_breakpoints) {
600 local *dbline = $main::{'_<' . $file};
604 for ($i = 1; $i <= $max ; $i++) {
605 if (defined $dbline{$i}) {
606 $dbline{$i} =~ s/^[^\0]+//;
607 if ($dbline{$i} =~ s/^\0?$//) {
614 undef %postponed_file;
615 undef %break_on_load;
616 undef %had_breakpoints;
618 $cmd =~ /^L$/ && do {
620 for $file (keys %had_breakpoints) {
621 local *dbline = $main::{'_<' . $file};
625 for ($i = 1; $i <= $max; $i++) {
626 if (defined $dbline{$i}) {
627 print "$file:\n" unless $was++;
628 print $OUT " $i:\t", $dbline[$i];
629 ($stop,$action) = split(/\0/, $dbline{$i});
630 print $OUT " break if (", $stop, ")\n"
632 print $OUT " action: ", $action, "\n"
639 print $OUT "Postponed breakpoints in subroutines:\n";
641 for $subname (keys %postponed) {
642 print $OUT " $subname\t$postponed{$subname}\n";
646 my @have = map { # Combined keys
647 keys %{$postponed_file{$_}}
648 } keys %postponed_file;
650 print $OUT "Postponed breakpoints in files:\n";
652 for $file (keys %postponed_file) {
653 my %db = %{$postponed_file{$file}};
654 next unless keys %db;
655 print $OUT " $file:\n";
656 for $line (sort {$a <=> $b} keys %db) {
657 print $OUT " $line:\n";
658 my ($stop,$action) = split(/\0/, $db{$line});
659 print $OUT " break if (", $stop, ")\n"
661 print $OUT " action: ", $action, "\n"
668 if (%break_on_load) {
669 print $OUT "Breakpoints on load:\n";
671 for $file (keys %break_on_load) {
672 print $OUT " $file\n";
677 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
678 my $file = $1; $file =~ s/\s+$//;
680 $break_on_load{$file} = 1;
681 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
682 $file .= '.pm', redo unless $file =~ /\./;
684 $had_breakpoints{$file} = 1;
685 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
687 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
688 my $cond = $3 || '1';
689 my ($subname, $break) = ($2, $1 eq 'postpone');
690 $subname =~ s/\'/::/;
691 $subname = "${'package'}::" . $subname
692 unless $subname =~ /::/;
693 $subname = "main".$subname if substr($subname,0,2) eq "::";
694 $postponed{$subname} = $break
695 ? "break +0 if $cond" : "compile";
697 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
700 $subname =~ s/\'/::/;
701 $subname = "${'package'}::" . $subname
702 unless $subname =~ /::/;
703 $subname = "main".$subname if substr($subname,0,2) eq "::";
704 # Filename below can contain ':'
705 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
709 *dbline = $main::{'_<' . $filename};
710 $had_breakpoints{$filename} = 1;
712 ++$i while $dbline[$i] == 0 && $i < $max;
713 $dbline{$i} =~ s/^[^\0]*/$cond/;
715 print $OUT "Subroutine $subname not found.\n";
718 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
721 if ($dbline[$i] == 0) {
722 print $OUT "Line $i not breakable.\n";
724 $had_breakpoints{$filename} = 1;
725 $dbline{$i} =~ s/^[^\0]*/$cond/;
728 $cmd =~ /^d\b\s*(\d+)?/ && do {
730 $dbline{$i} =~ s/^[^\0]*//;
731 delete $dbline{$i} if $dbline{$i} eq '';
733 $cmd =~ /^A$/ && do {
735 for $file (keys %had_breakpoints) {
736 local *dbline = $main::{'_<' . $file};
740 for ($i = 1; $i <= $max ; $i++) {
741 if (defined $dbline{$i}) {
742 $dbline{$i} =~ s/\0[^\0]*//;
743 delete $dbline{$i} if $dbline{$i} eq '';
748 $cmd =~ /^O\s*$/ && do {
753 $cmd =~ /^O\s*(\S.*)/ && do {
756 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
757 push @$pre, action($1);
759 $cmd =~ /^>>\s*(.*)/ && do {
760 push @$post, action($1);
762 $cmd =~ /^<\s*(.*)/ && do {
763 $pre = [], next CMD unless $1;
766 $cmd =~ /^>\s*(.*)/ && do {
767 $post = [], next CMD unless $1;
768 $post = [action($1)];
770 $cmd =~ /^\{\{\s*(.*)/ && do {
773 $cmd =~ /^\{\s*(.*)/ && do {
774 $pretype = [], next CMD unless $1;
777 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
779 if ($dbline[$i] == 0) {
780 print $OUT "Line $i may not have an action.\n";
782 $dbline{$i} =~ s/\0[^\0]*//;
783 $dbline{$i} .= "\0" . action($j);
786 $cmd =~ /^n$/ && do {
787 end_report(), next CMD if $finished and $level <= 1;
791 $cmd =~ /^s$/ && do {
792 end_report(), next CMD if $finished and $level <= 1;
796 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
797 end_report(), next CMD if $finished and $level <= 1;
799 if ($i =~ /\D/) { # subroutine name
800 ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/);
804 *dbline = $main::{'_<' . $filename};
805 $had_breakpoints{$filename}++;
807 ++$i while $dbline[$i] == 0 && $i < $max;
809 print $OUT "Subroutine $subname not found.\n";
814 if ($dbline[$i] == 0) {
815 print $OUT "Line $i not breakable.\n";
818 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
820 for ($i=0; $i <= $#stack; ) {
824 $cmd =~ /^r$/ && do {
825 end_report(), next CMD if $finished and $level <= 1;
826 $stack[$#stack] |= 1;
827 $doret = $option{PrintRet} ? $#stack - 1 : -2;
829 $cmd =~ /^R$/ && do {
830 print $OUT "Warning: some settings and command-line options may be lost!\n";
831 my (@script, @flags, $cl);
832 push @flags, '-w' if $ini_warn;
833 # Put all the old includes at the start to get
836 push @flags, '-I', $_;
838 # Arrange for setting the old INC:
839 set_list("PERLDB_INC", @ini_INC);
841 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
842 chomp ($cl = $ {'::_<-e'}[$_]);
843 push @script, '-e', $cl;
848 set_list("PERLDB_HIST",
849 $term->Features->{getHistory}
850 ? $term->GetHistory : @hist);
851 my @had_breakpoints = keys %had_breakpoints;
852 set_list("PERLDB_VISITED", @had_breakpoints);
853 set_list("PERLDB_OPT", %option);
854 set_list("PERLDB_ON_LOAD", %break_on_load);
856 for (0 .. $#had_breakpoints) {
857 my $file = $had_breakpoints[$_];
858 *dbline = $main::{'_<' . $file};
859 next unless %dbline or %{$postponed_file{$file}};
860 (push @hard, $file), next
861 if $file =~ /^\(eval \d+\)$/;
863 @add = %{$postponed_file{$file}}
864 if %{$postponed_file{$file}};
865 set_list("PERLDB_FILE_$_", %dbline, @add);
867 for (@hard) { # Yes, really-really...
868 # Find the subroutines in this eval
869 *dbline = $main::{'_<' . $_};
870 my ($quoted, $sub, %subs, $line) = quotemeta $_;
871 for $sub (keys %sub) {
872 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
873 $subs{$sub} = [$1, $2];
877 "No subroutines in $_, ignoring breakpoints.\n";
880 LINES: for $line (keys %dbline) {
881 # One breakpoint per sub only:
882 my ($offset, $sub, $found);
883 SUBS: for $sub (keys %subs) {
884 if ($subs{$sub}->[1] >= $line # Not after the subroutine
885 and (not defined $offset # Not caught
886 or $offset < 0 )) { # or badly caught
888 $offset = $line - $subs{$sub}->[0];
889 $offset = "+$offset", last SUBS if $offset >= 0;
892 if (defined $offset) {
894 "break $offset if $dbline{$line}";
896 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
900 set_list("PERLDB_POSTPONE", %postponed);
901 $ENV{PERLDB_RESTART} = 1;
902 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
903 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
904 print $OUT "exec failed: $!\n";
906 $cmd =~ /^T$/ && do {
907 print_trace($OUT, 1); # skip DB
909 $cmd =~ /^\/(.*)$/ && do {
911 $inpat =~ s:([^\\])/$:$1:;
913 eval '$inpat =~ m'."\a$inpat\a";
925 $start = 1 if ($start > $max);
926 last if ($start == $end);
927 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
929 print $OUT "\032\032$filename:$start:0\n";
931 print $OUT "$start:\t", $dbline[$start], "\n";
936 print $OUT "/$pat/: not found\n" if ($start == $end);
938 $cmd =~ /^\?(.*)$/ && do {
940 $inpat =~ s:([^\\])\?$:$1:;
942 eval '$inpat =~ m'."\a$inpat\a";
954 $start = $max if ($start <= 0);
955 last if ($start == $end);
956 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
958 print $OUT "\032\032$filename:$start:0\n";
960 print $OUT "$start:\t", $dbline[$start], "\n";
965 print $OUT "?$pat?: not found\n" if ($start == $end);
967 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
968 pop(@hist) if length($cmd) > 1;
969 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
970 $cmd = $hist[$i] . "\n";
973 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
976 $cmd =~ /^$rc([^$rc].*)$/ && do {
978 pop(@hist) if length($cmd) > 1;
979 for ($i = $#hist; $i; --$i) {
980 last if $hist[$i] =~ /$pat/;
983 print $OUT "No such command!\n\n";
986 $cmd = $hist[$i] . "\n";
989 $cmd =~ /^$sh$/ && do {
990 &system($ENV{SHELL}||"/bin/sh");
992 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
993 &system($ENV{SHELL}||"/bin/sh","-c",$1);
995 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
996 $end = $2?($#hist-$2):0;
997 $hist = 0 if $hist < 0;
998 for ($i=$#hist; $i>$end; $i--) {
999 print $OUT "$i: ",$hist[$i],"\n"
1000 unless $hist[$i] =~ /^.?$/;
1003 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1004 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1005 $cmd =~ /^=/ && do {
1006 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1007 $alias{$k}="s~$k~$v~";
1008 print $OUT "$k = $v\n";
1009 } elsif ($cmd =~ /^=\s*$/) {
1010 foreach $k (sort keys(%alias)) {
1011 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1012 print $OUT "$k = $v\n";
1014 print $OUT "$k\t$alias{$k}\n";
1019 $cmd =~ /^\|\|?\s*[^|]/ && do {
1020 if ($pager =~ /^\|/) {
1021 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1022 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1024 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1026 unless ($piped=open(OUT,$pager)) {
1027 &warn("Can't pipe output to `$pager'");
1028 if ($pager =~ /^\|/) {
1029 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1030 open(STDOUT,">&SAVEOUT")
1031 || &warn("Can't restore STDOUT");
1034 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1038 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1039 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1040 $selected= select(OUT);
1042 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1043 $cmd =~ s/^\|+\s*//;
1045 # XXX Local variants do not work!
1046 $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
1047 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1048 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1050 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1052 $onetimeDump = undef;
1058 if ($pager =~ /^\|/) {
1059 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1060 &warn( "Pager `$pager' failed: ",
1061 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1062 ( $? & 128 ) ? " (core dumped)" : "",
1063 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1064 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1065 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1066 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1067 # Will stop ignoring SIGPIPE if done like nohup(1)
1068 # does SIGINT but Perl doesn't give us a choice.
1070 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1073 select($selected), $selected= "" unless $selected eq "";
1077 $exiting = 1 unless defined $cmd;
1078 map {$evalarg = $_; &eval} @$post;
1079 } # if ($single || $signal)
1080 ($@, $!, $,, $/, $\, $^W) = @saved;
1084 # The following code may be executed now:
1088 my ($al, $ret, @ret) = "";
1089 if ($sub =~ /(.*)::AUTOLOAD$/) {
1090 $al = " for $ {$1 . '::AUTOLOAD'}";
1092 push(@stack, $single);
1094 $single |= 4 if $#stack == $deep;
1096 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1097 # Why -1? But it works! :-(
1098 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1099 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1102 $single |= pop(@stack);
1104 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1105 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1106 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1107 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1108 "list context return from $sub:\n"), dumpit( \@ret ),
1109 $doret = -2 if $doret eq $#stack or $frame & 16;
1113 $single |= pop(@stack);
1115 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1116 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1117 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1118 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1119 "scalar context return from $sub: "), dumpit( $ret ),
1120 $doret = -2 if $doret eq $#stack or $frame & 16;
1126 @saved = ($@, $!, $,, $/, $\, $^W);
1127 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1130 # The following takes its argument via $evalarg to preserve current @_
1135 local (@stack) = @stack; # guard against recursive debugging
1136 my $otrace = $trace;
1137 my $osingle = $single;
1139 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1145 local $saved[0]; # Preserve the old value of $@
1149 } elsif ($onetimeDump eq 'dump') {
1151 } elsif ($onetimeDump eq 'methods') {
1157 my $subname = shift;
1158 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1159 my $offset = $1 || 0;
1160 # Filename below can contain ':'
1161 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1164 local *dbline = $main::{'_<' . $file};
1165 local $^W = 0; # != 0 is magical below
1166 $had_breakpoints{$file}++;
1168 ++$i until $dbline[$i] != 0 or $i >= $max;
1169 $dbline{$i} = delete $postponed{$subname};
1171 print $OUT "Subroutine $subname not found.\n";
1175 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1176 #print $OUT "In postponed_sub for `$subname'.\n";
1180 return &postponed_sub
1181 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1182 # Cannot be done before the file is compiled
1183 local *dbline = shift;
1184 my $filename = $dbline;
1185 $filename =~ s/^_<//;
1186 $signal = 1, print $OUT "'$filename' loaded...\n"
1187 if $break_on_load{$filename};
1188 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1189 return unless %{$postponed_file{$filename}};
1190 $had_breakpoints{$filename}++;
1191 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1193 for $key (keys %{$postponed_file{$filename}}) {
1194 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1196 undef %{$postponed_file{$filename}};
1200 local ($savout) = select($OUT);
1201 my $osingle = $single;
1202 my $otrace = $trace;
1203 $single = $trace = 0;
1206 unless (defined &main::dumpValue) {
1209 if (defined &main::dumpValue) {
1210 &main::dumpValue(shift);
1212 print $OUT "dumpvar.pl not available.\n";
1219 # Tied method do not create a context, so may get wrong message:
1223 my @sub = dump_trace($_[0] + 1, $_[1]);
1224 my $short = $_[2]; # Print short report, next one for sub name
1226 for ($i=0; $i <= $#sub; $i++) {
1229 my $args = defined $sub[$i]{args}
1230 ? "(@{ $sub[$i]{args} })"
1232 $args = (substr $args, 0, $maxtrace - 3) . '...'
1233 if length $args > $maxtrace;
1234 my $file = $sub[$i]{file};
1235 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1237 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1239 my $sub = @_ >= 4 ? $_[3] : $s;
1240 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1242 print $fh "$sub[$i]{context} = $s$args" .
1243 " called from $file" .
1244 " line $sub[$i]{line}\n";
1251 my $count = shift || 1e9;
1254 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1255 my $nothard = not $frame & 8;
1256 local $frame = 0; # Do not want to trace this.
1257 my $otrace = $trace;
1260 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1265 if (not defined $arg) {
1267 } elsif ($nothard and tied $arg) {
1269 } elsif ($nothard and $type = ref $arg) {
1270 push @a, "ref($type)";
1272 local $_ = "$arg"; # Safe to stringify now - should not call f().
1275 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1276 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1277 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1281 $context = $context ? '@' : "\$";
1282 $args = $h ? [@a] : undef;
1283 $e =~ s/\n\s*\;\s*\Z// if $e;
1284 $e =~ s/([\\\'])/\\$1/g if $e;
1286 $sub = "require '$e'";
1287 } elsif (defined $r) {
1289 } elsif ($sub eq '(eval)') {
1290 $sub = "eval {...}";
1292 push(@sub, {context => $context, sub => $sub, args => $args,
1293 file => $file, line => $line});
1302 while ($action =~ s/\\$//) {
1313 &readline("cont: ");
1317 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1318 # many non-Unix systems can do system() but have problems with fork().
1319 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1320 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1321 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1322 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1324 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1325 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1326 close(SAVEIN); close(SAVEOUT);
1327 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1328 ( $? & 128 ) ? " (core dumped)" : "",
1329 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1336 local @stack = @stack; # Prevent growth by failing `use'.
1337 eval { require Term::ReadLine } or die $@;
1340 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1341 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1344 my $sel = select($OUT);
1348 eval "require Term::Rendezvous;" or die $@;
1349 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1350 my $term_rv = new Term::Rendezvous $rv;
1352 $OUT = $term_rv->OUT;
1356 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1358 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1360 $readline::rl_basic_word_break_characters .= "[:"
1361 if defined $readline::rl_basic_word_break_characters
1362 and index($readline::rl_basic_word_break_characters, ":") == -1;
1363 $readline::rl_special_prefixes =
1364 $readline::rl_special_prefixes = '$@&%';
1365 $readline::rl_completer_word_break_characters =
1366 $readline::rl_completer_word_break_characters . '$@&%';
1367 $readline::rl_completion_function =
1368 $readline::rl_completion_function = \&db_complete;
1370 $LINEINFO = $OUT unless defined $LINEINFO;
1371 $lineinfo = $console unless defined $lineinfo;
1373 if ($term->Features->{setHistory} and "@hist" ne "?") {
1374 $term->SetHistory(@hist);
1380 my $left = @typeahead;
1381 my $got = shift @typeahead;
1382 print $OUT "auto(-$left)", shift, $got, "\n";
1383 $term->AddHistory($got)
1384 if length($got) > 1 and defined $term->Features->{addHistory};
1389 $term->readline(@_);
1393 my ($opt, $val)= @_;
1394 $val = option_val($opt,'N/A');
1395 $val =~ s/([\\\'])/\\$1/g;
1396 printf $OUT "%20s = '%s'\n", $opt, $val;
1400 my ($opt, $default)= @_;
1402 if (defined $optionVars{$opt}
1403 and defined $ {$optionVars{$opt}}) {
1404 $val = $ {$optionVars{$opt}};
1405 } elsif (defined $optionAction{$opt}
1406 and defined &{$optionAction{$opt}}) {
1407 $val = &{$optionAction{$opt}}();
1408 } elsif (defined $optionAction{$opt}
1409 and not defined $option{$opt}
1410 or defined $optionVars{$opt}
1411 and not defined $ {$optionVars{$opt}}) {
1414 $val = $option{$opt};
1422 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1423 my ($opt,$sep) = ($1,$2);
1426 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1428 #&dump_option($opt);
1429 } elsif ($sep !~ /\S/) {
1431 } elsif ($sep eq "=") {
1434 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1435 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1436 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1437 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1439 $val =~ s/\\([\\$end])/$1/g;
1443 grep( /^\Q$opt/ && ($option = $_), @options );
1444 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1446 print $OUT "Unknown option `$opt'\n" unless $matches;
1447 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1448 $option{$option} = $val if $matches == 1 and defined $val;
1449 eval "local \$frame = 0; local \$doret = -2;
1450 require '$optionRequire{$option}'"
1451 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1452 $ {$optionVars{$option}} = $val
1454 and defined $optionVars{$option} and defined $val;
1455 & {$optionAction{$option}} ($val)
1457 and defined $optionAction{$option}
1458 and defined &{$optionAction{$option}} and defined $val;
1459 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1465 my ($stem,@list) = @_;
1467 $ENV{"$ {stem}_n"} = @list;
1468 for $i (0 .. $#list) {
1470 $val =~ s/\\/\\\\/g;
1471 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1472 $ENV{"$ {stem}_$i"} = $val;
1479 my $n = delete $ENV{"$ {stem}_n"};
1481 for $i (0 .. $n - 1) {
1482 $val = delete $ENV{"$ {stem}_$i"};
1483 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1491 return; # Put nothing on the stack - malloc/free land!
1495 my($msg)= join("",@_);
1496 $msg .= ": $!\n" unless $msg =~ /\n$/;
1502 &warn("Too late to set TTY!\n") if @_;
1511 &warn("Too late to set noTTY!\n") if @_;
1513 $notty = shift if @_;
1520 &warn("Too late to set ReadLine!\n") if @_;
1529 &warn("Too late to set up NonStop mode!\n") if @_;
1531 $runnonstop = shift if @_;
1539 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1546 $sh = quotemeta shift;
1547 $sh .= "\\b" if $sh =~ /\w$/;
1551 $psh =~ s/\\(.)/$1/g;
1558 $rc = quotemeta shift;
1559 $rc .= "\\b" if $rc =~ /\w$/;
1563 $prc =~ s/\\(.)/$1/g;
1569 return $lineinfo unless @_;
1571 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1572 $emacs = ($stream =~ /^\|/);
1573 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1574 $LINEINFO = \*LINEINFO;
1575 my $save = select($LINEINFO);
1589 s/^Term::ReadLine::readline$/readline/;
1590 if (defined $ { $_ . '::VERSION' }) {
1591 $version{$file} = "$ { $_ . '::VERSION' } from ";
1593 $version{$file} .= $INC{$file};
1595 do 'dumpvar.pl' unless defined &main::dumpValue;
1596 if (defined &main::dumpValue) {
1598 &main::dumpValue(\%version);
1600 print $OUT "dumpvar.pl not available.\n";
1607 s [expr] Single step [in expr].
1608 n [expr] Next, steps over subroutine calls [in expr].
1609 <CR> Repeat last n or s command.
1610 r Return from current subroutine.
1611 c [line|sub] Continue; optionally inserts a one-time-only breakpoint
1612 at the specified position.
1613 l min+incr List incr+1 lines starting at min.
1614 l min-max List lines min through max.
1615 l line List single line.
1616 l subname List first window of lines from subroutine.
1617 l List next window of lines.
1618 - List previous window of lines.
1619 w [line] List window around line.
1620 . Return to the executed line.
1621 f filename Switch to viewing filename. Must be loaded.
1622 /pattern/ Search forwards for pattern; final / is optional.
1623 ?pattern? Search backwards for pattern; final ? is optional.
1624 L List all breakpoints and actions.
1625 S [[!]pattern] List subroutine names [not] matching pattern.
1626 t Toggle trace mode.
1627 t expr Trace through execution of expr.
1628 b [line] [condition]
1629 Set breakpoint; line defaults to the current execution line;
1630 condition breaks if it evaluates to true, defaults to '1'.
1631 b subname [condition]
1632 Set breakpoint at first line of subroutine.
1633 b load filename Set breakpoint on `require'ing the given file.
1634 b postpone subname [condition]
1635 Set breakpoint at first line of subroutine after
1638 Stop after the subroutine is compiled.
1639 d [line] Delete the breakpoint for line.
1640 D Delete all breakpoints.
1642 Set an action to be done before the line is executed.
1643 Sequence is: check for breakpoint, print line if necessary,
1644 do action, prompt user if breakpoint or step, evaluate line.
1645 A Delete all actions.
1646 V [pkg [vars]] List some (default all) variables in package (default current).
1647 Use ~pattern and !pattern for positive and negative regexps.
1648 X [vars] Same as \"V currentpackage [vars]\".
1649 x expr Evals expression in array context, dumps the result.
1650 m expr Evals expression in array context, prints methods callable
1651 on the first element of the result.
1652 m class Prints methods callable via the given class.
1653 O [opt[=val]] [opt\"val\"] [opt?]...
1654 Set or query values of options. val defaults to 1. opt can
1655 be abbreviated. Several options can be listed.
1656 recallCommand, ShellBang: chars used to recall command or spawn shell;
1657 pager: program for output of \"|cmd\";
1658 tkRunning: run Tk while prompting (with ReadLine);
1659 signalLevel warnLevel dieLevel: level of verbosity;
1660 inhibit_exit Allows stepping off the end of the script.
1661 The following options affect what happens with V, X, and x commands:
1662 arrayDepth, hashDepth: print only first N elements ('' for all);
1663 compactDump, veryCompact: change style of array and hash dump;
1664 globPrint: whether to print contents of globs;
1665 DumpDBFiles: dump arrays holding debugged files;
1666 DumpPackages: dump symbol tables of packages;
1667 quote, HighBit, undefPrint: change style of string dump;
1668 Option PrintRet affects printing of return value after r command,
1669 frame affects printing messages on entry and exit from subroutines.
1670 AutoTrace affects printing messages on every possible breaking point.
1671 maxTraceLen gives maximal length of evals/args listed in stack trace.
1672 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1673 You can put additional initialization options TTY, noTTY,
1674 ReadLine, and NonStop there.
1675 < command Define Perl command to run before each prompt.
1676 << command Add to the list of Perl commands to run before each prompt.
1677 > command Define Perl command to run after each prompt.
1678 >> command Add to the list of Perl commands to run after each prompt.
1679 \{ commandline Define debugger command to run before each prompt.
1680 \{{ commandline Add to the list of debugger commands to run before each prompt.
1681 $prc number Redo a previous command (default previous command).
1682 $prc -number Redo number'th-to-last command.
1683 $prc pattern Redo last command that started with pattern.
1684 See 'O recallCommand' too.
1685 $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1686 . ( $rc eq $sh ? "" : "
1687 $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1688 See 'O shellBang' too.
1689 H -number Display last number commands (default all).
1690 p expr Same as \"print {DB::OUT} expr\" in current package.
1691 |dbcmd Run debugger command, piping DB::OUT to current pager.
1692 ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1693 \= [alias value] Define a command alias, or list current aliases.
1694 command Execute as a perl statement in current package.
1695 v Show versions of loaded modules.
1696 R Pure-man-restart of debugger, some of debugger state
1697 and command-line options may be lost.
1698 Currently the following setting are preserved:
1699 history, breakpoints and actions, debugger Options
1700 and the following command-line options: -w, -I, -e.
1701 h [db_command] Get help [on a specific debugger command], enter |h to page.
1702 h h Summary of debugger commands.
1703 q or ^D Quit. Set \$DB::finished to 0 to debug global destruction.
1706 $summary = <<"END_SUM";
1707 List/search source lines: Control script execution:
1708 l [ln|sub] List source code T Stack trace
1709 - or . List previous/current line s [expr] Single step [in expr]
1710 w [line] List around line n [expr] Next, steps over subs
1711 f filename View source in file <CR> Repeat last n or s
1712 /pattern/ ?patt? Search forw/backw r Return from subroutine
1713 v Show versions of modules c [ln|sub] Continue until position
1714 Debugger controls: L List break pts & actions
1715 O [...] Set debugger options t [expr] Toggle trace [trace expr]
1716 <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
1717 >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
1718 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1719 H [-num] Display last num commands D Delete all breakpoints
1720 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1721 h [db_cmd] Get help on command A Delete all actions
1722 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
1723 q or ^D Quit R Attempt a restart
1724 Data Examination: expr Execute perl code, also see: s,n,t expr
1725 x|m expr Evals expr in array context, dumps the result or lists methods.
1726 p expr Print expression (uses script's current package).
1727 S [[!]pat] List subroutine names [not] matching pattern
1728 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1729 X [Vars] Same as \"V current_package [Vars]\".
1731 # ')}}; # Fix balance of Emacs parsing
1737 $SIG{'ABRT'} = 'DEFAULT';
1738 kill 'ABRT', $$ if $panic++;
1739 print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue
1740 local $SIG{__WARN__} = '';
1742 local $Carp::CarpLevel = 2; # mydie + confess
1743 &warn(Carp::longmess("Signal @_"));
1750 local $SIG{__WARN__} = '';
1751 local $SIG{__DIE__} = '';
1752 eval { require Carp }; # If error/warning during compilation,
1753 # require may be broken.
1754 warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1755 unless defined &Carp::longmess;
1756 #&warn("Entering dbwarn\n");
1757 my ($mysingle,$mytrace) = ($single,$trace);
1758 $single = 0; $trace = 0;
1759 my $mess = Carp::longmess(@_);
1760 ($single,$trace) = ($mysingle,$mytrace);
1761 #&warn("Warning in dbwarn\n");
1763 #&warn("Exiting dbwarn\n");
1769 local $SIG{__DIE__} = '';
1770 local $SIG{__WARN__} = '';
1771 my $i = 0; my $ineval = 0; my $sub;
1772 #&warn("Entering dbdie\n");
1773 if ($dieLevel != 2) {
1774 while ((undef,undef,undef,$sub) = caller(++$i)) {
1775 $ineval = 1, last if $sub eq '(eval)';
1778 local $SIG{__WARN__} = \&dbwarn;
1779 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1781 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1782 die @_ if $ineval and $dieLevel < 2;
1784 eval { require Carp }; # If error/warning during compilation,
1785 # require may be broken.
1786 die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1787 # We do not want to debug this chunk (automatic disabling works
1788 # inside DB::DB, but not in Carp).
1789 my ($mysingle,$mytrace) = ($single,$trace);
1790 $single = 0; $trace = 0;
1791 my $mess = Carp::longmess(@_);
1792 ($single,$trace) = ($mysingle,$mytrace);
1793 #&warn("dieing loudly in dbdie\n");
1799 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1802 $SIG{__WARN__} = \&DB::dbwarn;
1804 $SIG{__WARN__} = $prevwarn;
1812 $prevdie = $SIG{__DIE__} unless $dieLevel;
1815 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1816 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1817 print $OUT "Stack dump during die enabled",
1818 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1819 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1821 $SIG{__DIE__} = $prevdie;
1822 print $OUT "Default die handler restored.\n";
1830 $prevsegv = $SIG{SEGV} unless $signalLevel;
1831 $prevbus = $SIG{BUS} unless $signalLevel;
1832 $signalLevel = shift;
1834 $SIG{SEGV} = \&DB::diesignal;
1835 $SIG{BUS} = \&DB::diesignal;
1837 $SIG{SEGV} = $prevsegv;
1838 $SIG{BUS} = $prevbus;
1846 return unless defined &$subr;
1848 $subr = \&$subr; # Hard reference
1851 $s = $_, last if $subr eq \&$_;
1859 $class = ref $class if ref $class;
1862 methods_via($class, '', 1);
1863 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
1868 return if $packs{$class}++;
1870 my $prepend = $prefix ? "via $prefix: " : '';
1872 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
1873 sort keys %{"$ {class}::"}) {
1874 next if $seen{ $name }++;
1875 print $DB::OUT "$prepend$name\n";
1877 return unless shift; # Recurse?
1878 for $name (@{"$ {class}::ISA"}) {
1879 $prepend = $prefix ? $prefix . " -> $name" : $name;
1880 methods_via($name, $prepend, 1);
1884 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1886 BEGIN { # This does not compile, alas.
1887 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1888 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1892 $deep = 100; # warning if stack gets this deep
1896 $SIG{INT} = \&DB::catch;
1897 # This may be enabled to debug debugger:
1898 #$warnLevel = 1 unless defined $warnLevel;
1899 #$dieLevel = 1 unless defined $dieLevel;
1900 #$signalLevel = 1 unless defined $signalLevel;
1902 $db_stop = 0; # Compiler warning
1904 $level = 0; # Level of recursive debugging
1905 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1906 # Triggers bug (?) in perl is we postpone this until runtime:
1907 @postponed = @stack = (0);
1912 BEGIN {$^W = $ini_warn;} # Switch warnings back
1914 #use Carp; # This did break, left for debuggin
1917 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
1918 my($text, $line, $start) = @_;
1919 my ($itext, $search, $prefix, $pack) =
1920 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
1922 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
1923 (map { /$search/ ? ($1) : () } keys %sub)
1924 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
1925 return sort grep /^\Q$text/, values %INC # files
1926 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
1927 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1928 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
1929 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
1930 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1932 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
1934 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
1935 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
1936 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
1937 # We may want to complete to (eval 9), so $text may be wrong
1938 $prefix = length($1) - length($text);
1941 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
1943 if ((substr $text, 0, 1) eq '&') { # subroutines
1944 $text = substr $text, 1;
1946 return sort map "$prefix$_",
1949 (map { /$search/ ? ($1) : () }
1952 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
1953 $pack = ($1 eq 'main' ? '' : $1) . '::';
1954 $prefix = (substr $text, 0, 1) . $1 . '::';
1957 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
1958 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1959 return db_complete($out[0], $line, $start);
1963 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
1964 $pack = ($package eq 'main' ? '' : $package) . '::';
1965 $prefix = substr $text, 0, 1;
1966 $text = substr $text, 1;
1967 my @out = map "$prefix$_", grep /^\Q$text/,
1968 (grep /^_?[a-zA-Z]/, keys %$pack),
1969 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
1970 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1971 return db_complete($out[0], $line, $start);
1975 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
1976 my @out = grep /^\Q$text/, @options;
1977 my $val = option_val($out[0], undef);
1979 if (not defined $val or $val =~ /[\n\r]/) {
1980 # Can do nothing better
1981 } elsif ($val =~ /\s/) {
1983 foreach $l (split //, qq/\"\'\#\|/) {
1984 $out = "$l$val$l ", last if (index $val, $l) == -1;
1989 # Default to value if one completion, to question if many
1990 $readline::rl_completer_terminator_character
1991 = $readline::rl_completer_terminator_character
1992 = (@out == 1 ? $out : '? ');
1995 return &readline::rl_filename_list($text); # filenames
1998 sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
2001 $finished = $inhibit_exit; # So that some keys may be disabled.
2002 # Do not stop in at_exit() and destructors on exit:
2003 $DB::single = !$exiting && !$runnonstop;
2004 DB::fake::at_exit() unless $exiting or $runnonstop;
2010 "Debuggee terminated. Use `q' to quit and `R' to restart.";
2013 package DB; # Do not trace this 1; below!