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";
299 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
304 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
308 $console = $tty if defined $tty;
310 if (defined $console) {
311 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
312 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
313 || open(OUT,">&STDOUT"); # so we don't dongle stdout
316 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
317 $console = 'STDIN/OUT';
319 # so open("|more") can read from STDOUT and so we don't dingle stdin
324 $| = 1; # for DB::OUT
327 $LINEINFO = $OUT unless defined $LINEINFO;
328 $lineinfo = $console unless defined $lineinfo;
330 $| = 1; # for real STDOUT
332 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
333 unless ($runnonstop) {
334 print $OUT "\nLoading DB routines from $header\n";
335 print $OUT ("Emacs support ",
336 $emacs ? "enabled" : "available",
338 print $OUT "\nEnter h or `h h' for help.\n\n";
345 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
348 if (defined &afterinit) { # May be defined in $rcfile
354 ############################################################ Subroutines
357 # _After_ the perl program is compiled, $single is set to 1:
358 if ($single and not $second_time++) {
359 if ($runnonstop) { # Disable until signal
360 for ($i=0; $i <= $#stack; ) {
364 # return; # Would not print trace!
367 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
369 ($package, $filename, $line) = caller;
370 $filename_ini = $filename;
371 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
372 "package $package;"; # this won't let them modify, alas
373 local(*dbline) = $main::{'_<' . $filename};
375 if (($stop,$action) = split(/\0/,$dbline{$line})) {
379 $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
380 $dbline{$line} =~ s/;9($|\0)/$1/;
383 my $was_signal = $signal;
385 if ($single || $trace || $was_signal) {
388 $position = "\032\032$filename:$line:0\n";
389 print $LINEINFO $position;
392 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
393 $prefix .= "$sub($filename:";
394 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
395 if (length($prefix) > 30) {
396 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
401 $position = "$prefix$line$infix$dbline[$line]$after";
404 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
406 print $LINEINFO $position;
408 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
409 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
411 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
412 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
413 $position .= $incr_pos;
415 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
417 print $LINEINFO $incr_pos;
422 $evalarg = $action, &eval if $action;
423 if ($single || $was_signal) {
424 local $level = $level + 1;
425 foreach $evalarg (@$pre) {
428 print $OUT $#stack . " levels deep in subroutine calls!\n"
431 $incr = -1; # for backward motion.
432 @typeahead = @$pretype, @typeahead;
434 while (($term || &setterm),
435 ($term_pid == $$ or &resetterm),
436 defined ($cmd=&readline(" DB" . ('<' x $level) .
437 ($#hist+1) . ('>' x $level) .
441 $cmd =~ s/\\$/\n/ && do {
442 $cmd .= &readline(" cont: ");
445 $cmd =~ /^$/ && ($cmd = $laststep);
446 push(@hist,$cmd) if length($cmd) > 1;
448 ($i) = split(/\s+/,$cmd);
449 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
450 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
451 $cmd =~ /^h$/ && do {
454 $cmd =~ /^h\s+h$/ && do {
457 $cmd =~ /^h\s+(\S)$/ && do {
459 if ($help =~ /^$asked/m) {
460 while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
464 print $OUT "`$asked' is not a debugger command.\n";
467 $cmd =~ /^t$/ && do {
469 print $OUT "Trace = ".($trace?"on":"off")."\n";
471 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
472 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
473 foreach $subname (sort(keys %sub)) {
474 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
475 print $OUT $subname,"\n";
479 $cmd =~ /^v$/ && do {
480 list_versions(); next CMD};
481 $cmd =~ s/^X\b/V $package/;
482 $cmd =~ /^V$/ && do {
483 $cmd = "V $package"; };
484 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
485 local ($savout) = select($OUT);
487 @vars = split(' ',$2);
488 do 'dumpvar.pl' unless defined &main::dumpvar;
489 if (defined &main::dumpvar) {
492 &main::dumpvar($packname,@vars);
494 print $OUT "dumpvar.pl not available.\n";
498 $cmd =~ s/^x\b/ / && do { # So that will be evaled
499 $onetimeDump = 'dump'; };
500 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
501 methods($1); next CMD};
502 $cmd =~ s/^m\b/ / && do { # So this will be evaled
503 $onetimeDump = 'methods'; };
504 $cmd =~ /^f\b\s*(.*)/ && do {
508 print $OUT "The old f command is now the r command.\n";
509 print $OUT "The new f command switches filenames.\n";
512 if (!defined $main::{'_<' . $file}) {
513 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
514 $try = substr($try,2);
515 print $OUT "Choosing $try matching `$file':\n";
519 if (!defined $main::{'_<' . $file}) {
520 print $OUT "No file matching `$file' is loaded.\n";
522 } elsif ($file ne $filename) {
523 *dbline = $main::{'_<' . $file};
529 print $OUT "Already in $file.\n";
533 $cmd =~ s/^l\s+-\s*$/-/;
534 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
536 $subname =~ s/\'/::/;
537 $subname = $package."::".$subname
538 unless $subname =~ /::/;
539 $subname = "main".$subname if substr($subname,0,2) eq "::";
540 @pieces = split(/:/,find_sub($subname));
541 $subrange = pop @pieces;
542 $file = join(':', @pieces);
543 if ($file ne $filename) {
544 *dbline = $main::{'_<' . $file};
549 if (eval($subrange) < -$window) {
550 $subrange =~ s/-.*/+/;
552 $cmd = "l $subrange";
554 print $OUT "Subroutine $subname not found.\n";
557 $cmd =~ /^\.$/ && do {
558 $incr = -1; # for backward motion.
560 $filename = $filename_ini;
561 *dbline = $main::{'_<' . $filename};
563 print $LINEINFO $position;
565 $cmd =~ /^w\b\s*(\d*)$/ && do {
569 #print $OUT 'l ' . $start . '-' . ($start + $incr);
570 $cmd = 'l ' . $start . '-' . ($start + $incr); };
571 $cmd =~ /^-$/ && do {
572 $start -= $incr + $window + 1;
573 $start = 1 if $start <= 0;
575 $cmd = 'l ' . ($start) . '+'; };
576 $cmd =~ /^l$/ && do {
578 $cmd = 'l ' . $start . '-' . ($start + $incr); };
579 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
582 $incr = $window - 1 unless $incr;
583 $cmd = 'l ' . $start . '-' . ($start + $incr); };
584 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
585 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
586 $end = $max if $end > $max;
588 $i = $line if $i eq '.';
592 print $OUT "\032\032$filename:$i:0\n";
595 for (; $i <= $end; $i++) {
596 ($stop,$action) = split(/\0/, $dbline{$i});
598 and $filename eq $filename_ini)
600 : ($dbline[$i]+0 ? ':' : ' ') ;
601 $arrow .= 'b' if $stop;
602 $arrow .= 'a' if $action;
603 print $OUT "$i$arrow\t", $dbline[$i];
607 $start = $i; # remember in case they want more
608 $start = $max if $start > $max;
610 $cmd =~ /^D$/ && do {
611 print $OUT "Deleting all breakpoints...\n";
613 for $file (keys %had_breakpoints) {
614 local *dbline = $main::{'_<' . $file};
618 for ($i = 1; $i <= $max ; $i++) {
619 if (defined $dbline{$i}) {
620 $dbline{$i} =~ s/^[^\0]+//;
621 if ($dbline{$i} =~ s/^\0?$//) {
628 undef %postponed_file;
629 undef %break_on_load;
630 undef %had_breakpoints;
632 $cmd =~ /^L$/ && do {
634 for $file (keys %had_breakpoints) {
635 local *dbline = $main::{'_<' . $file};
639 for ($i = 1; $i <= $max; $i++) {
640 if (defined $dbline{$i}) {
641 print "$file:\n" unless $was++;
642 print $OUT " $i:\t", $dbline[$i];
643 ($stop,$action) = split(/\0/, $dbline{$i});
644 print $OUT " break if (", $stop, ")\n"
646 print $OUT " action: ", $action, "\n"
653 print $OUT "Postponed breakpoints in subroutines:\n";
655 for $subname (keys %postponed) {
656 print $OUT " $subname\t$postponed{$subname}\n";
660 my @have = map { # Combined keys
661 keys %{$postponed_file{$_}}
662 } keys %postponed_file;
664 print $OUT "Postponed breakpoints in files:\n";
666 for $file (keys %postponed_file) {
667 my $db = $postponed_file{$file};
668 print $OUT " $file:\n";
669 for $line (sort {$a <=> $b} keys %$db) {
670 print $OUT " $line:\n";
671 my ($stop,$action) = split(/\0/, $$db{$line});
672 print $OUT " break if (", $stop, ")\n"
674 print $OUT " action: ", $action, "\n"
681 if (%break_on_load) {
682 print $OUT "Breakpoints on load:\n";
684 for $file (keys %break_on_load) {
685 print $OUT " $file\n";
690 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
691 my $file = $1; $file =~ s/\s+$//;
693 $break_on_load{$file} = 1;
694 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
695 $file .= '.pm', redo unless $file =~ /\./;
697 $had_breakpoints{$file} = 1;
698 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
700 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
701 my $cond = $3 || '1';
702 my ($subname, $break) = ($2, $1 eq 'postpone');
703 $subname =~ s/\'/::/;
704 $subname = "${'package'}::" . $subname
705 unless $subname =~ /::/;
706 $subname = "main".$subname if substr($subname,0,2) eq "::";
707 $postponed{$subname} = $break
708 ? "break +0 if $cond" : "compile";
710 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
713 $subname =~ s/\'/::/;
714 $subname = "${'package'}::" . $subname
715 unless $subname =~ /::/;
716 $subname = "main".$subname if substr($subname,0,2) eq "::";
717 # Filename below can contain ':'
718 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
722 *dbline = $main::{'_<' . $filename};
723 $had_breakpoints{$filename} = 1;
725 ++$i while $dbline[$i] == 0 && $i < $max;
726 $dbline{$i} =~ s/^[^\0]*/$cond/;
728 print $OUT "Subroutine $subname not found.\n";
731 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
734 if ($dbline[$i] == 0) {
735 print $OUT "Line $i not breakable.\n";
737 $had_breakpoints{$filename} = 1;
738 $dbline{$i} =~ s/^[^\0]*/$cond/;
741 $cmd =~ /^d\b\s*(\d+)?/ && do {
743 $dbline{$i} =~ s/^[^\0]*//;
744 delete $dbline{$i} if $dbline{$i} eq '';
746 $cmd =~ /^A$/ && do {
748 for $file (keys %had_breakpoints) {
749 local *dbline = $main::{'_<' . $file};
753 for ($i = 1; $i <= $max ; $i++) {
754 if (defined $dbline{$i}) {
755 $dbline{$i} =~ s/\0[^\0]*//;
756 delete $dbline{$i} if $dbline{$i} eq '';
761 $cmd =~ /^O\s*$/ && do {
766 $cmd =~ /^O\s*(\S.*)/ && do {
769 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
770 push @$pre, action($1);
772 $cmd =~ /^>>\s*(.*)/ && do {
773 push @$post, action($1);
775 $cmd =~ /^<\s*(.*)/ && do {
776 $pre = [], next CMD unless $1;
779 $cmd =~ /^>\s*(.*)/ && do {
780 $post = [], next CMD unless $1;
781 $post = [action($1)];
783 $cmd =~ /^\{\{\s*(.*)/ && do {
786 $cmd =~ /^\{\s*(.*)/ && do {
787 $pretype = [], next CMD unless $1;
790 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
792 if ($dbline[$i] == 0) {
793 print $OUT "Line $i may not have an action.\n";
795 $dbline{$i} =~ s/\0[^\0]*//;
796 $dbline{$i} .= "\0" . action($j);
799 $cmd =~ /^n$/ && do {
800 end_report(), next CMD if $finished and $level <= 1;
804 $cmd =~ /^s$/ && do {
805 end_report(), next CMD if $finished and $level <= 1;
809 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
810 end_report(), next CMD if $finished and $level <= 1;
812 if ($i =~ /\D/) { # subroutine name
813 ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/);
817 *dbline = $main::{'_<' . $filename};
818 $had_breakpoints{$filename}++;
820 ++$i while $dbline[$i] == 0 && $i < $max;
822 print $OUT "Subroutine $subname not found.\n";
827 if ($dbline[$i] == 0) {
828 print $OUT "Line $i not breakable.\n";
831 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
833 for ($i=0; $i <= $#stack; ) {
837 $cmd =~ /^r$/ && do {
838 end_report(), next CMD if $finished and $level <= 1;
839 $stack[$#stack] |= 1;
840 $doret = $option{PrintRet} ? $#stack - 1 : -2;
842 $cmd =~ /^R$/ && do {
843 print $OUT "Warning: some settings and command-line options may be lost!\n";
844 my (@script, @flags, $cl);
845 push @flags, '-w' if $ini_warn;
846 # Put all the old includes at the start to get
849 push @flags, '-I', $_;
851 # Arrange for setting the old INC:
852 set_list("PERLDB_INC", @ini_INC);
854 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
855 chomp ($cl = $ {'::_<-e'}[$_]);
856 push @script, '-e', $cl;
861 set_list("PERLDB_HIST",
862 $term->Features->{getHistory}
863 ? $term->GetHistory : @hist);
864 my @had_breakpoints = keys %had_breakpoints;
865 set_list("PERLDB_VISITED", @had_breakpoints);
866 set_list("PERLDB_OPT", %option);
867 set_list("PERLDB_ON_LOAD", %break_on_load);
869 for (0 .. $#had_breakpoints) {
870 my $file = $had_breakpoints[$_];
871 *dbline = $main::{'_<' . $file};
872 next unless %dbline or $postponed_file{$file};
873 (push @hard, $file), next
874 if $file =~ /^\(eval \d+\)$/;
876 @add = %{$postponed_file{$file}}
877 if $postponed_file{$file};
878 set_list("PERLDB_FILE_$_", %dbline, @add);
880 for (@hard) { # Yes, really-really...
881 # Find the subroutines in this eval
882 *dbline = $main::{'_<' . $_};
883 my ($quoted, $sub, %subs, $line) = quotemeta $_;
884 for $sub (keys %sub) {
885 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
886 $subs{$sub} = [$1, $2];
890 "No subroutines in $_, ignoring breakpoints.\n";
893 LINES: for $line (keys %dbline) {
894 # One breakpoint per sub only:
895 my ($offset, $sub, $found);
896 SUBS: for $sub (keys %subs) {
897 if ($subs{$sub}->[1] >= $line # Not after the subroutine
898 and (not defined $offset # Not caught
899 or $offset < 0 )) { # or badly caught
901 $offset = $line - $subs{$sub}->[0];
902 $offset = "+$offset", last SUBS if $offset >= 0;
905 if (defined $offset) {
907 "break $offset if $dbline{$line}";
909 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
913 set_list("PERLDB_POSTPONE", %postponed);
914 set_list("PERLDB_PRETYPE", @$pretype);
915 set_list("PERLDB_PRE", @$pre);
916 set_list("PERLDB_POST", @$post);
917 set_list("PERLDB_TYPEAHEAD", @typeahead);
918 $ENV{PERLDB_RESTART} = 1;
919 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
920 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
921 print $OUT "exec failed: $!\n";
923 $cmd =~ /^T$/ && do {
924 print_trace($OUT, 1); # skip DB
926 $cmd =~ /^\/(.*)$/ && do {
928 $inpat =~ s:([^\\])/$:$1:;
930 eval '$inpat =~ m'."\a$inpat\a";
942 $start = 1 if ($start > $max);
943 last if ($start == $end);
944 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
946 print $OUT "\032\032$filename:$start:0\n";
948 print $OUT "$start:\t", $dbline[$start], "\n";
953 print $OUT "/$pat/: not found\n" if ($start == $end);
955 $cmd =~ /^\?(.*)$/ && do {
957 $inpat =~ s:([^\\])\?$:$1:;
959 eval '$inpat =~ m'."\a$inpat\a";
971 $start = $max if ($start <= 0);
972 last if ($start == $end);
973 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
975 print $OUT "\032\032$filename:$start:0\n";
977 print $OUT "$start:\t", $dbline[$start], "\n";
982 print $OUT "?$pat?: not found\n" if ($start == $end);
984 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
985 pop(@hist) if length($cmd) > 1;
986 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
987 $cmd = $hist[$i] . "\n";
990 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
993 $cmd =~ /^$rc([^$rc].*)$/ && do {
995 pop(@hist) if length($cmd) > 1;
996 for ($i = $#hist; $i; --$i) {
997 last if $hist[$i] =~ /$pat/;
1000 print $OUT "No such command!\n\n";
1003 $cmd = $hist[$i] . "\n";
1006 $cmd =~ /^$sh$/ && do {
1007 &system($ENV{SHELL}||"/bin/sh");
1009 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1010 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1012 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1013 $end = $2?($#hist-$2):0;
1014 $hist = 0 if $hist < 0;
1015 for ($i=$#hist; $i>$end; $i--) {
1016 print $OUT "$i: ",$hist[$i],"\n"
1017 unless $hist[$i] =~ /^.?$/;
1020 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1021 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1022 $cmd =~ /^=/ && do {
1023 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1024 $alias{$k}="s~$k~$v~";
1025 print $OUT "$k = $v\n";
1026 } elsif ($cmd =~ /^=\s*$/) {
1027 foreach $k (sort keys(%alias)) {
1028 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1029 print $OUT "$k = $v\n";
1031 print $OUT "$k\t$alias{$k}\n";
1036 $cmd =~ /^\|\|?\s*[^|]/ && do {
1037 if ($pager =~ /^\|/) {
1038 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1039 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1041 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1043 unless ($piped=open(OUT,$pager)) {
1044 &warn("Can't pipe output to `$pager'");
1045 if ($pager =~ /^\|/) {
1046 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1047 open(STDOUT,">&SAVEOUT")
1048 || &warn("Can't restore STDOUT");
1051 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1055 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1056 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1057 $selected= select(OUT);
1059 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1060 $cmd =~ s/^\|+\s*//;
1062 # XXX Local variants do not work!
1063 $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
1064 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1065 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1067 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1069 $onetimeDump = undef;
1070 } elsif ($term_pid == $$) {
1075 if ($pager =~ /^\|/) {
1076 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1077 &warn( "Pager `$pager' failed: ",
1078 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1079 ( $? & 128 ) ? " (core dumped)" : "",
1080 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1081 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1082 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1083 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1084 # Will stop ignoring SIGPIPE if done like nohup(1)
1085 # does SIGINT but Perl doesn't give us a choice.
1087 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1090 select($selected), $selected= "" unless $selected eq "";
1094 $exiting = 1 unless defined $cmd;
1095 foreach $evalarg (@$post) {
1098 } # if ($single || $signal)
1099 ($@, $!, $,, $/, $\, $^W) = @saved;
1103 # The following code may be executed now:
1107 my ($al, $ret, @ret) = "";
1108 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1111 push(@stack, $single);
1113 $single |= 4 if $#stack == $deep;
1115 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1116 # Why -1? But it works! :-(
1117 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1118 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1121 $single |= pop(@stack);
1123 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1124 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1125 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1126 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1127 "list context return from $sub:\n"), dumpit( \@ret ),
1128 $doret = -2 if $doret eq $#stack or $frame & 16;
1132 $single |= pop(@stack);
1134 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1135 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1136 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1137 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1138 "scalar context return from $sub: "), dumpit( $ret ),
1139 $doret = -2 if $doret eq $#stack or $frame & 16;
1145 @saved = ($@, $!, $,, $/, $\, $^W);
1146 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1149 # The following takes its argument via $evalarg to preserve current @_
1154 local (@stack) = @stack; # guard against recursive debugging
1155 my $otrace = $trace;
1156 my $osingle = $single;
1158 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1164 local $saved[0]; # Preserve the old value of $@
1168 } elsif ($onetimeDump eq 'dump') {
1170 } elsif ($onetimeDump eq 'methods') {
1176 my $subname = shift;
1177 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1178 my $offset = $1 || 0;
1179 # Filename below can contain ':'
1180 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1183 local *dbline = $main::{'_<' . $file};
1184 local $^W = 0; # != 0 is magical below
1185 $had_breakpoints{$file}++;
1187 ++$i until $dbline[$i] != 0 or $i >= $max;
1188 $dbline{$i} = delete $postponed{$subname};
1190 print $OUT "Subroutine $subname not found.\n";
1194 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1195 #print $OUT "In postponed_sub for `$subname'.\n";
1199 return &postponed_sub
1200 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1201 # Cannot be done before the file is compiled
1202 local *dbline = shift;
1203 my $filename = $dbline;
1204 $filename =~ s/^_<//;
1205 $signal = 1, print $OUT "'$filename' loaded...\n"
1206 if $break_on_load{$filename};
1207 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1208 return unless $postponed_file{$filename};
1209 $had_breakpoints{$filename}++;
1210 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1212 for $key (keys %{$postponed_file{$filename}}) {
1213 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1215 delete $postponed_file{$filename};
1219 local ($savout) = select($OUT);
1220 my $osingle = $single;
1221 my $otrace = $trace;
1222 $single = $trace = 0;
1225 unless (defined &main::dumpValue) {
1228 if (defined &main::dumpValue) {
1229 &main::dumpValue(shift);
1231 print $OUT "dumpvar.pl not available.\n";
1238 # Tied method do not create a context, so may get wrong message:
1242 my @sub = dump_trace($_[0] + 1, $_[1]);
1243 my $short = $_[2]; # Print short report, next one for sub name
1245 for ($i=0; $i <= $#sub; $i++) {
1248 my $args = defined $sub[$i]{args}
1249 ? "(@{ $sub[$i]{args} })"
1251 $args = (substr $args, 0, $maxtrace - 3) . '...'
1252 if length $args > $maxtrace;
1253 my $file = $sub[$i]{file};
1254 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1256 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1258 my $sub = @_ >= 4 ? $_[3] : $s;
1259 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1261 print $fh "$sub[$i]{context} = $s$args" .
1262 " called from $file" .
1263 " line $sub[$i]{line}\n";
1270 my $count = shift || 1e9;
1273 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1274 my $nothard = not $frame & 8;
1275 local $frame = 0; # Do not want to trace this.
1276 my $otrace = $trace;
1279 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1284 if (not defined $arg) {
1286 } elsif ($nothard and tied $arg) {
1288 } elsif ($nothard and $type = ref $arg) {
1289 push @a, "ref($type)";
1291 local $_ = "$arg"; # Safe to stringify now - should not call f().
1294 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1295 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1296 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1300 $context = $context ? '@' : "\$";
1301 $args = $h ? [@a] : undef;
1302 $e =~ s/\n\s*\;\s*\Z// if $e;
1303 $e =~ s/([\\\'])/\\$1/g if $e;
1305 $sub = "require '$e'";
1306 } elsif (defined $r) {
1308 } elsif ($sub eq '(eval)') {
1309 $sub = "eval {...}";
1311 push(@sub, {context => $context, sub => $sub, args => $args,
1312 file => $file, line => $line});
1321 while ($action =~ s/\\$//) {
1332 &readline("cont: ");
1336 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1337 # many non-Unix systems can do system() but have problems with fork().
1338 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1339 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1340 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1341 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1343 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1344 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1345 close(SAVEIN); close(SAVEOUT);
1346 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1347 ( $? & 128 ) ? " (core dumped)" : "",
1348 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1355 local @stack = @stack; # Prevent growth by failing `use'.
1356 eval { require Term::ReadLine } or die $@;
1359 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1360 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1363 my $sel = select($OUT);
1367 eval "require Term::Rendezvous;" or die $@;
1368 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1369 my $term_rv = new Term::Rendezvous $rv;
1371 $OUT = $term_rv->OUT;
1375 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1377 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1379 $rl_attribs = $term->Attribs;
1380 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1381 if defined $rl_attribs->{basic_word_break_characters}
1382 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1383 $rl_attribs->{special_prefixes} = '$@&%';
1384 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1385 $rl_attribs->{completion_function} = \&db_complete;
1387 $LINEINFO = $OUT unless defined $LINEINFO;
1388 $lineinfo = $console unless defined $lineinfo;
1390 if ($term->Features->{setHistory} and "@hist" ne "?") {
1391 $term->SetHistory(@hist);
1393 ornaments($ornaments) if defined $ornaments;
1397 sub resetterm { # We forked, so we need a different TTY
1399 if (defined &get_fork_TTY) {
1401 } elsif (not defined $fork_TTY
1402 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1403 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1404 # Possibly _inside_ XTERM
1405 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1410 if (defined $fork_TTY) {
1414 print $OUT "Forked, but do not know how to change a TTY.\n",
1415 "Define \$DB::fork_TTY or get_fork_TTY().\n";
1421 my $left = @typeahead;
1422 my $got = shift @typeahead;
1423 print $OUT "auto(-$left)", shift, $got, "\n";
1424 $term->AddHistory($got)
1425 if length($got) > 1 and defined $term->Features->{addHistory};
1430 $term->readline(@_);
1434 my ($opt, $val)= @_;
1435 $val = option_val($opt,'N/A');
1436 $val =~ s/([\\\'])/\\$1/g;
1437 printf $OUT "%20s = '%s'\n", $opt, $val;
1441 my ($opt, $default)= @_;
1443 if (defined $optionVars{$opt}
1444 and defined $ {$optionVars{$opt}}) {
1445 $val = $ {$optionVars{$opt}};
1446 } elsif (defined $optionAction{$opt}
1447 and defined &{$optionAction{$opt}}) {
1448 $val = &{$optionAction{$opt}}();
1449 } elsif (defined $optionAction{$opt}
1450 and not defined $option{$opt}
1451 or defined $optionVars{$opt}
1452 and not defined $ {$optionVars{$opt}}) {
1455 $val = $option{$opt};
1463 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1464 my ($opt,$sep) = ($1,$2);
1467 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1469 #&dump_option($opt);
1470 } elsif ($sep !~ /\S/) {
1472 } elsif ($sep eq "=") {
1475 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1476 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1477 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1478 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1480 $val =~ s/\\([\\$end])/$1/g;
1484 grep( /^\Q$opt/ && ($option = $_), @options );
1485 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1487 print $OUT "Unknown option `$opt'\n" unless $matches;
1488 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1489 $option{$option} = $val if $matches == 1 and defined $val;
1490 eval "local \$frame = 0; local \$doret = -2;
1491 require '$optionRequire{$option}'"
1492 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1493 $ {$optionVars{$option}} = $val
1495 and defined $optionVars{$option} and defined $val;
1496 & {$optionAction{$option}} ($val)
1498 and defined $optionAction{$option}
1499 and defined &{$optionAction{$option}} and defined $val;
1500 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1506 my ($stem,@list) = @_;
1508 $ENV{"$ {stem}_n"} = @list;
1509 for $i (0 .. $#list) {
1511 $val =~ s/\\/\\\\/g;
1512 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1513 $ENV{"$ {stem}_$i"} = $val;
1520 my $n = delete $ENV{"$ {stem}_n"};
1522 for $i (0 .. $n - 1) {
1523 $val = delete $ENV{"$ {stem}_$i"};
1524 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1532 return; # Put nothing on the stack - malloc/free land!
1536 my($msg)= join("",@_);
1537 $msg .= ": $!\n" unless $msg =~ /\n$/;
1542 if (@_ and $term and $term->Features->{newTTY}) {
1543 my ($in, $out) = shift;
1545 ($in, $out) = split /,/, $in, 2;
1549 open IN, $in or die "cannot open `$in' for read: $!";
1550 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1551 $term->newTTY(\*IN, \*OUT);
1555 } elsif ($term and @_) {
1556 &warn("Too late to set TTY, enabled on next `R'!\n");
1564 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1566 $notty = shift if @_;
1572 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1579 if ($ {$term->Features}{tkRunning}) {
1580 return $term->tkRunning(@_);
1582 print $OUT "tkRunning not supported by current ReadLine package.\n";
1589 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1591 $runnonstop = shift if @_;
1598 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1605 $sh = quotemeta shift;
1606 $sh .= "\\b" if $sh =~ /\w$/;
1610 $psh =~ s/\\(.)/$1/g;
1616 if (defined $term) {
1617 local ($warnLevel,$dieLevel) = (0, 1);
1618 return '' unless $term->Features->{ornaments};
1619 eval { $term->ornaments(@_) } || '';
1627 $rc = quotemeta shift;
1628 $rc .= "\\b" if $rc =~ /\w$/;
1632 $prc =~ s/\\(.)/$1/g;
1638 return $lineinfo unless @_;
1640 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1641 $emacs = ($stream =~ /^\|/);
1642 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1643 $LINEINFO = \*LINEINFO;
1644 my $save = select($LINEINFO);
1658 s/^Term::ReadLine::readline$/readline/;
1659 if (defined $ { $_ . '::VERSION' }) {
1660 $version{$file} = "$ { $_ . '::VERSION' } from ";
1662 $version{$file} .= $INC{$file};
1664 do 'dumpvar.pl' unless defined &main::dumpValue;
1665 if (defined &main::dumpValue) {
1667 &main::dumpValue(\%version);
1669 print $OUT "dumpvar.pl not available.\n";
1676 s [expr] Single step [in expr].
1677 n [expr] Next, steps over subroutine calls [in expr].
1678 <CR> Repeat last n or s command.
1679 r Return from current subroutine.
1680 c [line|sub] Continue; optionally inserts a one-time-only breakpoint
1681 at the specified position.
1682 l min+incr List incr+1 lines starting at min.
1683 l min-max List lines min through max.
1684 l line List single line.
1685 l subname List first window of lines from subroutine.
1686 l List next window of lines.
1687 - List previous window of lines.
1688 w [line] List window around line.
1689 . Return to the executed line.
1690 f filename Switch to viewing filename. Must be loaded.
1691 /pattern/ Search forwards for pattern; final / is optional.
1692 ?pattern? Search backwards for pattern; final ? is optional.
1693 L List all breakpoints and actions.
1694 S [[!]pattern] List subroutine names [not] matching pattern.
1695 t Toggle trace mode.
1696 t expr Trace through execution of expr.
1697 b [line] [condition]
1698 Set breakpoint; line defaults to the current execution line;
1699 condition breaks if it evaluates to true, defaults to '1'.
1700 b subname [condition]
1701 Set breakpoint at first line of subroutine.
1702 b load filename Set breakpoint on `require'ing the given file.
1703 b postpone subname [condition]
1704 Set breakpoint at first line of subroutine after
1707 Stop after the subroutine is compiled.
1708 d [line] Delete the breakpoint for line.
1709 D Delete all breakpoints.
1711 Set an action to be done before the line is executed.
1712 Sequence is: check for breakpoint, print line if necessary,
1713 do action, prompt user if breakpoint or step, evaluate line.
1714 A Delete all actions.
1715 V [pkg [vars]] List some (default all) variables in package (default current).
1716 Use ~pattern and !pattern for positive and negative regexps.
1717 X [vars] Same as \"V currentpackage [vars]\".
1718 x expr Evals expression in array context, dumps the result.
1719 m expr Evals expression in array context, prints methods callable
1720 on the first element of the result.
1721 m class Prints methods callable via the given class.
1722 O [opt[=val]] [opt\"val\"] [opt?]...
1723 Set or query values of options. val defaults to 1. opt can
1724 be abbreviated. Several options can be listed.
1725 recallCommand, ShellBang: chars used to recall command or spawn shell;
1726 pager: program for output of \"|cmd\";
1727 tkRunning: run Tk while prompting (with ReadLine);
1728 signalLevel warnLevel dieLevel: level of verbosity;
1729 inhibit_exit Allows stepping off the end of the script.
1730 The following options affect what happens with V, X, and x commands:
1731 arrayDepth, hashDepth: print only first N elements ('' for all);
1732 compactDump, veryCompact: change style of array and hash dump;
1733 globPrint: whether to print contents of globs;
1734 DumpDBFiles: dump arrays holding debugged files;
1735 DumpPackages: dump symbol tables of packages;
1736 quote, HighBit, undefPrint: change style of string dump;
1737 Option PrintRet affects printing of return value after r command,
1738 frame affects printing messages on entry and exit from subroutines.
1739 AutoTrace affects printing messages on every possible breaking point.
1740 maxTraceLen gives maximal length of evals/args listed in stack trace.
1741 ornaments affects screen appearance of the command line.
1742 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1743 You can put additional initialization options TTY, noTTY,
1744 ReadLine, and NonStop there (or use `R' after you set them).
1745 < command Define Perl command to run before each prompt.
1746 << command Add to the list of Perl commands to run before each prompt.
1747 > command Define Perl command to run after each prompt.
1748 >> command Add to the list of Perl commands to run after each prompt.
1749 \{ commandline Define debugger command to run before each prompt.
1750 \{{ commandline Add to the list of debugger commands to run before each prompt.
1751 $prc number Redo a previous command (default previous command).
1752 $prc -number Redo number'th-to-last command.
1753 $prc pattern Redo last command that started with pattern.
1754 See 'O recallCommand' too.
1755 $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1756 . ( $rc eq $sh ? "" : "
1757 $psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1758 See 'O shellBang' too.
1759 H -number Display last number commands (default all).
1760 p expr Same as \"print {DB::OUT} expr\" in current package.
1761 |dbcmd Run debugger command, piping DB::OUT to current pager.
1762 ||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1763 \= [alias value] Define a command alias, or list current aliases.
1764 command Execute as a perl statement in current package.
1765 v Show versions of loaded modules.
1766 R Pure-man-restart of debugger, some of debugger state
1767 and command-line options may be lost.
1768 Currently the following setting are preserved:
1769 history, breakpoints and actions, debugger Options
1770 and the following command-line options: -w, -I, -e.
1771 h [db_command] Get help [on a specific debugger command], enter |h to page.
1772 h h Summary of debugger commands.
1773 q or ^D Quit. Set \$DB::finished to 0 to debug global destruction.
1776 $summary = <<"END_SUM";
1777 List/search source lines: Control script execution:
1778 l [ln|sub] List source code T Stack trace
1779 - or . List previous/current line s [expr] Single step [in expr]
1780 w [line] List around line n [expr] Next, steps over subs
1781 f filename View source in file <CR> Repeat last n or s
1782 /pattern/ ?patt? Search forw/backw r Return from subroutine
1783 v Show versions of modules c [ln|sub] Continue until position
1784 Debugger controls: L List break pts & actions
1785 O [...] Set debugger options t [expr] Toggle trace [trace expr]
1786 <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
1787 >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
1788 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1789 H [-num] Display last num commands D Delete all breakpoints
1790 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1791 h [db_cmd] Get help on command A Delete all actions
1792 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
1793 q or ^D Quit R Attempt a restart
1794 Data Examination: expr Execute perl code, also see: s,n,t expr
1795 x|m expr Evals expr in array context, dumps the result or lists methods.
1796 p expr Print expression (uses script's current package).
1797 S [[!]pat] List subroutine names [not] matching pattern
1798 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1799 X [Vars] Same as \"V current_package [Vars]\".
1801 # ')}}; # Fix balance of Emacs parsing
1807 $SIG{'ABRT'} = 'DEFAULT';
1808 kill 'ABRT', $$ if $panic++;
1809 if (defined &Carp::longmess) {
1810 local $SIG{__WARN__} = '';
1811 local $Carp::CarpLevel = 2; # mydie + confess
1812 &warn(Carp::longmess("Signal @_"));
1815 print $DB::OUT "Got signal @_\n";
1823 local $SIG{__WARN__} = '';
1824 local $SIG{__DIE__} = '';
1825 eval { require Carp }; # If error/warning during compilation,
1826 # require may be broken.
1827 warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1828 unless defined &Carp::longmess;
1829 #&warn("Entering dbwarn\n");
1830 my ($mysingle,$mytrace) = ($single,$trace);
1831 $single = 0; $trace = 0;
1832 my $mess = Carp::longmess(@_);
1833 ($single,$trace) = ($mysingle,$mytrace);
1834 #&warn("Warning in dbwarn\n");
1836 #&warn("Exiting dbwarn\n");
1842 local $SIG{__DIE__} = '';
1843 local $SIG{__WARN__} = '';
1844 my $i = 0; my $ineval = 0; my $sub;
1845 #&warn("Entering dbdie\n");
1846 if ($dieLevel != 2) {
1847 while ((undef,undef,undef,$sub) = caller(++$i)) {
1848 $ineval = 1, last if $sub eq '(eval)';
1851 local $SIG{__WARN__} = \&dbwarn;
1852 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1854 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1855 die @_ if $ineval and $dieLevel < 2;
1857 eval { require Carp }; # If error/warning during compilation,
1858 # require may be broken.
1859 die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
1860 # We do not want to debug this chunk (automatic disabling works
1861 # inside DB::DB, but not in Carp).
1862 my ($mysingle,$mytrace) = ($single,$trace);
1863 $single = 0; $trace = 0;
1864 my $mess = Carp::longmess(@_);
1865 ($single,$trace) = ($mysingle,$mytrace);
1866 #&warn("dieing loudly in dbdie\n");
1872 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1875 $SIG{__WARN__} = \&DB::dbwarn;
1877 $SIG{__WARN__} = $prevwarn;
1885 $prevdie = $SIG{__DIE__} unless $dieLevel;
1888 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1889 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1890 print $OUT "Stack dump during die enabled",
1891 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1893 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1895 $SIG{__DIE__} = $prevdie;
1896 print $OUT "Default die handler restored.\n";
1904 $prevsegv = $SIG{SEGV} unless $signalLevel;
1905 $prevbus = $SIG{BUS} unless $signalLevel;
1906 $signalLevel = shift;
1908 $SIG{SEGV} = \&DB::diesignal;
1909 $SIG{BUS} = \&DB::diesignal;
1911 $SIG{SEGV} = $prevsegv;
1912 $SIG{BUS} = $prevbus;
1920 return unless defined &$subr;
1922 $subr = \&$subr; # Hard reference
1925 $s = $_, last if $subr eq \&$_;
1933 $class = ref $class if ref $class;
1936 methods_via($class, '', 1);
1937 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
1942 return if $packs{$class}++;
1944 my $prepend = $prefix ? "via $prefix: " : '';
1946 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
1947 sort keys %{"$ {class}::"}) {
1948 next if $seen{ $name }++;
1949 print $DB::OUT "$prepend$name\n";
1951 return unless shift; # Recurse?
1952 for $name (@{"$ {class}::ISA"}) {
1953 $prepend = $prefix ? $prefix . " -> $name" : $name;
1954 methods_via($name, $prepend, 1);
1958 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1960 BEGIN { # This does not compile, alas.
1961 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1962 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1966 $deep = 100; # warning if stack gets this deep
1970 $SIG{INT} = \&DB::catch;
1971 # This may be enabled to debug debugger:
1972 #$warnLevel = 1 unless defined $warnLevel;
1973 #$dieLevel = 1 unless defined $dieLevel;
1974 #$signalLevel = 1 unless defined $signalLevel;
1976 $db_stop = 0; # Compiler warning
1978 $level = 0; # Level of recursive debugging
1979 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1980 # Triggers bug (?) in perl is we postpone this until runtime:
1981 @postponed = @stack = (0);
1986 BEGIN {$^W = $ini_warn;} # Switch warnings back
1988 #use Carp; # This did break, left for debuggin
1991 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
1992 my($text, $line, $start) = @_;
1993 my ($itext, $search, $prefix, $pack) =
1994 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
1996 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
1997 (map { /$search/ ? ($1) : () } keys %sub)
1998 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
1999 return sort grep /^\Q$text/, values %INC # files
2000 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2001 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2002 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2003 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2004 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2006 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2008 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2009 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2010 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2011 # We may want to complete to (eval 9), so $text may be wrong
2012 $prefix = length($1) - length($text);
2015 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2017 if ((substr $text, 0, 1) eq '&') { # subroutines
2018 $text = substr $text, 1;
2020 return sort map "$prefix$_",
2023 (map { /$search/ ? ($1) : () }
2026 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2027 $pack = ($1 eq 'main' ? '' : $1) . '::';
2028 $prefix = (substr $text, 0, 1) . $1 . '::';
2031 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2032 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2033 return db_complete($out[0], $line, $start);
2037 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2038 $pack = ($package eq 'main' ? '' : $package) . '::';
2039 $prefix = substr $text, 0, 1;
2040 $text = substr $text, 1;
2041 my @out = map "$prefix$_", grep /^\Q$text/,
2042 (grep /^_?[a-zA-Z]/, keys %$pack),
2043 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2044 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2045 return db_complete($out[0], $line, $start);
2049 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2050 my @out = grep /^\Q$text/, @options;
2051 my $val = option_val($out[0], undef);
2053 if (not defined $val or $val =~ /[\n\r]/) {
2054 # Can do nothing better
2055 } elsif ($val =~ /\s/) {
2057 foreach $l (split //, qq/\"\'\#\|/) {
2058 $out = "$l$val$l ", last if (index $val, $l) == -1;
2063 # Default to value if one completion, to question if many
2064 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2067 return $term->filename_list($text); # filenames
2071 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2075 $finished = $inhibit_exit; # So that some keys may be disabled.
2076 # Do not stop in at_exit() and destructors on exit:
2077 $DB::single = !$exiting && !$runnonstop;
2078 DB::fake::at_exit() unless $exiting or $runnonstop;
2084 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2087 package DB; # Do not trace this 1; below!