3 # Debugger for Perl 5.00x; perl5db.pl patch level:
6 $header = "perl5db.pl version $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 ornaments
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,
214 ornaments => \&ornaments,
218 compactDump => 'dumpvar.pl',
219 veryCompact => 'dumpvar.pl',
220 quote => 'dumpvar.pl',
223 # These guys may be defined in $ENV{PERL5DB} :
224 $rl = 1 unless defined $rl;
225 $warnLevel = 1 unless defined $warnLevel;
226 $dieLevel = 1 unless defined $dieLevel;
227 $signalLevel = 1 unless defined $signalLevel;
228 $pre = [] unless defined $pre;
229 $post = [] unless defined $post;
230 $pretype = [] unless defined $pretype;
231 warnLevel($warnLevel);
233 signalLevel($signalLevel);
234 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
235 &recallCommand("!") unless defined $prc;
236 &shellBang("!") unless defined $psh;
237 $maxtrace = 400 unless defined $maxtrace;
242 $rcfile="perldb.ini";
247 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
248 do "$ENV{LOGDIR}/$rcfile";
249 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
250 do "$ENV{HOME}/$rcfile";
253 if (defined $ENV{PERLDB_OPTS}) {
254 parse_options($ENV{PERLDB_OPTS});
257 if (exists $ENV{PERLDB_RESTART}) {
258 delete $ENV{PERLDB_RESTART};
260 @hist = get_list('PERLDB_HIST');
261 %break_on_load = get_list("PERLDB_ON_LOAD");
262 %postponed = get_list("PERLDB_POSTPONE");
263 my @had_breakpoints= get_list("PERLDB_VISITED");
264 for (0 .. $#had_breakpoints) {
265 my %pf = get_list("PERLDB_FILE_$_");
266 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
268 my %opt = get_list("PERLDB_OPT");
270 while (($opt,$val) = each %opt) {
271 $val =~ s/[\\\']/\\$1/g;
272 parse_options("$opt'$val'");
274 @INC = get_list("PERLDB_INC");
276 $pretype = [get_list("PERLDB_PRETYPE")];
277 $pre = [get_list("PERLDB_PRE")];
278 $post = [get_list("PERLDB_POST")];
279 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
285 # Is Perl being run from Emacs?
286 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
287 $rl = 0, shift(@main::ARGV) if $emacs;
289 #require Term::ReadLine;
292 $console = "/dev/tty";
293 } elsif (-e "con" or $^O eq 'MSWin32') {
296 $console = "sys\$command";
300 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
304 $console = $tty if defined $tty;
306 if (defined $console) {
307 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
308 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
309 || open(OUT,">&STDOUT"); # so we don't dongle stdout
312 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
313 $console = 'STDIN/OUT';
315 # so open("|more") can read from STDOUT and so we don't dingle stdin
320 $| = 1; # for DB::OUT
323 $LINEINFO = $OUT unless defined $LINEINFO;
324 $lineinfo = $console unless defined $lineinfo;
326 $| = 1; # for real STDOUT
328 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
329 unless ($runnonstop) {
330 print $OUT "\nLoading DB routines from $header\n";
331 print $OUT ("Emacs support ",
332 $emacs ? "enabled" : "available",
334 print $OUT "\nEnter h or `h h' for help.\n\n";
341 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
344 if (defined &afterinit) { # May be defined in $rcfile
350 ############################################################ Subroutines
353 # _After_ the perl program is compiled, $single is set to 1:
354 if ($single and not $second_time++) {
355 if ($runnonstop) { # Disable until signal
356 for ($i=0; $i <= $#stack; ) {
360 # return; # Would not print trace!
363 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
365 ($package, $filename, $line) = caller;
366 $filename_ini = $filename;
367 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
368 "package $package;"; # this won't let them modify, alas
369 local(*dbline) = $main::{'_<' . $filename};
371 if (($stop,$action) = split(/\0/,$dbline{$line})) {
375 $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
376 $dbline{$line} =~ s/;9($|\0)/$1/;
379 my $was_signal = $signal;
381 if ($single || $trace || $was_signal) {
384 $position = "\032\032$filename:$line:0\n";
385 print $LINEINFO $position;
388 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
389 $prefix .= "$sub($filename:";
390 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
391 if (length($prefix) > 30) {
392 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
397 $position = "$prefix$line$infix$dbline[$line]$after";
400 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
402 print $LINEINFO $position;
404 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
405 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
407 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
408 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
409 $position .= $incr_pos;
411 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
413 print $LINEINFO $incr_pos;
418 $evalarg = $action, &eval if $action;
419 if ($single || $was_signal) {
420 local $level = $level + 1;
421 foreach $evalarg (@$pre) {
424 print $OUT $#stack . " levels deep in subroutine calls!\n"
427 $incr = -1; # for backward motion.
428 @typeahead = @$pretype, @typeahead;
430 while (($term || &setterm),
431 ($term_pid == $$ or &resetterm),
432 defined ($cmd=&readline(" DB" . ('<' x $level) .
433 ($#hist+1) . ('>' x $level) .
437 $cmd =~ s/\\$/\n/ && do {
438 $cmd .= &readline(" cont: ");
441 $cmd =~ /^$/ && ($cmd = $laststep);
442 push(@hist,$cmd) if length($cmd) > 1;
444 ($i) = split(/\s+/,$cmd);
445 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
446 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
447 $cmd =~ /^h$/ && do {
450 $cmd =~ /^h\s+h$/ && do {
453 $cmd =~ /^h\s+(\S)$/ && do {
455 if ($help =~ /^$asked/m) {
456 while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
460 print $OUT "`$asked' is not a debugger command.\n";
463 $cmd =~ /^t$/ && do {
465 print $OUT "Trace = ".($trace?"on":"off")."\n";
467 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
468 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
469 foreach $subname (sort(keys %sub)) {
470 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
471 print $OUT $subname,"\n";
475 $cmd =~ /^v$/ && do {
476 list_versions(); next CMD};
477 $cmd =~ s/^X\b/V $package/;
478 $cmd =~ /^V$/ && do {
479 $cmd = "V $package"; };
480 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
481 local ($savout) = select($OUT);
483 @vars = split(' ',$2);
484 do 'dumpvar.pl' unless defined &main::dumpvar;
485 if (defined &main::dumpvar) {
488 &main::dumpvar($packname,@vars);
490 print $OUT "dumpvar.pl not available.\n";
494 $cmd =~ s/^x\b/ / && do { # So that will be evaled
495 $onetimeDump = 'dump'; };
496 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
497 methods($1); next CMD};
498 $cmd =~ s/^m\b/ / && do { # So this will be evaled
499 $onetimeDump = 'methods'; };
500 $cmd =~ /^f\b\s*(.*)/ && do {
504 print $OUT "The old f command is now the r command.\n";
505 print $OUT "The new f command switches filenames.\n";
508 if (!defined $main::{'_<' . $file}) {
509 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
510 $try = substr($try,2);
511 print $OUT "Choosing $try matching `$file':\n";
515 if (!defined $main::{'_<' . $file}) {
516 print $OUT "No file matching `$file' is loaded.\n";
518 } elsif ($file ne $filename) {
519 *dbline = $main::{'_<' . $file};
525 print $OUT "Already in $file.\n";
529 $cmd =~ s/^l\s+-\s*$/-/;
530 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
532 $subname =~ s/\'/::/;
533 $subname = $package."::".$subname
534 unless $subname =~ /::/;
535 $subname = "main".$subname if substr($subname,0,2) eq "::";
536 @pieces = split(/:/,find_sub($subname));
537 $subrange = pop @pieces;
538 $file = join(':', @pieces);
539 if ($file ne $filename) {
540 *dbline = $main::{'_<' . $file};
545 if (eval($subrange) < -$window) {
546 $subrange =~ s/-.*/+/;
548 $cmd = "l $subrange";
550 print $OUT "Subroutine $subname not found.\n";
553 $cmd =~ /^\.$/ && do {
554 $incr = -1; # for backward motion.
556 $filename = $filename_ini;
557 *dbline = $main::{'_<' . $filename};
559 print $LINEINFO $position;
561 $cmd =~ /^w\b\s*(\d*)$/ && do {
565 #print $OUT 'l ' . $start . '-' . ($start + $incr);
566 $cmd = 'l ' . $start . '-' . ($start + $incr); };
567 $cmd =~ /^-$/ && do {
568 $start -= $incr + $window + 1;
569 $start = 1 if $start <= 0;
571 $cmd = 'l ' . ($start) . '+'; };
572 $cmd =~ /^l$/ && do {
574 $cmd = 'l ' . $start . '-' . ($start + $incr); };
575 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
578 $incr = $window - 1 unless $incr;
579 $cmd = 'l ' . $start . '-' . ($start + $incr); };
580 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
581 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
582 $end = $max if $end > $max;
584 $i = $line if $i eq '.';
588 print $OUT "\032\032$filename:$i:0\n";
591 for (; $i <= $end; $i++) {
592 ($stop,$action) = split(/\0/, $dbline{$i});
594 and $filename eq $filename_ini)
596 : ($dbline[$i]+0 ? ':' : ' ') ;
597 $arrow .= 'b' if $stop;
598 $arrow .= 'a' if $action;
599 print $OUT "$i$arrow\t", $dbline[$i];
603 $start = $i; # remember in case they want more
604 $start = $max if $start > $max;
606 $cmd =~ /^D$/ && do {
607 print $OUT "Deleting all breakpoints...\n";
609 for $file (keys %had_breakpoints) {
610 local *dbline = $main::{'_<' . $file};
614 for ($i = 1; $i <= $max ; $i++) {
615 if (defined $dbline{$i}) {
616 $dbline{$i} =~ s/^[^\0]+//;
617 if ($dbline{$i} =~ s/^\0?$//) {
624 undef %postponed_file;
625 undef %break_on_load;
626 undef %had_breakpoints;
628 $cmd =~ /^L$/ && do {
630 for $file (keys %had_breakpoints) {
631 local *dbline = $main::{'_<' . $file};
635 for ($i = 1; $i <= $max; $i++) {
636 if (defined $dbline{$i}) {
637 print "$file:\n" unless $was++;
638 print $OUT " $i:\t", $dbline[$i];
639 ($stop,$action) = split(/\0/, $dbline{$i});
640 print $OUT " break if (", $stop, ")\n"
642 print $OUT " action: ", $action, "\n"
649 print $OUT "Postponed breakpoints in subroutines:\n";
651 for $subname (keys %postponed) {
652 print $OUT " $subname\t$postponed{$subname}\n";
656 my @have = map { # Combined keys
657 keys %{$postponed_file{$_}}
658 } keys %postponed_file;
660 print $OUT "Postponed breakpoints in files:\n";
662 for $file (keys %postponed_file) {
663 my $db = $postponed_file{$file};
664 print $OUT " $file:\n";
665 for $line (sort {$a <=> $b} keys %$db) {
666 print $OUT " $line:\n";
667 my ($stop,$action) = split(/\0/, $$db{$line});
668 print $OUT " break if (", $stop, ")\n"
670 print $OUT " action: ", $action, "\n"
677 if (%break_on_load) {
678 print $OUT "Breakpoints on load:\n";
680 for $file (keys %break_on_load) {
681 print $OUT " $file\n";
686 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
687 my $file = $1; $file =~ s/\s+$//;
689 $break_on_load{$file} = 1;
690 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
691 $file .= '.pm', redo unless $file =~ /\./;
693 $had_breakpoints{$file} = 1;
694 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
696 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
697 my $cond = $3 || '1';
698 my ($subname, $break) = ($2, $1 eq 'postpone');
699 $subname =~ s/\'/::/;
700 $subname = "${'package'}::" . $subname
701 unless $subname =~ /::/;
702 $subname = "main".$subname if substr($subname,0,2) eq "::";
703 $postponed{$subname} = $break
704 ? "break +0 if $cond" : "compile";
706 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
709 $subname =~ s/\'/::/;
710 $subname = "${'package'}::" . $subname
711 unless $subname =~ /::/;
712 $subname = "main".$subname if substr($subname,0,2) eq "::";
713 # Filename below can contain ':'
714 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
718 *dbline = $main::{'_<' . $filename};
719 $had_breakpoints{$filename} = 1;
721 ++$i while $dbline[$i] == 0 && $i < $max;
722 $dbline{$i} =~ s/^[^\0]*/$cond/;
724 print $OUT "Subroutine $subname not found.\n";
727 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
730 if ($dbline[$i] == 0) {
731 print $OUT "Line $i not breakable.\n";
733 $had_breakpoints{$filename} = 1;
734 $dbline{$i} =~ s/^[^\0]*/$cond/;
737 $cmd =~ /^d\b\s*(\d+)?/ && do {
739 $dbline{$i} =~ s/^[^\0]*//;
740 delete $dbline{$i} if $dbline{$i} eq '';
742 $cmd =~ /^A$/ && do {
744 for $file (keys %had_breakpoints) {
745 local *dbline = $main::{'_<' . $file};
749 for ($i = 1; $i <= $max ; $i++) {
750 if (defined $dbline{$i}) {
751 $dbline{$i} =~ s/\0[^\0]*//;
752 delete $dbline{$i} if $dbline{$i} eq '';
757 $cmd =~ /^O\s*$/ && do {
762 $cmd =~ /^O\s*(\S.*)/ && do {
765 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
766 push @$pre, action($1);
768 $cmd =~ /^>>\s*(.*)/ && do {
769 push @$post, action($1);
771 $cmd =~ /^<\s*(.*)/ && do {
772 $pre = [], next CMD unless $1;
775 $cmd =~ /^>\s*(.*)/ && do {
776 $post = [], next CMD unless $1;
777 $post = [action($1)];
779 $cmd =~ /^\{\{\s*(.*)/ && do {
782 $cmd =~ /^\{\s*(.*)/ && do {
783 $pretype = [], next CMD unless $1;
786 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
788 if ($dbline[$i] == 0) {
789 print $OUT "Line $i may not have an action.\n";
791 $dbline{$i} =~ s/\0[^\0]*//;
792 $dbline{$i} .= "\0" . action($j);
795 $cmd =~ /^n$/ && do {
796 end_report(), next CMD if $finished and $level <= 1;
800 $cmd =~ /^s$/ && do {
801 end_report(), next CMD if $finished and $level <= 1;
805 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
806 end_report(), next CMD if $finished and $level <= 1;
808 if ($i =~ /\D/) { # subroutine name
809 ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/);
813 *dbline = $main::{'_<' . $filename};
814 $had_breakpoints{$filename}++;
816 ++$i while $dbline[$i] == 0 && $i < $max;
818 print $OUT "Subroutine $subname not found.\n";
823 if ($dbline[$i] == 0) {
824 print $OUT "Line $i not breakable.\n";
827 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
829 for ($i=0; $i <= $#stack; ) {
833 $cmd =~ /^r$/ && do {
834 end_report(), next CMD if $finished and $level <= 1;
835 $stack[$#stack] |= 1;
836 $doret = $option{PrintRet} ? $#stack - 1 : -2;
838 $cmd =~ /^R$/ && do {
839 print $OUT "Warning: some settings and command-line options may be lost!\n";
840 my (@script, @flags, $cl);
841 push @flags, '-w' if $ini_warn;
842 # Put all the old includes at the start to get
845 push @flags, '-I', $_;
847 # Arrange for setting the old INC:
848 set_list("PERLDB_INC", @ini_INC);
850 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
851 chomp ($cl = $ {'::_<-e'}[$_]);
852 push @script, '-e', $cl;
857 set_list("PERLDB_HIST",
858 $term->Features->{getHistory}
859 ? $term->GetHistory : @hist);
860 my @had_breakpoints = keys %had_breakpoints;
861 set_list("PERLDB_VISITED", @had_breakpoints);
862 set_list("PERLDB_OPT", %option);
863 set_list("PERLDB_ON_LOAD", %break_on_load);
865 for (0 .. $#had_breakpoints) {
866 my $file = $had_breakpoints[$_];
867 *dbline = $main::{'_<' . $file};
868 next unless %dbline or $postponed_file{$file};
869 (push @hard, $file), next
870 if $file =~ /^\(eval \d+\)$/;
872 @add = %{$postponed_file{$file}}
873 if $postponed_file{$file};
874 set_list("PERLDB_FILE_$_", %dbline, @add);
876 for (@hard) { # Yes, really-really...
877 # Find the subroutines in this eval
878 *dbline = $main::{'_<' . $_};
879 my ($quoted, $sub, %subs, $line) = quotemeta $_;
880 for $sub (keys %sub) {
881 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
882 $subs{$sub} = [$1, $2];
886 "No subroutines in $_, ignoring breakpoints.\n";
889 LINES: for $line (keys %dbline) {
890 # One breakpoint per sub only:
891 my ($offset, $sub, $found);
892 SUBS: for $sub (keys %subs) {
893 if ($subs{$sub}->[1] >= $line # Not after the subroutine
894 and (not defined $offset # Not caught
895 or $offset < 0 )) { # or badly caught
897 $offset = $line - $subs{$sub}->[0];
898 $offset = "+$offset", last SUBS if $offset >= 0;
901 if (defined $offset) {
903 "break $offset if $dbline{$line}";
905 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
909 set_list("PERLDB_POSTPONE", %postponed);
910 set_list("PERLDB_PRETYPE", @$pretype);
911 set_list("PERLDB_PRE", @$pre);
912 set_list("PERLDB_POST", @$post);
913 set_list("PERLDB_TYPEAHEAD", @typeahead);
914 $ENV{PERLDB_RESTART} = 1;
915 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
916 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
917 print $OUT "exec failed: $!\n";
919 $cmd =~ /^T$/ && do {
920 print_trace($OUT, 1); # skip DB
922 $cmd =~ /^\/(.*)$/ && do {
924 $inpat =~ s:([^\\])/$:$1:;
926 eval '$inpat =~ m'."\a$inpat\a";
938 $start = 1 if ($start > $max);
939 last if ($start == $end);
940 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
942 print $OUT "\032\032$filename:$start:0\n";
944 print $OUT "$start:\t", $dbline[$start], "\n";
949 print $OUT "/$pat/: not found\n" if ($start == $end);
951 $cmd =~ /^\?(.*)$/ && do {
953 $inpat =~ s:([^\\])\?$:$1:;
955 eval '$inpat =~ m'."\a$inpat\a";
967 $start = $max if ($start <= 0);
968 last if ($start == $end);
969 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
971 print $OUT "\032\032$filename:$start:0\n";
973 print $OUT "$start:\t", $dbline[$start], "\n";
978 print $OUT "?$pat?: not found\n" if ($start == $end);
980 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
981 pop(@hist) if length($cmd) > 1;
982 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
983 $cmd = $hist[$i] . "\n";
986 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
989 $cmd =~ /^$rc([^$rc].*)$/ && do {
991 pop(@hist) if length($cmd) > 1;
992 for ($i = $#hist; $i; --$i) {
993 last if $hist[$i] =~ /$pat/;
996 print $OUT "No such command!\n\n";
999 $cmd = $hist[$i] . "\n";
1002 $cmd =~ /^$sh$/ && do {
1003 &system($ENV{SHELL}||"/bin/sh");
1005 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1006 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1008 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1009 $end = $2?($#hist-$2):0;
1010 $hist = 0 if $hist < 0;
1011 for ($i=$#hist; $i>$end; $i--) {
1012 print $OUT "$i: ",$hist[$i],"\n"
1013 unless $hist[$i] =~ /^.?$/;
1016 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1017 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1018 $cmd =~ /^=/ && do {
1019 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1020 $alias{$k}="s~$k~$v~";
1021 print $OUT "$k = $v\n";
1022 } elsif ($cmd =~ /^=\s*$/) {
1023 foreach $k (sort keys(%alias)) {
1024 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1025 print $OUT "$k = $v\n";
1027 print $OUT "$k\t$alias{$k}\n";
1032 $cmd =~ /^\|\|?\s*[^|]/ && do {
1033 if ($pager =~ /^\|/) {
1034 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1035 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1037 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1039 unless ($piped=open(OUT,$pager)) {
1040 &warn("Can't pipe output to `$pager'");
1041 if ($pager =~ /^\|/) {
1042 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1043 open(STDOUT,">&SAVEOUT")
1044 || &warn("Can't restore STDOUT");
1047 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1051 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1052 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1053 $selected= select(OUT);
1055 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1056 $cmd =~ s/^\|+\s*//;
1058 # XXX Local variants do not work!
1059 $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
1060 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1061 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1063 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1065 $onetimeDump = undef;
1066 } elsif ($term_pid == $$) {
1071 if ($pager =~ /^\|/) {
1072 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1073 &warn( "Pager `$pager' failed: ",
1074 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1075 ( $? & 128 ) ? " (core dumped)" : "",
1076 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1077 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1078 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1079 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1080 # Will stop ignoring SIGPIPE if done like nohup(1)
1081 # does SIGINT but Perl doesn't give us a choice.
1083 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1086 select($selected), $selected= "" unless $selected eq "";
1090 $exiting = 1 unless defined $cmd;
1091 foreach $evalarg (@$post) {
1094 } # if ($single || $signal)
1095 ($@, $!, $,, $/, $\, $^W) = @saved;
1099 # The following code may be executed now:
1103 my ($al, $ret, @ret) = "";
1104 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1107 push(@stack, $single);
1109 $single |= 4 if $#stack == $deep;
1111 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1112 # Why -1? But it works! :-(
1113 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1114 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1117 $single |= pop(@stack);
1119 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1120 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1121 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1122 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1123 "list context return from $sub:\n"), dumpit( \@ret ),
1124 $doret = -2 if $doret eq $#stack or $frame & 16;
1128 $single |= pop(@stack);
1130 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1131 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1132 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1133 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1134 "scalar context return from $sub: "), dumpit( $ret ),
1135 $doret = -2 if $doret eq $#stack or $frame & 16;
1141 @saved = ($@, $!, $,, $/, $\, $^W);
1142 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1145 # The following takes its argument via $evalarg to preserve current @_
1150 local (@stack) = @stack; # guard against recursive debugging
1151 my $otrace = $trace;
1152 my $osingle = $single;
1154 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1160 local $saved[0]; # Preserve the old value of $@
1164 } elsif ($onetimeDump eq 'dump') {
1166 } elsif ($onetimeDump eq 'methods') {
1172 my $subname = shift;
1173 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1174 my $offset = $1 || 0;
1175 # Filename below can contain ':'
1176 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1179 local *dbline = $main::{'_<' . $file};
1180 local $^W = 0; # != 0 is magical below
1181 $had_breakpoints{$file}++;
1183 ++$i until $dbline[$i] != 0 or $i >= $max;
1184 $dbline{$i} = delete $postponed{$subname};
1186 print $OUT "Subroutine $subname not found.\n";
1190 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1191 #print $OUT "In postponed_sub for `$subname'.\n";
1195 return &postponed_sub
1196 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1197 # Cannot be done before the file is compiled
1198 local *dbline = shift;
1199 my $filename = $dbline;
1200 $filename =~ s/^_<//;
1201 $signal = 1, print $OUT "'$filename' loaded...\n"
1202 if $break_on_load{$filename};
1203 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1204 return unless $postponed_file{$filename};
1205 $had_breakpoints{$filename}++;
1206 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1208 for $key (keys %{$postponed_file{$filename}}) {
1209 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1211 delete $postponed_file{$filename};
1215 local ($savout) = select($OUT);
1216 my $osingle = $single;
1217 my $otrace = $trace;
1218 $single = $trace = 0;
1221 unless (defined &main::dumpValue) {
1224 if (defined &main::dumpValue) {
1225 &main::dumpValue(shift);
1227 print $OUT "dumpvar.pl not available.\n";
1234 # Tied method do not create a context, so may get wrong message:
1238 my @sub = dump_trace($_[0] + 1, $_[1]);
1239 my $short = $_[2]; # Print short report, next one for sub name
1241 for ($i=0; $i <= $#sub; $i++) {
1244 my $args = defined $sub[$i]{args}
1245 ? "(@{ $sub[$i]{args} })"
1247 $args = (substr $args, 0, $maxtrace - 3) . '...'
1248 if length $args > $maxtrace;
1249 my $file = $sub[$i]{file};
1250 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1252 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1254 my $sub = @_ >= 4 ? $_[3] : $s;
1255 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1257 print $fh "$sub[$i]{context} = $s$args" .
1258 " called from $file" .
1259 " line $sub[$i]{line}\n";
1266 my $count = shift || 1e9;
1269 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1270 my $nothard = not $frame & 8;
1271 local $frame = 0; # Do not want to trace this.
1272 my $otrace = $trace;
1275 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1280 if (not defined $arg) {
1282 } elsif ($nothard and tied $arg) {
1284 } elsif ($nothard and $type = ref $arg) {
1285 push @a, "ref($type)";
1287 local $_ = "$arg"; # Safe to stringify now - should not call f().
1290 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1291 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1292 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1296 $context = $context ? '@' : "\$";
1297 $args = $h ? [@a] : undef;
1298 $e =~ s/\n\s*\;\s*\Z// if $e;
1299 $e =~ s/([\\\'])/\\$1/g if $e;
1301 $sub = "require '$e'";
1302 } elsif (defined $r) {
1304 } elsif ($sub eq '(eval)') {
1305 $sub = "eval {...}";
1307 push(@sub, {context => $context, sub => $sub, args => $args,
1308 file => $file, line => $line});
1317 while ($action =~ s/\\$//) {
1328 &readline("cont: ");
1332 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1333 # many non-Unix systems can do system() but have problems with fork().
1334 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1335 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1336 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1337 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1339 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1340 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1341 close(SAVEIN); close(SAVEOUT);
1342 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1343 ( $? & 128 ) ? " (core dumped)" : "",
1344 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1351 local @stack = @stack; # Prevent growth by failing `use'.
1352 eval { require Term::ReadLine } or die $@;
1355 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1356 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1359 my $sel = select($OUT);
1363 eval "require Term::Rendezvous;" or die $@;
1364 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1365 my $term_rv = new Term::Rendezvous $rv;
1367 $OUT = $term_rv->OUT;
1371 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1373 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1375 $rl_attribs = $term->Attribs;
1376 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1377 if defined $rl_attribs->{basic_word_break_characters}
1378 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1379 $rl_attribs->{special_prefixes} = '$@&%';
1380 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1381 $rl_attribs->{completion_function} = \&db_complete;
1383 $LINEINFO = $OUT unless defined $LINEINFO;
1384 $lineinfo = $console unless defined $lineinfo;
1386 if ($term->Features->{setHistory} and "@hist" ne "?") {
1387 $term->SetHistory(@hist);
1389 ornaments($ornaments) if defined $ornaments;
1393 sub resetterm { # We forked, so we need a different TTY
1395 if (defined &get_fork_TTY) {
1397 } elsif (not defined $fork_TTY
1398 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1399 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1400 # Possibly _inside_ XTERM
1401 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1406 if (defined $fork_TTY) {
1410 print $OUT "Forked, but do not know how to change a TTY.\n",
1411 "Define \$DB::fork_TTY or get_fork_TTY().\n";
1417 my $left = @typeahead;
1418 my $got = shift @typeahead;
1419 print $OUT "auto(-$left)", shift, $got, "\n";
1420 $term->AddHistory($got)
1421 if length($got) > 1 and defined $term->Features->{addHistory};
1426 $term->readline(@_);
1430 my ($opt, $val)= @_;
1431 $val = option_val($opt,'N/A');
1432 $val =~ s/([\\\'])/\\$1/g;
1433 printf $OUT "%20s = '%s'\n", $opt, $val;
1437 my ($opt, $default)= @_;
1439 if (defined $optionVars{$opt}
1440 and defined $ {$optionVars{$opt}}) {
1441 $val = $ {$optionVars{$opt}};
1442 } elsif (defined $optionAction{$opt}
1443 and defined &{$optionAction{$opt}}) {
1444 $val = &{$optionAction{$opt}}();
1445 } elsif (defined $optionAction{$opt}
1446 and not defined $option{$opt}
1447 or defined $optionVars{$opt}
1448 and not defined $ {$optionVars{$opt}}) {
1451 $val = $option{$opt};
1459 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1460 my ($opt,$sep) = ($1,$2);
1463 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1465 #&dump_option($opt);
1466 } elsif ($sep !~ /\S/) {
1468 } elsif ($sep eq "=") {
1471 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1472 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1473 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1474 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1476 $val =~ s/\\([\\$end])/$1/g;
1480 grep( /^\Q$opt/ && ($option = $_), @options );
1481 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1483 print $OUT "Unknown option `$opt'\n" unless $matches;
1484 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1485 $option{$option} = $val if $matches == 1 and defined $val;
1486 eval "local \$frame = 0; local \$doret = -2;
1487 require '$optionRequire{$option}'"
1488 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1489 $ {$optionVars{$option}} = $val
1491 and defined $optionVars{$option} and defined $val;
1492 & {$optionAction{$option}} ($val)
1494 and defined $optionAction{$option}
1495 and defined &{$optionAction{$option}} and defined $val;
1496 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1502 my ($stem,@list) = @_;
1504 $ENV{"$ {stem}_n"} = @list;
1505 for $i (0 .. $#list) {
1507 $val =~ s/\\/\\\\/g;
1508 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1509 $ENV{"$ {stem}_$i"} = $val;
1516 my $n = delete $ENV{"$ {stem}_n"};
1518 for $i (0 .. $n - 1) {
1519 $val = delete $ENV{"$ {stem}_$i"};
1520 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1528 return; # Put nothing on the stack - malloc/free land!
1532 my($msg)= join("",@_);
1533 $msg .= ": $!\n" unless $msg =~ /\n$/;
1538 if (@_ and $term and $term->Features->{newTTY}) {
1539 my ($in, $out) = shift;
1541 ($in, $out) = split /,/, $in, 2;
1545 open IN, $in or die "cannot open `$in' for read: $!";
1546 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1547 $term->newTTY(\*IN, \*OUT);
1551 } elsif ($term and @_) {
1552 &warn("Too late to set TTY, enabled on next `R'!\n");
1560 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1562 $notty = shift if @_;
1568 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1575 if ($ {$term->Features}{tkRunning}) {
1576 return $term->tkRunning(@_);
1578 print $OUT "tkRunning not supported by current ReadLine package.\n";
1585 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1587 $runnonstop = shift if @_;
1594 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1601 $sh = quotemeta shift;
1602 $sh .= "\\b" if $sh =~ /\w$/;
1606 $psh =~ s/\\(.)/$1/g;
1612 if (defined $term) {
1613 local ($warnLevel,$dieLevel) = (0, 1);
1614 return '' unless $term->Features->{ornaments};
1615 eval { $term->ornaments(@_) } || '';
1623 $rc = quotemeta shift;
1624 $rc .= "\\b" if $rc =~ /\w$/;
1628 $prc =~ s/\\(.)/$1/g;
1634 return $lineinfo unless @_;
1636 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1637 $emacs = ($stream =~ /^\|/);
1638 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1639 $LINEINFO = \*LINEINFO;
1640 my $save = select($LINEINFO);
1654 s/^Term::ReadLine::readline$/readline/;
1655 if (defined $ { $_ . '::VERSION' }) {
1656 $version{$file} = "$ { $_ . '::VERSION' } from ";
1658 $version{$file} .= $INC{$file};
1660 do 'dumpvar.pl' unless defined &main::dumpValue;
1661 if (defined &main::dumpValue) {
1663 &main::dumpValue(\%version);
1665 print $OUT "dumpvar.pl not available.\n";
1672 s [expr] Single step [in expr].
1673 n [expr] Next, steps over subroutine calls [in expr].
1674 <CR> Repeat last n or s command.
1675 r Return from current subroutine.
1676 c [line|sub] Continue; optionally inserts a one-time-only breakpoint
1677 at the specified position.
1678 l min+incr List incr+1 lines starting at min.
1679 l min-max List lines min through max.
1680 l line List single line.
1681 l subname List first window of lines from subroutine.
1682 l List next window of lines.
1683 - List previous window of lines.
1684 w [line] List window around line.
1685 . Return to the executed line.
1686 f filename Switch to viewing filename. Must be loaded.
1687 /pattern/ Search forwards for pattern; final / is optional.
1688 ?pattern? Search backwards for pattern; final ? is optional.
1689 L List all breakpoints and actions.
1690 S [[!]pattern] List subroutine names [not] matching pattern.
1691 t Toggle trace mode.
1692 t expr Trace through execution of expr.
1693 b [line] [condition]
1694 Set breakpoint; line defaults to the current execution line;
1695 condition breaks if it evaluates to true, defaults to '1'.
1696 b subname [condition]
1697 Set breakpoint at first line of subroutine.
1698 b load filename Set breakpoint on `require'ing the given file.
1699 b postpone subname [condition]
1700 Set breakpoint at first line of subroutine after
1703 Stop after the subroutine is compiled.
1704 d [line] Delete the breakpoint for line.
1705 D Delete all breakpoints.
1707 Set an action to be done before the line is executed.
1708 Sequence is: check for breakpoint, print line if necessary,
1709 do action, prompt user if breakpoint or step, evaluate line.
1710 A Delete all actions.
1711 V [pkg [vars]] List some (default all) variables in package (default current).
1712 Use ~pattern and !pattern for positive and negative regexps.
1713 X [vars] Same as \"V currentpackage [vars]\".
1714 x expr Evals expression in array context, dumps the result.
1715 m expr Evals expression in array context, prints methods callable
1716 on the first element of the result.
1717 m class Prints methods callable via the given class.
1718 O [opt[=val]] [opt\"val\"] [opt?]...
1719 Set or query values of options. val defaults to 1. opt can
1720 be abbreviated. Several options can be listed.
1721 recallCommand, ShellBang: chars used to recall command or spawn shell;
1722 pager: program for output of \"|cmd\";
1723 tkRunning: run Tk while prompting (with ReadLine);
1724 signalLevel warnLevel dieLevel: level of verbosity;
1725 inhibit_exit Allows stepping off the end of the script.
1726 The following options affect what happens with V, X, and x commands:
1727 arrayDepth, hashDepth: print only first N elements ('' for all);
1728 compactDump, veryCompact: change style of array and hash dump;
1729 globPrint: whether to print contents of globs;
1730 DumpDBFiles: dump arrays holding debugged files;
1731 DumpPackages: dump symbol tables of packages;
1732 quote, HighBit, undefPrint: change style of string dump;
1733 Option PrintRet affects printing of return value after r command,
1734 frame affects printing messages on entry and exit from subroutines.
1735 AutoTrace affects printing messages on every possible breaking point.
1736 maxTraceLen gives maximal length of evals/args listed in stack trace.
1737 ornaments affects screen appearance of the command line.
1738 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1739 You can put additional initialization options TTY, noTTY,
1740 ReadLine, and NonStop there (or use `R' after you set them).
1741 < command Define Perl command to run before each prompt.
1742 << command Add to the list of Perl commands to run before each prompt.
1743 > command Define Perl command to run after each prompt.
1744 >> command Add to the list of Perl commands to run after each prompt.
1745 \{ commandline Define debugger command to run before each prompt.
1746 \{{ commandline Add to the list of debugger commands to run before each prompt.
1747 $prc number Redo a previous command (default previous command).
1748 $prc -number Redo number'th-to-last command.
1749 $prc pattern Redo last command that started with pattern.
1750 See 'O recallCommand' too.
1751 $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1752 . ( $rc eq $sh ? "" : "
1753 $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1754 See 'O shellBang' too.
1755 H -number Display last number commands (default all).
1756 p expr Same as \"print {DB::OUT} expr\" in current package.
1757 |dbcmd Run debugger command, piping DB::OUT to current pager.
1758 ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1759 \= [alias value] Define a command alias, or list current aliases.
1760 command Execute as a perl statement in current package.
1761 v Show versions of loaded modules.
1762 R Pure-man-restart of debugger, some of debugger state
1763 and command-line options may be lost.
1764 Currently the following setting are preserved:
1765 history, breakpoints and actions, debugger Options
1766 and the following command-line options: -w, -I, -e.
1767 h [db_command] Get help [on a specific debugger command], enter |h to page.
1768 h h Summary of debugger commands.
1769 q or ^D Quit. Set \$DB::finished to 0 to debug global destruction.
1772 $summary = <<"END_SUM";
1773 List/search source lines: Control script execution:
1774 l [ln|sub] List source code T Stack trace
1775 - or . List previous/current line s [expr] Single step [in expr]
1776 w [line] List around line n [expr] Next, steps over subs
1777 f filename View source in file <CR> Repeat last n or s
1778 /pattern/ ?patt? Search forw/backw r Return from subroutine
1779 v Show versions of modules c [ln|sub] Continue until position
1780 Debugger controls: L List break pts & actions
1781 O [...] Set debugger options t [expr] Toggle trace [trace expr]
1782 <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
1783 >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
1784 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1785 H [-num] Display last num commands D Delete all breakpoints
1786 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1787 h [db_cmd] Get help on command A Delete all actions
1788 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
1789 q or ^D Quit R Attempt a restart
1790 Data Examination: expr Execute perl code, also see: s,n,t expr
1791 x|m expr Evals expr in array context, dumps the result or lists methods.
1792 p expr Print expression (uses script's current package).
1793 S [[!]pat] List subroutine names [not] matching pattern
1794 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1795 X [Vars] Same as \"V current_package [Vars]\".
1797 # ')}}; # Fix balance of Emacs parsing
1803 $SIG{'ABRT'} = 'DEFAULT';
1804 kill 'ABRT', $$ if $panic++;
1805 if (defined &Carp::longmess) {
1806 local $SIG{__WARN__} = '';
1807 local $Carp::CarpLevel = 2; # mydie + confess
1808 &warn(Carp::longmess("Signal @_"));
1811 print $DB::OUT "Got signal @_\n";
1819 local $SIG{__WARN__} = '';
1820 local $SIG{__DIE__} = '';
1821 eval { require Carp }; # If error/warning during compilation,
1822 # require may be broken.
1823 warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1824 unless defined &Carp::longmess;
1825 #&warn("Entering dbwarn\n");
1826 my ($mysingle,$mytrace) = ($single,$trace);
1827 $single = 0; $trace = 0;
1828 my $mess = Carp::longmess(@_);
1829 ($single,$trace) = ($mysingle,$mytrace);
1830 #&warn("Warning in dbwarn\n");
1832 #&warn("Exiting dbwarn\n");
1838 local $SIG{__DIE__} = '';
1839 local $SIG{__WARN__} = '';
1840 my $i = 0; my $ineval = 0; my $sub;
1841 #&warn("Entering dbdie\n");
1842 if ($dieLevel != 2) {
1843 while ((undef,undef,undef,$sub) = caller(++$i)) {
1844 $ineval = 1, last if $sub eq '(eval)';
1847 local $SIG{__WARN__} = \&dbwarn;
1848 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1850 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1851 die @_ if $ineval and $dieLevel < 2;
1853 eval { require Carp }; # If error/warning during compilation,
1854 # require may be broken.
1855 die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1856 # We do not want to debug this chunk (automatic disabling works
1857 # inside DB::DB, but not in Carp).
1858 my ($mysingle,$mytrace) = ($single,$trace);
1859 $single = 0; $trace = 0;
1860 my $mess = Carp::longmess(@_);
1861 ($single,$trace) = ($mysingle,$mytrace);
1862 #&warn("dieing loudly in dbdie\n");
1868 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1871 $SIG{__WARN__} = \&DB::dbwarn;
1873 $SIG{__WARN__} = $prevwarn;
1881 $prevdie = $SIG{__DIE__} unless $dieLevel;
1884 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1885 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1886 print $OUT "Stack dump during die enabled",
1887 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1889 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1891 $SIG{__DIE__} = $prevdie;
1892 print $OUT "Default die handler restored.\n";
1900 $prevsegv = $SIG{SEGV} unless $signalLevel;
1901 $prevbus = $SIG{BUS} unless $signalLevel;
1902 $signalLevel = shift;
1904 $SIG{SEGV} = \&DB::diesignal;
1905 $SIG{BUS} = \&DB::diesignal;
1907 $SIG{SEGV} = $prevsegv;
1908 $SIG{BUS} = $prevbus;
1916 return unless defined &$subr;
1918 $subr = \&$subr; # Hard reference
1921 $s = $_, last if $subr eq \&$_;
1929 $class = ref $class if ref $class;
1932 methods_via($class, '', 1);
1933 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
1938 return if $packs{$class}++;
1940 my $prepend = $prefix ? "via $prefix: " : '';
1942 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
1943 sort keys %{"$ {class}::"}) {
1944 next if $seen{ $name }++;
1945 print $DB::OUT "$prepend$name\n";
1947 return unless shift; # Recurse?
1948 for $name (@{"$ {class}::ISA"}) {
1949 $prepend = $prefix ? $prefix . " -> $name" : $name;
1950 methods_via($name, $prepend, 1);
1954 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1956 BEGIN { # This does not compile, alas.
1957 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1958 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1962 $deep = 100; # warning if stack gets this deep
1966 $SIG{INT} = \&DB::catch;
1967 # This may be enabled to debug debugger:
1968 #$warnLevel = 1 unless defined $warnLevel;
1969 #$dieLevel = 1 unless defined $dieLevel;
1970 #$signalLevel = 1 unless defined $signalLevel;
1972 $db_stop = 0; # Compiler warning
1974 $level = 0; # Level of recursive debugging
1975 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1976 # Triggers bug (?) in perl is we postpone this until runtime:
1977 @postponed = @stack = (0);
1982 BEGIN {$^W = $ini_warn;} # Switch warnings back
1984 #use Carp; # This did break, left for debuggin
1987 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
1988 my($text, $line, $start) = @_;
1989 my ($itext, $search, $prefix, $pack) =
1990 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
1992 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
1993 (map { /$search/ ? ($1) : () } keys %sub)
1994 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
1995 return sort grep /^\Q$text/, values %INC # files
1996 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
1997 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1998 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
1999 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2000 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2002 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2004 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2005 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2006 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2007 # We may want to complete to (eval 9), so $text may be wrong
2008 $prefix = length($1) - length($text);
2011 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2013 if ((substr $text, 0, 1) eq '&') { # subroutines
2014 $text = substr $text, 1;
2016 return sort map "$prefix$_",
2019 (map { /$search/ ? ($1) : () }
2022 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2023 $pack = ($1 eq 'main' ? '' : $1) . '::';
2024 $prefix = (substr $text, 0, 1) . $1 . '::';
2027 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2028 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2029 return db_complete($out[0], $line, $start);
2033 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2034 $pack = ($package eq 'main' ? '' : $package) . '::';
2035 $prefix = substr $text, 0, 1;
2036 $text = substr $text, 1;
2037 my @out = map "$prefix$_", grep /^\Q$text/,
2038 (grep /^_?[a-zA-Z]/, keys %$pack),
2039 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2040 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2041 return db_complete($out[0], $line, $start);
2045 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2046 my @out = grep /^\Q$text/, @options;
2047 my $val = option_val($out[0], undef);
2049 if (not defined $val or $val =~ /[\n\r]/) {
2050 # Can do nothing better
2051 } elsif ($val =~ /\s/) {
2053 foreach $l (split //, qq/\"\'\#\|/) {
2054 $out = "$l$val$l ", last if (index $val, $l) == -1;
2059 # Default to value if one completion, to question if many
2060 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2063 return $term->filename_list($text); # filenames
2067 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2071 $finished = $inhibit_exit; # So that some keys may be disabled.
2072 # Do not stop in at_exit() and destructors on exit:
2073 $DB::single = !$exiting && !$runnonstop;
2074 DB::fake::at_exit() unless $exiting or $runnonstop;
2080 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2083 package DB; # Do not trace this 1; below!