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 my %pf = get_list("PERLDB_FILE_$_");
265 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
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";
288 } elsif (-e "con" or $^O eq 'MSWin32') {
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 foreach $evalarg (@$pre) {
417 print $OUT $#stack . " levels deep in subroutine calls!\n"
420 $incr = -1; # for backward motion.
421 @typeahead = @$pretype, @typeahead;
423 while (($term || &setterm),
424 defined ($cmd=&readline(" DB" . ('<' x $level) .
425 ($#hist+1) . ('>' x $level) .
429 $cmd =~ s/\\$/\n/ && do {
430 $cmd .= &readline(" cont: ");
433 $cmd =~ /^$/ && ($cmd = $laststep);
434 push(@hist,$cmd) if length($cmd) > 1;
436 ($i) = split(/\s+/,$cmd);
437 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
438 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
439 $cmd =~ /^h$/ && do {
442 $cmd =~ /^h\s+h$/ && do {
445 $cmd =~ /^h\s+(\S)$/ && do {
447 if ($help =~ /^$asked/m) {
448 while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
452 print $OUT "`$asked' is not a debugger command.\n";
455 $cmd =~ /^t$/ && do {
457 print $OUT "Trace = ".($trace?"on":"off")."\n";
459 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
460 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
461 foreach $subname (sort(keys %sub)) {
462 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
463 print $OUT $subname,"\n";
467 $cmd =~ /^v$/ && do {
468 list_versions(); next CMD};
469 $cmd =~ s/^X\b/V $package/;
470 $cmd =~ /^V$/ && do {
471 $cmd = "V $package"; };
472 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
473 local ($savout) = select($OUT);
475 @vars = split(' ',$2);
476 do 'dumpvar.pl' unless defined &main::dumpvar;
477 if (defined &main::dumpvar) {
480 &main::dumpvar($packname,@vars);
482 print $OUT "dumpvar.pl not available.\n";
486 $cmd =~ s/^x\b/ / && do { # So that will be evaled
487 $onetimeDump = 'dump'; };
488 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
489 methods($1); next CMD};
490 $cmd =~ s/^m\b/ / && do { # So this will be evaled
491 $onetimeDump = 'methods'; };
492 $cmd =~ /^f\b\s*(.*)/ && do {
496 print $OUT "The old f command is now the r command.\n";
497 print $OUT "The new f command switches filenames.\n";
500 if (!defined $main::{'_<' . $file}) {
501 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
502 $try = substr($try,2);
503 print $OUT "Choosing $try matching `$file':\n";
507 if (!defined $main::{'_<' . $file}) {
508 print $OUT "No file matching `$file' is loaded.\n";
510 } elsif ($file ne $filename) {
511 *dbline = $main::{'_<' . $file};
517 print $OUT "Already in $file.\n";
521 $cmd =~ s/^l\s+-\s*$/-/;
522 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
524 $subname =~ s/\'/::/;
525 $subname = $package."::".$subname
526 unless $subname =~ /::/;
527 $subname = "main".$subname if substr($subname,0,2) eq "::";
528 @pieces = split(/:/,find_sub($subname));
529 $subrange = pop @pieces;
530 $file = join(':', @pieces);
531 if ($file ne $filename) {
532 *dbline = $main::{'_<' . $file};
537 if (eval($subrange) < -$window) {
538 $subrange =~ s/-.*/+/;
540 $cmd = "l $subrange";
542 print $OUT "Subroutine $subname not found.\n";
545 $cmd =~ /^\.$/ && do {
546 $incr = -1; # for backward motion.
548 $filename = $filename_ini;
549 *dbline = $main::{'_<' . $filename};
551 print $LINEINFO $position;
553 $cmd =~ /^w\b\s*(\d*)$/ && do {
557 #print $OUT 'l ' . $start . '-' . ($start + $incr);
558 $cmd = 'l ' . $start . '-' . ($start + $incr); };
559 $cmd =~ /^-$/ && do {
560 $start -= $incr + $window + 1;
561 $start = 1 if $start <= 0;
563 $cmd = 'l ' . ($start) . '+'; };
564 $cmd =~ /^l$/ && do {
566 $cmd = 'l ' . $start . '-' . ($start + $incr); };
567 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
570 $incr = $window - 1 unless $incr;
571 $cmd = 'l ' . $start . '-' . ($start + $incr); };
572 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
573 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
574 $end = $max if $end > $max;
576 $i = $line if $i eq '.';
580 print $OUT "\032\032$filename:$i:0\n";
583 for (; $i <= $end; $i++) {
584 ($stop,$action) = split(/\0/, $dbline{$i});
586 and $filename eq $filename_ini)
588 : ($dbline[$i]+0 ? ':' : ' ') ;
589 $arrow .= 'b' if $stop;
590 $arrow .= 'a' if $action;
591 print $OUT "$i$arrow\t", $dbline[$i];
595 $start = $i; # remember in case they want more
596 $start = $max if $start > $max;
598 $cmd =~ /^D$/ && do {
599 print $OUT "Deleting all breakpoints...\n";
601 for $file (keys %had_breakpoints) {
602 local *dbline = $main::{'_<' . $file};
606 for ($i = 1; $i <= $max ; $i++) {
607 if (defined $dbline{$i}) {
608 $dbline{$i} =~ s/^[^\0]+//;
609 if ($dbline{$i} =~ s/^\0?$//) {
616 undef %postponed_file;
617 undef %break_on_load;
618 undef %had_breakpoints;
620 $cmd =~ /^L$/ && do {
622 for $file (keys %had_breakpoints) {
623 local *dbline = $main::{'_<' . $file};
627 for ($i = 1; $i <= $max; $i++) {
628 if (defined $dbline{$i}) {
629 print "$file:\n" unless $was++;
630 print $OUT " $i:\t", $dbline[$i];
631 ($stop,$action) = split(/\0/, $dbline{$i});
632 print $OUT " break if (", $stop, ")\n"
634 print $OUT " action: ", $action, "\n"
641 print $OUT "Postponed breakpoints in subroutines:\n";
643 for $subname (keys %postponed) {
644 print $OUT " $subname\t$postponed{$subname}\n";
648 my @have = map { # Combined keys
649 keys %{$postponed_file{$_}}
650 } keys %postponed_file;
652 print $OUT "Postponed breakpoints in files:\n";
654 for $file (keys %postponed_file) {
655 my $db = $postponed_file{$file};
656 print $OUT " $file:\n";
657 for $line (sort {$a <=> $b} keys %$db) {
658 print $OUT " $line:\n";
659 my ($stop,$action) = split(/\0/, $$db{$line});
660 print $OUT " break if (", $stop, ")\n"
662 print $OUT " action: ", $action, "\n"
669 if (%break_on_load) {
670 print $OUT "Breakpoints on load:\n";
672 for $file (keys %break_on_load) {
673 print $OUT " $file\n";
678 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
679 my $file = $1; $file =~ s/\s+$//;
681 $break_on_load{$file} = 1;
682 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
683 $file .= '.pm', redo unless $file =~ /\./;
685 $had_breakpoints{$file} = 1;
686 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
688 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
689 my $cond = $3 || '1';
690 my ($subname, $break) = ($2, $1 eq 'postpone');
691 $subname =~ s/\'/::/;
692 $subname = "${'package'}::" . $subname
693 unless $subname =~ /::/;
694 $subname = "main".$subname if substr($subname,0,2) eq "::";
695 $postponed{$subname} = $break
696 ? "break +0 if $cond" : "compile";
698 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
701 $subname =~ s/\'/::/;
702 $subname = "${'package'}::" . $subname
703 unless $subname =~ /::/;
704 $subname = "main".$subname if substr($subname,0,2) eq "::";
705 # Filename below can contain ':'
706 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
710 *dbline = $main::{'_<' . $filename};
711 $had_breakpoints{$filename} = 1;
713 ++$i while $dbline[$i] == 0 && $i < $max;
714 $dbline{$i} =~ s/^[^\0]*/$cond/;
716 print $OUT "Subroutine $subname not found.\n";
719 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
722 if ($dbline[$i] == 0) {
723 print $OUT "Line $i not breakable.\n";
725 $had_breakpoints{$filename} = 1;
726 $dbline{$i} =~ s/^[^\0]*/$cond/;
729 $cmd =~ /^d\b\s*(\d+)?/ && do {
731 $dbline{$i} =~ s/^[^\0]*//;
732 delete $dbline{$i} if $dbline{$i} eq '';
734 $cmd =~ /^A$/ && do {
736 for $file (keys %had_breakpoints) {
737 local *dbline = $main::{'_<' . $file};
741 for ($i = 1; $i <= $max ; $i++) {
742 if (defined $dbline{$i}) {
743 $dbline{$i} =~ s/\0[^\0]*//;
744 delete $dbline{$i} if $dbline{$i} eq '';
749 $cmd =~ /^O\s*$/ && do {
754 $cmd =~ /^O\s*(\S.*)/ && do {
757 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
758 push @$pre, action($1);
760 $cmd =~ /^>>\s*(.*)/ && do {
761 push @$post, action($1);
763 $cmd =~ /^<\s*(.*)/ && do {
764 $pre = [], next CMD unless $1;
767 $cmd =~ /^>\s*(.*)/ && do {
768 $post = [], next CMD unless $1;
769 $post = [action($1)];
771 $cmd =~ /^\{\{\s*(.*)/ && do {
774 $cmd =~ /^\{\s*(.*)/ && do {
775 $pretype = [], next CMD unless $1;
778 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
780 if ($dbline[$i] == 0) {
781 print $OUT "Line $i may not have an action.\n";
783 $dbline{$i} =~ s/\0[^\0]*//;
784 $dbline{$i} .= "\0" . action($j);
787 $cmd =~ /^n$/ && do {
788 end_report(), next CMD if $finished and $level <= 1;
792 $cmd =~ /^s$/ && do {
793 end_report(), next CMD if $finished and $level <= 1;
797 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
798 end_report(), next CMD if $finished and $level <= 1;
800 if ($i =~ /\D/) { # subroutine name
801 ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/);
805 *dbline = $main::{'_<' . $filename};
806 $had_breakpoints{$filename}++;
808 ++$i while $dbline[$i] == 0 && $i < $max;
810 print $OUT "Subroutine $subname not found.\n";
815 if ($dbline[$i] == 0) {
816 print $OUT "Line $i not breakable.\n";
819 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
821 for ($i=0; $i <= $#stack; ) {
825 $cmd =~ /^r$/ && do {
826 end_report(), next CMD if $finished and $level <= 1;
827 $stack[$#stack] |= 1;
828 $doret = $option{PrintRet} ? $#stack - 1 : -2;
830 $cmd =~ /^R$/ && do {
831 print $OUT "Warning: some settings and command-line options may be lost!\n";
832 my (@script, @flags, $cl);
833 push @flags, '-w' if $ini_warn;
834 # Put all the old includes at the start to get
837 push @flags, '-I', $_;
839 # Arrange for setting the old INC:
840 set_list("PERLDB_INC", @ini_INC);
842 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
843 chomp ($cl = $ {'::_<-e'}[$_]);
844 push @script, '-e', $cl;
849 set_list("PERLDB_HIST",
850 $term->Features->{getHistory}
851 ? $term->GetHistory : @hist);
852 my @had_breakpoints = keys %had_breakpoints;
853 set_list("PERLDB_VISITED", @had_breakpoints);
854 set_list("PERLDB_OPT", %option);
855 set_list("PERLDB_ON_LOAD", %break_on_load);
857 for (0 .. $#had_breakpoints) {
858 my $file = $had_breakpoints[$_];
859 *dbline = $main::{'_<' . $file};
860 next unless %dbline or $postponed_file{$file};
861 (push @hard, $file), next
862 if $file =~ /^\(eval \d+\)$/;
864 @add = %{$postponed_file{$file}}
865 if $postponed_file{$file};
866 set_list("PERLDB_FILE_$_", %dbline, @add);
868 for (@hard) { # Yes, really-really...
869 # Find the subroutines in this eval
870 *dbline = $main::{'_<' . $_};
871 my ($quoted, $sub, %subs, $line) = quotemeta $_;
872 for $sub (keys %sub) {
873 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
874 $subs{$sub} = [$1, $2];
878 "No subroutines in $_, ignoring breakpoints.\n";
881 LINES: for $line (keys %dbline) {
882 # One breakpoint per sub only:
883 my ($offset, $sub, $found);
884 SUBS: for $sub (keys %subs) {
885 if ($subs{$sub}->[1] >= $line # Not after the subroutine
886 and (not defined $offset # Not caught
887 or $offset < 0 )) { # or badly caught
889 $offset = $line - $subs{$sub}->[0];
890 $offset = "+$offset", last SUBS if $offset >= 0;
893 if (defined $offset) {
895 "break $offset if $dbline{$line}";
897 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
901 set_list("PERLDB_POSTPONE", %postponed);
902 $ENV{PERLDB_RESTART} = 1;
903 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
904 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
905 print $OUT "exec failed: $!\n";
907 $cmd =~ /^T$/ && do {
908 print_trace($OUT, 1); # skip DB
910 $cmd =~ /^\/(.*)$/ && do {
912 $inpat =~ s:([^\\])/$:$1:;
914 eval '$inpat =~ m'."\a$inpat\a";
926 $start = 1 if ($start > $max);
927 last if ($start == $end);
928 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
930 print $OUT "\032\032$filename:$start:0\n";
932 print $OUT "$start:\t", $dbline[$start], "\n";
937 print $OUT "/$pat/: not found\n" if ($start == $end);
939 $cmd =~ /^\?(.*)$/ && do {
941 $inpat =~ s:([^\\])\?$:$1:;
943 eval '$inpat =~ m'."\a$inpat\a";
955 $start = $max if ($start <= 0);
956 last if ($start == $end);
957 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
959 print $OUT "\032\032$filename:$start:0\n";
961 print $OUT "$start:\t", $dbline[$start], "\n";
966 print $OUT "?$pat?: not found\n" if ($start == $end);
968 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
969 pop(@hist) if length($cmd) > 1;
970 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
971 $cmd = $hist[$i] . "\n";
974 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
977 $cmd =~ /^$rc([^$rc].*)$/ && do {
979 pop(@hist) if length($cmd) > 1;
980 for ($i = $#hist; $i; --$i) {
981 last if $hist[$i] =~ /$pat/;
984 print $OUT "No such command!\n\n";
987 $cmd = $hist[$i] . "\n";
990 $cmd =~ /^$sh$/ && do {
991 &system($ENV{SHELL}||"/bin/sh");
993 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
994 &system($ENV{SHELL}||"/bin/sh","-c",$1);
996 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
997 $end = $2?($#hist-$2):0;
998 $hist = 0 if $hist < 0;
999 for ($i=$#hist; $i>$end; $i--) {
1000 print $OUT "$i: ",$hist[$i],"\n"
1001 unless $hist[$i] =~ /^.?$/;
1004 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1005 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1006 $cmd =~ /^=/ && do {
1007 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1008 $alias{$k}="s~$k~$v~";
1009 print $OUT "$k = $v\n";
1010 } elsif ($cmd =~ /^=\s*$/) {
1011 foreach $k (sort keys(%alias)) {
1012 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1013 print $OUT "$k = $v\n";
1015 print $OUT "$k\t$alias{$k}\n";
1020 $cmd =~ /^\|\|?\s*[^|]/ && do {
1021 if ($pager =~ /^\|/) {
1022 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1023 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1025 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1027 unless ($piped=open(OUT,$pager)) {
1028 &warn("Can't pipe output to `$pager'");
1029 if ($pager =~ /^\|/) {
1030 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1031 open(STDOUT,">&SAVEOUT")
1032 || &warn("Can't restore STDOUT");
1035 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1039 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1040 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1041 $selected= select(OUT);
1043 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1044 $cmd =~ s/^\|+\s*//;
1046 # XXX Local variants do not work!
1047 $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
1048 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1049 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1051 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1053 $onetimeDump = undef;
1059 if ($pager =~ /^\|/) {
1060 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1061 &warn( "Pager `$pager' failed: ",
1062 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1063 ( $? & 128 ) ? " (core dumped)" : "",
1064 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1065 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1066 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1067 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1068 # Will stop ignoring SIGPIPE if done like nohup(1)
1069 # does SIGINT but Perl doesn't give us a choice.
1071 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1074 select($selected), $selected= "" unless $selected eq "";
1078 $exiting = 1 unless defined $cmd;
1079 foreach $evalarg (@$post) {
1082 } # if ($single || $signal)
1083 ($@, $!, $,, $/, $\, $^W) = @saved;
1087 # The following code may be executed now:
1091 my ($al, $ret, @ret) = "";
1092 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1095 push(@stack, $single);
1097 $single |= 4 if $#stack == $deep;
1099 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1100 # Why -1? But it works! :-(
1101 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1102 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1105 $single |= pop(@stack);
1107 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1108 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1109 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1110 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1111 "list context return from $sub:\n"), dumpit( \@ret ),
1112 $doret = -2 if $doret eq $#stack or $frame & 16;
1116 $single |= pop(@stack);
1118 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1119 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1120 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1121 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1122 "scalar context return from $sub: "), dumpit( $ret ),
1123 $doret = -2 if $doret eq $#stack or $frame & 16;
1129 @saved = ($@, $!, $,, $/, $\, $^W);
1130 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1133 # The following takes its argument via $evalarg to preserve current @_
1138 local (@stack) = @stack; # guard against recursive debugging
1139 my $otrace = $trace;
1140 my $osingle = $single;
1142 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1148 local $saved[0]; # Preserve the old value of $@
1152 } elsif ($onetimeDump eq 'dump') {
1154 } elsif ($onetimeDump eq 'methods') {
1160 my $subname = shift;
1161 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1162 my $offset = $1 || 0;
1163 # Filename below can contain ':'
1164 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1167 local *dbline = $main::{'_<' . $file};
1168 local $^W = 0; # != 0 is magical below
1169 $had_breakpoints{$file}++;
1171 ++$i until $dbline[$i] != 0 or $i >= $max;
1172 $dbline{$i} = delete $postponed{$subname};
1174 print $OUT "Subroutine $subname not found.\n";
1178 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1179 #print $OUT "In postponed_sub for `$subname'.\n";
1183 return &postponed_sub
1184 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1185 # Cannot be done before the file is compiled
1186 local *dbline = shift;
1187 my $filename = $dbline;
1188 $filename =~ s/^_<//;
1189 $signal = 1, print $OUT "'$filename' loaded...\n"
1190 if $break_on_load{$filename};
1191 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1192 return unless $postponed_file{$filename};
1193 $had_breakpoints{$filename}++;
1194 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1196 for $key (keys %{$postponed_file{$filename}}) {
1197 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1199 delete $postponed_file{$filename};
1203 local ($savout) = select($OUT);
1204 my $osingle = $single;
1205 my $otrace = $trace;
1206 $single = $trace = 0;
1209 unless (defined &main::dumpValue) {
1212 if (defined &main::dumpValue) {
1213 &main::dumpValue(shift);
1215 print $OUT "dumpvar.pl not available.\n";
1222 # Tied method do not create a context, so may get wrong message:
1226 my @sub = dump_trace($_[0] + 1, $_[1]);
1227 my $short = $_[2]; # Print short report, next one for sub name
1229 for ($i=0; $i <= $#sub; $i++) {
1232 my $args = defined $sub[$i]{args}
1233 ? "(@{ $sub[$i]{args} })"
1235 $args = (substr $args, 0, $maxtrace - 3) . '...'
1236 if length $args > $maxtrace;
1237 my $file = $sub[$i]{file};
1238 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1240 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1242 my $sub = @_ >= 4 ? $_[3] : $s;
1243 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1245 print $fh "$sub[$i]{context} = $s$args" .
1246 " called from $file" .
1247 " line $sub[$i]{line}\n";
1254 my $count = shift || 1e9;
1257 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1258 my $nothard = not $frame & 8;
1259 local $frame = 0; # Do not want to trace this.
1260 my $otrace = $trace;
1263 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1268 if (not defined $arg) {
1270 } elsif ($nothard and tied $arg) {
1272 } elsif ($nothard and $type = ref $arg) {
1273 push @a, "ref($type)";
1275 local $_ = "$arg"; # Safe to stringify now - should not call f().
1278 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1279 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1280 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1284 $context = $context ? '@' : "\$";
1285 $args = $h ? [@a] : undef;
1286 $e =~ s/\n\s*\;\s*\Z// if $e;
1287 $e =~ s/([\\\'])/\\$1/g if $e;
1289 $sub = "require '$e'";
1290 } elsif (defined $r) {
1292 } elsif ($sub eq '(eval)') {
1293 $sub = "eval {...}";
1295 push(@sub, {context => $context, sub => $sub, args => $args,
1296 file => $file, line => $line});
1305 while ($action =~ s/\\$//) {
1316 &readline("cont: ");
1320 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1321 # many non-Unix systems can do system() but have problems with fork().
1322 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1323 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1324 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1325 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1327 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1328 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1329 close(SAVEIN); close(SAVEOUT);
1330 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1331 ( $? & 128 ) ? " (core dumped)" : "",
1332 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1339 local @stack = @stack; # Prevent growth by failing `use'.
1340 eval { require Term::ReadLine } or die $@;
1343 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1344 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1347 my $sel = select($OUT);
1351 eval "require Term::Rendezvous;" or die $@;
1352 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1353 my $term_rv = new Term::Rendezvous $rv;
1355 $OUT = $term_rv->OUT;
1359 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1361 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1363 $rl_attribs = $term->Attribs;
1364 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1365 if defined $rl_attribs->{basic_word_break_characters}
1366 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1367 $rl_attribs->{special_prefixes} = '$@&%';
1368 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1369 $rl_attribs->{completion_function} = \&db_complete;
1371 $LINEINFO = $OUT unless defined $LINEINFO;
1372 $lineinfo = $console unless defined $lineinfo;
1374 if ($term->Features->{setHistory} and "@hist" ne "?") {
1375 $term->SetHistory(@hist);
1381 my $left = @typeahead;
1382 my $got = shift @typeahead;
1383 print $OUT "auto(-$left)", shift, $got, "\n";
1384 $term->AddHistory($got)
1385 if length($got) > 1 and defined $term->Features->{addHistory};
1390 $term->readline(@_);
1394 my ($opt, $val)= @_;
1395 $val = option_val($opt,'N/A');
1396 $val =~ s/([\\\'])/\\$1/g;
1397 printf $OUT "%20s = '%s'\n", $opt, $val;
1401 my ($opt, $default)= @_;
1403 if (defined $optionVars{$opt}
1404 and defined $ {$optionVars{$opt}}) {
1405 $val = $ {$optionVars{$opt}};
1406 } elsif (defined $optionAction{$opt}
1407 and defined &{$optionAction{$opt}}) {
1408 $val = &{$optionAction{$opt}}();
1409 } elsif (defined $optionAction{$opt}
1410 and not defined $option{$opt}
1411 or defined $optionVars{$opt}
1412 and not defined $ {$optionVars{$opt}}) {
1415 $val = $option{$opt};
1423 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1424 my ($opt,$sep) = ($1,$2);
1427 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1429 #&dump_option($opt);
1430 } elsif ($sep !~ /\S/) {
1432 } elsif ($sep eq "=") {
1435 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1436 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1437 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1438 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1440 $val =~ s/\\([\\$end])/$1/g;
1444 grep( /^\Q$opt/ && ($option = $_), @options );
1445 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1447 print $OUT "Unknown option `$opt'\n" unless $matches;
1448 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1449 $option{$option} = $val if $matches == 1 and defined $val;
1450 eval "local \$frame = 0; local \$doret = -2;
1451 require '$optionRequire{$option}'"
1452 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1453 $ {$optionVars{$option}} = $val
1455 and defined $optionVars{$option} and defined $val;
1456 & {$optionAction{$option}} ($val)
1458 and defined $optionAction{$option}
1459 and defined &{$optionAction{$option}} and defined $val;
1460 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1466 my ($stem,@list) = @_;
1468 $ENV{"$ {stem}_n"} = @list;
1469 for $i (0 .. $#list) {
1471 $val =~ s/\\/\\\\/g;
1472 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1473 $ENV{"$ {stem}_$i"} = $val;
1480 my $n = delete $ENV{"$ {stem}_n"};
1482 for $i (0 .. $n - 1) {
1483 $val = delete $ENV{"$ {stem}_$i"};
1484 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1492 return; # Put nothing on the stack - malloc/free land!
1496 my($msg)= join("",@_);
1497 $msg .= ": $!\n" unless $msg =~ /\n$/;
1503 &warn("Too late to set TTY!\n") if @_;
1512 &warn("Too late to set noTTY!\n") if @_;
1514 $notty = shift if @_;
1521 &warn("Too late to set ReadLine!\n") if @_;
1529 if ($ {$term->Features}{tkRunning}) {
1530 return $term->tkRunning(@_);
1532 print $OUT "tkRunning not supported by current ReadLine package.\n";
1539 &warn("Too late to set up NonStop mode!\n") if @_;
1541 $runnonstop = shift if @_;
1549 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1556 $sh = quotemeta shift;
1557 $sh .= "\\b" if $sh =~ /\w$/;
1561 $psh =~ s/\\(.)/$1/g;
1568 $rc = quotemeta shift;
1569 $rc .= "\\b" if $rc =~ /\w$/;
1573 $prc =~ s/\\(.)/$1/g;
1579 return $lineinfo unless @_;
1581 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1582 $emacs = ($stream =~ /^\|/);
1583 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1584 $LINEINFO = \*LINEINFO;
1585 my $save = select($LINEINFO);
1599 s/^Term::ReadLine::readline$/readline/;
1600 if (defined $ { $_ . '::VERSION' }) {
1601 $version{$file} = "$ { $_ . '::VERSION' } from ";
1603 $version{$file} .= $INC{$file};
1605 do 'dumpvar.pl' unless defined &main::dumpValue;
1606 if (defined &main::dumpValue) {
1608 &main::dumpValue(\%version);
1610 print $OUT "dumpvar.pl not available.\n";
1617 s [expr] Single step [in expr].
1618 n [expr] Next, steps over subroutine calls [in expr].
1619 <CR> Repeat last n or s command.
1620 r Return from current subroutine.
1621 c [line|sub] Continue; optionally inserts a one-time-only breakpoint
1622 at the specified position.
1623 l min+incr List incr+1 lines starting at min.
1624 l min-max List lines min through max.
1625 l line List single line.
1626 l subname List first window of lines from subroutine.
1627 l List next window of lines.
1628 - List previous window of lines.
1629 w [line] List window around line.
1630 . Return to the executed line.
1631 f filename Switch to viewing filename. Must be loaded.
1632 /pattern/ Search forwards for pattern; final / is optional.
1633 ?pattern? Search backwards for pattern; final ? is optional.
1634 L List all breakpoints and actions.
1635 S [[!]pattern] List subroutine names [not] matching pattern.
1636 t Toggle trace mode.
1637 t expr Trace through execution of expr.
1638 b [line] [condition]
1639 Set breakpoint; line defaults to the current execution line;
1640 condition breaks if it evaluates to true, defaults to '1'.
1641 b subname [condition]
1642 Set breakpoint at first line of subroutine.
1643 b load filename Set breakpoint on `require'ing the given file.
1644 b postpone subname [condition]
1645 Set breakpoint at first line of subroutine after
1648 Stop after the subroutine is compiled.
1649 d [line] Delete the breakpoint for line.
1650 D Delete all breakpoints.
1652 Set an action to be done before the line is executed.
1653 Sequence is: check for breakpoint, print line if necessary,
1654 do action, prompt user if breakpoint or step, evaluate line.
1655 A Delete all actions.
1656 V [pkg [vars]] List some (default all) variables in package (default current).
1657 Use ~pattern and !pattern for positive and negative regexps.
1658 X [vars] Same as \"V currentpackage [vars]\".
1659 x expr Evals expression in array context, dumps the result.
1660 m expr Evals expression in array context, prints methods callable
1661 on the first element of the result.
1662 m class Prints methods callable via the given class.
1663 O [opt[=val]] [opt\"val\"] [opt?]...
1664 Set or query values of options. val defaults to 1. opt can
1665 be abbreviated. Several options can be listed.
1666 recallCommand, ShellBang: chars used to recall command or spawn shell;
1667 pager: program for output of \"|cmd\";
1668 tkRunning: run Tk while prompting (with ReadLine);
1669 signalLevel warnLevel dieLevel: level of verbosity;
1670 inhibit_exit Allows stepping off the end of the script.
1671 The following options affect what happens with V, X, and x commands:
1672 arrayDepth, hashDepth: print only first N elements ('' for all);
1673 compactDump, veryCompact: change style of array and hash dump;
1674 globPrint: whether to print contents of globs;
1675 DumpDBFiles: dump arrays holding debugged files;
1676 DumpPackages: dump symbol tables of packages;
1677 quote, HighBit, undefPrint: change style of string dump;
1678 Option PrintRet affects printing of return value after r command,
1679 frame affects printing messages on entry and exit from subroutines.
1680 AutoTrace affects printing messages on every possible breaking point.
1681 maxTraceLen gives maximal length of evals/args listed in stack trace.
1682 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1683 You can put additional initialization options TTY, noTTY,
1684 ReadLine, and NonStop there.
1685 < command Define Perl command to run before each prompt.
1686 << command Add to the list of Perl commands to run before each prompt.
1687 > command Define Perl command to run after each prompt.
1688 >> command Add to the list of Perl commands to run after each prompt.
1689 \{ commandline Define debugger command to run before each prompt.
1690 \{{ commandline Add to the list of debugger commands to run before each prompt.
1691 $prc number Redo a previous command (default previous command).
1692 $prc -number Redo number'th-to-last command.
1693 $prc pattern Redo last command that started with pattern.
1694 See 'O recallCommand' too.
1695 $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1696 . ( $rc eq $sh ? "" : "
1697 $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1698 See 'O shellBang' too.
1699 H -number Display last number commands (default all).
1700 p expr Same as \"print {DB::OUT} expr\" in current package.
1701 |dbcmd Run debugger command, piping DB::OUT to current pager.
1702 ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1703 \= [alias value] Define a command alias, or list current aliases.
1704 command Execute as a perl statement in current package.
1705 v Show versions of loaded modules.
1706 R Pure-man-restart of debugger, some of debugger state
1707 and command-line options may be lost.
1708 Currently the following setting are preserved:
1709 history, breakpoints and actions, debugger Options
1710 and the following command-line options: -w, -I, -e.
1711 h [db_command] Get help [on a specific debugger command], enter |h to page.
1712 h h Summary of debugger commands.
1713 q or ^D Quit. Set \$DB::finished to 0 to debug global destruction.
1716 $summary = <<"END_SUM";
1717 List/search source lines: Control script execution:
1718 l [ln|sub] List source code T Stack trace
1719 - or . List previous/current line s [expr] Single step [in expr]
1720 w [line] List around line n [expr] Next, steps over subs
1721 f filename View source in file <CR> Repeat last n or s
1722 /pattern/ ?patt? Search forw/backw r Return from subroutine
1723 v Show versions of modules c [ln|sub] Continue until position
1724 Debugger controls: L List break pts & actions
1725 O [...] Set debugger options t [expr] Toggle trace [trace expr]
1726 <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
1727 >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
1728 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1729 H [-num] Display last num commands D Delete all breakpoints
1730 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1731 h [db_cmd] Get help on command A Delete all actions
1732 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
1733 q or ^D Quit R Attempt a restart
1734 Data Examination: expr Execute perl code, also see: s,n,t expr
1735 x|m expr Evals expr in array context, dumps the result or lists methods.
1736 p expr Print expression (uses script's current package).
1737 S [[!]pat] List subroutine names [not] matching pattern
1738 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1739 X [Vars] Same as \"V current_package [Vars]\".
1741 # ')}}; # Fix balance of Emacs parsing
1747 $SIG{'ABRT'} = 'DEFAULT';
1748 kill 'ABRT', $$ if $panic++;
1749 if (defined &Carp::longmess) {
1750 local $SIG{__WARN__} = '';
1751 local $Carp::CarpLevel = 2; # mydie + confess
1752 &warn(Carp::longmess("Signal @_"));
1755 print $DB::OUT "Got signal @_\n";
1763 local $SIG{__WARN__} = '';
1764 local $SIG{__DIE__} = '';
1765 eval { require Carp }; # If error/warning during compilation,
1766 # require may be broken.
1767 warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1768 unless defined &Carp::longmess;
1769 #&warn("Entering dbwarn\n");
1770 my ($mysingle,$mytrace) = ($single,$trace);
1771 $single = 0; $trace = 0;
1772 my $mess = Carp::longmess(@_);
1773 ($single,$trace) = ($mysingle,$mytrace);
1774 #&warn("Warning in dbwarn\n");
1776 #&warn("Exiting dbwarn\n");
1782 local $SIG{__DIE__} = '';
1783 local $SIG{__WARN__} = '';
1784 my $i = 0; my $ineval = 0; my $sub;
1785 #&warn("Entering dbdie\n");
1786 if ($dieLevel != 2) {
1787 while ((undef,undef,undef,$sub) = caller(++$i)) {
1788 $ineval = 1, last if $sub eq '(eval)';
1791 local $SIG{__WARN__} = \&dbwarn;
1792 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1794 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1795 die @_ if $ineval and $dieLevel < 2;
1797 eval { require Carp }; # If error/warning during compilation,
1798 # require may be broken.
1799 die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1800 # We do not want to debug this chunk (automatic disabling works
1801 # inside DB::DB, but not in Carp).
1802 my ($mysingle,$mytrace) = ($single,$trace);
1803 $single = 0; $trace = 0;
1804 my $mess = Carp::longmess(@_);
1805 ($single,$trace) = ($mysingle,$mytrace);
1806 #&warn("dieing loudly in dbdie\n");
1812 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1815 $SIG{__WARN__} = \&DB::dbwarn;
1817 $SIG{__WARN__} = $prevwarn;
1825 $prevdie = $SIG{__DIE__} unless $dieLevel;
1828 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1829 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1830 print $OUT "Stack dump during die enabled",
1831 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1832 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1834 $SIG{__DIE__} = $prevdie;
1835 print $OUT "Default die handler restored.\n";
1843 $prevsegv = $SIG{SEGV} unless $signalLevel;
1844 $prevbus = $SIG{BUS} unless $signalLevel;
1845 $signalLevel = shift;
1847 $SIG{SEGV} = \&DB::diesignal;
1848 $SIG{BUS} = \&DB::diesignal;
1850 $SIG{SEGV} = $prevsegv;
1851 $SIG{BUS} = $prevbus;
1859 return unless defined &$subr;
1861 $subr = \&$subr; # Hard reference
1864 $s = $_, last if $subr eq \&$_;
1872 $class = ref $class if ref $class;
1875 methods_via($class, '', 1);
1876 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
1881 return if $packs{$class}++;
1883 my $prepend = $prefix ? "via $prefix: " : '';
1885 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
1886 sort keys %{"$ {class}::"}) {
1887 next if $seen{ $name }++;
1888 print $DB::OUT "$prepend$name\n";
1890 return unless shift; # Recurse?
1891 for $name (@{"$ {class}::ISA"}) {
1892 $prepend = $prefix ? $prefix . " -> $name" : $name;
1893 methods_via($name, $prepend, 1);
1897 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1899 BEGIN { # This does not compile, alas.
1900 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1901 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1905 $deep = 100; # warning if stack gets this deep
1909 $SIG{INT} = \&DB::catch;
1910 # This may be enabled to debug debugger:
1911 #$warnLevel = 1 unless defined $warnLevel;
1912 #$dieLevel = 1 unless defined $dieLevel;
1913 #$signalLevel = 1 unless defined $signalLevel;
1915 $db_stop = 0; # Compiler warning
1917 $level = 0; # Level of recursive debugging
1918 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1919 # Triggers bug (?) in perl is we postpone this until runtime:
1920 @postponed = @stack = (0);
1925 BEGIN {$^W = $ini_warn;} # Switch warnings back
1927 #use Carp; # This did break, left for debuggin
1930 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
1931 my($text, $line, $start) = @_;
1932 my ($itext, $search, $prefix, $pack) =
1933 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
1935 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
1936 (map { /$search/ ? ($1) : () } keys %sub)
1937 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
1938 return sort grep /^\Q$text/, values %INC # files
1939 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
1940 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1941 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
1942 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
1943 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1945 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
1947 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
1948 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
1949 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
1950 # We may want to complete to (eval 9), so $text may be wrong
1951 $prefix = length($1) - length($text);
1954 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
1956 if ((substr $text, 0, 1) eq '&') { # subroutines
1957 $text = substr $text, 1;
1959 return sort map "$prefix$_",
1962 (map { /$search/ ? ($1) : () }
1965 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
1966 $pack = ($1 eq 'main' ? '' : $1) . '::';
1967 $prefix = (substr $text, 0, 1) . $1 . '::';
1970 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
1971 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1972 return db_complete($out[0], $line, $start);
1976 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
1977 $pack = ($package eq 'main' ? '' : $package) . '::';
1978 $prefix = substr $text, 0, 1;
1979 $text = substr $text, 1;
1980 my @out = map "$prefix$_", grep /^\Q$text/,
1981 (grep /^_?[a-zA-Z]/, keys %$pack),
1982 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
1983 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1984 return db_complete($out[0], $line, $start);
1988 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
1989 my @out = grep /^\Q$text/, @options;
1990 my $val = option_val($out[0], undef);
1992 if (not defined $val or $val =~ /[\n\r]/) {
1993 # Can do nothing better
1994 } elsif ($val =~ /\s/) {
1996 foreach $l (split //, qq/\"\'\#\|/) {
1997 $out = "$l$val$l ", last if (index $val, $l) == -1;
2002 # Default to value if one completion, to question if many
2003 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2006 return $term->filename_list($text); # filenames
2009 sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
2012 $finished = $inhibit_exit; # So that some keys may be disabled.
2013 # Do not stop in at_exit() and destructors on exit:
2014 $DB::single = !$exiting && !$runnonstop;
2015 DB::fake::at_exit() unless $exiting or $runnonstop;
2021 "Debuggee terminated. Use `q' to quit and `R' to restart.";
2024 package DB; # Do not trace this 1; below!