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 DumpReused
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
185 hashDepth => \$dumpvar::hashDepth,
186 arrayDepth => \$dumpvar::arrayDepth,
187 DumpDBFiles => \$dumpvar::dumpDBFiles,
188 DumpPackages => \$dumpvar::dumpPackages,
189 DumpReused => \$dumpvar::dumpReused,
190 HighBit => \$dumpvar::quoteHighBit,
191 undefPrint => \$dumpvar::printUndef,
192 globPrint => \$dumpvar::globPrint,
193 UsageOnly => \$dumpvar::usageOnly,
195 AutoTrace => \$trace,
196 inhibit_exit => \$inhibit_exit,
197 maxTraceLen => \$maxtrace,
198 ImmediateStop => \$ImmediateStop,
202 compactDump => \&dumpvar::compactDump,
203 veryCompact => \&dumpvar::veryCompact,
204 quote => \&dumpvar::quote,
207 ReadLine => \&ReadLine,
208 NonStop => \&NonStop,
209 LineInfo => \&LineInfo,
210 recallCommand => \&recallCommand,
211 ShellBang => \&shellBang,
213 signalLevel => \&signalLevel,
214 warnLevel => \&warnLevel,
215 dieLevel => \&dieLevel,
216 tkRunning => \&tkRunning,
217 ornaments => \&ornaments,
221 compactDump => 'dumpvar.pl',
222 veryCompact => 'dumpvar.pl',
223 quote => 'dumpvar.pl',
226 # These guys may be defined in $ENV{PERL5DB} :
227 $rl = 1 unless defined $rl;
228 $warnLevel = 1 unless defined $warnLevel;
229 $dieLevel = 1 unless defined $dieLevel;
230 $signalLevel = 1 unless defined $signalLevel;
231 $pre = [] unless defined $pre;
232 $post = [] unless defined $post;
233 $pretype = [] unless defined $pretype;
234 warnLevel($warnLevel);
236 signalLevel($signalLevel);
237 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
238 &recallCommand("!") unless defined $prc;
239 &shellBang("!") unless defined $psh;
240 $maxtrace = 400 unless defined $maxtrace;
245 $rcfile="perldb.ini";
250 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
251 do "$ENV{LOGDIR}/$rcfile";
252 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
253 do "$ENV{HOME}/$rcfile";
256 if (defined $ENV{PERLDB_OPTS}) {
257 parse_options($ENV{PERLDB_OPTS});
260 if (exists $ENV{PERLDB_RESTART}) {
261 delete $ENV{PERLDB_RESTART};
263 @hist = get_list('PERLDB_HIST');
264 %break_on_load = get_list("PERLDB_ON_LOAD");
265 %postponed = get_list("PERLDB_POSTPONE");
266 my @had_breakpoints= get_list("PERLDB_VISITED");
267 for (0 .. $#had_breakpoints) {
268 my %pf = get_list("PERLDB_FILE_$_");
269 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
271 my %opt = get_list("PERLDB_OPT");
273 while (($opt,$val) = each %opt) {
274 $val =~ s/[\\\']/\\$1/g;
275 parse_options("$opt'$val'");
277 @INC = get_list("PERLDB_INC");
279 $pretype = [get_list("PERLDB_PRETYPE")];
280 $pre = [get_list("PERLDB_PRE")];
281 $post = [get_list("PERLDB_POST")];
282 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
288 # Is Perl being run from Emacs?
289 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
290 $rl = 0, shift(@main::ARGV) if $emacs;
292 #require Term::ReadLine;
295 $console = "/dev/tty";
296 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
299 $console = "sys\$command";
302 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
307 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
311 $console = $tty if defined $tty;
313 if (defined $console) {
314 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
315 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
316 || open(OUT,">&STDOUT"); # so we don't dongle stdout
319 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
320 $console = 'STDIN/OUT';
322 # so open("|more") can read from STDOUT and so we don't dingle stdin
327 $| = 1; # for DB::OUT
330 $LINEINFO = $OUT unless defined $LINEINFO;
331 $lineinfo = $console unless defined $lineinfo;
333 $| = 1; # for real STDOUT
335 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
336 unless ($runnonstop) {
337 print $OUT "\nLoading DB routines from $header\n";
338 print $OUT ("Emacs support ",
339 $emacs ? "enabled" : "available",
341 print $OUT "\nEnter h or `h h' for help.\n\n";
348 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
351 if (defined &afterinit) { # May be defined in $rcfile
357 ############################################################ Subroutines
360 # _After_ the perl program is compiled, $single is set to 1:
361 if ($single and not $second_time++) {
362 if ($runnonstop) { # Disable until signal
363 for ($i=0; $i <= $#stack; ) {
367 # return; # Would not print trace!
368 } elsif ($ImmediateStop) {
373 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
375 ($package, $filename, $line) = caller;
376 $filename_ini = $filename;
377 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
378 "package $package;"; # this won't let them modify, alas
379 local(*dbline) = $main::{'_<' . $filename};
381 if (($stop,$action) = split(/\0/,$dbline{$line})) {
385 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
386 $dbline{$line} =~ s/;9($|\0)/$1/;
389 my $was_signal = $signal;
391 for (my $n = 0; $n <= $#to_watch; $n++) {
392 $evalarg = $to_watch[$n];
393 my ($val) = &eval; # Fix context (&eval is doing array)?
394 $val = ( (defined $val) ? "'$val'" : 'undef' );
395 if ($val ne $old_watch[$n]) {
398 Watchpoint $n:\t$to_watch[$n] changed:
399 old value:\t$old_watch[$n]
402 $old_watch[$n] = $val;
406 if ($trace & 4) { # User-installed watch
407 return if watchfunction($package, $filename, $line)
408 and not $single and not $was_signal and not ($trace & ~4);
410 $was_signal = $signal;
412 if ($single || ($trace & 1) || $was_signal) {
415 $position = "\032\032$filename:$line:0\n";
416 print $LINEINFO $position;
417 } elsif ($package eq 'DB::fake') {
419 Debugged program terminated. Use B<q> to quit or B<R> to restart,
420 use B<O> I<inhibit_exit> to avoid stopping after program termination,
421 B<h q>, B<h R> or B<h O> to get additional info.
424 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
425 "package $package;"; # this won't let them modify, alas
428 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
429 $prefix .= "$sub($filename:";
430 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
431 if (length($prefix) > 30) {
432 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
437 $position = "$prefix$line$infix$dbline[$line]$after";
440 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
442 print $LINEINFO $position;
444 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
445 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
447 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
448 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
449 $position .= $incr_pos;
451 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
453 print $LINEINFO $incr_pos;
458 $evalarg = $action, &eval if $action;
459 if ($single || $was_signal) {
460 local $level = $level + 1;
461 foreach $evalarg (@$pre) {
464 print $OUT $#stack . " levels deep in subroutine calls!\n"
467 $incr = -1; # for backward motion.
468 @typeahead = @$pretype, @typeahead;
470 while (($term || &setterm),
471 ($term_pid == $$ or &resetterm),
472 defined ($cmd=&readline(" DB" . ('<' x $level) .
473 ($#hist+1) . ('>' x $level) .
477 $cmd =~ s/\\$/\n/ && do {
478 $cmd .= &readline(" cont: ");
481 $cmd =~ /^$/ && ($cmd = $laststep);
482 push(@hist,$cmd) if length($cmd) > 1;
484 ($i) = split(/\s+/,$cmd);
485 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
486 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
487 $cmd =~ /^h$/ && do {
490 $cmd =~ /^h\s+h$/ && do {
491 print_help($summary);
493 $cmd =~ /^h\s+(\S)$/ && do {
495 if ($help =~ /^(?:[IB]<)$asked/m) {
496 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
500 print_help("B<$asked> is not a debugger command.\n");
503 $cmd =~ /^t$/ && do {
504 ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
505 print $OUT "Trace = " .
506 (($trace & 1) ? "on" : "off" ) . "\n";
508 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
509 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
510 foreach $subname (sort(keys %sub)) {
511 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
512 print $OUT $subname,"\n";
516 $cmd =~ /^v$/ && do {
517 list_versions(); next CMD};
518 $cmd =~ s/^X\b/V $package/;
519 $cmd =~ /^V$/ && do {
520 $cmd = "V $package"; };
521 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
522 local ($savout) = select($OUT);
524 @vars = split(' ',$2);
525 do 'dumpvar.pl' unless defined &main::dumpvar;
526 if (defined &main::dumpvar) {
529 &main::dumpvar($packname,@vars);
531 print $OUT "dumpvar.pl not available.\n";
535 $cmd =~ s/^x\b/ / && do { # So that will be evaled
536 $onetimeDump = 'dump'; };
537 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
538 methods($1); next CMD};
539 $cmd =~ s/^m\b/ / && do { # So this will be evaled
540 $onetimeDump = 'methods'; };
541 $cmd =~ /^f\b\s*(.*)/ && do {
545 print $OUT "The old f command is now the r command.\n";
546 print $OUT "The new f command switches filenames.\n";
549 if (!defined $main::{'_<' . $file}) {
550 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
551 $try = substr($try,2);
552 print $OUT "Choosing $try matching `$file':\n";
556 if (!defined $main::{'_<' . $file}) {
557 print $OUT "No file matching `$file' is loaded.\n";
559 } elsif ($file ne $filename) {
560 *dbline = $main::{'_<' . $file};
566 print $OUT "Already in $file.\n";
570 $cmd =~ s/^l\s+-\s*$/-/;
571 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
573 $subname =~ s/\'/::/;
574 $subname = $package."::".$subname
575 unless $subname =~ /::/;
576 $subname = "main".$subname if substr($subname,0,2) eq "::";
577 @pieces = split(/:/,find_sub($subname));
578 $subrange = pop @pieces;
579 $file = join(':', @pieces);
580 if ($file ne $filename) {
581 *dbline = $main::{'_<' . $file};
586 if (eval($subrange) < -$window) {
587 $subrange =~ s/-.*/+/;
589 $cmd = "l $subrange";
591 print $OUT "Subroutine $subname not found.\n";
594 $cmd =~ /^\.$/ && do {
595 $incr = -1; # for backward motion.
597 $filename = $filename_ini;
598 *dbline = $main::{'_<' . $filename};
600 print $LINEINFO $position;
602 $cmd =~ /^w\b\s*(\d*)$/ && do {
606 #print $OUT 'l ' . $start . '-' . ($start + $incr);
607 $cmd = 'l ' . $start . '-' . ($start + $incr); };
608 $cmd =~ /^-$/ && do {
609 $start -= $incr + $window + 1;
610 $start = 1 if $start <= 0;
612 $cmd = 'l ' . ($start) . '+'; };
613 $cmd =~ /^l$/ && do {
615 $cmd = 'l ' . $start . '-' . ($start + $incr); };
616 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
619 $incr = $window - 1 unless $incr;
620 $cmd = 'l ' . $start . '-' . ($start + $incr); };
621 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
622 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
623 $end = $max if $end > $max;
625 $i = $line if $i eq '.';
629 print $OUT "\032\032$filename:$i:0\n";
632 for (; $i <= $end; $i++) {
633 ($stop,$action) = split(/\0/, $dbline{$i});
635 and $filename eq $filename_ini)
637 : ($dbline[$i]+0 ? ':' : ' ') ;
638 $arrow .= 'b' if $stop;
639 $arrow .= 'a' if $action;
640 print $OUT "$i$arrow\t", $dbline[$i];
644 $start = $i; # remember in case they want more
645 $start = $max if $start > $max;
647 $cmd =~ /^D$/ && do {
648 print $OUT "Deleting all breakpoints...\n";
650 for $file (keys %had_breakpoints) {
651 local *dbline = $main::{'_<' . $file};
655 for ($i = 1; $i <= $max ; $i++) {
656 if (defined $dbline{$i}) {
657 $dbline{$i} =~ s/^[^\0]+//;
658 if ($dbline{$i} =~ s/^\0?$//) {
665 undef %postponed_file;
666 undef %break_on_load;
667 undef %had_breakpoints;
669 $cmd =~ /^L$/ && do {
671 for $file (keys %had_breakpoints) {
672 local *dbline = $main::{'_<' . $file};
676 for ($i = 1; $i <= $max; $i++) {
677 if (defined $dbline{$i}) {
678 print "$file:\n" unless $was++;
679 print $OUT " $i:\t", $dbline[$i];
680 ($stop,$action) = split(/\0/, $dbline{$i});
681 print $OUT " break if (", $stop, ")\n"
683 print $OUT " action: ", $action, "\n"
690 print $OUT "Postponed breakpoints in subroutines:\n";
692 for $subname (keys %postponed) {
693 print $OUT " $subname\t$postponed{$subname}\n";
697 my @have = map { # Combined keys
698 keys %{$postponed_file{$_}}
699 } keys %postponed_file;
701 print $OUT "Postponed breakpoints in files:\n";
703 for $file (keys %postponed_file) {
704 my $db = $postponed_file{$file};
705 print $OUT " $file:\n";
706 for $line (sort {$a <=> $b} keys %$db) {
707 print $OUT " $line:\n";
708 my ($stop,$action) = split(/\0/, $$db{$line});
709 print $OUT " break if (", $stop, ")\n"
711 print $OUT " action: ", $action, "\n"
718 if (%break_on_load) {
719 print $OUT "Breakpoints on load:\n";
721 for $file (keys %break_on_load) {
722 print $OUT " $file\n";
727 print $OUT "Watch-expressions:\n";
729 for $expr (@to_watch) {
730 print $OUT " $expr\n";
735 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
736 my $file = $1; $file =~ s/\s+$//;
738 $break_on_load{$file} = 1;
739 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
740 $file .= '.pm', redo unless $file =~ /\./;
742 $had_breakpoints{$file} = 1;
743 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
745 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
746 my $cond = $3 || '1';
747 my ($subname, $break) = ($2, $1 eq 'postpone');
748 $subname =~ s/\'/::/;
749 $subname = "${'package'}::" . $subname
750 unless $subname =~ /::/;
751 $subname = "main".$subname if substr($subname,0,2) eq "::";
752 $postponed{$subname} = $break
753 ? "break +0 if $cond" : "compile";
755 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
758 $subname =~ s/\'/::/;
759 $subname = "${'package'}::" . $subname
760 unless $subname =~ /::/;
761 $subname = "main".$subname if substr($subname,0,2) eq "::";
762 # Filename below can contain ':'
763 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
767 *dbline = $main::{'_<' . $filename};
768 $had_breakpoints{$filename} = 1;
770 ++$i while $dbline[$i] == 0 && $i < $max;
771 $dbline{$i} =~ s/^[^\0]*/$cond/;
773 print $OUT "Subroutine $subname not found.\n";
776 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
779 if ($dbline[$i] == 0) {
780 print $OUT "Line $i not breakable.\n";
782 $had_breakpoints{$filename} = 1;
783 $dbline{$i} =~ s/^[^\0]*/$cond/;
786 $cmd =~ /^d\b\s*(\d+)?/ && do {
788 $dbline{$i} =~ s/^[^\0]*//;
789 delete $dbline{$i} if $dbline{$i} eq '';
791 $cmd =~ /^A$/ && do {
793 for $file (keys %had_breakpoints) {
794 local *dbline = $main::{'_<' . $file};
798 for ($i = 1; $i <= $max ; $i++) {
799 if (defined $dbline{$i}) {
800 $dbline{$i} =~ s/\0[^\0]*//;
801 delete $dbline{$i} if $dbline{$i} eq '';
806 $cmd =~ /^O\s*$/ && do {
811 $cmd =~ /^O\s*(\S.*)/ && do {
814 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
815 push @$pre, action($1);
817 $cmd =~ /^>>\s*(.*)/ && do {
818 push @$post, action($1);
820 $cmd =~ /^<\s*(.*)/ && do {
821 $pre = [], next CMD unless $1;
824 $cmd =~ /^>\s*(.*)/ && do {
825 $post = [], next CMD unless $1;
826 $post = [action($1)];
828 $cmd =~ /^\{\{\s*(.*)/ && do {
831 $cmd =~ /^\{\s*(.*)/ && do {
832 $pretype = [], next CMD unless $1;
835 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
837 if ($dbline[$i] == 0) {
838 print $OUT "Line $i may not have an action.\n";
840 $dbline{$i} =~ s/\0[^\0]*//;
841 $dbline{$i} .= "\0" . action($j);
844 $cmd =~ /^n$/ && do {
845 end_report(), next CMD if $finished and $level <= 1;
849 $cmd =~ /^s$/ && do {
850 end_report(), next CMD if $finished and $level <= 1;
854 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
855 end_report(), next CMD if $finished and $level <= 1;
857 if ($i =~ /\D/) { # subroutine name
858 $subname = $package."::".$subname
859 unless $subname =~ /::/;
860 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
864 *dbline = $main::{'_<' . $filename};
865 $had_breakpoints{$filename}++;
867 ++$i while $dbline[$i] == 0 && $i < $max;
869 print $OUT "Subroutine $subname not found.\n";
874 if ($dbline[$i] == 0) {
875 print $OUT "Line $i not breakable.\n";
878 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
880 for ($i=0; $i <= $#stack; ) {
884 $cmd =~ /^r$/ && do {
885 end_report(), next CMD if $finished and $level <= 1;
886 $stack[$#stack] |= 1;
887 $doret = $option{PrintRet} ? $#stack - 1 : -2;
889 $cmd =~ /^R$/ && do {
890 print $OUT "Warning: some settings and command-line options may be lost!\n";
891 my (@script, @flags, $cl);
892 push @flags, '-w' if $ini_warn;
893 # Put all the old includes at the start to get
896 push @flags, '-I', $_;
898 # Arrange for setting the old INC:
899 set_list("PERLDB_INC", @ini_INC);
901 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
902 chomp ($cl = $ {'::_<-e'}[$_]);
903 push @script, '-e', $cl;
908 set_list("PERLDB_HIST",
909 $term->Features->{getHistory}
910 ? $term->GetHistory : @hist);
911 my @had_breakpoints = keys %had_breakpoints;
912 set_list("PERLDB_VISITED", @had_breakpoints);
913 set_list("PERLDB_OPT", %option);
914 set_list("PERLDB_ON_LOAD", %break_on_load);
916 for (0 .. $#had_breakpoints) {
917 my $file = $had_breakpoints[$_];
918 *dbline = $main::{'_<' . $file};
919 next unless %dbline or $postponed_file{$file};
920 (push @hard, $file), next
921 if $file =~ /^\(eval \d+\)$/;
923 @add = %{$postponed_file{$file}}
924 if $postponed_file{$file};
925 set_list("PERLDB_FILE_$_", %dbline, @add);
927 for (@hard) { # Yes, really-really...
928 # Find the subroutines in this eval
929 *dbline = $main::{'_<' . $_};
930 my ($quoted, $sub, %subs, $line) = quotemeta $_;
931 for $sub (keys %sub) {
932 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
933 $subs{$sub} = [$1, $2];
937 "No subroutines in $_, ignoring breakpoints.\n";
940 LINES: for $line (keys %dbline) {
941 # One breakpoint per sub only:
942 my ($offset, $sub, $found);
943 SUBS: for $sub (keys %subs) {
944 if ($subs{$sub}->[1] >= $line # Not after the subroutine
945 and (not defined $offset # Not caught
946 or $offset < 0 )) { # or badly caught
948 $offset = $line - $subs{$sub}->[0];
949 $offset = "+$offset", last SUBS if $offset >= 0;
952 if (defined $offset) {
954 "break $offset if $dbline{$line}";
956 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
960 set_list("PERLDB_POSTPONE", %postponed);
961 set_list("PERLDB_PRETYPE", @$pretype);
962 set_list("PERLDB_PRE", @$pre);
963 set_list("PERLDB_POST", @$post);
964 set_list("PERLDB_TYPEAHEAD", @typeahead);
965 $ENV{PERLDB_RESTART} = 1;
966 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
967 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
968 print $OUT "exec failed: $!\n";
970 $cmd =~ /^T$/ && do {
971 print_trace($OUT, 1); # skip DB
973 $cmd =~ /^W\s*$/ && do {
975 @to_watch = @old_watch = ();
977 $cmd =~ /^W\b\s*(.*)/s && do {
981 $val = (defined $val) ? "'$val'" : 'undef' ;
982 push @old_watch, $val;
985 $cmd =~ /^\/(.*)$/ && do {
987 $inpat =~ s:([^\\])/$:$1:;
989 eval '$inpat =~ m'."\a$inpat\a";
1001 $start = 1 if ($start > $max);
1002 last if ($start == $end);
1003 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1005 print $OUT "\032\032$filename:$start:0\n";
1007 print $OUT "$start:\t", $dbline[$start], "\n";
1012 print $OUT "/$pat/: not found\n" if ($start == $end);
1014 $cmd =~ /^\?(.*)$/ && do {
1016 $inpat =~ s:([^\\])\?$:$1:;
1018 eval '$inpat =~ m'."\a$inpat\a";
1030 $start = $max if ($start <= 0);
1031 last if ($start == $end);
1032 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1034 print $OUT "\032\032$filename:$start:0\n";
1036 print $OUT "$start:\t", $dbline[$start], "\n";
1041 print $OUT "?$pat?: not found\n" if ($start == $end);
1043 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1044 pop(@hist) if length($cmd) > 1;
1045 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1046 $cmd = $hist[$i] . "\n";
1049 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1052 $cmd =~ /^$rc([^$rc].*)$/ && do {
1054 pop(@hist) if length($cmd) > 1;
1055 for ($i = $#hist; $i; --$i) {
1056 last if $hist[$i] =~ /$pat/;
1059 print $OUT "No such command!\n\n";
1062 $cmd = $hist[$i] . "\n";
1065 $cmd =~ /^$sh$/ && do {
1066 &system($ENV{SHELL}||"/bin/sh");
1068 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1069 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1071 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1072 $end = $2?($#hist-$2):0;
1073 $hist = 0 if $hist < 0;
1074 for ($i=$#hist; $i>$end; $i--) {
1075 print $OUT "$i: ",$hist[$i],"\n"
1076 unless $hist[$i] =~ /^.?$/;
1079 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1080 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1081 $cmd =~ /^=/ && do {
1082 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1083 $alias{$k}="s~$k~$v~";
1084 print $OUT "$k = $v\n";
1085 } elsif ($cmd =~ /^=\s*$/) {
1086 foreach $k (sort keys(%alias)) {
1087 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1088 print $OUT "$k = $v\n";
1090 print $OUT "$k\t$alias{$k}\n";
1095 $cmd =~ /^\|\|?\s*[^|]/ && do {
1096 if ($pager =~ /^\|/) {
1097 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1098 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1100 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1102 unless ($piped=open(OUT,$pager)) {
1103 &warn("Can't pipe output to `$pager'");
1104 if ($pager =~ /^\|/) {
1105 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1106 open(STDOUT,">&SAVEOUT")
1107 || &warn("Can't restore STDOUT");
1110 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1114 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1115 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1116 $selected= select(OUT);
1118 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1119 $cmd =~ s/^\|+\s*//;
1121 # XXX Local variants do not work!
1122 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1123 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1124 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1126 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1128 $onetimeDump = undef;
1129 } elsif ($term_pid == $$) {
1134 if ($pager =~ /^\|/) {
1135 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1136 &warn( "Pager `$pager' failed: ",
1137 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1138 ( $? & 128 ) ? " (core dumped)" : "",
1139 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1140 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1141 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1142 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1143 # Will stop ignoring SIGPIPE if done like nohup(1)
1144 # does SIGINT but Perl doesn't give us a choice.
1146 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1149 select($selected), $selected= "" unless $selected eq "";
1153 $exiting = 1 unless defined $cmd;
1154 foreach $evalarg (@$post) {
1157 } # if ($single || $signal)
1158 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1162 # The following code may be executed now:
1166 my ($al, $ret, @ret) = "";
1167 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1170 push(@stack, $single);
1172 $single |= 4 if $#stack == $deep;
1174 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1175 # Why -1? But it works! :-(
1176 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1177 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1180 $single |= pop(@stack);
1182 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1183 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1184 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1185 if ($doret eq $#stack or $frame & 16) {
1186 my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
1187 print $fh ' ' x $#stack if $frame & 16;
1188 print $fh "list context return from $sub:\n";
1189 dumpit($fh, \@ret );
1194 if (defined wantarray) {
1199 $single |= pop(@stack);
1201 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1202 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1203 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1204 if ($doret eq $#stack or $frame & 16 and defined wantarray) {
1205 my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
1206 print $fh (' ' x $#stack) if $frame & 16;
1207 print $fh (defined wantarray
1208 ? "scalar context return from $sub: "
1209 : "void context return from $sub\n");
1210 dumpit( $fh, $ret ) if defined wantarray;
1218 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1219 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1222 # The following takes its argument via $evalarg to preserve current @_
1227 local (@stack) = @stack; # guard against recursive debugging
1228 my $otrace = $trace;
1229 my $osingle = $single;
1231 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1237 local $saved[0]; # Preserve the old value of $@
1241 } elsif ($onetimeDump eq 'dump') {
1242 dumpit($OUT, \@res);
1243 } elsif ($onetimeDump eq 'methods') {
1250 my $subname = shift;
1251 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1252 my $offset = $1 || 0;
1253 # Filename below can contain ':'
1254 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1257 local *dbline = $main::{'_<' . $file};
1258 local $^W = 0; # != 0 is magical below
1259 $had_breakpoints{$file}++;
1261 ++$i until $dbline[$i] != 0 or $i >= $max;
1262 $dbline{$i} = delete $postponed{$subname};
1264 print $OUT "Subroutine $subname not found.\n";
1268 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1269 #print $OUT "In postponed_sub for `$subname'.\n";
1273 if ($ImmediateStop) {
1277 return &postponed_sub
1278 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1279 # Cannot be done before the file is compiled
1280 local *dbline = shift;
1281 my $filename = $dbline;
1282 $filename =~ s/^_<//;
1283 $signal = 1, print $OUT "'$filename' loaded...\n"
1284 if $break_on_load{$filename};
1285 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1286 return unless $postponed_file{$filename};
1287 $had_breakpoints{$filename}++;
1288 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1290 for $key (keys %{$postponed_file{$filename}}) {
1291 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1293 delete $postponed_file{$filename};
1297 local ($savout) = select(shift);
1298 my $osingle = $single;
1299 my $otrace = $trace;
1300 $single = $trace = 0;
1303 unless (defined &main::dumpValue) {
1306 if (defined &main::dumpValue) {
1307 &main::dumpValue(shift);
1309 print $OUT "dumpvar.pl not available.\n";
1316 # Tied method do not create a context, so may get wrong message:
1320 my @sub = dump_trace($_[0] + 1, $_[1]);
1321 my $short = $_[2]; # Print short report, next one for sub name
1323 for ($i=0; $i <= $#sub; $i++) {
1326 my $args = defined $sub[$i]{args}
1327 ? "(@{ $sub[$i]{args} })"
1329 $args = (substr $args, 0, $maxtrace - 3) . '...'
1330 if length $args > $maxtrace;
1331 my $file = $sub[$i]{file};
1332 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1334 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1336 my $sub = @_ >= 4 ? $_[3] : $s;
1337 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1339 print $fh "$sub[$i]{context} = $s$args" .
1340 " called from $file" .
1341 " line $sub[$i]{line}\n";
1348 my $count = shift || 1e9;
1351 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1352 my $nothard = not $frame & 8;
1353 local $frame = 0; # Do not want to trace this.
1354 my $otrace = $trace;
1357 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1362 if (not defined $arg) {
1364 } elsif ($nothard and tied $arg) {
1366 } elsif ($nothard and $type = ref $arg) {
1367 push @a, "ref($type)";
1369 local $_ = "$arg"; # Safe to stringify now - should not call f().
1372 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1373 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1374 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1378 $context = $context ? '@' : (defined $context ? "\$" : '.');
1379 $args = $h ? [@a] : undef;
1380 $e =~ s/\n\s*\;\s*\Z// if $e;
1381 $e =~ s/([\\\'])/\\$1/g if $e;
1383 $sub = "require '$e'";
1384 } elsif (defined $r) {
1386 } elsif ($sub eq '(eval)') {
1387 $sub = "eval {...}";
1389 push(@sub, {context => $context, sub => $sub, args => $args,
1390 file => $file, line => $line});
1399 while ($action =~ s/\\$//) {
1410 &readline("cont: ");
1414 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1415 # many non-Unix systems can do system() but have problems with fork().
1416 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1417 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1418 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1419 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1421 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1422 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1423 close(SAVEIN); close(SAVEOUT);
1424 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1425 ( $? & 128 ) ? " (core dumped)" : "",
1426 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1433 local @stack = @stack; # Prevent growth by failing `use'.
1434 eval { require Term::ReadLine } or die $@;
1437 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1438 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1441 my $sel = select($OUT);
1445 eval "require Term::Rendezvous;" or die $@;
1446 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1447 my $term_rv = new Term::Rendezvous $rv;
1449 $OUT = $term_rv->OUT;
1453 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1455 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1457 $rl_attribs = $term->Attribs;
1458 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1459 if defined $rl_attribs->{basic_word_break_characters}
1460 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1461 $rl_attribs->{special_prefixes} = '$@&%';
1462 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1463 $rl_attribs->{completion_function} = \&db_complete;
1465 $LINEINFO = $OUT unless defined $LINEINFO;
1466 $lineinfo = $console unless defined $lineinfo;
1468 if ($term->Features->{setHistory} and "@hist" ne "?") {
1469 $term->SetHistory(@hist);
1471 ornaments($ornaments) if defined $ornaments;
1475 sub resetterm { # We forked, so we need a different TTY
1477 if (defined &get_fork_TTY) {
1479 } elsif (not defined $fork_TTY
1480 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1481 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1482 # Possibly _inside_ XTERM
1483 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1488 if (defined $fork_TTY) {
1493 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1494 Define B<\$DB::fork_TTY>
1495 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1496 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1497 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1498 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1505 my $left = @typeahead;
1506 my $got = shift @typeahead;
1507 print $OUT "auto(-$left)", shift, $got, "\n";
1508 $term->AddHistory($got)
1509 if length($got) > 1 and defined $term->Features->{addHistory};
1514 $term->readline(@_);
1518 my ($opt, $val)= @_;
1519 $val = option_val($opt,'N/A');
1520 $val =~ s/([\\\'])/\\$1/g;
1521 printf $OUT "%20s = '%s'\n", $opt, $val;
1525 my ($opt, $default)= @_;
1527 if (defined $optionVars{$opt}
1528 and defined $ {$optionVars{$opt}}) {
1529 $val = $ {$optionVars{$opt}};
1530 } elsif (defined $optionAction{$opt}
1531 and defined &{$optionAction{$opt}}) {
1532 $val = &{$optionAction{$opt}}();
1533 } elsif (defined $optionAction{$opt}
1534 and not defined $option{$opt}
1535 or defined $optionVars{$opt}
1536 and not defined $ {$optionVars{$opt}}) {
1539 $val = $option{$opt};
1547 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1548 my ($opt,$sep) = ($1,$2);
1551 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1553 #&dump_option($opt);
1554 } elsif ($sep !~ /\S/) {
1556 } elsif ($sep eq "=") {
1559 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1560 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1561 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1562 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1564 $val =~ s/\\([\\$end])/$1/g;
1568 grep( /^\Q$opt/ && ($option = $_), @options );
1569 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1571 print $OUT "Unknown option `$opt'\n" unless $matches;
1572 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1573 $option{$option} = $val if $matches == 1 and defined $val;
1574 eval "local \$frame = 0; local \$doret = -2;
1575 require '$optionRequire{$option}'"
1576 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1577 $ {$optionVars{$option}} = $val
1579 and defined $optionVars{$option} and defined $val;
1580 & {$optionAction{$option}} ($val)
1582 and defined $optionAction{$option}
1583 and defined &{$optionAction{$option}} and defined $val;
1584 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1590 my ($stem,@list) = @_;
1592 $ENV{"$ {stem}_n"} = @list;
1593 for $i (0 .. $#list) {
1595 $val =~ s/\\/\\\\/g;
1596 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1597 $ENV{"$ {stem}_$i"} = $val;
1604 my $n = delete $ENV{"$ {stem}_n"};
1606 for $i (0 .. $n - 1) {
1607 $val = delete $ENV{"$ {stem}_$i"};
1608 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1616 return; # Put nothing on the stack - malloc/free land!
1620 my($msg)= join("",@_);
1621 $msg .= ": $!\n" unless $msg =~ /\n$/;
1626 if (@_ and $term and $term->Features->{newTTY}) {
1627 my ($in, $out) = shift;
1629 ($in, $out) = split /,/, $in, 2;
1633 open IN, $in or die "cannot open `$in' for read: $!";
1634 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1635 $term->newTTY(\*IN, \*OUT);
1639 } elsif ($term and @_) {
1640 &warn("Too late to set TTY, enabled on next `R'!\n");
1648 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1650 $notty = shift if @_;
1656 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1663 if ($ {$term->Features}{tkRunning}) {
1664 return $term->tkRunning(@_);
1666 print $OUT "tkRunning not supported by current ReadLine package.\n";
1673 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1675 $runnonstop = shift if @_;
1682 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1689 $sh = quotemeta shift;
1690 $sh .= "\\b" if $sh =~ /\w$/;
1694 $psh =~ s/\\(.)/$1/g;
1700 if (defined $term) {
1701 local ($warnLevel,$dieLevel) = (0, 1);
1702 return '' unless $term->Features->{ornaments};
1703 eval { $term->ornaments(@_) } || '';
1711 $rc = quotemeta shift;
1712 $rc .= "\\b" if $rc =~ /\w$/;
1716 $prc =~ s/\\(.)/$1/g;
1722 return $lineinfo unless @_;
1724 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1725 $emacs = ($stream =~ /^\|/);
1726 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1727 $LINEINFO = \*LINEINFO;
1728 my $save = select($LINEINFO);
1742 s/^Term::ReadLine::readline$/readline/;
1743 if (defined $ { $_ . '::VERSION' }) {
1744 $version{$file} = "$ { $_ . '::VERSION' } from ";
1746 $version{$file} .= $INC{$file};
1748 do 'dumpvar.pl' unless defined &main::dumpValue;
1749 if (defined &main::dumpValue) {
1751 &main::dumpValue(\%version);
1753 print $OUT "dumpvar.pl not available.\n";
1760 B<s> [I<expr>] Single step [in I<expr>].
1761 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1762 <B<CR>> Repeat last B<n> or B<s> command.
1763 B<r> Return from current subroutine.
1764 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1765 at the specified position.
1766 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1767 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1768 B<l> I<line> List single I<line>.
1769 B<l> I<subname> List first window of lines from subroutine.
1770 B<l> List next window of lines.
1771 B<-> List previous window of lines.
1772 B<w> [I<line>] List window around I<line>.
1773 B<.> Return to the executed line.
1774 B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
1775 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1776 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1777 B<L> List all breakpoints and actions.
1778 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1779 B<t> Toggle trace mode.
1780 B<t> I<expr> Trace through execution of I<expr>.
1781 B<b> [I<line>] [I<condition>]
1782 Set breakpoint; I<line> defaults to the current execution line;
1783 I<condition> breaks if it evaluates to true, defaults to '1'.
1784 B<b> I<subname> [I<condition>]
1785 Set breakpoint at first line of subroutine.
1786 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1787 B<b> B<postpone> I<subname> [I<condition>]
1788 Set breakpoint at first line of subroutine after
1790 B<b> B<compile> I<subname>
1791 Stop after the subroutine is compiled.
1792 B<d> [I<line>] Delete the breakpoint for I<line>.
1793 B<D> Delete all breakpoints.
1794 B<a> [I<line>] I<command>
1795 Set an action to be done before the I<line> is executed.
1796 Sequence is: check for breakpoint/watchpoint, print line
1797 if necessary, do action, prompt user if necessary,
1799 B<A> Delete all actions.
1800 B<W> I<expr> Add a global watch-expression.
1801 B<W> Delete all watch-expressions.
1802 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1803 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1804 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1805 B<x> I<expr> Evals expression in array context, dumps the result.
1806 B<m> I<expr> Evals expression in array context, prints methods callable
1807 on the first element of the result.
1808 B<m> I<class> Prints methods callable via the given class.
1809 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1810 Set or query values of options. I<val> defaults to 1. I<opt> can
1811 be abbreviated. Several options can be listed.
1812 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1813 I<pager>: program for output of \"|cmd\";
1814 I<tkRunning>: run Tk while prompting (with ReadLine);
1815 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1816 I<inhibit_exit> Allows stepping off the end of the script.
1817 I<ImmediateStop> Debugger should stop as early as possible.
1818 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1819 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1820 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1821 I<globPrint>: whether to print contents of globs;
1822 I<DumpDBFiles>: dump arrays holding debugged files;
1823 I<DumpPackages>: dump symbol tables of packages;
1824 I<DumpReused>: dump contents of \"reused\" addresses;
1825 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1826 Option I<PrintRet> affects printing of return value after B<r> command,
1827 I<frame> affects printing messages on entry and exit from subroutines.
1828 I<AutoTrace> affects printing messages on every possible breaking point.
1829 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1830 I<ornaments> affects screen appearance of the command line.
1831 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1832 You can put additional initialization options I<TTY>, I<noTTY>,
1833 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1834 B<<> I<expr> Define Perl command to run before each prompt.
1835 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1836 B<>> I<expr> Define Perl command to run after each prompt.
1837 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1838 B<{> I<db_command> Define debugger command to run before each prompt.
1839 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1840 B<$prc> I<number> Redo a previous command (default previous command).
1841 B<$prc> I<-number> Redo number'th-to-last command.
1842 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1843 See 'B<O> I<recallCommand>' too.
1844 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1845 . ( $rc eq $sh ? "" : "
1846 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1847 See 'B<O> I<shellBang>' too.
1848 B<H> I<-number> Display last number commands (default all).
1849 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1850 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1851 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1852 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1853 I<command> Execute as a perl statement in current package.
1854 B<v> Show versions of loaded modules.
1855 B<R> Pure-man-restart of debugger, some of debugger state
1856 and command-line options may be lost.
1857 Currently the following setting are preserved:
1858 history, breakpoints and actions, debugger B<O>ptions
1859 and the following command-line options: I<-w>, I<-I>, I<-e>.
1860 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1861 B<h h> Summary of debugger commands.
1862 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1865 $summary = <<"END_SUM";
1866 I<List/search source lines:> I<Control script execution:>
1867 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1868 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1869 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1870 B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s>
1871 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1872 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1873 I<Debugger controls:> B<L> List break/watch/actions
1874 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1875 B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint
1876 B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub
1877 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1878 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1879 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1880 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1881 B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1882 B<q> or B<^D> Quit B<R> Attempt a restart
1883 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1884 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1885 B<p> I<expr> Print expression (uses script's current package).
1886 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1887 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1888 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1890 # ')}}; # Fix balance of Emacs parsing
1894 my $message = shift;
1895 if (@Term::ReadLine::TermCap::rl_term_set) {
1896 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1897 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1899 print $OUT $message;
1905 $SIG{'ABRT'} = 'DEFAULT';
1906 kill 'ABRT', $$ if $panic++;
1907 if (defined &Carp::longmess) {
1908 local $SIG{__WARN__} = '';
1909 local $Carp::CarpLevel = 2; # mydie + confess
1910 &warn(Carp::longmess("Signal @_"));
1913 print $DB::OUT "Got signal @_\n";
1921 local $SIG{__WARN__} = '';
1922 local $SIG{__DIE__} = '';
1923 eval { require Carp } if defined $^S; # If error/warning during compilation,
1924 # require may be broken.
1925 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1926 return unless defined &Carp::longmess;
1927 my ($mysingle,$mytrace) = ($single,$trace);
1928 $single = 0; $trace = 0;
1929 my $mess = Carp::longmess(@_);
1930 ($single,$trace) = ($mysingle,$mytrace);
1937 local $SIG{__DIE__} = '';
1938 local $SIG{__WARN__} = '';
1939 my $i = 0; my $ineval = 0; my $sub;
1940 if ($dieLevel > 2) {
1941 local $SIG{__WARN__} = \&dbwarn;
1942 &warn(@_); # Yell no matter what
1945 if ($dieLevel < 2) {
1946 die @_ if $^S; # in eval propagate
1948 eval { require Carp } if defined $^S; # If error/warning during compilation,
1949 # require may be broken.
1950 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1951 unless defined &Carp::longmess;
1952 # We do not want to debug this chunk (automatic disabling works
1953 # inside DB::DB, but not in Carp).
1954 my ($mysingle,$mytrace) = ($single,$trace);
1955 $single = 0; $trace = 0;
1956 my $mess = Carp::longmess(@_);
1957 ($single,$trace) = ($mysingle,$mytrace);
1963 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1966 $SIG{__WARN__} = \&DB::dbwarn;
1968 $SIG{__WARN__} = $prevwarn;
1976 $prevdie = $SIG{__DIE__} unless $dieLevel;
1979 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1980 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1981 print $OUT "Stack dump during die enabled",
1982 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1984 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1986 $SIG{__DIE__} = $prevdie;
1987 print $OUT "Default die handler restored.\n";
1995 $prevsegv = $SIG{SEGV} unless $signalLevel;
1996 $prevbus = $SIG{BUS} unless $signalLevel;
1997 $signalLevel = shift;
1999 $SIG{SEGV} = \&DB::diesignal;
2000 $SIG{BUS} = \&DB::diesignal;
2002 $SIG{SEGV} = $prevsegv;
2003 $SIG{BUS} = $prevbus;
2011 return unless defined &$subr;
2013 $subr = \&$subr; # Hard reference
2016 $s = $_, last if $subr eq \&$_;
2024 $class = ref $class if ref $class;
2027 methods_via($class, '', 1);
2028 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2033 return if $packs{$class}++;
2035 my $prepend = $prefix ? "via $prefix: " : '';
2037 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2038 sort keys %{"$ {class}::"}) {
2039 next if $seen{ $name }++;
2040 print $DB::OUT "$prepend$name\n";
2042 return unless shift; # Recurse?
2043 for $name (@{"$ {class}::ISA"}) {
2044 $prepend = $prefix ? $prefix . " -> $name" : $name;
2045 methods_via($name, $prepend, 1);
2049 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2051 BEGIN { # This does not compile, alas.
2052 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2053 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2057 $deep = 100; # warning if stack gets this deep
2061 $SIG{INT} = \&DB::catch;
2062 # This may be enabled to debug debugger:
2063 #$warnLevel = 1 unless defined $warnLevel;
2064 #$dieLevel = 1 unless defined $dieLevel;
2065 #$signalLevel = 1 unless defined $signalLevel;
2067 $db_stop = 0; # Compiler warning
2069 $level = 0; # Level of recursive debugging
2070 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2071 # Triggers bug (?) in perl is we postpone this until runtime:
2072 @postponed = @stack = (0);
2077 BEGIN {$^W = $ini_warn;} # Switch warnings back
2079 #use Carp; # This did break, left for debuggin
2082 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2083 my($text, $line, $start) = @_;
2084 my ($itext, $search, $prefix, $pack) =
2085 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2087 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2088 (map { /$search/ ? ($1) : () } keys %sub)
2089 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2090 return sort grep /^\Q$text/, values %INC # files
2091 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2092 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2093 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2094 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2095 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2097 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2099 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2100 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2101 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2102 # We may want to complete to (eval 9), so $text may be wrong
2103 $prefix = length($1) - length($text);
2106 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2108 if ((substr $text, 0, 1) eq '&') { # subroutines
2109 $text = substr $text, 1;
2111 return sort map "$prefix$_",
2114 (map { /$search/ ? ($1) : () }
2117 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2118 $pack = ($1 eq 'main' ? '' : $1) . '::';
2119 $prefix = (substr $text, 0, 1) . $1 . '::';
2122 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2123 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2124 return db_complete($out[0], $line, $start);
2128 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2129 $pack = ($package eq 'main' ? '' : $package) . '::';
2130 $prefix = substr $text, 0, 1;
2131 $text = substr $text, 1;
2132 my @out = map "$prefix$_", grep /^\Q$text/,
2133 (grep /^_?[a-zA-Z]/, keys %$pack),
2134 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2135 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2136 return db_complete($out[0], $line, $start);
2140 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2141 my @out = grep /^\Q$text/, @options;
2142 my $val = option_val($out[0], undef);
2144 if (not defined $val or $val =~ /[\n\r]/) {
2145 # Can do nothing better
2146 } elsif ($val =~ /\s/) {
2148 foreach $l (split //, qq/\"\'\#\|/) {
2149 $out = "$l$val$l ", last if (index $val, $l) == -1;
2154 # Default to value if one completion, to question if many
2155 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2158 return $term->filename_list($text); # filenames
2162 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2166 $finished = $inhibit_exit; # So that some keys may be disabled.
2167 # Do not stop in at_exit() and destructors on exit:
2168 $DB::single = !$exiting && !$runnonstop;
2169 DB::fake::at_exit() unless $exiting or $runnonstop;
2175 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2178 package DB; # Do not trace this 1; below!