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 defined ($cmd=&readline(" DB" . ('<' x $level) .
432 ($#hist+1) . ('>' x $level) .
436 $cmd =~ s/\\$/\n/ && do {
437 $cmd .= &readline(" cont: ");
440 $cmd =~ /^$/ && ($cmd = $laststep);
441 push(@hist,$cmd) if length($cmd) > 1;
443 ($i) = split(/\s+/,$cmd);
444 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
445 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
446 $cmd =~ /^h$/ && do {
449 $cmd =~ /^h\s+h$/ && do {
452 $cmd =~ /^h\s+(\S)$/ && do {
454 if ($help =~ /^$asked/m) {
455 while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
459 print $OUT "`$asked' is not a debugger command.\n";
462 $cmd =~ /^t$/ && do {
464 print $OUT "Trace = ".($trace?"on":"off")."\n";
466 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
467 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
468 foreach $subname (sort(keys %sub)) {
469 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
470 print $OUT $subname,"\n";
474 $cmd =~ /^v$/ && do {
475 list_versions(); next CMD};
476 $cmd =~ s/^X\b/V $package/;
477 $cmd =~ /^V$/ && do {
478 $cmd = "V $package"; };
479 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
480 local ($savout) = select($OUT);
482 @vars = split(' ',$2);
483 do 'dumpvar.pl' unless defined &main::dumpvar;
484 if (defined &main::dumpvar) {
487 &main::dumpvar($packname,@vars);
489 print $OUT "dumpvar.pl not available.\n";
493 $cmd =~ s/^x\b/ / && do { # So that will be evaled
494 $onetimeDump = 'dump'; };
495 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
496 methods($1); next CMD};
497 $cmd =~ s/^m\b/ / && do { # So this will be evaled
498 $onetimeDump = 'methods'; };
499 $cmd =~ /^f\b\s*(.*)/ && do {
503 print $OUT "The old f command is now the r command.\n";
504 print $OUT "The new f command switches filenames.\n";
507 if (!defined $main::{'_<' . $file}) {
508 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
509 $try = substr($try,2);
510 print $OUT "Choosing $try matching `$file':\n";
514 if (!defined $main::{'_<' . $file}) {
515 print $OUT "No file matching `$file' is loaded.\n";
517 } elsif ($file ne $filename) {
518 *dbline = $main::{'_<' . $file};
524 print $OUT "Already in $file.\n";
528 $cmd =~ s/^l\s+-\s*$/-/;
529 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
531 $subname =~ s/\'/::/;
532 $subname = $package."::".$subname
533 unless $subname =~ /::/;
534 $subname = "main".$subname if substr($subname,0,2) eq "::";
535 @pieces = split(/:/,find_sub($subname));
536 $subrange = pop @pieces;
537 $file = join(':', @pieces);
538 if ($file ne $filename) {
539 *dbline = $main::{'_<' . $file};
544 if (eval($subrange) < -$window) {
545 $subrange =~ s/-.*/+/;
547 $cmd = "l $subrange";
549 print $OUT "Subroutine $subname not found.\n";
552 $cmd =~ /^\.$/ && do {
553 $incr = -1; # for backward motion.
555 $filename = $filename_ini;
556 *dbline = $main::{'_<' . $filename};
558 print $LINEINFO $position;
560 $cmd =~ /^w\b\s*(\d*)$/ && do {
564 #print $OUT 'l ' . $start . '-' . ($start + $incr);
565 $cmd = 'l ' . $start . '-' . ($start + $incr); };
566 $cmd =~ /^-$/ && do {
567 $start -= $incr + $window + 1;
568 $start = 1 if $start <= 0;
570 $cmd = 'l ' . ($start) . '+'; };
571 $cmd =~ /^l$/ && do {
573 $cmd = 'l ' . $start . '-' . ($start + $incr); };
574 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
577 $incr = $window - 1 unless $incr;
578 $cmd = 'l ' . $start . '-' . ($start + $incr); };
579 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
580 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
581 $end = $max if $end > $max;
583 $i = $line if $i eq '.';
587 print $OUT "\032\032$filename:$i:0\n";
590 for (; $i <= $end; $i++) {
591 ($stop,$action) = split(/\0/, $dbline{$i});
593 and $filename eq $filename_ini)
595 : ($dbline[$i]+0 ? ':' : ' ') ;
596 $arrow .= 'b' if $stop;
597 $arrow .= 'a' if $action;
598 print $OUT "$i$arrow\t", $dbline[$i];
602 $start = $i; # remember in case they want more
603 $start = $max if $start > $max;
605 $cmd =~ /^D$/ && do {
606 print $OUT "Deleting all breakpoints...\n";
608 for $file (keys %had_breakpoints) {
609 local *dbline = $main::{'_<' . $file};
613 for ($i = 1; $i <= $max ; $i++) {
614 if (defined $dbline{$i}) {
615 $dbline{$i} =~ s/^[^\0]+//;
616 if ($dbline{$i} =~ s/^\0?$//) {
623 undef %postponed_file;
624 undef %break_on_load;
625 undef %had_breakpoints;
627 $cmd =~ /^L$/ && do {
629 for $file (keys %had_breakpoints) {
630 local *dbline = $main::{'_<' . $file};
634 for ($i = 1; $i <= $max; $i++) {
635 if (defined $dbline{$i}) {
636 print "$file:\n" unless $was++;
637 print $OUT " $i:\t", $dbline[$i];
638 ($stop,$action) = split(/\0/, $dbline{$i});
639 print $OUT " break if (", $stop, ")\n"
641 print $OUT " action: ", $action, "\n"
648 print $OUT "Postponed breakpoints in subroutines:\n";
650 for $subname (keys %postponed) {
651 print $OUT " $subname\t$postponed{$subname}\n";
655 my @have = map { # Combined keys
656 keys %{$postponed_file{$_}}
657 } keys %postponed_file;
659 print $OUT "Postponed breakpoints in files:\n";
661 for $file (keys %postponed_file) {
662 my $db = $postponed_file{$file};
663 print $OUT " $file:\n";
664 for $line (sort {$a <=> $b} keys %$db) {
665 print $OUT " $line:\n";
666 my ($stop,$action) = split(/\0/, $$db{$line});
667 print $OUT " break if (", $stop, ")\n"
669 print $OUT " action: ", $action, "\n"
676 if (%break_on_load) {
677 print $OUT "Breakpoints on load:\n";
679 for $file (keys %break_on_load) {
680 print $OUT " $file\n";
685 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
686 my $file = $1; $file =~ s/\s+$//;
688 $break_on_load{$file} = 1;
689 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
690 $file .= '.pm', redo unless $file =~ /\./;
692 $had_breakpoints{$file} = 1;
693 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
695 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
696 my $cond = $3 || '1';
697 my ($subname, $break) = ($2, $1 eq 'postpone');
698 $subname =~ s/\'/::/;
699 $subname = "${'package'}::" . $subname
700 unless $subname =~ /::/;
701 $subname = "main".$subname if substr($subname,0,2) eq "::";
702 $postponed{$subname} = $break
703 ? "break +0 if $cond" : "compile";
705 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
708 $subname =~ s/\'/::/;
709 $subname = "${'package'}::" . $subname
710 unless $subname =~ /::/;
711 $subname = "main".$subname if substr($subname,0,2) eq "::";
712 # Filename below can contain ':'
713 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
717 *dbline = $main::{'_<' . $filename};
718 $had_breakpoints{$filename} = 1;
720 ++$i while $dbline[$i] == 0 && $i < $max;
721 $dbline{$i} =~ s/^[^\0]*/$cond/;
723 print $OUT "Subroutine $subname not found.\n";
726 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
729 if ($dbline[$i] == 0) {
730 print $OUT "Line $i not breakable.\n";
732 $had_breakpoints{$filename} = 1;
733 $dbline{$i} =~ s/^[^\0]*/$cond/;
736 $cmd =~ /^d\b\s*(\d+)?/ && do {
738 $dbline{$i} =~ s/^[^\0]*//;
739 delete $dbline{$i} if $dbline{$i} eq '';
741 $cmd =~ /^A$/ && do {
743 for $file (keys %had_breakpoints) {
744 local *dbline = $main::{'_<' . $file};
748 for ($i = 1; $i <= $max ; $i++) {
749 if (defined $dbline{$i}) {
750 $dbline{$i} =~ s/\0[^\0]*//;
751 delete $dbline{$i} if $dbline{$i} eq '';
756 $cmd =~ /^O\s*$/ && do {
761 $cmd =~ /^O\s*(\S.*)/ && do {
764 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
765 push @$pre, action($1);
767 $cmd =~ /^>>\s*(.*)/ && do {
768 push @$post, action($1);
770 $cmd =~ /^<\s*(.*)/ && do {
771 $pre = [], next CMD unless $1;
774 $cmd =~ /^>\s*(.*)/ && do {
775 $post = [], next CMD unless $1;
776 $post = [action($1)];
778 $cmd =~ /^\{\{\s*(.*)/ && do {
781 $cmd =~ /^\{\s*(.*)/ && do {
782 $pretype = [], next CMD unless $1;
785 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
787 if ($dbline[$i] == 0) {
788 print $OUT "Line $i may not have an action.\n";
790 $dbline{$i} =~ s/\0[^\0]*//;
791 $dbline{$i} .= "\0" . action($j);
794 $cmd =~ /^n$/ && do {
795 end_report(), next CMD if $finished and $level <= 1;
799 $cmd =~ /^s$/ && do {
800 end_report(), next CMD if $finished and $level <= 1;
804 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
805 end_report(), next CMD if $finished and $level <= 1;
807 if ($i =~ /\D/) { # subroutine name
808 ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/);
812 *dbline = $main::{'_<' . $filename};
813 $had_breakpoints{$filename}++;
815 ++$i while $dbline[$i] == 0 && $i < $max;
817 print $OUT "Subroutine $subname not found.\n";
822 if ($dbline[$i] == 0) {
823 print $OUT "Line $i not breakable.\n";
826 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
828 for ($i=0; $i <= $#stack; ) {
832 $cmd =~ /^r$/ && do {
833 end_report(), next CMD if $finished and $level <= 1;
834 $stack[$#stack] |= 1;
835 $doret = $option{PrintRet} ? $#stack - 1 : -2;
837 $cmd =~ /^R$/ && do {
838 print $OUT "Warning: some settings and command-line options may be lost!\n";
839 my (@script, @flags, $cl);
840 push @flags, '-w' if $ini_warn;
841 # Put all the old includes at the start to get
844 push @flags, '-I', $_;
846 # Arrange for setting the old INC:
847 set_list("PERLDB_INC", @ini_INC);
849 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
850 chomp ($cl = $ {'::_<-e'}[$_]);
851 push @script, '-e', $cl;
856 set_list("PERLDB_HIST",
857 $term->Features->{getHistory}
858 ? $term->GetHistory : @hist);
859 my @had_breakpoints = keys %had_breakpoints;
860 set_list("PERLDB_VISITED", @had_breakpoints);
861 set_list("PERLDB_OPT", %option);
862 set_list("PERLDB_ON_LOAD", %break_on_load);
864 for (0 .. $#had_breakpoints) {
865 my $file = $had_breakpoints[$_];
866 *dbline = $main::{'_<' . $file};
867 next unless %dbline or $postponed_file{$file};
868 (push @hard, $file), next
869 if $file =~ /^\(eval \d+\)$/;
871 @add = %{$postponed_file{$file}}
872 if $postponed_file{$file};
873 set_list("PERLDB_FILE_$_", %dbline, @add);
875 for (@hard) { # Yes, really-really...
876 # Find the subroutines in this eval
877 *dbline = $main::{'_<' . $_};
878 my ($quoted, $sub, %subs, $line) = quotemeta $_;
879 for $sub (keys %sub) {
880 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
881 $subs{$sub} = [$1, $2];
885 "No subroutines in $_, ignoring breakpoints.\n";
888 LINES: for $line (keys %dbline) {
889 # One breakpoint per sub only:
890 my ($offset, $sub, $found);
891 SUBS: for $sub (keys %subs) {
892 if ($subs{$sub}->[1] >= $line # Not after the subroutine
893 and (not defined $offset # Not caught
894 or $offset < 0 )) { # or badly caught
896 $offset = $line - $subs{$sub}->[0];
897 $offset = "+$offset", last SUBS if $offset >= 0;
900 if (defined $offset) {
902 "break $offset if $dbline{$line}";
904 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
908 set_list("PERLDB_POSTPONE", %postponed);
909 set_list("PERLDB_PRETYPE", @$pretype);
910 set_list("PERLDB_PRE", @$pre);
911 set_list("PERLDB_POST", @$post);
912 set_list("PERLDB_TYPEAHEAD", @typeahead);
913 $ENV{PERLDB_RESTART} = 1;
914 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
915 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
916 print $OUT "exec failed: $!\n";
918 $cmd =~ /^T$/ && do {
919 print_trace($OUT, 1); # skip DB
921 $cmd =~ /^\/(.*)$/ && do {
923 $inpat =~ s:([^\\])/$:$1:;
925 eval '$inpat =~ m'."\a$inpat\a";
937 $start = 1 if ($start > $max);
938 last if ($start == $end);
939 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
941 print $OUT "\032\032$filename:$start:0\n";
943 print $OUT "$start:\t", $dbline[$start], "\n";
948 print $OUT "/$pat/: not found\n" if ($start == $end);
950 $cmd =~ /^\?(.*)$/ && do {
952 $inpat =~ s:([^\\])\?$:$1:;
954 eval '$inpat =~ m'."\a$inpat\a";
966 $start = $max if ($start <= 0);
967 last if ($start == $end);
968 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
970 print $OUT "\032\032$filename:$start:0\n";
972 print $OUT "$start:\t", $dbline[$start], "\n";
977 print $OUT "?$pat?: not found\n" if ($start == $end);
979 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
980 pop(@hist) if length($cmd) > 1;
981 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
982 $cmd = $hist[$i] . "\n";
985 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
988 $cmd =~ /^$rc([^$rc].*)$/ && do {
990 pop(@hist) if length($cmd) > 1;
991 for ($i = $#hist; $i; --$i) {
992 last if $hist[$i] =~ /$pat/;
995 print $OUT "No such command!\n\n";
998 $cmd = $hist[$i] . "\n";
1001 $cmd =~ /^$sh$/ && do {
1002 &system($ENV{SHELL}||"/bin/sh");
1004 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1005 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1007 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1008 $end = $2?($#hist-$2):0;
1009 $hist = 0 if $hist < 0;
1010 for ($i=$#hist; $i>$end; $i--) {
1011 print $OUT "$i: ",$hist[$i],"\n"
1012 unless $hist[$i] =~ /^.?$/;
1015 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1016 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1017 $cmd =~ /^=/ && do {
1018 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1019 $alias{$k}="s~$k~$v~";
1020 print $OUT "$k = $v\n";
1021 } elsif ($cmd =~ /^=\s*$/) {
1022 foreach $k (sort keys(%alias)) {
1023 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1024 print $OUT "$k = $v\n";
1026 print $OUT "$k\t$alias{$k}\n";
1031 $cmd =~ /^\|\|?\s*[^|]/ && do {
1032 if ($pager =~ /^\|/) {
1033 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1034 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1036 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1038 unless ($piped=open(OUT,$pager)) {
1039 &warn("Can't pipe output to `$pager'");
1040 if ($pager =~ /^\|/) {
1041 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1042 open(STDOUT,">&SAVEOUT")
1043 || &warn("Can't restore STDOUT");
1046 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1050 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1051 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1052 $selected= select(OUT);
1054 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1055 $cmd =~ s/^\|+\s*//;
1057 # XXX Local variants do not work!
1058 $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
1059 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1060 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1062 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1064 $onetimeDump = undef;
1070 if ($pager =~ /^\|/) {
1071 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1072 &warn( "Pager `$pager' failed: ",
1073 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1074 ( $? & 128 ) ? " (core dumped)" : "",
1075 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1076 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1077 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1078 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1079 # Will stop ignoring SIGPIPE if done like nohup(1)
1080 # does SIGINT but Perl doesn't give us a choice.
1082 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1085 select($selected), $selected= "" unless $selected eq "";
1089 $exiting = 1 unless defined $cmd;
1090 foreach $evalarg (@$post) {
1093 } # if ($single || $signal)
1094 ($@, $!, $,, $/, $\, $^W) = @saved;
1098 # The following code may be executed now:
1102 my ($al, $ret, @ret) = "";
1103 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1106 push(@stack, $single);
1108 $single |= 4 if $#stack == $deep;
1110 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1111 # Why -1? But it works! :-(
1112 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1113 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
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 "list context return from $sub:\n"), dumpit( \@ret ),
1123 $doret = -2 if $doret eq $#stack or $frame & 16;
1127 $single |= pop(@stack);
1129 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1130 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1131 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1132 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1133 "scalar context return from $sub: "), dumpit( $ret ),
1134 $doret = -2 if $doret eq $#stack or $frame & 16;
1140 @saved = ($@, $!, $,, $/, $\, $^W);
1141 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1144 # The following takes its argument via $evalarg to preserve current @_
1149 local (@stack) = @stack; # guard against recursive debugging
1150 my $otrace = $trace;
1151 my $osingle = $single;
1153 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1159 local $saved[0]; # Preserve the old value of $@
1163 } elsif ($onetimeDump eq 'dump') {
1165 } elsif ($onetimeDump eq 'methods') {
1171 my $subname = shift;
1172 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1173 my $offset = $1 || 0;
1174 # Filename below can contain ':'
1175 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1178 local *dbline = $main::{'_<' . $file};
1179 local $^W = 0; # != 0 is magical below
1180 $had_breakpoints{$file}++;
1182 ++$i until $dbline[$i] != 0 or $i >= $max;
1183 $dbline{$i} = delete $postponed{$subname};
1185 print $OUT "Subroutine $subname not found.\n";
1189 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1190 #print $OUT "In postponed_sub for `$subname'.\n";
1194 return &postponed_sub
1195 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1196 # Cannot be done before the file is compiled
1197 local *dbline = shift;
1198 my $filename = $dbline;
1199 $filename =~ s/^_<//;
1200 $signal = 1, print $OUT "'$filename' loaded...\n"
1201 if $break_on_load{$filename};
1202 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1203 return unless $postponed_file{$filename};
1204 $had_breakpoints{$filename}++;
1205 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1207 for $key (keys %{$postponed_file{$filename}}) {
1208 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1210 delete $postponed_file{$filename};
1214 local ($savout) = select($OUT);
1215 my $osingle = $single;
1216 my $otrace = $trace;
1217 $single = $trace = 0;
1220 unless (defined &main::dumpValue) {
1223 if (defined &main::dumpValue) {
1224 &main::dumpValue(shift);
1226 print $OUT "dumpvar.pl not available.\n";
1233 # Tied method do not create a context, so may get wrong message:
1237 my @sub = dump_trace($_[0] + 1, $_[1]);
1238 my $short = $_[2]; # Print short report, next one for sub name
1240 for ($i=0; $i <= $#sub; $i++) {
1243 my $args = defined $sub[$i]{args}
1244 ? "(@{ $sub[$i]{args} })"
1246 $args = (substr $args, 0, $maxtrace - 3) . '...'
1247 if length $args > $maxtrace;
1248 my $file = $sub[$i]{file};
1249 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1251 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1253 my $sub = @_ >= 4 ? $_[3] : $s;
1254 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1256 print $fh "$sub[$i]{context} = $s$args" .
1257 " called from $file" .
1258 " line $sub[$i]{line}\n";
1265 my $count = shift || 1e9;
1268 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1269 my $nothard = not $frame & 8;
1270 local $frame = 0; # Do not want to trace this.
1271 my $otrace = $trace;
1274 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1279 if (not defined $arg) {
1281 } elsif ($nothard and tied $arg) {
1283 } elsif ($nothard and $type = ref $arg) {
1284 push @a, "ref($type)";
1286 local $_ = "$arg"; # Safe to stringify now - should not call f().
1289 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1290 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1291 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1295 $context = $context ? '@' : "\$";
1296 $args = $h ? [@a] : undef;
1297 $e =~ s/\n\s*\;\s*\Z// if $e;
1298 $e =~ s/([\\\'])/\\$1/g if $e;
1300 $sub = "require '$e'";
1301 } elsif (defined $r) {
1303 } elsif ($sub eq '(eval)') {
1304 $sub = "eval {...}";
1306 push(@sub, {context => $context, sub => $sub, args => $args,
1307 file => $file, line => $line});
1316 while ($action =~ s/\\$//) {
1327 &readline("cont: ");
1331 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1332 # many non-Unix systems can do system() but have problems with fork().
1333 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1334 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1335 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1336 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1338 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1339 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1340 close(SAVEIN); close(SAVEOUT);
1341 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1342 ( $? & 128 ) ? " (core dumped)" : "",
1343 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1350 local @stack = @stack; # Prevent growth by failing `use'.
1351 eval { require Term::ReadLine } or die $@;
1354 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1355 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1358 my $sel = select($OUT);
1362 eval "require Term::Rendezvous;" or die $@;
1363 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1364 my $term_rv = new Term::Rendezvous $rv;
1366 $OUT = $term_rv->OUT;
1370 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1372 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1374 $rl_attribs = $term->Attribs;
1375 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1376 if defined $rl_attribs->{basic_word_break_characters}
1377 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1378 $rl_attribs->{special_prefixes} = '$@&%';
1379 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1380 $rl_attribs->{completion_function} = \&db_complete;
1382 $LINEINFO = $OUT unless defined $LINEINFO;
1383 $lineinfo = $console unless defined $lineinfo;
1385 if ($term->Features->{setHistory} and "@hist" ne "?") {
1386 $term->SetHistory(@hist);
1388 ornaments($ornaments) if defined $ornaments;
1393 my $left = @typeahead;
1394 my $got = shift @typeahead;
1395 print $OUT "auto(-$left)", shift, $got, "\n";
1396 $term->AddHistory($got)
1397 if length($got) > 1 and defined $term->Features->{addHistory};
1402 $term->readline(@_);
1406 my ($opt, $val)= @_;
1407 $val = option_val($opt,'N/A');
1408 $val =~ s/([\\\'])/\\$1/g;
1409 printf $OUT "%20s = '%s'\n", $opt, $val;
1413 my ($opt, $default)= @_;
1415 if (defined $optionVars{$opt}
1416 and defined $ {$optionVars{$opt}}) {
1417 $val = $ {$optionVars{$opt}};
1418 } elsif (defined $optionAction{$opt}
1419 and defined &{$optionAction{$opt}}) {
1420 $val = &{$optionAction{$opt}}();
1421 } elsif (defined $optionAction{$opt}
1422 and not defined $option{$opt}
1423 or defined $optionVars{$opt}
1424 and not defined $ {$optionVars{$opt}}) {
1427 $val = $option{$opt};
1435 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1436 my ($opt,$sep) = ($1,$2);
1439 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1441 #&dump_option($opt);
1442 } elsif ($sep !~ /\S/) {
1444 } elsif ($sep eq "=") {
1447 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1448 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1449 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1450 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1452 $val =~ s/\\([\\$end])/$1/g;
1456 grep( /^\Q$opt/ && ($option = $_), @options );
1457 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1459 print $OUT "Unknown option `$opt'\n" unless $matches;
1460 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1461 $option{$option} = $val if $matches == 1 and defined $val;
1462 eval "local \$frame = 0; local \$doret = -2;
1463 require '$optionRequire{$option}'"
1464 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1465 $ {$optionVars{$option}} = $val
1467 and defined $optionVars{$option} and defined $val;
1468 & {$optionAction{$option}} ($val)
1470 and defined $optionAction{$option}
1471 and defined &{$optionAction{$option}} and defined $val;
1472 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1478 my ($stem,@list) = @_;
1480 $ENV{"$ {stem}_n"} = @list;
1481 for $i (0 .. $#list) {
1483 $val =~ s/\\/\\\\/g;
1484 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1485 $ENV{"$ {stem}_$i"} = $val;
1492 my $n = delete $ENV{"$ {stem}_n"};
1494 for $i (0 .. $n - 1) {
1495 $val = delete $ENV{"$ {stem}_$i"};
1496 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1504 return; # Put nothing on the stack - malloc/free land!
1508 my($msg)= join("",@_);
1509 $msg .= ": $!\n" unless $msg =~ /\n$/;
1515 &warn("Too late to set TTY, enabled on next `R'!\n") if @_;
1523 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1525 $notty = shift if @_;
1531 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1538 if ($ {$term->Features}{tkRunning}) {
1539 return $term->tkRunning(@_);
1541 print $OUT "tkRunning not supported by current ReadLine package.\n";
1548 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1550 $runnonstop = shift if @_;
1557 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1564 $sh = quotemeta shift;
1565 $sh .= "\\b" if $sh =~ /\w$/;
1569 $psh =~ s/\\(.)/$1/g;
1575 if (defined $term) {
1576 local ($warnLevel,$dieLevel) = (0, 1);
1577 return '' unless $term->Features->{ornaments};
1578 eval { $term->ornaments(@_) } || '';
1586 $rc = quotemeta shift;
1587 $rc .= "\\b" if $rc =~ /\w$/;
1591 $prc =~ s/\\(.)/$1/g;
1597 return $lineinfo unless @_;
1599 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1600 $emacs = ($stream =~ /^\|/);
1601 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1602 $LINEINFO = \*LINEINFO;
1603 my $save = select($LINEINFO);
1617 s/^Term::ReadLine::readline$/readline/;
1618 if (defined $ { $_ . '::VERSION' }) {
1619 $version{$file} = "$ { $_ . '::VERSION' } from ";
1621 $version{$file} .= $INC{$file};
1623 do 'dumpvar.pl' unless defined &main::dumpValue;
1624 if (defined &main::dumpValue) {
1626 &main::dumpValue(\%version);
1628 print $OUT "dumpvar.pl not available.\n";
1635 s [expr] Single step [in expr].
1636 n [expr] Next, steps over subroutine calls [in expr].
1637 <CR> Repeat last n or s command.
1638 r Return from current subroutine.
1639 c [line|sub] Continue; optionally inserts a one-time-only breakpoint
1640 at the specified position.
1641 l min+incr List incr+1 lines starting at min.
1642 l min-max List lines min through max.
1643 l line List single line.
1644 l subname List first window of lines from subroutine.
1645 l List next window of lines.
1646 - List previous window of lines.
1647 w [line] List window around line.
1648 . Return to the executed line.
1649 f filename Switch to viewing filename. Must be loaded.
1650 /pattern/ Search forwards for pattern; final / is optional.
1651 ?pattern? Search backwards for pattern; final ? is optional.
1652 L List all breakpoints and actions.
1653 S [[!]pattern] List subroutine names [not] matching pattern.
1654 t Toggle trace mode.
1655 t expr Trace through execution of expr.
1656 b [line] [condition]
1657 Set breakpoint; line defaults to the current execution line;
1658 condition breaks if it evaluates to true, defaults to '1'.
1659 b subname [condition]
1660 Set breakpoint at first line of subroutine.
1661 b load filename Set breakpoint on `require'ing the given file.
1662 b postpone subname [condition]
1663 Set breakpoint at first line of subroutine after
1666 Stop after the subroutine is compiled.
1667 d [line] Delete the breakpoint for line.
1668 D Delete all breakpoints.
1670 Set an action to be done before the line is executed.
1671 Sequence is: check for breakpoint, print line if necessary,
1672 do action, prompt user if breakpoint or step, evaluate line.
1673 A Delete all actions.
1674 V [pkg [vars]] List some (default all) variables in package (default current).
1675 Use ~pattern and !pattern for positive and negative regexps.
1676 X [vars] Same as \"V currentpackage [vars]\".
1677 x expr Evals expression in array context, dumps the result.
1678 m expr Evals expression in array context, prints methods callable
1679 on the first element of the result.
1680 m class Prints methods callable via the given class.
1681 O [opt[=val]] [opt\"val\"] [opt?]...
1682 Set or query values of options. val defaults to 1. opt can
1683 be abbreviated. Several options can be listed.
1684 recallCommand, ShellBang: chars used to recall command or spawn shell;
1685 pager: program for output of \"|cmd\";
1686 tkRunning: run Tk while prompting (with ReadLine);
1687 signalLevel warnLevel dieLevel: level of verbosity;
1688 inhibit_exit Allows stepping off the end of the script.
1689 The following options affect what happens with V, X, and x commands:
1690 arrayDepth, hashDepth: print only first N elements ('' for all);
1691 compactDump, veryCompact: change style of array and hash dump;
1692 globPrint: whether to print contents of globs;
1693 DumpDBFiles: dump arrays holding debugged files;
1694 DumpPackages: dump symbol tables of packages;
1695 quote, HighBit, undefPrint: change style of string dump;
1696 Option PrintRet affects printing of return value after r command,
1697 frame affects printing messages on entry and exit from subroutines.
1698 AutoTrace affects printing messages on every possible breaking point.
1699 maxTraceLen gives maximal length of evals/args listed in stack trace.
1700 ornaments affects screen appearance of the command line.
1701 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1702 You can put additional initialization options TTY, noTTY,
1703 ReadLine, and NonStop there (or use `R' after you set them).
1704 < command Define Perl command to run before each prompt.
1705 << command Add to the list of Perl commands to run before each prompt.
1706 > command Define Perl command to run after each prompt.
1707 >> command Add to the list of Perl commands to run after each prompt.
1708 \{ commandline Define debugger command to run before each prompt.
1709 \{{ commandline Add to the list of debugger commands to run before each prompt.
1710 $prc number Redo a previous command (default previous command).
1711 $prc -number Redo number'th-to-last command.
1712 $prc pattern Redo last command that started with pattern.
1713 See 'O recallCommand' too.
1714 $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1715 . ( $rc eq $sh ? "" : "
1716 $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1717 See 'O shellBang' too.
1718 H -number Display last number commands (default all).
1719 p expr Same as \"print {DB::OUT} expr\" in current package.
1720 |dbcmd Run debugger command, piping DB::OUT to current pager.
1721 ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1722 \= [alias value] Define a command alias, or list current aliases.
1723 command Execute as a perl statement in current package.
1724 v Show versions of loaded modules.
1725 R Pure-man-restart of debugger, some of debugger state
1726 and command-line options may be lost.
1727 Currently the following setting are preserved:
1728 history, breakpoints and actions, debugger Options
1729 and the following command-line options: -w, -I, -e.
1730 h [db_command] Get help [on a specific debugger command], enter |h to page.
1731 h h Summary of debugger commands.
1732 q or ^D Quit. Set \$DB::finished to 0 to debug global destruction.
1735 $summary = <<"END_SUM";
1736 List/search source lines: Control script execution:
1737 l [ln|sub] List source code T Stack trace
1738 - or . List previous/current line s [expr] Single step [in expr]
1739 w [line] List around line n [expr] Next, steps over subs
1740 f filename View source in file <CR> Repeat last n or s
1741 /pattern/ ?patt? Search forw/backw r Return from subroutine
1742 v Show versions of modules c [ln|sub] Continue until position
1743 Debugger controls: L List break pts & actions
1744 O [...] Set debugger options t [expr] Toggle trace [trace expr]
1745 <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
1746 >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
1747 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1748 H [-num] Display last num commands D Delete all breakpoints
1749 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1750 h [db_cmd] Get help on command A Delete all actions
1751 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
1752 q or ^D Quit R Attempt a restart
1753 Data Examination: expr Execute perl code, also see: s,n,t expr
1754 x|m expr Evals expr in array context, dumps the result or lists methods.
1755 p expr Print expression (uses script's current package).
1756 S [[!]pat] List subroutine names [not] matching pattern
1757 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1758 X [Vars] Same as \"V current_package [Vars]\".
1760 # ')}}; # Fix balance of Emacs parsing
1766 $SIG{'ABRT'} = 'DEFAULT';
1767 kill 'ABRT', $$ if $panic++;
1768 if (defined &Carp::longmess) {
1769 local $SIG{__WARN__} = '';
1770 local $Carp::CarpLevel = 2; # mydie + confess
1771 &warn(Carp::longmess("Signal @_"));
1774 print $DB::OUT "Got signal @_\n";
1782 local $SIG{__WARN__} = '';
1783 local $SIG{__DIE__} = '';
1784 eval { require Carp }; # If error/warning during compilation,
1785 # require may be broken.
1786 warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1787 unless defined &Carp::longmess;
1788 #&warn("Entering dbwarn\n");
1789 my ($mysingle,$mytrace) = ($single,$trace);
1790 $single = 0; $trace = 0;
1791 my $mess = Carp::longmess(@_);
1792 ($single,$trace) = ($mysingle,$mytrace);
1793 #&warn("Warning in dbwarn\n");
1795 #&warn("Exiting dbwarn\n");
1801 local $SIG{__DIE__} = '';
1802 local $SIG{__WARN__} = '';
1803 my $i = 0; my $ineval = 0; my $sub;
1804 #&warn("Entering dbdie\n");
1805 if ($dieLevel != 2) {
1806 while ((undef,undef,undef,$sub) = caller(++$i)) {
1807 $ineval = 1, last if $sub eq '(eval)';
1810 local $SIG{__WARN__} = \&dbwarn;
1811 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1813 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1814 die @_ if $ineval and $dieLevel < 2;
1816 eval { require Carp }; # If error/warning during compilation,
1817 # require may be broken.
1818 die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1819 # We do not want to debug this chunk (automatic disabling works
1820 # inside DB::DB, but not in Carp).
1821 my ($mysingle,$mytrace) = ($single,$trace);
1822 $single = 0; $trace = 0;
1823 my $mess = Carp::longmess(@_);
1824 ($single,$trace) = ($mysingle,$mytrace);
1825 #&warn("dieing loudly in dbdie\n");
1831 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1834 $SIG{__WARN__} = \&DB::dbwarn;
1836 $SIG{__WARN__} = $prevwarn;
1844 $prevdie = $SIG{__DIE__} unless $dieLevel;
1847 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1848 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1849 print $OUT "Stack dump during die enabled",
1850 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1852 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1854 $SIG{__DIE__} = $prevdie;
1855 print $OUT "Default die handler restored.\n";
1863 $prevsegv = $SIG{SEGV} unless $signalLevel;
1864 $prevbus = $SIG{BUS} unless $signalLevel;
1865 $signalLevel = shift;
1867 $SIG{SEGV} = \&DB::diesignal;
1868 $SIG{BUS} = \&DB::diesignal;
1870 $SIG{SEGV} = $prevsegv;
1871 $SIG{BUS} = $prevbus;
1879 return unless defined &$subr;
1881 $subr = \&$subr; # Hard reference
1884 $s = $_, last if $subr eq \&$_;
1892 $class = ref $class if ref $class;
1895 methods_via($class, '', 1);
1896 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
1901 return if $packs{$class}++;
1903 my $prepend = $prefix ? "via $prefix: " : '';
1905 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
1906 sort keys %{"$ {class}::"}) {
1907 next if $seen{ $name }++;
1908 print $DB::OUT "$prepend$name\n";
1910 return unless shift; # Recurse?
1911 for $name (@{"$ {class}::ISA"}) {
1912 $prepend = $prefix ? $prefix . " -> $name" : $name;
1913 methods_via($name, $prepend, 1);
1917 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1919 BEGIN { # This does not compile, alas.
1920 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1921 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1925 $deep = 100; # warning if stack gets this deep
1929 $SIG{INT} = \&DB::catch;
1930 # This may be enabled to debug debugger:
1931 #$warnLevel = 1 unless defined $warnLevel;
1932 #$dieLevel = 1 unless defined $dieLevel;
1933 #$signalLevel = 1 unless defined $signalLevel;
1935 $db_stop = 0; # Compiler warning
1937 $level = 0; # Level of recursive debugging
1938 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1939 # Triggers bug (?) in perl is we postpone this until runtime:
1940 @postponed = @stack = (0);
1945 BEGIN {$^W = $ini_warn;} # Switch warnings back
1947 #use Carp; # This did break, left for debuggin
1950 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
1951 my($text, $line, $start) = @_;
1952 my ($itext, $search, $prefix, $pack) =
1953 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
1955 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
1956 (map { /$search/ ? ($1) : () } keys %sub)
1957 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
1958 return sort grep /^\Q$text/, values %INC # files
1959 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
1960 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1961 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
1962 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
1963 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1965 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
1967 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
1968 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
1969 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
1970 # We may want to complete to (eval 9), so $text may be wrong
1971 $prefix = length($1) - length($text);
1974 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
1976 if ((substr $text, 0, 1) eq '&') { # subroutines
1977 $text = substr $text, 1;
1979 return sort map "$prefix$_",
1982 (map { /$search/ ? ($1) : () }
1985 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
1986 $pack = ($1 eq 'main' ? '' : $1) . '::';
1987 $prefix = (substr $text, 0, 1) . $1 . '::';
1990 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
1991 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1992 return db_complete($out[0], $line, $start);
1996 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
1997 $pack = ($package eq 'main' ? '' : $package) . '::';
1998 $prefix = substr $text, 0, 1;
1999 $text = substr $text, 1;
2000 my @out = map "$prefix$_", grep /^\Q$text/,
2001 (grep /^_?[a-zA-Z]/, keys %$pack),
2002 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2003 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2004 return db_complete($out[0], $line, $start);
2008 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2009 my @out = grep /^\Q$text/, @options;
2010 my $val = option_val($out[0], undef);
2012 if (not defined $val or $val =~ /[\n\r]/) {
2013 # Can do nothing better
2014 } elsif ($val =~ /\s/) {
2016 foreach $l (split //, qq/\"\'\#\|/) {
2017 $out = "$l$val$l ", last if (index $val, $l) == -1;
2022 # Default to value if one completion, to question if many
2023 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2026 return $term->filename_list($text); # filenames
2030 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2034 $finished = $inhibit_exit; # So that some keys may be disabled.
2035 # Do not stop in at_exit() and destructors on exit:
2036 $DB::single = !$exiting && !$runnonstop;
2037 DB::fake::at_exit() unless $exiting or $runnonstop;
2043 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2046 package DB; # Do not trace this 1; below!