3 # Debugger for Perl 5.00x; perl5db.pl patch level:
6 $header = "perl5db.pl patch level $VERSION";
8 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
9 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
11 # modified Perl debugger, to be run from Emacs in perldb-mode
12 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
13 # Johan Vromans -- upgrade to 4.0 pl 10
14 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
17 # This file is automatically included if you do perl -d.
18 # It's probably not useful to include this yourself.
20 # Perl supplies the values for %sub. It effectively inserts
21 # a &DB'DB(); in front of every place that can have a
22 # breakpoint. Instead of a subroutine call it calls &DB::sub with
23 # $DB::sub being the called subroutine. It also inserts a BEGIN
24 # {require 'perl5db.pl'} before the first line.
26 # After each `require'd file is compiled, but before it is executed, a
27 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
28 # $filename is the expanded name of the `require'd file (as found as
31 # Additional services from Perl interpreter:
33 # if caller() is called from the package DB, it provides some
36 # The array @{$main::{'_<'.$filename} is the line-by-line contents of
39 # The hash %{'_<'.$filename} contains breakpoints and action (it is
40 # keyed by line number), and individual entries are settable (as
41 # opposed to the whole hash). Only true/false is important to the
42 # interpreter, though the values used by perl5db.pl have the form
43 # "$break_condition\0$action". Values are magical in numeric context.
45 # The scalar ${'_<'.$filename} contains "_<$filename".
47 # Note that no subroutine call is possible until &DB::sub is defined
48 # (for subroutines defined outside of the package DB). In fact the same is
49 # true if $deep is not defined.
54 # At start reads $rcfile that may set important options. This file
55 # may define a subroutine &afterinit that will be executed after the
56 # debugger is initialized.
58 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
59 # it as a rest of `O ...' line in debugger prompt.
61 # The options that can be specified only at startup:
62 # [To set in $rcfile, call &parse_options("optionName=new_value").]
64 # TTY - the TTY to use for debugging i/o.
66 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
67 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
68 # Term::Rendezvous. Current variant is to have the name of TTY in this
71 # ReadLine - If false, dummy ReadLine is used, so you can debug
72 # ReadLine applications.
74 # NonStop - if true, no i/o is performed until interrupt.
76 # LineInfo - file or pipe to print line number info to. If it is a
77 # pipe, a short "emacs like" message is used.
79 # Example $rcfile: (delete leading hashes!)
81 # &parse_options("NonStop=1 LineInfo=db.out");
82 # sub afterinit { $trace = 1; }
84 # The script will run without human intervention, putting trace
85 # information into db.out. (If you interrupt it, you would better
86 # reset LineInfo to something "interactive"!)
88 ##################################################################
91 # A lot of things changed after 0.94. First of all, core now informs
92 # debugger about entry into XSUBs, overloaded operators, tied operations,
93 # BEGIN and END. Handy with `O f=2'.
95 # This can make debugger a little bit too verbose, please be patient
96 # and report your problems promptly.
98 # Now the option frame has 3 values: 0,1,2.
100 # Note that if DESTROY returns a reference to the object (or object),
101 # the deletion of data may be postponed until the next function call,
102 # due to the need to examine the return value.
104 # Changes: 0.95: `v' command shows versions.
105 # Changes: 0.96: `v' command shows version of readline.
106 # primitive completion works (dynamic variables, subs for `b' and `l',
107 # options). Can `p %var'
108 # Better help (`h <' now works). New commands <<, >>, {, {{.
109 # {dump|print}_trace() coded (to be able to do it from <<cmd).
110 # `c sub' documented.
111 # At last enough magic combined to stop after the end of debuggee.
112 # !! should work now (thanks to Emacs bracket matching an extra
113 # `]' in a regexp is caught).
114 # `L', `D' and `A' span files now (as documented).
115 # Breakpoints in `require'd code are possible (used in `R').
116 # Some additional words on internal work of debugger.
117 # `b load filename' implemented.
118 # `b postpone subr' implemented.
119 # now only `q' exits debugger (overwriteable on $inhibit_exit).
120 # When restarting debugger breakpoints/actions persist.
121 # Buglet: When restarting debugger only one breakpoint/action per
122 # autoloaded function persists.
123 # Changes: 0.97: NonStop will not stop in at_exit().
124 # Option AutoTrace implemented.
125 # Trace printed differently if frames are printed too.
126 # new `inhibitExit' option.
127 # printing of a very long statement interruptible.
128 # Changes: 0.98: New command `m' for printing possible methods
129 # 'l -' is a synonim for `-'.
130 # Cosmetic bugs in printing stack trace.
131 # `frame' & 8 to print "expanded args" in stack trace.
132 # Can list/break in imported subs.
133 # new `maxTraceLen' option.
134 # frame & 4 and frame & 8 granted.
136 # nonstoppable lines do not have `:' near the line number.
137 # `b compile subname' implemented.
138 # Will not use $` any more.
139 # `-' behaves sane now.
140 # Changes: 0.99: Completion for `f', `m'.
141 # `m' will remove duplicate names instead of duplicate functions.
142 # `b load' strips trailing whitespace.
143 # completion ignores leading `|'; takes into account current package
144 # when completing a subroutine name (same for `l').
146 ####################################################################
148 # Needed for the statement after exec():
150 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
151 local($^W) = 0; # Switch run-time warnings off during init.
154 $dumpvar::arrayDepth,
155 $dumpvar::dumpDBFiles,
156 $dumpvar::dumpPackages,
157 $dumpvar::quoteHighBit,
158 $dumpvar::printUndef,
167 # Command-line + PERLLIB:
170 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
172 $trace = $signal = $single = 0; # Uninitialized warning suppression
173 # (local $^W cannot help - other packages!).
174 $inhibit_exit = $option{PrintRet} = 1;
176 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
177 compactDump veryCompact quote HighBit undefPrint
178 globPrint PrintRet UsageOnly frame AutoTrace
179 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
180 recallCommand ShellBang pager tkRunning 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");
281 # Is Perl being run from Emacs?
282 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
283 $rl = 0, shift(@main::ARGV) if $emacs;
285 #require Term::ReadLine;
288 $console = "/dev/tty";
289 } elsif (-e "con" or $^O eq 'MSWin32') {
292 $console = "sys\$command";
296 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
300 $console = $tty if defined $tty;
302 if (defined $console) {
303 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
304 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
305 || open(OUT,">&STDOUT"); # so we don't dongle stdout
308 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
309 $console = 'STDIN/OUT';
311 # so open("|more") can read from STDOUT and so we don't dingle stdin
316 $| = 1; # for DB::OUT
319 $LINEINFO = $OUT unless defined $LINEINFO;
320 $lineinfo = $console unless defined $lineinfo;
322 $| = 1; # for real STDOUT
324 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
325 unless ($runnonstop) {
326 print $OUT "\nLoading DB routines from $header\n";
327 print $OUT ("Emacs support ",
328 $emacs ? "enabled" : "available",
330 print $OUT "\nEnter h or `h h' for help.\n\n";
337 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
340 if (defined &afterinit) { # May be defined in $rcfile
344 ############################################################ Subroutines
347 # _After_ the perl program is compiled, $single is set to 1:
348 if ($single and not $second_time++) {
349 if ($runnonstop) { # Disable until signal
350 for ($i=0; $i <= $#stack; ) {
354 # return; # Would not print trace!
357 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
359 ($package, $filename, $line) = caller;
360 $filename_ini = $filename;
361 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
362 "package $package;"; # this won't let them modify, alas
363 local(*dbline) = $main::{'_<' . $filename};
365 if (($stop,$action) = split(/\0/,$dbline{$line})) {
369 $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
370 $dbline{$line} =~ s/;9($|\0)/$1/;
373 my $was_signal = $signal;
375 if ($single || $trace || $was_signal) {
378 $position = "\032\032$filename:$line:0\n";
379 print $LINEINFO $position;
382 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
383 $prefix .= "$sub($filename:";
384 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
385 if (length($prefix) > 30) {
386 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
391 $position = "$prefix$line$infix$dbline[$line]$after";
394 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
396 print $LINEINFO $position;
398 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
399 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
401 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
402 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
403 $position .= $incr_pos;
405 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
407 print $LINEINFO $incr_pos;
412 $evalarg = $action, &eval if $action;
413 if ($single || $was_signal) {
414 local $level = $level + 1;
415 foreach $evalarg (@$pre) {
418 print $OUT $#stack . " levels deep in subroutine calls!\n"
421 $incr = -1; # for backward motion.
422 @typeahead = @$pretype, @typeahead;
424 while (($term || &setterm),
425 defined ($cmd=&readline(" DB" . ('<' x $level) .
426 ($#hist+1) . ('>' x $level) .
430 $cmd =~ s/\\$/\n/ && do {
431 $cmd .= &readline(" cont: ");
434 $cmd =~ /^$/ && ($cmd = $laststep);
435 push(@hist,$cmd) if length($cmd) > 1;
437 ($i) = split(/\s+/,$cmd);
438 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
439 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
440 $cmd =~ /^h$/ && do {
443 $cmd =~ /^h\s+h$/ && do {
446 $cmd =~ /^h\s+(\S)$/ && do {
448 if ($help =~ /^$asked/m) {
449 while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
453 print $OUT "`$asked' is not a debugger command.\n";
456 $cmd =~ /^t$/ && do {
458 print $OUT "Trace = ".($trace?"on":"off")."\n";
460 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
461 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
462 foreach $subname (sort(keys %sub)) {
463 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
464 print $OUT $subname,"\n";
468 $cmd =~ /^v$/ && do {
469 list_versions(); next CMD};
470 $cmd =~ s/^X\b/V $package/;
471 $cmd =~ /^V$/ && do {
472 $cmd = "V $package"; };
473 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
474 local ($savout) = select($OUT);
476 @vars = split(' ',$2);
477 do 'dumpvar.pl' unless defined &main::dumpvar;
478 if (defined &main::dumpvar) {
481 &main::dumpvar($packname,@vars);
483 print $OUT "dumpvar.pl not available.\n";
487 $cmd =~ s/^x\b/ / && do { # So that will be evaled
488 $onetimeDump = 'dump'; };
489 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
490 methods($1); next CMD};
491 $cmd =~ s/^m\b/ / && do { # So this will be evaled
492 $onetimeDump = 'methods'; };
493 $cmd =~ /^f\b\s*(.*)/ && do {
497 print $OUT "The old f command is now the r command.\n";
498 print $OUT "The new f command switches filenames.\n";
501 if (!defined $main::{'_<' . $file}) {
502 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
503 $try = substr($try,2);
504 print $OUT "Choosing $try matching `$file':\n";
508 if (!defined $main::{'_<' . $file}) {
509 print $OUT "No file matching `$file' is loaded.\n";
511 } elsif ($file ne $filename) {
512 *dbline = $main::{'_<' . $file};
518 print $OUT "Already in $file.\n";
522 $cmd =~ s/^l\s+-\s*$/-/;
523 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
525 $subname =~ s/\'/::/;
526 $subname = $package."::".$subname
527 unless $subname =~ /::/;
528 $subname = "main".$subname if substr($subname,0,2) eq "::";
529 @pieces = split(/:/,find_sub($subname));
530 $subrange = pop @pieces;
531 $file = join(':', @pieces);
532 if ($file ne $filename) {
533 *dbline = $main::{'_<' . $file};
538 if (eval($subrange) < -$window) {
539 $subrange =~ s/-.*/+/;
541 $cmd = "l $subrange";
543 print $OUT "Subroutine $subname not found.\n";
546 $cmd =~ /^\.$/ && do {
547 $incr = -1; # for backward motion.
549 $filename = $filename_ini;
550 *dbline = $main::{'_<' . $filename};
552 print $LINEINFO $position;
554 $cmd =~ /^w\b\s*(\d*)$/ && do {
558 #print $OUT 'l ' . $start . '-' . ($start + $incr);
559 $cmd = 'l ' . $start . '-' . ($start + $incr); };
560 $cmd =~ /^-$/ && do {
561 $start -= $incr + $window + 1;
562 $start = 1 if $start <= 0;
564 $cmd = 'l ' . ($start) . '+'; };
565 $cmd =~ /^l$/ && do {
567 $cmd = 'l ' . $start . '-' . ($start + $incr); };
568 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
571 $incr = $window - 1 unless $incr;
572 $cmd = 'l ' . $start . '-' . ($start + $incr); };
573 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
574 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
575 $end = $max if $end > $max;
577 $i = $line if $i eq '.';
581 print $OUT "\032\032$filename:$i:0\n";
584 for (; $i <= $end; $i++) {
585 ($stop,$action) = split(/\0/, $dbline{$i});
587 and $filename eq $filename_ini)
589 : ($dbline[$i]+0 ? ':' : ' ') ;
590 $arrow .= 'b' if $stop;
591 $arrow .= 'a' if $action;
592 print $OUT "$i$arrow\t", $dbline[$i];
596 $start = $i; # remember in case they want more
597 $start = $max if $start > $max;
599 $cmd =~ /^D$/ && do {
600 print $OUT "Deleting all breakpoints...\n";
602 for $file (keys %had_breakpoints) {
603 local *dbline = $main::{'_<' . $file};
607 for ($i = 1; $i <= $max ; $i++) {
608 if (defined $dbline{$i}) {
609 $dbline{$i} =~ s/^[^\0]+//;
610 if ($dbline{$i} =~ s/^\0?$//) {
617 undef %postponed_file;
618 undef %break_on_load;
619 undef %had_breakpoints;
621 $cmd =~ /^L$/ && do {
623 for $file (keys %had_breakpoints) {
624 local *dbline = $main::{'_<' . $file};
628 for ($i = 1; $i <= $max; $i++) {
629 if (defined $dbline{$i}) {
630 print "$file:\n" unless $was++;
631 print $OUT " $i:\t", $dbline[$i];
632 ($stop,$action) = split(/\0/, $dbline{$i});
633 print $OUT " break if (", $stop, ")\n"
635 print $OUT " action: ", $action, "\n"
642 print $OUT "Postponed breakpoints in subroutines:\n";
644 for $subname (keys %postponed) {
645 print $OUT " $subname\t$postponed{$subname}\n";
649 my @have = map { # Combined keys
650 keys %{$postponed_file{$_}}
651 } keys %postponed_file;
653 print $OUT "Postponed breakpoints in files:\n";
655 for $file (keys %postponed_file) {
656 my $db = $postponed_file{$file};
657 print $OUT " $file:\n";
658 for $line (sort {$a <=> $b} keys %$db) {
659 print $OUT " $line:\n";
660 my ($stop,$action) = split(/\0/, $$db{$line});
661 print $OUT " break if (", $stop, ")\n"
663 print $OUT " action: ", $action, "\n"
670 if (%break_on_load) {
671 print $OUT "Breakpoints on load:\n";
673 for $file (keys %break_on_load) {
674 print $OUT " $file\n";
679 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
680 my $file = $1; $file =~ s/\s+$//;
682 $break_on_load{$file} = 1;
683 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
684 $file .= '.pm', redo unless $file =~ /\./;
686 $had_breakpoints{$file} = 1;
687 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
689 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
690 my $cond = $3 || '1';
691 my ($subname, $break) = ($2, $1 eq 'postpone');
692 $subname =~ s/\'/::/;
693 $subname = "${'package'}::" . $subname
694 unless $subname =~ /::/;
695 $subname = "main".$subname if substr($subname,0,2) eq "::";
696 $postponed{$subname} = $break
697 ? "break +0 if $cond" : "compile";
699 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
702 $subname =~ s/\'/::/;
703 $subname = "${'package'}::" . $subname
704 unless $subname =~ /::/;
705 $subname = "main".$subname if substr($subname,0,2) eq "::";
706 # Filename below can contain ':'
707 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
711 *dbline = $main::{'_<' . $filename};
712 $had_breakpoints{$filename} = 1;
714 ++$i while $dbline[$i] == 0 && $i < $max;
715 $dbline{$i} =~ s/^[^\0]*/$cond/;
717 print $OUT "Subroutine $subname not found.\n";
720 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
723 if ($dbline[$i] == 0) {
724 print $OUT "Line $i not breakable.\n";
726 $had_breakpoints{$filename} = 1;
727 $dbline{$i} =~ s/^[^\0]*/$cond/;
730 $cmd =~ /^d\b\s*(\d+)?/ && do {
732 $dbline{$i} =~ s/^[^\0]*//;
733 delete $dbline{$i} if $dbline{$i} eq '';
735 $cmd =~ /^A$/ && do {
737 for $file (keys %had_breakpoints) {
738 local *dbline = $main::{'_<' . $file};
742 for ($i = 1; $i <= $max ; $i++) {
743 if (defined $dbline{$i}) {
744 $dbline{$i} =~ s/\0[^\0]*//;
745 delete $dbline{$i} if $dbline{$i} eq '';
750 $cmd =~ /^O\s*$/ && do {
755 $cmd =~ /^O\s*(\S.*)/ && do {
758 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
759 push @$pre, action($1);
761 $cmd =~ /^>>\s*(.*)/ && do {
762 push @$post, action($1);
764 $cmd =~ /^<\s*(.*)/ && do {
765 $pre = [], next CMD unless $1;
768 $cmd =~ /^>\s*(.*)/ && do {
769 $post = [], next CMD unless $1;
770 $post = [action($1)];
772 $cmd =~ /^\{\{\s*(.*)/ && do {
775 $cmd =~ /^\{\s*(.*)/ && do {
776 $pretype = [], next CMD unless $1;
779 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
781 if ($dbline[$i] == 0) {
782 print $OUT "Line $i may not have an action.\n";
784 $dbline{$i} =~ s/\0[^\0]*//;
785 $dbline{$i} .= "\0" . action($j);
788 $cmd =~ /^n$/ && do {
789 end_report(), next CMD if $finished and $level <= 1;
793 $cmd =~ /^s$/ && do {
794 end_report(), next CMD if $finished and $level <= 1;
798 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
799 end_report(), next CMD if $finished and $level <= 1;
801 if ($i =~ /\D/) { # subroutine name
802 ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/);
806 *dbline = $main::{'_<' . $filename};
807 $had_breakpoints{$filename}++;
809 ++$i while $dbline[$i] == 0 && $i < $max;
811 print $OUT "Subroutine $subname not found.\n";
816 if ($dbline[$i] == 0) {
817 print $OUT "Line $i not breakable.\n";
820 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
822 for ($i=0; $i <= $#stack; ) {
826 $cmd =~ /^r$/ && do {
827 end_report(), next CMD if $finished and $level <= 1;
828 $stack[$#stack] |= 1;
829 $doret = $option{PrintRet} ? $#stack - 1 : -2;
831 $cmd =~ /^R$/ && do {
832 print $OUT "Warning: some settings and command-line options may be lost!\n";
833 my (@script, @flags, $cl);
834 push @flags, '-w' if $ini_warn;
835 # Put all the old includes at the start to get
838 push @flags, '-I', $_;
840 # Arrange for setting the old INC:
841 set_list("PERLDB_INC", @ini_INC);
843 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
844 chomp ($cl = $ {'::_<-e'}[$_]);
845 push @script, '-e', $cl;
850 set_list("PERLDB_HIST",
851 $term->Features->{getHistory}
852 ? $term->GetHistory : @hist);
853 my @had_breakpoints = keys %had_breakpoints;
854 set_list("PERLDB_VISITED", @had_breakpoints);
855 set_list("PERLDB_OPT", %option);
856 set_list("PERLDB_ON_LOAD", %break_on_load);
858 for (0 .. $#had_breakpoints) {
859 my $file = $had_breakpoints[$_];
860 *dbline = $main::{'_<' . $file};
861 next unless %dbline or $postponed_file{$file};
862 (push @hard, $file), next
863 if $file =~ /^\(eval \d+\)$/;
865 @add = %{$postponed_file{$file}}
866 if $postponed_file{$file};
867 set_list("PERLDB_FILE_$_", %dbline, @add);
869 for (@hard) { # Yes, really-really...
870 # Find the subroutines in this eval
871 *dbline = $main::{'_<' . $_};
872 my ($quoted, $sub, %subs, $line) = quotemeta $_;
873 for $sub (keys %sub) {
874 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
875 $subs{$sub} = [$1, $2];
879 "No subroutines in $_, ignoring breakpoints.\n";
882 LINES: for $line (keys %dbline) {
883 # One breakpoint per sub only:
884 my ($offset, $sub, $found);
885 SUBS: for $sub (keys %subs) {
886 if ($subs{$sub}->[1] >= $line # Not after the subroutine
887 and (not defined $offset # Not caught
888 or $offset < 0 )) { # or badly caught
890 $offset = $line - $subs{$sub}->[0];
891 $offset = "+$offset", last SUBS if $offset >= 0;
894 if (defined $offset) {
896 "break $offset if $dbline{$line}";
898 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
902 set_list("PERLDB_POSTPONE", %postponed);
903 $ENV{PERLDB_RESTART} = 1;
904 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
905 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
906 print $OUT "exec failed: $!\n";
908 $cmd =~ /^T$/ && do {
909 print_trace($OUT, 1); # skip DB
911 $cmd =~ /^\/(.*)$/ && do {
913 $inpat =~ s:([^\\])/$:$1:;
915 eval '$inpat =~ m'."\a$inpat\a";
927 $start = 1 if ($start > $max);
928 last if ($start == $end);
929 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
931 print $OUT "\032\032$filename:$start:0\n";
933 print $OUT "$start:\t", $dbline[$start], "\n";
938 print $OUT "/$pat/: not found\n" if ($start == $end);
940 $cmd =~ /^\?(.*)$/ && do {
942 $inpat =~ s:([^\\])\?$:$1:;
944 eval '$inpat =~ m'."\a$inpat\a";
956 $start = $max if ($start <= 0);
957 last if ($start == $end);
958 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
960 print $OUT "\032\032$filename:$start:0\n";
962 print $OUT "$start:\t", $dbline[$start], "\n";
967 print $OUT "?$pat?: not found\n" if ($start == $end);
969 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
970 pop(@hist) if length($cmd) > 1;
971 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
972 $cmd = $hist[$i] . "\n";
975 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
978 $cmd =~ /^$rc([^$rc].*)$/ && do {
980 pop(@hist) if length($cmd) > 1;
981 for ($i = $#hist; $i; --$i) {
982 last if $hist[$i] =~ /$pat/;
985 print $OUT "No such command!\n\n";
988 $cmd = $hist[$i] . "\n";
991 $cmd =~ /^$sh$/ && do {
992 &system($ENV{SHELL}||"/bin/sh");
994 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
995 &system($ENV{SHELL}||"/bin/sh","-c",$1);
997 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
998 $end = $2?($#hist-$2):0;
999 $hist = 0 if $hist < 0;
1000 for ($i=$#hist; $i>$end; $i--) {
1001 print $OUT "$i: ",$hist[$i],"\n"
1002 unless $hist[$i] =~ /^.?$/;
1005 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1006 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1007 $cmd =~ /^=/ && do {
1008 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1009 $alias{$k}="s~$k~$v~";
1010 print $OUT "$k = $v\n";
1011 } elsif ($cmd =~ /^=\s*$/) {
1012 foreach $k (sort keys(%alias)) {
1013 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1014 print $OUT "$k = $v\n";
1016 print $OUT "$k\t$alias{$k}\n";
1021 $cmd =~ /^\|\|?\s*[^|]/ && do {
1022 if ($pager =~ /^\|/) {
1023 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1024 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1026 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1028 unless ($piped=open(OUT,$pager)) {
1029 &warn("Can't pipe output to `$pager'");
1030 if ($pager =~ /^\|/) {
1031 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1032 open(STDOUT,">&SAVEOUT")
1033 || &warn("Can't restore STDOUT");
1036 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1040 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1041 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1042 $selected= select(OUT);
1044 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1045 $cmd =~ s/^\|+\s*//;
1047 # XXX Local variants do not work!
1048 $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
1049 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1050 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1052 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1054 $onetimeDump = undef;
1060 if ($pager =~ /^\|/) {
1061 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1062 &warn( "Pager `$pager' failed: ",
1063 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1064 ( $? & 128 ) ? " (core dumped)" : "",
1065 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1066 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1067 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1068 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1069 # Will stop ignoring SIGPIPE if done like nohup(1)
1070 # does SIGINT but Perl doesn't give us a choice.
1072 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1075 select($selected), $selected= "" unless $selected eq "";
1079 $exiting = 1 unless defined $cmd;
1080 foreach $evalarg (@$post) {
1083 } # if ($single || $signal)
1084 ($@, $!, $,, $/, $\, $^W) = @saved;
1088 # The following code may be executed now:
1092 my ($al, $ret, @ret) = "";
1093 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1096 push(@stack, $single);
1098 $single |= 4 if $#stack == $deep;
1100 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1101 # Why -1? But it works! :-(
1102 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1103 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1106 $single |= pop(@stack);
1108 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1109 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1110 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1111 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1112 "list context return from $sub:\n"), dumpit( \@ret ),
1113 $doret = -2 if $doret eq $#stack or $frame & 16;
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 "scalar context return from $sub: "), dumpit( $ret ),
1124 $doret = -2 if $doret eq $#stack or $frame & 16;
1130 @saved = ($@, $!, $,, $/, $\, $^W);
1131 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1134 # The following takes its argument via $evalarg to preserve current @_
1139 local (@stack) = @stack; # guard against recursive debugging
1140 my $otrace = $trace;
1141 my $osingle = $single;
1143 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1149 local $saved[0]; # Preserve the old value of $@
1153 } elsif ($onetimeDump eq 'dump') {
1155 } elsif ($onetimeDump eq 'methods') {
1161 my $subname = shift;
1162 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1163 my $offset = $1 || 0;
1164 # Filename below can contain ':'
1165 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1168 local *dbline = $main::{'_<' . $file};
1169 local $^W = 0; # != 0 is magical below
1170 $had_breakpoints{$file}++;
1172 ++$i until $dbline[$i] != 0 or $i >= $max;
1173 $dbline{$i} = delete $postponed{$subname};
1175 print $OUT "Subroutine $subname not found.\n";
1179 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1180 #print $OUT "In postponed_sub for `$subname'.\n";
1184 return &postponed_sub
1185 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1186 # Cannot be done before the file is compiled
1187 local *dbline = shift;
1188 my $filename = $dbline;
1189 $filename =~ s/^_<//;
1190 $signal = 1, print $OUT "'$filename' loaded...\n"
1191 if $break_on_load{$filename};
1192 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1193 return unless $postponed_file{$filename};
1194 $had_breakpoints{$filename}++;
1195 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1197 for $key (keys %{$postponed_file{$filename}}) {
1198 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1200 delete $postponed_file{$filename};
1204 local ($savout) = select($OUT);
1205 my $osingle = $single;
1206 my $otrace = $trace;
1207 $single = $trace = 0;
1210 unless (defined &main::dumpValue) {
1213 if (defined &main::dumpValue) {
1214 &main::dumpValue(shift);
1216 print $OUT "dumpvar.pl not available.\n";
1223 # Tied method do not create a context, so may get wrong message:
1227 my @sub = dump_trace($_[0] + 1, $_[1]);
1228 my $short = $_[2]; # Print short report, next one for sub name
1230 for ($i=0; $i <= $#sub; $i++) {
1233 my $args = defined $sub[$i]{args}
1234 ? "(@{ $sub[$i]{args} })"
1236 $args = (substr $args, 0, $maxtrace - 3) . '...'
1237 if length $args > $maxtrace;
1238 my $file = $sub[$i]{file};
1239 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1241 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1243 my $sub = @_ >= 4 ? $_[3] : $s;
1244 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1246 print $fh "$sub[$i]{context} = $s$args" .
1247 " called from $file" .
1248 " line $sub[$i]{line}\n";
1255 my $count = shift || 1e9;
1258 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1259 my $nothard = not $frame & 8;
1260 local $frame = 0; # Do not want to trace this.
1261 my $otrace = $trace;
1264 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1269 if (not defined $arg) {
1271 } elsif ($nothard and tied $arg) {
1273 } elsif ($nothard and $type = ref $arg) {
1274 push @a, "ref($type)";
1276 local $_ = "$arg"; # Safe to stringify now - should not call f().
1279 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1280 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1281 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1285 $context = $context ? '@' : "\$";
1286 $args = $h ? [@a] : undef;
1287 $e =~ s/\n\s*\;\s*\Z// if $e;
1288 $e =~ s/([\\\'])/\\$1/g if $e;
1290 $sub = "require '$e'";
1291 } elsif (defined $r) {
1293 } elsif ($sub eq '(eval)') {
1294 $sub = "eval {...}";
1296 push(@sub, {context => $context, sub => $sub, args => $args,
1297 file => $file, line => $line});
1306 while ($action =~ s/\\$//) {
1317 &readline("cont: ");
1321 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1322 # many non-Unix systems can do system() but have problems with fork().
1323 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1324 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1325 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1326 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1328 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1329 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1330 close(SAVEIN); close(SAVEOUT);
1331 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1332 ( $? & 128 ) ? " (core dumped)" : "",
1333 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1340 local @stack = @stack; # Prevent growth by failing `use'.
1341 eval { require Term::ReadLine } or die $@;
1344 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1345 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1348 my $sel = select($OUT);
1352 eval "require Term::Rendezvous;" or die $@;
1353 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1354 my $term_rv = new Term::Rendezvous $rv;
1356 $OUT = $term_rv->OUT;
1360 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1362 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1364 $rl_attribs = $term->Attribs;
1365 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1366 if defined $rl_attribs->{basic_word_break_characters}
1367 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1368 $rl_attribs->{special_prefixes} = '$@&%';
1369 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1370 $rl_attribs->{completion_function} = \&db_complete;
1372 $LINEINFO = $OUT unless defined $LINEINFO;
1373 $lineinfo = $console unless defined $lineinfo;
1375 if ($term->Features->{setHistory} and "@hist" ne "?") {
1376 $term->SetHistory(@hist);
1378 ornaments($ornaments) if defined $ornaments;
1383 my $left = @typeahead;
1384 my $got = shift @typeahead;
1385 print $OUT "auto(-$left)", shift, $got, "\n";
1386 $term->AddHistory($got)
1387 if length($got) > 1 and defined $term->Features->{addHistory};
1392 $term->readline(@_);
1396 my ($opt, $val)= @_;
1397 $val = option_val($opt,'N/A');
1398 $val =~ s/([\\\'])/\\$1/g;
1399 printf $OUT "%20s = '%s'\n", $opt, $val;
1403 my ($opt, $default)= @_;
1405 if (defined $optionVars{$opt}
1406 and defined $ {$optionVars{$opt}}) {
1407 $val = $ {$optionVars{$opt}};
1408 } elsif (defined $optionAction{$opt}
1409 and defined &{$optionAction{$opt}}) {
1410 $val = &{$optionAction{$opt}}();
1411 } elsif (defined $optionAction{$opt}
1412 and not defined $option{$opt}
1413 or defined $optionVars{$opt}
1414 and not defined $ {$optionVars{$opt}}) {
1417 $val = $option{$opt};
1425 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1426 my ($opt,$sep) = ($1,$2);
1429 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1431 #&dump_option($opt);
1432 } elsif ($sep !~ /\S/) {
1434 } elsif ($sep eq "=") {
1437 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1438 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1439 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1440 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1442 $val =~ s/\\([\\$end])/$1/g;
1446 grep( /^\Q$opt/ && ($option = $_), @options );
1447 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1449 print $OUT "Unknown option `$opt'\n" unless $matches;
1450 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1451 $option{$option} = $val if $matches == 1 and defined $val;
1452 eval "local \$frame = 0; local \$doret = -2;
1453 require '$optionRequire{$option}'"
1454 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1455 $ {$optionVars{$option}} = $val
1457 and defined $optionVars{$option} and defined $val;
1458 & {$optionAction{$option}} ($val)
1460 and defined $optionAction{$option}
1461 and defined &{$optionAction{$option}} and defined $val;
1462 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1468 my ($stem,@list) = @_;
1470 $ENV{"$ {stem}_n"} = @list;
1471 for $i (0 .. $#list) {
1473 $val =~ s/\\/\\\\/g;
1474 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1475 $ENV{"$ {stem}_$i"} = $val;
1482 my $n = delete $ENV{"$ {stem}_n"};
1484 for $i (0 .. $n - 1) {
1485 $val = delete $ENV{"$ {stem}_$i"};
1486 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1494 return; # Put nothing on the stack - malloc/free land!
1498 my($msg)= join("",@_);
1499 $msg .= ": $!\n" unless $msg =~ /\n$/;
1505 &warn("Too late to set TTY!\n") if @_;
1514 &warn("Too late to set noTTY!\n") if @_;
1516 $notty = shift if @_;
1523 &warn("Too late to set ReadLine!\n") if @_;
1531 if ($ {$term->Features}{tkRunning}) {
1532 return $term->tkRunning(@_);
1534 print $OUT "tkRunning not supported by current ReadLine package.\n";
1541 &warn("Too late to set up NonStop mode!\n") if @_;
1543 $runnonstop = shift if @_;
1551 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1558 $sh = quotemeta shift;
1559 $sh .= "\\b" if $sh =~ /\w$/;
1563 $psh =~ s/\\(.)/$1/g;
1569 if (defined $term) {
1570 local ($warnLevel,$dieLevel) = (0, 1);
1571 return '' unless $term->Features->{ornaments};
1572 eval { $term->ornaments(@_) } || '';
1580 $rc = quotemeta shift;
1581 $rc .= "\\b" if $rc =~ /\w$/;
1585 $prc =~ s/\\(.)/$1/g;
1591 return $lineinfo unless @_;
1593 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1594 $emacs = ($stream =~ /^\|/);
1595 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1596 $LINEINFO = \*LINEINFO;
1597 my $save = select($LINEINFO);
1611 s/^Term::ReadLine::readline$/readline/;
1612 if (defined $ { $_ . '::VERSION' }) {
1613 $version{$file} = "$ { $_ . '::VERSION' } from ";
1615 $version{$file} .= $INC{$file};
1617 do 'dumpvar.pl' unless defined &main::dumpValue;
1618 if (defined &main::dumpValue) {
1620 &main::dumpValue(\%version);
1622 print $OUT "dumpvar.pl not available.\n";
1629 s [expr] Single step [in expr].
1630 n [expr] Next, steps over subroutine calls [in expr].
1631 <CR> Repeat last n or s command.
1632 r Return from current subroutine.
1633 c [line|sub] Continue; optionally inserts a one-time-only breakpoint
1634 at the specified position.
1635 l min+incr List incr+1 lines starting at min.
1636 l min-max List lines min through max.
1637 l line List single line.
1638 l subname List first window of lines from subroutine.
1639 l List next window of lines.
1640 - List previous window of lines.
1641 w [line] List window around line.
1642 . Return to the executed line.
1643 f filename Switch to viewing filename. Must be loaded.
1644 /pattern/ Search forwards for pattern; final / is optional.
1645 ?pattern? Search backwards for pattern; final ? is optional.
1646 L List all breakpoints and actions.
1647 S [[!]pattern] List subroutine names [not] matching pattern.
1648 t Toggle trace mode.
1649 t expr Trace through execution of expr.
1650 b [line] [condition]
1651 Set breakpoint; line defaults to the current execution line;
1652 condition breaks if it evaluates to true, defaults to '1'.
1653 b subname [condition]
1654 Set breakpoint at first line of subroutine.
1655 b load filename Set breakpoint on `require'ing the given file.
1656 b postpone subname [condition]
1657 Set breakpoint at first line of subroutine after
1660 Stop after the subroutine is compiled.
1661 d [line] Delete the breakpoint for line.
1662 D Delete all breakpoints.
1664 Set an action to be done before the line is executed.
1665 Sequence is: check for breakpoint, print line if necessary,
1666 do action, prompt user if breakpoint or step, evaluate line.
1667 A Delete all actions.
1668 V [pkg [vars]] List some (default all) variables in package (default current).
1669 Use ~pattern and !pattern for positive and negative regexps.
1670 X [vars] Same as \"V currentpackage [vars]\".
1671 x expr Evals expression in array context, dumps the result.
1672 m expr Evals expression in array context, prints methods callable
1673 on the first element of the result.
1674 m class Prints methods callable via the given class.
1675 O [opt[=val]] [opt\"val\"] [opt?]...
1676 Set or query values of options. val defaults to 1. opt can
1677 be abbreviated. Several options can be listed.
1678 recallCommand, ShellBang: chars used to recall command or spawn shell;
1679 pager: program for output of \"|cmd\";
1680 tkRunning: run Tk while prompting (with ReadLine);
1681 signalLevel warnLevel dieLevel: level of verbosity;
1682 inhibit_exit Allows stepping off the end of the script.
1683 The following options affect what happens with V, X, and x commands:
1684 arrayDepth, hashDepth: print only first N elements ('' for all);
1685 compactDump, veryCompact: change style of array and hash dump;
1686 globPrint: whether to print contents of globs;
1687 DumpDBFiles: dump arrays holding debugged files;
1688 DumpPackages: dump symbol tables of packages;
1689 quote, HighBit, undefPrint: change style of string dump;
1690 Option PrintRet affects printing of return value after r command,
1691 frame affects printing messages on entry and exit from subroutines.
1692 AutoTrace affects printing messages on every possible breaking point.
1693 maxTraceLen gives maximal length of evals/args listed in stack trace.
1694 ornaments affects screen appearance of the command line.
1695 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1696 You can put additional initialization options TTY, noTTY,
1697 ReadLine, and NonStop there.
1698 < command Define Perl command to run before each prompt.
1699 << command Add to the list of Perl commands to run before each prompt.
1700 > command Define Perl command to run after each prompt.
1701 >> command Add to the list of Perl commands to run after each prompt.
1702 \{ commandline Define debugger command to run before each prompt.
1703 \{{ commandline Add to the list of debugger commands to run before each prompt.
1704 $prc number Redo a previous command (default previous command).
1705 $prc -number Redo number'th-to-last command.
1706 $prc pattern Redo last command that started with pattern.
1707 See 'O recallCommand' too.
1708 $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1709 . ( $rc eq $sh ? "" : "
1710 $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1711 See 'O shellBang' too.
1712 H -number Display last number commands (default all).
1713 p expr Same as \"print {DB::OUT} expr\" in current package.
1714 |dbcmd Run debugger command, piping DB::OUT to current pager.
1715 ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1716 \= [alias value] Define a command alias, or list current aliases.
1717 command Execute as a perl statement in current package.
1718 v Show versions of loaded modules.
1719 R Pure-man-restart of debugger, some of debugger state
1720 and command-line options may be lost.
1721 Currently the following setting are preserved:
1722 history, breakpoints and actions, debugger Options
1723 and the following command-line options: -w, -I, -e.
1724 h [db_command] Get help [on a specific debugger command], enter |h to page.
1725 h h Summary of debugger commands.
1726 q or ^D Quit. Set \$DB::finished to 0 to debug global destruction.
1729 $summary = <<"END_SUM";
1730 List/search source lines: Control script execution:
1731 l [ln|sub] List source code T Stack trace
1732 - or . List previous/current line s [expr] Single step [in expr]
1733 w [line] List around line n [expr] Next, steps over subs
1734 f filename View source in file <CR> Repeat last n or s
1735 /pattern/ ?patt? Search forw/backw r Return from subroutine
1736 v Show versions of modules c [ln|sub] Continue until position
1737 Debugger controls: L List break pts & actions
1738 O [...] Set debugger options t [expr] Toggle trace [trace expr]
1739 <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
1740 >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
1741 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1742 H [-num] Display last num commands D Delete all breakpoints
1743 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1744 h [db_cmd] Get help on command A Delete all actions
1745 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
1746 q or ^D Quit R Attempt a restart
1747 Data Examination: expr Execute perl code, also see: s,n,t expr
1748 x|m expr Evals expr in array context, dumps the result or lists methods.
1749 p expr Print expression (uses script's current package).
1750 S [[!]pat] List subroutine names [not] matching pattern
1751 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1752 X [Vars] Same as \"V current_package [Vars]\".
1754 # ')}}; # Fix balance of Emacs parsing
1760 $SIG{'ABRT'} = 'DEFAULT';
1761 kill 'ABRT', $$ if $panic++;
1762 if (defined &Carp::longmess) {
1763 local $SIG{__WARN__} = '';
1764 local $Carp::CarpLevel = 2; # mydie + confess
1765 &warn(Carp::longmess("Signal @_"));
1768 print $DB::OUT "Got signal @_\n";
1776 local $SIG{__WARN__} = '';
1777 local $SIG{__DIE__} = '';
1778 eval { require Carp }; # If error/warning during compilation,
1779 # require may be broken.
1780 warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1781 unless defined &Carp::longmess;
1782 #&warn("Entering dbwarn\n");
1783 my ($mysingle,$mytrace) = ($single,$trace);
1784 $single = 0; $trace = 0;
1785 my $mess = Carp::longmess(@_);
1786 ($single,$trace) = ($mysingle,$mytrace);
1787 #&warn("Warning in dbwarn\n");
1789 #&warn("Exiting dbwarn\n");
1795 local $SIG{__DIE__} = '';
1796 local $SIG{__WARN__} = '';
1797 my $i = 0; my $ineval = 0; my $sub;
1798 #&warn("Entering dbdie\n");
1799 if ($dieLevel != 2) {
1800 while ((undef,undef,undef,$sub) = caller(++$i)) {
1801 $ineval = 1, last if $sub eq '(eval)';
1804 local $SIG{__WARN__} = \&dbwarn;
1805 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1807 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1808 die @_ if $ineval and $dieLevel < 2;
1810 eval { require Carp }; # If error/warning during compilation,
1811 # require may be broken.
1812 die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1813 # We do not want to debug this chunk (automatic disabling works
1814 # inside DB::DB, but not in Carp).
1815 my ($mysingle,$mytrace) = ($single,$trace);
1816 $single = 0; $trace = 0;
1817 my $mess = Carp::longmess(@_);
1818 ($single,$trace) = ($mysingle,$mytrace);
1819 #&warn("dieing loudly in dbdie\n");
1825 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1828 $SIG{__WARN__} = \&DB::dbwarn;
1830 $SIG{__WARN__} = $prevwarn;
1838 $prevdie = $SIG{__DIE__} unless $dieLevel;
1841 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1842 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1843 print $OUT "Stack dump during die enabled",
1844 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1845 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1847 $SIG{__DIE__} = $prevdie;
1848 print $OUT "Default die handler restored.\n";
1856 $prevsegv = $SIG{SEGV} unless $signalLevel;
1857 $prevbus = $SIG{BUS} unless $signalLevel;
1858 $signalLevel = shift;
1860 $SIG{SEGV} = \&DB::diesignal;
1861 $SIG{BUS} = \&DB::diesignal;
1863 $SIG{SEGV} = $prevsegv;
1864 $SIG{BUS} = $prevbus;
1872 return unless defined &$subr;
1874 $subr = \&$subr; # Hard reference
1877 $s = $_, last if $subr eq \&$_;
1885 $class = ref $class if ref $class;
1888 methods_via($class, '', 1);
1889 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
1894 return if $packs{$class}++;
1896 my $prepend = $prefix ? "via $prefix: " : '';
1898 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
1899 sort keys %{"$ {class}::"}) {
1900 next if $seen{ $name }++;
1901 print $DB::OUT "$prepend$name\n";
1903 return unless shift; # Recurse?
1904 for $name (@{"$ {class}::ISA"}) {
1905 $prepend = $prefix ? $prefix . " -> $name" : $name;
1906 methods_via($name, $prepend, 1);
1910 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1912 BEGIN { # This does not compile, alas.
1913 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1914 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1918 $deep = 100; # warning if stack gets this deep
1922 $SIG{INT} = \&DB::catch;
1923 # This may be enabled to debug debugger:
1924 #$warnLevel = 1 unless defined $warnLevel;
1925 #$dieLevel = 1 unless defined $dieLevel;
1926 #$signalLevel = 1 unless defined $signalLevel;
1928 $db_stop = 0; # Compiler warning
1930 $level = 0; # Level of recursive debugging
1931 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1932 # Triggers bug (?) in perl is we postpone this until runtime:
1933 @postponed = @stack = (0);
1938 BEGIN {$^W = $ini_warn;} # Switch warnings back
1940 #use Carp; # This did break, left for debuggin
1943 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
1944 my($text, $line, $start) = @_;
1945 my ($itext, $search, $prefix, $pack) =
1946 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
1948 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
1949 (map { /$search/ ? ($1) : () } keys %sub)
1950 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
1951 return sort grep /^\Q$text/, values %INC # files
1952 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
1953 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1954 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
1955 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
1956 return sort map {($_, db_complete($_ . "::", "V ", 2))}
1958 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
1960 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
1961 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
1962 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
1963 # We may want to complete to (eval 9), so $text may be wrong
1964 $prefix = length($1) - length($text);
1967 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
1969 if ((substr $text, 0, 1) eq '&') { # subroutines
1970 $text = substr $text, 1;
1972 return sort map "$prefix$_",
1975 (map { /$search/ ? ($1) : () }
1978 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
1979 $pack = ($1 eq 'main' ? '' : $1) . '::';
1980 $prefix = (substr $text, 0, 1) . $1 . '::';
1983 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
1984 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1985 return db_complete($out[0], $line, $start);
1989 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
1990 $pack = ($package eq 'main' ? '' : $package) . '::';
1991 $prefix = substr $text, 0, 1;
1992 $text = substr $text, 1;
1993 my @out = map "$prefix$_", grep /^\Q$text/,
1994 (grep /^_?[a-zA-Z]/, keys %$pack),
1995 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
1996 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1997 return db_complete($out[0], $line, $start);
2001 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2002 my @out = grep /^\Q$text/, @options;
2003 my $val = option_val($out[0], undef);
2005 if (not defined $val or $val =~ /[\n\r]/) {
2006 # Can do nothing better
2007 } elsif ($val =~ /\s/) {
2009 foreach $l (split //, qq/\"\'\#\|/) {
2010 $out = "$l$val$l ", last if (index $val, $l) == -1;
2015 # Default to value if one completion, to question if many
2016 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2019 return $term->filename_list($text); # filenames
2022 sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
2025 $finished = $inhibit_exit; # So that some keys may be disabled.
2026 # Do not stop in at_exit() and destructors on exit:
2027 $DB::single = !$exiting && !$runnonstop;
2028 DB::fake::at_exit() unless $exiting or $runnonstop;
2034 "Debuggee terminated. Use `q' to quit and `R' to restart.";
2037 package DB; # Do not trace this 1; below!