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,
167 # Command-line + PERLLIB:
170 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
172 $trace = $signal = $single = 0; # Uninitialized warning suppression
173 # (local $^W cannot help - other packages!).
174 $inhibit_exit = $option{PrintRet} = 1;
176 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
177 compactDump veryCompact quote HighBit undefPrint
178 globPrint PrintRet UsageOnly frame AutoTrace
179 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
180 recallCommand ShellBang pager tkRunning
181 signalLevel warnLevel dieLevel inhibit_exit);
184 hashDepth => \$dumpvar::hashDepth,
185 arrayDepth => \$dumpvar::arrayDepth,
186 DumpDBFiles => \$dumpvar::dumpDBFiles,
187 DumpPackages => \$dumpvar::dumpPackages,
188 HighBit => \$dumpvar::quoteHighBit,
189 undefPrint => \$dumpvar::printUndef,
190 globPrint => \$dumpvar::globPrint,
191 UsageOnly => \$dumpvar::usageOnly,
193 AutoTrace => \$trace,
194 inhibit_exit => \$inhibit_exit,
195 maxTraceLen => \$maxtrace,
199 compactDump => \&dumpvar::compactDump,
200 veryCompact => \&dumpvar::veryCompact,
201 quote => \&dumpvar::quote,
204 ReadLine => \&ReadLine,
205 NonStop => \&NonStop,
206 LineInfo => \&LineInfo,
207 recallCommand => \&recallCommand,
208 ShellBang => \&shellBang,
210 signalLevel => \&signalLevel,
211 warnLevel => \&warnLevel,
212 dieLevel => \&dieLevel,
213 tkRunning => \&tkRunning,
217 compactDump => 'dumpvar.pl',
218 veryCompact => 'dumpvar.pl',
219 quote => 'dumpvar.pl',
222 # These guys may be defined in $ENV{PERL5DB} :
223 $rl = 1 unless defined $rl;
224 $warnLevel = 1 unless defined $warnLevel;
225 $dieLevel = 1 unless defined $dieLevel;
226 $signalLevel = 1 unless defined $signalLevel;
227 $pre = [] unless defined $pre;
228 $post = [] unless defined $post;
229 $pretype = [] unless defined $pretype;
230 warnLevel($warnLevel);
232 signalLevel($signalLevel);
233 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
234 &recallCommand("!") unless defined $prc;
235 &shellBang("!") unless defined $psh;
236 $maxtrace = 400 unless defined $maxtrace;
241 $rcfile="perldb.ini";
246 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
247 do "$ENV{LOGDIR}/$rcfile";
248 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
249 do "$ENV{HOME}/$rcfile";
252 if (defined $ENV{PERLDB_OPTS}) {
253 parse_options($ENV{PERLDB_OPTS});
256 if (exists $ENV{PERLDB_RESTART}) {
257 delete $ENV{PERLDB_RESTART};
259 @hist = get_list('PERLDB_HIST');
260 %break_on_load = get_list("PERLDB_ON_LOAD");
261 %postponed = get_list("PERLDB_POSTPONE");
262 my @had_breakpoints= get_list("PERLDB_VISITED");
263 for (0 .. $#had_breakpoints) {
264 %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_");
266 my %opt = get_list("PERLDB_OPT");
268 while (($opt,$val) = each %opt) {
269 $val =~ s/[\\\']/\\$1/g;
270 parse_options("$opt'$val'");
272 @INC = get_list("PERLDB_INC");
279 # Is Perl being run from Emacs?
280 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
281 $rl = 0, shift(@main::ARGV) if $emacs;
283 #require Term::ReadLine;
286 $console = "/dev/tty";
290 $console = "sys\$command";
294 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
298 $console = $tty if defined $tty;
300 if (defined $console) {
301 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
302 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
303 || open(OUT,">&STDOUT"); # so we don't dongle stdout
306 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
307 $console = 'STDIN/OUT';
309 # so open("|more") can read from STDOUT and so we don't dingle stdin
314 $| = 1; # for DB::OUT
317 $LINEINFO = $OUT unless defined $LINEINFO;
318 $lineinfo = $console unless defined $lineinfo;
320 $| = 1; # for real STDOUT
322 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
323 unless ($runnonstop) {
324 print $OUT "\nLoading DB routines from $header\n";
325 print $OUT ("Emacs support ",
326 $emacs ? "enabled" : "available",
328 print $OUT "\nEnter h or `h h' for help.\n\n";
335 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
338 if (defined &afterinit) { # May be defined in $rcfile
342 ############################################################ Subroutines
345 # _After_ the perl program is compiled, $single is set to 1:
346 if ($single and not $second_time++) {
347 if ($runnonstop) { # Disable until signal
348 for ($i=0; $i <= $#stack; ) {
352 # return; # Would not print trace!
355 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
357 ($package, $filename, $line) = caller;
358 $filename_ini = $filename;
359 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
360 "package $package;"; # this won't let them modify, alas
361 local(*dbline) = $main::{'_<' . $filename};
363 if (($stop,$action) = split(/\0/,$dbline{$line})) {
367 $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
368 $dbline{$line} =~ s/;9($|\0)/$1/;
371 my $was_signal = $signal;
373 if ($single || $trace || $was_signal) {
376 $position = "\032\032$filename:$line:0\n";
377 print $LINEINFO $position;
380 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
381 $prefix .= "$sub($filename:";
382 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
383 if (length($prefix) > 30) {
384 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
389 $position = "$prefix$line$infix$dbline[$line]$after";
392 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
394 print $LINEINFO $position;
396 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
397 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
399 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
400 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
401 $position .= $incr_pos;
403 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
405 print $LINEINFO $incr_pos;
410 $evalarg = $action, &eval if $action;
411 if ($single || $was_signal) {
412 local $level = $level + 1;
413 map {$evalarg = $_, &eval} @$pre;
414 print $OUT $#stack . " levels deep in subroutine calls!\n"
417 $incr = -1; # for backward motion.
418 @typeahead = @$pretype, @typeahead;
420 while (($term || &setterm),
421 defined ($cmd=&readline(" DB" . ('<' x $level) .
422 ($#hist+1) . ('>' x $level) .
426 $cmd =~ s/\\$/\n/ && do {
427 $cmd .= &readline(" cont: ");
430 $cmd =~ /^$/ && ($cmd = $laststep);
431 push(@hist,$cmd) if length($cmd) > 1;
433 ($i) = split(/\s+/,$cmd);
434 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
435 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
436 $cmd =~ /^h$/ && do {
439 $cmd =~ /^h\s+h$/ && do {
442 $cmd =~ /^h\s+(\S)$/ && do {
444 if ($help =~ /^$asked/m) {
445 while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
449 print $OUT "`$asked' is not a debugger command.\n";
452 $cmd =~ /^t$/ && do {
454 print $OUT "Trace = ".($trace?"on":"off")."\n";
456 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
457 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
458 foreach $subname (sort(keys %sub)) {
459 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
460 print $OUT $subname,"\n";
464 $cmd =~ /^v$/ && do {
465 list_versions(); next CMD};
466 $cmd =~ s/^X\b/V $package/;
467 $cmd =~ /^V$/ && do {
468 $cmd = "V $package"; };
469 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
470 local ($savout) = select($OUT);
472 @vars = split(' ',$2);
473 do 'dumpvar.pl' unless defined &main::dumpvar;
474 if (defined &main::dumpvar) {
477 &main::dumpvar($packname,@vars);
479 print $OUT "dumpvar.pl not available.\n";
483 $cmd =~ s/^x\b/ / && do { # So that will be evaled
484 $onetimeDump = 'dump'; };
485 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
486 methods($1); next CMD};
487 $cmd =~ s/^m\b/ / && do { # So this will be evaled
488 $onetimeDump = 'methods'; };
489 $cmd =~ /^f\b\s*(.*)/ && do {
493 print $OUT "The old f command is now the r command.\n";
494 print $OUT "The new f command switches filenames.\n";
497 if (!defined $main::{'_<' . $file}) {
498 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
499 $try = substr($try,2);
500 print $OUT "Choosing $try matching `$file':\n";
504 if (!defined $main::{'_<' . $file}) {
505 print $OUT "No file matching `$file' is loaded.\n";
507 } elsif ($file ne $filename) {
508 *dbline = $main::{'_<' . $file};
514 print $OUT "Already in $file.\n";
518 $cmd =~ s/^l\s+-\s*$/-/;
519 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
521 $subname =~ s/\'/::/;
522 $subname = $package."::".$subname
523 unless $subname =~ /::/;
524 $subname = "main".$subname if substr($subname,0,2) eq "::";
525 @pieces = split(/:/,find_sub($subname));
526 $subrange = pop @pieces;
527 $file = join(':', @pieces);
528 if ($file ne $filename) {
529 *dbline = $main::{'_<' . $file};
534 if (eval($subrange) < -$window) {
535 $subrange =~ s/-.*/+/;
537 $cmd = "l $subrange";
539 print $OUT "Subroutine $subname not found.\n";
542 $cmd =~ /^\.$/ && do {
543 $incr = -1; # for backward motion.
545 $filename = $filename_ini;
546 *dbline = $main::{'_<' . $filename};
548 print $LINEINFO $position;
550 $cmd =~ /^w\b\s*(\d*)$/ && do {
554 #print $OUT 'l ' . $start . '-' . ($start + $incr);
555 $cmd = 'l ' . $start . '-' . ($start + $incr); };
556 $cmd =~ /^-$/ && do {
557 $start -= $incr + $window + 1;
558 $start = 1 if $start <= 0;
560 $cmd = 'l ' . ($start) . '+'; };
561 $cmd =~ /^l$/ && do {
563 $cmd = 'l ' . $start . '-' . ($start + $incr); };
564 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
567 $incr = $window - 1 unless $incr;
568 $cmd = 'l ' . $start . '-' . ($start + $incr); };
569 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
570 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
571 $end = $max if $end > $max;
573 $i = $line if $i eq '.';
577 print $OUT "\032\032$filename:$i:0\n";
580 for (; $i <= $end; $i++) {
581 ($stop,$action) = split(/\0/, $dbline{$i});
583 and $filename eq $filename_ini)
585 : ($dbline[$i]+0 ? ':' : ' ') ;
586 $arrow .= 'b' if $stop;
587 $arrow .= 'a' if $action;
588 print $OUT "$i$arrow\t", $dbline[$i];
592 $start = $i; # remember in case they want more
593 $start = $max if $start > $max;
595 $cmd =~ /^D$/ && do {
596 print $OUT "Deleting all breakpoints...\n";
598 for $file (keys %had_breakpoints) {
599 local *dbline = $main::{'_<' . $file};
603 for ($i = 1; $i <= $max ; $i++) {
604 if (defined $dbline{$i}) {
605 $dbline{$i} =~ s/^[^\0]+//;
606 if ($dbline{$i} =~ s/^\0?$//) {
613 undef %postponed_file;
614 undef %break_on_load;
615 undef %had_breakpoints;
617 $cmd =~ /^L$/ && do {
619 for $file (keys %had_breakpoints) {
620 local *dbline = $main::{'_<' . $file};
624 for ($i = 1; $i <= $max; $i++) {
625 if (defined $dbline{$i}) {
626 print "$file:\n" unless $was++;
627 print $OUT " $i:\t", $dbline[$i];
628 ($stop,$action) = split(/\0/, $dbline{$i});
629 print $OUT " break if (", $stop, ")\n"
631 print $OUT " action: ", $action, "\n"
638 print $OUT "Postponed breakpoints in subroutines:\n";
640 for $subname (keys %postponed) {
641 print $OUT " $subname\t$postponed{$subname}\n";
645 my @have = map { # Combined keys
646 keys %{$postponed_file{$_}}
647 } keys %postponed_file;
649 print $OUT "Postponed breakpoints in files:\n";
651 for $file (keys %postponed_file) {
652 my %db = %{$postponed_file{$file}};
653 next unless keys %db;
654 print $OUT " $file:\n";
655 for $line (sort {$a <=> $b} keys %db) {
656 print $OUT " $line:\n";
657 my ($stop,$action) = split(/\0/, $db{$line});
658 print $OUT " break if (", $stop, ")\n"
660 print $OUT " action: ", $action, "\n"
667 if (%break_on_load) {
668 print $OUT "Breakpoints on load:\n";
670 for $file (keys %break_on_load) {
671 print $OUT " $file\n";
676 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
677 my $file = $1; $file =~ s/\s+$//;
679 $break_on_load{$file} = 1;
680 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
681 $file .= '.pm', redo unless $file =~ /\./;
683 $had_breakpoints{$file} = 1;
684 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
686 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
687 my $cond = $3 || '1';
688 my ($subname, $break) = ($2, $1 eq 'postpone');
689 $subname =~ s/\'/::/;
690 $subname = "${'package'}::" . $subname
691 unless $subname =~ /::/;
692 $subname = "main".$subname if substr($subname,0,2) eq "::";
693 $postponed{$subname} = $break
694 ? "break +0 if $cond" : "compile";
696 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
699 $subname =~ s/\'/::/;
700 $subname = "${'package'}::" . $subname
701 unless $subname =~ /::/;
702 $subname = "main".$subname if substr($subname,0,2) eq "::";
703 # Filename below can contain ':'
704 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
708 *dbline = $main::{'_<' . $filename};
709 $had_breakpoints{$filename} = 1;
711 ++$i while $dbline[$i] == 0 && $i < $max;
712 $dbline{$i} =~ s/^[^\0]*/$cond/;
714 print $OUT "Subroutine $subname not found.\n";
717 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
720 if ($dbline[$i] == 0) {
721 print $OUT "Line $i not breakable.\n";
723 $had_breakpoints{$filename} = 1;
724 $dbline{$i} =~ s/^[^\0]*/$cond/;
727 $cmd =~ /^d\b\s*(\d+)?/ && do {
729 $dbline{$i} =~ s/^[^\0]*//;
730 delete $dbline{$i} if $dbline{$i} eq '';
732 $cmd =~ /^A$/ && do {
734 for $file (keys %had_breakpoints) {
735 local *dbline = $main::{'_<' . $file};
739 for ($i = 1; $i <= $max ; $i++) {
740 if (defined $dbline{$i}) {
741 $dbline{$i} =~ s/\0[^\0]*//;
742 delete $dbline{$i} if $dbline{$i} eq '';
747 $cmd =~ /^O\s*$/ && do {
752 $cmd =~ /^O\s*(\S.*)/ && do {
755 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
756 push @$pre, action($1);
758 $cmd =~ /^>>\s*(.*)/ && do {
759 push @$post, action($1);
761 $cmd =~ /^<\s*(.*)/ && do {
762 $pre = [], next CMD unless $1;
765 $cmd =~ /^>\s*(.*)/ && do {
766 $post = [], next CMD unless $1;
767 $post = [action($1)];
769 $cmd =~ /^\{\{\s*(.*)/ && do {
772 $cmd =~ /^\{\s*(.*)/ && do {
773 $pretype = [], next CMD unless $1;
776 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
778 if ($dbline[$i] == 0) {
779 print $OUT "Line $i may not have an action.\n";
781 $dbline{$i} =~ s/\0[^\0]*//;
782 $dbline{$i} .= "\0" . action($j);
785 $cmd =~ /^n$/ && do {
786 end_report(), next CMD if $finished and $level <= 1;
790 $cmd =~ /^s$/ && do {
791 end_report(), next CMD if $finished and $level <= 1;
795 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
796 end_report(), next CMD if $finished and $level <= 1;
798 if ($i =~ /\D/) { # subroutine name
799 ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/);
803 *dbline = $main::{'_<' . $filename};
804 $had_breakpoints{$filename}++;
806 ++$i while $dbline[$i] == 0 && $i < $max;
808 print $OUT "Subroutine $subname not found.\n";
813 if ($dbline[$i] == 0) {
814 print $OUT "Line $i not breakable.\n";
817 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
819 for ($i=0; $i <= $#stack; ) {
823 $cmd =~ /^r$/ && do {
824 end_report(), next CMD if $finished and $level <= 1;
825 $stack[$#stack] |= 1;
826 $doret = $option{PrintRet} ? $#stack - 1 : -2;
828 $cmd =~ /^R$/ && do {
829 print $OUT "Warning: some settings and command-line options may be lost!\n";
830 my (@script, @flags, $cl);
831 push @flags, '-w' if $ini_warn;
832 # Put all the old includes at the start to get
835 push @flags, '-I', $_;
837 # Arrange for setting the old INC:
838 set_list("PERLDB_INC", @ini_INC);
840 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
841 chomp ($cl = $ {'::_<-e'}[$_]);
842 push @script, '-e', $cl;
847 set_list("PERLDB_HIST",
848 $term->Features->{getHistory}
849 ? $term->GetHistory : @hist);
850 my @had_breakpoints = keys %had_breakpoints;
851 set_list("PERLDB_VISITED", @had_breakpoints);
852 set_list("PERLDB_OPT", %option);
853 set_list("PERLDB_ON_LOAD", %break_on_load);
855 for (0 .. $#had_breakpoints) {
856 my $file = $had_breakpoints[$_];
857 *dbline = $main::{'_<' . $file};
858 next unless %dbline or %{$postponed_file{$file}};
859 (push @hard, $file), next
860 if $file =~ /^\(eval \d+\)$/;
862 @add = %{$postponed_file{$file}}
863 if %{$postponed_file{$file}};
864 set_list("PERLDB_FILE_$_", %dbline, @add);
866 for (@hard) { # Yes, really-really...
867 # Find the subroutines in this eval
868 *dbline = $main::{'_<' . $_};
869 my ($quoted, $sub, %subs, $line) = quotemeta $_;
870 for $sub (keys %sub) {
871 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
872 $subs{$sub} = [$1, $2];
876 "No subroutines in $_, ignoring breakpoints.\n";
879 LINES: for $line (keys %dbline) {
880 # One breakpoint per sub only:
881 my ($offset, $sub, $found);
882 SUBS: for $sub (keys %subs) {
883 if ($subs{$sub}->[1] >= $line # Not after the subroutine
884 and (not defined $offset # Not caught
885 or $offset < 0 )) { # or badly caught
887 $offset = $line - $subs{$sub}->[0];
888 $offset = "+$offset", last SUBS if $offset >= 0;
891 if (defined $offset) {
893 "break $offset if $dbline{$line}";
895 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
899 set_list("PERLDB_POSTPONE", %postponed);
900 $ENV{PERLDB_RESTART} = 1;
901 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
902 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
903 print $OUT "exec failed: $!\n";
905 $cmd =~ /^T$/ && do {
906 print_trace($OUT, 1); # skip DB
908 $cmd =~ /^\/(.*)$/ && do {
910 $inpat =~ s:([^\\])/$:$1:;
912 eval '$inpat =~ m'."\a$inpat\a";
924 $start = 1 if ($start > $max);
925 last if ($start == $end);
926 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
928 print $OUT "\032\032$filename:$start:0\n";
930 print $OUT "$start:\t", $dbline[$start], "\n";
935 print $OUT "/$pat/: not found\n" if ($start == $end);
937 $cmd =~ /^\?(.*)$/ && do {
939 $inpat =~ s:([^\\])\?$:$1:;
941 eval '$inpat =~ m'."\a$inpat\a";
953 $start = $max if ($start <= 0);
954 last if ($start == $end);
955 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
957 print $OUT "\032\032$filename:$start:0\n";
959 print $OUT "$start:\t", $dbline[$start], "\n";
964 print $OUT "?$pat?: not found\n" if ($start == $end);
966 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
967 pop(@hist) if length($cmd) > 1;
968 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
969 $cmd = $hist[$i] . "\n";
972 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
975 $cmd =~ /^$rc([^$rc].*)$/ && do {
977 pop(@hist) if length($cmd) > 1;
978 for ($i = $#hist; $i; --$i) {
979 last if $hist[$i] =~ /$pat/;
982 print $OUT "No such command!\n\n";
985 $cmd = $hist[$i] . "\n";
988 $cmd =~ /^$sh$/ && do {
989 &system($ENV{SHELL}||"/bin/sh");
991 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
992 &system($ENV{SHELL}||"/bin/sh","-c",$1);
994 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
995 $end = $2?($#hist-$2):0;
996 $hist = 0 if $hist < 0;
997 for ($i=$#hist; $i>$end; $i--) {
998 print $OUT "$i: ",$hist[$i],"\n"
999 unless $hist[$i] =~ /^.?$/;
1002 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1003 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1004 $cmd =~ /^=/ && do {
1005 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1006 $alias{$k}="s~$k~$v~";
1007 print $OUT "$k = $v\n";
1008 } elsif ($cmd =~ /^=\s*$/) {
1009 foreach $k (sort keys(%alias)) {
1010 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1011 print $OUT "$k = $v\n";
1013 print $OUT "$k\t$alias{$k}\n";
1018 $cmd =~ /^\|\|?\s*[^|]/ && do {
1019 if ($pager =~ /^\|/) {
1020 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1021 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1023 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1025 unless ($piped=open(OUT,$pager)) {
1026 &warn("Can't pipe output to `$pager'");
1027 if ($pager =~ /^\|/) {
1028 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1029 open(STDOUT,">&SAVEOUT")
1030 || &warn("Can't restore STDOUT");
1033 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1037 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1038 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1039 $selected= select(OUT);
1041 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1042 $cmd =~ s/^\|+\s*//;
1044 # XXX Local variants do not work!
1045 $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
1046 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1047 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1049 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1051 $onetimeDump = undef;
1057 if ($pager =~ /^\|/) {
1058 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1059 &warn( "Pager `$pager' failed: ",
1060 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1061 ( $? & 128 ) ? " (core dumped)" : "",
1062 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1063 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1064 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1065 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1066 # Will stop ignoring SIGPIPE if done like nohup(1)
1067 # does SIGINT but Perl doesn't give us a choice.
1069 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1072 select($selected), $selected= "" unless $selected eq "";
1076 $exiting = 1 unless defined $cmd;
1077 map {$evalarg = $_; &eval} @$post;
1078 } # if ($single || $signal)
1079 ($@, $!, $,, $/, $\, $^W) = @saved;
1083 # The following code may be executed now:
1087 my ($al, $ret, @ret) = "";
1088 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1091 push(@stack, $single);
1093 $single |= 4 if $#stack == $deep;
1095 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1096 # Why -1? But it works! :-(
1097 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1098 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1101 $single |= pop(@stack);
1103 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1104 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1105 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1106 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1107 "list context return from $sub:\n"), dumpit( \@ret ),
1108 $doret = -2 if $doret eq $#stack or $frame & 16;
1112 $single |= pop(@stack);
1114 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1115 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1116 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1117 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1118 "scalar context return from $sub: "), dumpit( $ret ),
1119 $doret = -2 if $doret eq $#stack or $frame & 16;
1125 @saved = ($@, $!, $,, $/, $\, $^W);
1126 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1129 # The following takes its argument via $evalarg to preserve current @_
1134 local (@stack) = @stack; # guard against recursive debugging
1135 my $otrace = $trace;
1136 my $osingle = $single;
1138 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1144 local $saved[0]; # Preserve the old value of $@
1148 } elsif ($onetimeDump eq 'dump') {
1150 } elsif ($onetimeDump eq 'methods') {
1156 my $subname = shift;
1157 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1158 my $offset = $1 || 0;
1159 # Filename below can contain ':'
1160 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1163 local *dbline = $main::{'_<' . $file};
1164 local $^W = 0; # != 0 is magical below
1165 $had_breakpoints{$file}++;
1167 ++$i until $dbline[$i] != 0 or $i >= $max;
1168 $dbline{$i} = delete $postponed{$subname};
1170 print $OUT "Subroutine $subname not found.\n";
1174 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1175 #print $OUT "In postponed_sub for `$subname'.\n";
1179 return &postponed_sub
1180 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1181 # Cannot be done before the file is compiled
1182 local *dbline = shift;
1183 my $filename = $dbline;
1184 $filename =~ s/^_<//;
1185 $signal = 1, print $OUT "'$filename' loaded...\n"
1186 if $break_on_load{$filename};
1187 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1188 return unless %{$postponed_file{$filename}};
1189 $had_breakpoints{$filename}++;
1190 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1192 for $key (keys %{$postponed_file{$filename}}) {
1193 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1195 undef %{$postponed_file{$filename}};
1199 local ($savout) = select($OUT);
1200 my $osingle = $single;
1201 my $otrace = $trace;
1202 $single = $trace = 0;
1205 unless (defined &main::dumpValue) {
1208 if (defined &main::dumpValue) {
1209 &main::dumpValue(shift);
1211 print $OUT "dumpvar.pl not available.\n";
1218 # Tied method do not create a context, so may get wrong message:
1222 my @sub = dump_trace($_[0] + 1, $_[1]);
1223 my $short = $_[2]; # Print short report, next one for sub name
1225 for ($i=0; $i <= $#sub; $i++) {
1228 my $args = defined $sub[$i]{args}
1229 ? "(@{ $sub[$i]{args} })"
1231 $args = (substr $args, 0, $maxtrace - 3) . '...'
1232 if length $args > $maxtrace;
1233 my $file = $sub[$i]{file};
1234 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1236 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1238 my $sub = @_ >= 4 ? $_[3] : $s;
1239 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1241 print $fh "$sub[$i]{context} = $s$args" .
1242 " called from $file" .
1243 " line $sub[$i]{line}\n";
1250 my $count = shift || 1e9;
1253 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1254 my $nothard = not $frame & 8;
1255 local $frame = 0; # Do not want to trace this.
1256 my $otrace = $trace;
1259 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1264 if (not defined $arg) {
1266 } elsif ($nothard and tied $arg) {
1268 } elsif ($nothard and $type = ref $arg) {
1269 push @a, "ref($type)";
1271 local $_ = "$arg"; # Safe to stringify now - should not call f().
1274 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1275 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1276 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1280 $context = $context ? '@' : "\$";
1281 $args = $h ? [@a] : undef;
1282 $e =~ s/\n\s*\;\s*\Z// if $e;
1283 $e =~ s/([\\\'])/\\$1/g if $e;
1285 $sub = "require '$e'";
1286 } elsif (defined $r) {
1288 } elsif ($sub eq '(eval)') {
1289 $sub = "eval {...}";
1291 push(@sub, {context => $context, sub => $sub, args => $args,
1292 file => $file, line => $line});
1301 while ($action =~ s/\\$//) {
1312 &readline("cont: ");
1316 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1317 # many non-Unix systems can do system() but have problems with fork().
1318 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1319 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1320 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1321 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1323 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1324 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1325 close(SAVEIN); close(SAVEOUT);
1326 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1327 ( $? & 128 ) ? " (core dumped)" : "",
1328 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1335 local @stack = @stack; # Prevent growth by failing `use'.
1336 eval { require Term::ReadLine } or die $@;
1339 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1340 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1343 my $sel = select($OUT);
1347 eval "require Term::Rendezvous;" or die $@;
1348 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1349 my $term_rv = new Term::Rendezvous $rv;
1351 $OUT = $term_rv->OUT;
1355 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1357 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1359 $rl_attribs = $term->Attribs;
1360 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1361 if defined $rl_attribs->{basic_word_break_characters}
1362 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1363 $rl_attribs->{special_prefixes} = '$@&%';
1364 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1365 $rl_attribs->{completion_function} = \&db_complete;
1367 $LINEINFO = $OUT unless defined $LINEINFO;
1368 $lineinfo = $console unless defined $lineinfo;
1370 if ($term->Features->{setHistory} and "@hist" ne "?") {
1371 $term->SetHistory(@hist);
1377 my $left = @typeahead;
1378 my $got = shift @typeahead;
1379 print $OUT "auto(-$left)", shift, $got, "\n";
1380 $term->AddHistory($got)
1381 if length($got) > 1 and defined $term->Features->{addHistory};
1386 $term->readline(@_);
1390 my ($opt, $val)= @_;
1391 $val = option_val($opt,'N/A');
1392 $val =~ s/([\\\'])/\\$1/g;
1393 printf $OUT "%20s = '%s'\n", $opt, $val;
1397 my ($opt, $default)= @_;
1399 if (defined $optionVars{$opt}
1400 and defined $ {$optionVars{$opt}}) {
1401 $val = $ {$optionVars{$opt}};
1402 } elsif (defined $optionAction{$opt}
1403 and defined &{$optionAction{$opt}}) {
1404 $val = &{$optionAction{$opt}}();
1405 } elsif (defined $optionAction{$opt}
1406 and not defined $option{$opt}
1407 or defined $optionVars{$opt}
1408 and not defined $ {$optionVars{$opt}}) {
1411 $val = $option{$opt};
1419 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1420 my ($opt,$sep) = ($1,$2);
1423 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1425 #&dump_option($opt);
1426 } elsif ($sep !~ /\S/) {
1428 } elsif ($sep eq "=") {
1431 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1432 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1433 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1434 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1436 $val =~ s/\\([\\$end])/$1/g;
1440 grep( /^\Q$opt/ && ($option = $_), @options );
1441 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1443 print $OUT "Unknown option `$opt'\n" unless $matches;
1444 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1445 $option{$option} = $val if $matches == 1 and defined $val;
1446 eval "local \$frame = 0; local \$doret = -2;
1447 require '$optionRequire{$option}'"
1448 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1449 $ {$optionVars{$option}} = $val
1451 and defined $optionVars{$option} and defined $val;
1452 & {$optionAction{$option}} ($val)
1454 and defined $optionAction{$option}
1455 and defined &{$optionAction{$option}} and defined $val;
1456 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1462 my ($stem,@list) = @_;
1464 $ENV{"$ {stem}_n"} = @list;
1465 for $i (0 .. $#list) {
1467 $val =~ s/\\/\\\\/g;
1468 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1469 $ENV{"$ {stem}_$i"} = $val;
1476 my $n = delete $ENV{"$ {stem}_n"};
1478 for $i (0 .. $n - 1) {
1479 $val = delete $ENV{"$ {stem}_$i"};
1480 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1488 return; # Put nothing on the stack - malloc/free land!
1492 my($msg)= join("",@_);
1493 $msg .= ": $!\n" unless $msg =~ /\n$/;
1499 &warn("Too late to set TTY!\n") if @_;
1508 &warn("Too late to set noTTY!\n") if @_;
1510 $notty = shift if @_;
1517 &warn("Too late to set ReadLine!\n") if @_;
1525 if ($ {$term->Features}{tkRunning}) {
1526 return $term->tkRunning(@_);
1528 print $OUT "tkRunning not supported by current ReadLine package.\n";
1535 &warn("Too late to set up NonStop mode!\n") if @_;
1537 $runnonstop = shift if @_;
1545 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1552 $sh = quotemeta shift;
1553 $sh .= "\\b" if $sh =~ /\w$/;
1557 $psh =~ s/\\(.)/$1/g;
1564 $rc = quotemeta shift;
1565 $rc .= "\\b" if $rc =~ /\w$/;
1569 $prc =~ s/\\(.)/$1/g;
1575 return $lineinfo unless @_;
1577 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1578 $emacs = ($stream =~ /^\|/);
1579 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1580 $LINEINFO = \*LINEINFO;
1581 my $save = select($LINEINFO);
1595 s/^Term::ReadLine::readline$/readline/;
1596 if (defined $ { $_ . '::VERSION' }) {
1597 $version{$file} = "$ { $_ . '::VERSION' } from ";
1599 $version{$file} .= $INC{$file};
1601 do 'dumpvar.pl' unless defined &main::dumpValue;
1602 if (defined &main::dumpValue) {
1604 &main::dumpValue(\%version);
1606 print $OUT "dumpvar.pl not available.\n";
1613 s [expr] Single step [in expr].
1614 n [expr] Next, steps over subroutine calls [in expr].
1615 <CR> Repeat last n or s command.
1616 r Return from current subroutine.
1617 c [line|sub] Continue; optionally inserts a one-time-only breakpoint
1618 at the specified position.
1619 l min+incr List incr+1 lines starting at min.
1620 l min-max List lines min through max.
1621 l line List single line.
1622 l subname List first window of lines from subroutine.
1623 l List next window of lines.
1624 - List previous window of lines.
1625 w [line] List window around line.
1626 . Return to the executed line.
1627 f filename Switch to viewing filename. Must be loaded.
1628 /pattern/ Search forwards for pattern; final / is optional.
1629 ?pattern? Search backwards for pattern; final ? is optional.
1630 L List all breakpoints and actions.
1631 S [[!]pattern] List subroutine names [not] matching pattern.
1632 t Toggle trace mode.
1633 t expr Trace through execution of expr.
1634 b [line] [condition]
1635 Set breakpoint; line defaults to the current execution line;
1636 condition breaks if it evaluates to true, defaults to '1'.
1637 b subname [condition]
1638 Set breakpoint at first line of subroutine.
1639 b load filename Set breakpoint on `require'ing the given file.
1640 b postpone subname [condition]
1641 Set breakpoint at first line of subroutine after
1644 Stop after the subroutine is compiled.
1645 d [line] Delete the breakpoint for line.
1646 D Delete all breakpoints.
1648 Set an action to be done before the line is executed.
1649 Sequence is: check for breakpoint, print line if necessary,
1650 do action, prompt user if breakpoint or step, evaluate line.
1651 A Delete all actions.
1652 V [pkg [vars]] List some (default all) variables in package (default current).
1653 Use ~pattern and !pattern for positive and negative regexps.
1654 X [vars] Same as \"V currentpackage [vars]\".
1655 x expr Evals expression in array context, dumps the result.
1656 m expr Evals expression in array context, prints methods callable
1657 on the first element of the result.
1658 m class Prints methods callable via the given class.
1659 O [opt[=val]] [opt\"val\"] [opt?]...
1660 Set or query values of options. val defaults to 1. opt can
1661 be abbreviated. Several options can be listed.
1662 recallCommand, ShellBang: chars used to recall command or spawn shell;
1663 pager: program for output of \"|cmd\";
1664 tkRunning: run Tk while prompting (with ReadLine);
1665 signalLevel warnLevel dieLevel: level of verbosity;
1666 inhibit_exit Allows stepping off the end of the script.
1667 The following options affect what happens with V, X, and x commands:
1668 arrayDepth, hashDepth: print only first N elements ('' for all);
1669 compactDump, veryCompact: change style of array and hash dump;
1670 globPrint: whether to print contents of globs;
1671 DumpDBFiles: dump arrays holding debugged files;
1672 DumpPackages: dump symbol tables of packages;
1673 quote, HighBit, undefPrint: change style of string dump;
1674 Option PrintRet affects printing of return value after r command,
1675 frame affects printing messages on entry and exit from subroutines.
1676 AutoTrace affects printing messages on every possible breaking point.
1677 maxTraceLen gives maximal length of evals/args listed in stack trace.
1678 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1679 You can put additional initialization options TTY, noTTY,
1680 ReadLine, and NonStop there.
1681 < command Define Perl command to run before each prompt.
1682 << command Add to the list of Perl commands to run before each prompt.
1683 > command Define Perl command to run after each prompt.
1684 >> command Add to the list of Perl commands to run after each prompt.
1685 \{ commandline Define debugger command to run before each prompt.
1686 \{{ commandline Add to the list of debugger commands to run before each prompt.
1687 $prc number Redo a previous command (default previous command).
1688 $prc -number Redo number'th-to-last command.
1689 $prc pattern Redo last command that started with pattern.
1690 See 'O recallCommand' too.
1691 $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1692 . ( $rc eq $sh ? "" : "
1693 $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1694 See 'O shellBang' too.
1695 H -number Display last number commands (default all).
1696 p expr Same as \"print {DB::OUT} expr\" in current package.
1697 |dbcmd Run debugger command, piping DB::OUT to current pager.
1698 ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1699 \= [alias value] Define a command alias, or list current aliases.
1700 command Execute as a perl statement in current package.
1701 v Show versions of loaded modules.
1702 R Pure-man-restart of debugger, some of debugger state
1703 and command-line options may be lost.
1704 Currently the following setting are preserved:
1705 history, breakpoints and actions, debugger Options
1706 and the following command-line options: -w, -I, -e.
1707 h [db_command] Get help [on a specific debugger command], enter |h to page.
1708 h h Summary of debugger commands.
1709 q or ^D Quit. Set \$DB::finished to 0 to debug global destruction.
1712 $summary = <<"END_SUM";
1713 List/search source lines: Control script execution:
1714 l [ln|sub] List source code T Stack trace
1715 - or . List previous/current line s [expr] Single step [in expr]
1716 w [line] List around line n [expr] Next, steps over subs
1717 f filename View source in file <CR> Repeat last n or s
1718 /pattern/ ?patt? Search forw/backw r Return from subroutine
1719 v Show versions of modules c [ln|sub] Continue until position
1720 Debugger controls: L List break pts & actions
1721 O [...] Set debugger options t [expr] Toggle trace [trace expr]
1722 <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
1723 >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
1724 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1725 H [-num] Display last num commands D Delete all breakpoints
1726 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1727 h [db_cmd] Get help on command A Delete all actions
1728 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
1729 q or ^D Quit R Attempt a restart
1730 Data Examination: expr Execute perl code, also see: s,n,t expr
1731 x|m expr Evals expr in array context, dumps the result or lists methods.
1732 p expr Print expression (uses script's current package).
1733 S [[!]pat] List subroutine names [not] matching pattern
1734 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1735 X [Vars] Same as \"V current_package [Vars]\".
1737 # ')}}; # Fix balance of Emacs parsing
1743 $SIG{'ABRT'} = 'DEFAULT';
1744 kill 'ABRT', $$ if $panic++;
1745 if (defined &Carp::longmess) {
1746 local $SIG{__WARN__} = '';
1747 local $Carp::CarpLevel = 2; # mydie + confess
1748 &warn(Carp::longmess("Signal @_"));
1751 print $DB::OUT "Got signal @_\n";
1759 local $SIG{__WARN__} = '';
1760 local $SIG{__DIE__} = '';
1761 eval { require Carp }; # If error/warning during compilation,
1762 # require may be broken.
1763 warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1764 unless defined &Carp::longmess;
1765 #&warn("Entering dbwarn\n");
1766 my ($mysingle,$mytrace) = ($single,$trace);
1767 $single = 0; $trace = 0;
1768 my $mess = Carp::longmess(@_);
1769 ($single,$trace) = ($mysingle,$mytrace);
1770 #&warn("Warning in dbwarn\n");
1772 #&warn("Exiting dbwarn\n");
1778 local $SIG{__DIE__} = '';
1779 local $SIG{__WARN__} = '';
1780 my $i = 0; my $ineval = 0; my $sub;
1781 #&warn("Entering dbdie\n");
1782 if ($dieLevel != 2) {
1783 while ((undef,undef,undef,$sub) = caller(++$i)) {
1784 $ineval = 1, last if $sub eq '(eval)';
1787 local $SIG{__WARN__} = \&dbwarn;
1788 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1790 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1791 die @_ if $ineval and $dieLevel < 2;
1793 eval { require Carp }; # If error/warning during compilation,
1794 # require may be broken.
1795 die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1796 # We do not want to debug this chunk (automatic disabling works
1797 # inside DB::DB, but not in Carp).
1798 my ($mysingle,$mytrace) = ($single,$trace);
1799 $single = 0; $trace = 0;
1800 my $mess = Carp::longmess(@_);
1801 ($single,$trace) = ($mysingle,$mytrace);
1802 #&warn("dieing loudly in dbdie\n");
1808 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1811 $SIG{__WARN__} = \&DB::dbwarn;
1813 $SIG{__WARN__} = $prevwarn;
1821 $prevdie = $SIG{__DIE__} unless $dieLevel;
1824 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1825 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1826 print $OUT "Stack dump during die enabled",
1827 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1828 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1830 $SIG{__DIE__} = $prevdie;
1831 print $OUT "Default die handler restored.\n";
1839 $prevsegv = $SIG{SEGV} unless $signalLevel;
1840 $prevbus = $SIG{BUS} unless $signalLevel;
1841 $signalLevel = shift;
1843 $SIG{SEGV} = \&DB::diesignal;
1844 $SIG{BUS} = \&DB::diesignal;
1846 $SIG{SEGV} = $prevsegv;
1847 $SIG{BUS} = $prevbus;
1855 return unless defined &$subr;
1857 $subr = \&$subr; # Hard reference
1860 $s = $_, last if $subr eq \&$_;
1868 $class = ref $class if ref $class;
1871 methods_via($class, '', 1);
1872 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
1877 return if $packs{$class}++;
1879 my $prepend = $prefix ? "via $prefix: " : '';
1881 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
1882 sort keys %{"$ {class}::"}) {
1883 next if $seen{ $name }++;
1884 print $DB::OUT "$prepend$name\n";
1886 return unless shift; # Recurse?
1887 for $name (@{"$ {class}::ISA"}) {
1888 $prepend = $prefix ? $prefix . " -> $name" : $name;
1889 methods_via($name, $prepend, 1);
1893 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1895 BEGIN { # This does not compile, alas.
1896 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1897 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1901 $deep = 100; # warning if stack gets this deep
1905 $SIG{INT} = \&DB::catch;
1906 # This may be enabled to debug debugger:
1907 #$warnLevel = 1 unless defined $warnLevel;
1908 #$dieLevel = 1 unless defined $dieLevel;
1909 #$signalLevel = 1 unless defined $signalLevel;
1911 $db_stop = 0; # Compiler warning
1913 $level = 0; # Level of recursive debugging
1914 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1915 # Triggers bug (?) in perl is we postpone this until runtime:
1916 @postponed = @stack = (0);
1921 BEGIN {$^W = $ini_warn;} # Switch warnings back
1923 #use Carp; # This did break, left for debuggin
1926 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
1927 my($text, $line, $start) = @_;
1928 my ($itext, $search, $prefix, $pack) =
1929 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
1931 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
1932 (map { /$search/ ? ($1) : () } keys %sub)
1933 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
1934 return sort grep /^\Q$text/, values %INC # files
1935 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
1936 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1937 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
1938 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
1939 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1941 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
1943 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
1944 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
1945 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
1946 # We may want to complete to (eval 9), so $text may be wrong
1947 $prefix = length($1) - length($text);
1950 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
1952 if ((substr $text, 0, 1) eq '&') { # subroutines
1953 $text = substr $text, 1;
1955 return sort map "$prefix$_",
1958 (map { /$search/ ? ($1) : () }
1961 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
1962 $pack = ($1 eq 'main' ? '' : $1) . '::';
1963 $prefix = (substr $text, 0, 1) . $1 . '::';
1966 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
1967 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1968 return db_complete($out[0], $line, $start);
1972 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
1973 $pack = ($package eq 'main' ? '' : $package) . '::';
1974 $prefix = substr $text, 0, 1;
1975 $text = substr $text, 1;
1976 my @out = map "$prefix$_", grep /^\Q$text/,
1977 (grep /^_?[a-zA-Z]/, keys %$pack),
1978 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
1979 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1980 return db_complete($out[0], $line, $start);
1984 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
1985 my @out = grep /^\Q$text/, @options;
1986 my $val = option_val($out[0], undef);
1988 if (not defined $val or $val =~ /[\n\r]/) {
1989 # Can do nothing better
1990 } elsif ($val =~ /\s/) {
1992 foreach $l (split //, qq/\"\'\#\|/) {
1993 $out = "$l$val$l ", last if (index $val, $l) == -1;
1998 # Default to value if one completion, to question if many
1999 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2002 return $term->filename_list($text); # filenames
2005 sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
2008 $finished = $inhibit_exit; # So that some keys may be disabled.
2009 # Do not stop in at_exit() and destructors on exit:
2010 $DB::single = !$exiting && !$runnonstop;
2011 DB::fake::at_exit() unless $exiting or $runnonstop;
2017 "Debuggee terminated. Use `q' to quit and `R' to restart.";
2020 package DB; # Do not trace this 1; below!