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 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1186 "list context return from $sub:\n"), dumpit( \@ret ),
1187 $doret = -2 if $doret eq $#stack or $frame & 16;
1190 if (defined wantarray) {
1195 $single |= pop(@stack);
1197 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1198 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1199 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1200 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1201 "scalar context return from $sub: "), dumpit( $ret ),
1202 $doret = -2 if $doret eq $#stack or $frame & 16;
1208 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1209 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1212 # The following takes its argument via $evalarg to preserve current @_
1217 local (@stack) = @stack; # guard against recursive debugging
1218 my $otrace = $trace;
1219 my $osingle = $single;
1221 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1227 local $saved[0]; # Preserve the old value of $@
1231 } elsif ($onetimeDump eq 'dump') {
1233 } elsif ($onetimeDump eq 'methods') {
1240 my $subname = shift;
1241 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1242 my $offset = $1 || 0;
1243 # Filename below can contain ':'
1244 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1247 local *dbline = $main::{'_<' . $file};
1248 local $^W = 0; # != 0 is magical below
1249 $had_breakpoints{$file}++;
1251 ++$i until $dbline[$i] != 0 or $i >= $max;
1252 $dbline{$i} = delete $postponed{$subname};
1254 print $OUT "Subroutine $subname not found.\n";
1258 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1259 #print $OUT "In postponed_sub for `$subname'.\n";
1263 if ($ImmediateStop) {
1267 return &postponed_sub
1268 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1269 # Cannot be done before the file is compiled
1270 local *dbline = shift;
1271 my $filename = $dbline;
1272 $filename =~ s/^_<//;
1273 $signal = 1, print $OUT "'$filename' loaded...\n"
1274 if $break_on_load{$filename};
1275 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1276 return unless $postponed_file{$filename};
1277 $had_breakpoints{$filename}++;
1278 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1280 for $key (keys %{$postponed_file{$filename}}) {
1281 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1283 delete $postponed_file{$filename};
1287 local ($savout) = select($OUT);
1288 my $osingle = $single;
1289 my $otrace = $trace;
1290 $single = $trace = 0;
1293 unless (defined &main::dumpValue) {
1296 if (defined &main::dumpValue) {
1297 &main::dumpValue(shift);
1299 print $OUT "dumpvar.pl not available.\n";
1306 # Tied method do not create a context, so may get wrong message:
1310 my @sub = dump_trace($_[0] + 1, $_[1]);
1311 my $short = $_[2]; # Print short report, next one for sub name
1313 for ($i=0; $i <= $#sub; $i++) {
1316 my $args = defined $sub[$i]{args}
1317 ? "(@{ $sub[$i]{args} })"
1319 $args = (substr $args, 0, $maxtrace - 3) . '...'
1320 if length $args > $maxtrace;
1321 my $file = $sub[$i]{file};
1322 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1324 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1326 my $sub = @_ >= 4 ? $_[3] : $s;
1327 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1329 print $fh "$sub[$i]{context} = $s$args" .
1330 " called from $file" .
1331 " line $sub[$i]{line}\n";
1338 my $count = shift || 1e9;
1341 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1342 my $nothard = not $frame & 8;
1343 local $frame = 0; # Do not want to trace this.
1344 my $otrace = $trace;
1347 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1352 if (not defined $arg) {
1354 } elsif ($nothard and tied $arg) {
1356 } elsif ($nothard and $type = ref $arg) {
1357 push @a, "ref($type)";
1359 local $_ = "$arg"; # Safe to stringify now - should not call f().
1362 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1363 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1364 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1368 $context = $context ? '@' : "\$";
1369 $args = $h ? [@a] : undef;
1370 $e =~ s/\n\s*\;\s*\Z// if $e;
1371 $e =~ s/([\\\'])/\\$1/g if $e;
1373 $sub = "require '$e'";
1374 } elsif (defined $r) {
1376 } elsif ($sub eq '(eval)') {
1377 $sub = "eval {...}";
1379 push(@sub, {context => $context, sub => $sub, args => $args,
1380 file => $file, line => $line});
1389 while ($action =~ s/\\$//) {
1400 &readline("cont: ");
1404 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1405 # many non-Unix systems can do system() but have problems with fork().
1406 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1407 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1408 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1409 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1411 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1412 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1413 close(SAVEIN); close(SAVEOUT);
1414 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1415 ( $? & 128 ) ? " (core dumped)" : "",
1416 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1423 local @stack = @stack; # Prevent growth by failing `use'.
1424 eval { require Term::ReadLine } or die $@;
1427 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1428 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1431 my $sel = select($OUT);
1435 eval "require Term::Rendezvous;" or die $@;
1436 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1437 my $term_rv = new Term::Rendezvous $rv;
1439 $OUT = $term_rv->OUT;
1443 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1445 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1447 $rl_attribs = $term->Attribs;
1448 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1449 if defined $rl_attribs->{basic_word_break_characters}
1450 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1451 $rl_attribs->{special_prefixes} = '$@&%';
1452 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1453 $rl_attribs->{completion_function} = \&db_complete;
1455 $LINEINFO = $OUT unless defined $LINEINFO;
1456 $lineinfo = $console unless defined $lineinfo;
1458 if ($term->Features->{setHistory} and "@hist" ne "?") {
1459 $term->SetHistory(@hist);
1461 ornaments($ornaments) if defined $ornaments;
1465 sub resetterm { # We forked, so we need a different TTY
1467 if (defined &get_fork_TTY) {
1469 } elsif (not defined $fork_TTY
1470 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1471 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1472 # Possibly _inside_ XTERM
1473 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1478 if (defined $fork_TTY) {
1483 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1484 Define B<\$DB::fork_TTY>
1485 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1486 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1487 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1488 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1495 my $left = @typeahead;
1496 my $got = shift @typeahead;
1497 print $OUT "auto(-$left)", shift, $got, "\n";
1498 $term->AddHistory($got)
1499 if length($got) > 1 and defined $term->Features->{addHistory};
1504 $term->readline(@_);
1508 my ($opt, $val)= @_;
1509 $val = option_val($opt,'N/A');
1510 $val =~ s/([\\\'])/\\$1/g;
1511 printf $OUT "%20s = '%s'\n", $opt, $val;
1515 my ($opt, $default)= @_;
1517 if (defined $optionVars{$opt}
1518 and defined $ {$optionVars{$opt}}) {
1519 $val = $ {$optionVars{$opt}};
1520 } elsif (defined $optionAction{$opt}
1521 and defined &{$optionAction{$opt}}) {
1522 $val = &{$optionAction{$opt}}();
1523 } elsif (defined $optionAction{$opt}
1524 and not defined $option{$opt}
1525 or defined $optionVars{$opt}
1526 and not defined $ {$optionVars{$opt}}) {
1529 $val = $option{$opt};
1537 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1538 my ($opt,$sep) = ($1,$2);
1541 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1543 #&dump_option($opt);
1544 } elsif ($sep !~ /\S/) {
1546 } elsif ($sep eq "=") {
1549 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1550 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1551 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1552 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1554 $val =~ s/\\([\\$end])/$1/g;
1558 grep( /^\Q$opt/ && ($option = $_), @options );
1559 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1561 print $OUT "Unknown option `$opt'\n" unless $matches;
1562 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1563 $option{$option} = $val if $matches == 1 and defined $val;
1564 eval "local \$frame = 0; local \$doret = -2;
1565 require '$optionRequire{$option}'"
1566 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1567 $ {$optionVars{$option}} = $val
1569 and defined $optionVars{$option} and defined $val;
1570 & {$optionAction{$option}} ($val)
1572 and defined $optionAction{$option}
1573 and defined &{$optionAction{$option}} and defined $val;
1574 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1580 my ($stem,@list) = @_;
1582 $ENV{"$ {stem}_n"} = @list;
1583 for $i (0 .. $#list) {
1585 $val =~ s/\\/\\\\/g;
1586 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1587 $ENV{"$ {stem}_$i"} = $val;
1594 my $n = delete $ENV{"$ {stem}_n"};
1596 for $i (0 .. $n - 1) {
1597 $val = delete $ENV{"$ {stem}_$i"};
1598 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1606 return; # Put nothing on the stack - malloc/free land!
1610 my($msg)= join("",@_);
1611 $msg .= ": $!\n" unless $msg =~ /\n$/;
1616 if (@_ and $term and $term->Features->{newTTY}) {
1617 my ($in, $out) = shift;
1619 ($in, $out) = split /,/, $in, 2;
1623 open IN, $in or die "cannot open `$in' for read: $!";
1624 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1625 $term->newTTY(\*IN, \*OUT);
1629 } elsif ($term and @_) {
1630 &warn("Too late to set TTY, enabled on next `R'!\n");
1638 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1640 $notty = shift if @_;
1646 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1653 if ($ {$term->Features}{tkRunning}) {
1654 return $term->tkRunning(@_);
1656 print $OUT "tkRunning not supported by current ReadLine package.\n";
1663 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1665 $runnonstop = shift if @_;
1672 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1679 $sh = quotemeta shift;
1680 $sh .= "\\b" if $sh =~ /\w$/;
1684 $psh =~ s/\\(.)/$1/g;
1690 if (defined $term) {
1691 local ($warnLevel,$dieLevel) = (0, 1);
1692 return '' unless $term->Features->{ornaments};
1693 eval { $term->ornaments(@_) } || '';
1701 $rc = quotemeta shift;
1702 $rc .= "\\b" if $rc =~ /\w$/;
1706 $prc =~ s/\\(.)/$1/g;
1712 return $lineinfo unless @_;
1714 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1715 $emacs = ($stream =~ /^\|/);
1716 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1717 $LINEINFO = \*LINEINFO;
1718 my $save = select($LINEINFO);
1732 s/^Term::ReadLine::readline$/readline/;
1733 if (defined $ { $_ . '::VERSION' }) {
1734 $version{$file} = "$ { $_ . '::VERSION' } from ";
1736 $version{$file} .= $INC{$file};
1738 do 'dumpvar.pl' unless defined &main::dumpValue;
1739 if (defined &main::dumpValue) {
1741 &main::dumpValue(\%version);
1743 print $OUT "dumpvar.pl not available.\n";
1750 B<s> [I<expr>] Single step [in I<expr>].
1751 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1752 <B<CR>> Repeat last B<n> or B<s> command.
1753 B<r> Return from current subroutine.
1754 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1755 at the specified position.
1756 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1757 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1758 B<l> I<line> List single I<line>.
1759 B<l> I<subname> List first window of lines from subroutine.
1760 B<l> List next window of lines.
1761 B<-> List previous window of lines.
1762 B<w> [I<line>] List window around I<line>.
1763 B<.> Return to the executed line.
1764 B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
1765 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1766 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1767 B<L> List all breakpoints and actions.
1768 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1769 B<t> Toggle trace mode.
1770 B<t> I<expr> Trace through execution of I<expr>.
1771 B<b> [I<line>] [I<condition>]
1772 Set breakpoint; I<line> defaults to the current execution line;
1773 I<condition> breaks if it evaluates to true, defaults to '1'.
1774 B<b> I<subname> [I<condition>]
1775 Set breakpoint at first line of subroutine.
1776 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1777 B<b> B<postpone> I<subname> [I<condition>]
1778 Set breakpoint at first line of subroutine after
1780 B<b> B<compile> I<subname>
1781 Stop after the subroutine is compiled.
1782 B<d> [I<line>] Delete the breakpoint for I<line>.
1783 B<D> Delete all breakpoints.
1784 B<a> [I<line>] I<command>
1785 Set an action to be done before the I<line> is executed.
1786 Sequence is: check for breakpoint/watchpoint, print line
1787 if necessary, do action, prompt user if necessary,
1789 B<A> Delete all actions.
1790 B<W> I<expr> Add a global watch-expression.
1791 B<W> Delete all watch-expressions.
1792 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1793 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1794 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1795 B<x> I<expr> Evals expression in array context, dumps the result.
1796 B<m> I<expr> Evals expression in array context, prints methods callable
1797 on the first element of the result.
1798 B<m> I<class> Prints methods callable via the given class.
1799 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1800 Set or query values of options. I<val> defaults to 1. I<opt> can
1801 be abbreviated. Several options can be listed.
1802 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1803 I<pager>: program for output of \"|cmd\";
1804 I<tkRunning>: run Tk while prompting (with ReadLine);
1805 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1806 I<inhibit_exit> Allows stepping off the end of the script.
1807 I<ImmediateStop> Debugger should stop as early as possible.
1808 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1809 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1810 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1811 I<globPrint>: whether to print contents of globs;
1812 I<DumpDBFiles>: dump arrays holding debugged files;
1813 I<DumpPackages>: dump symbol tables of packages;
1814 I<DumpReused>: dump contents of \"reused\" addresses;
1815 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1816 Option I<PrintRet> affects printing of return value after B<r> command,
1817 I<frame> affects printing messages on entry and exit from subroutines.
1818 I<AutoTrace> affects printing messages on every possible breaking point.
1819 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1820 I<ornaments> affects screen appearance of the command line.
1821 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1822 You can put additional initialization options I<TTY>, I<noTTY>,
1823 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1824 B<<> I<expr> Define Perl command to run before each prompt.
1825 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1826 B<>> I<expr> Define Perl command to run after each prompt.
1827 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1828 B<{> I<db_command> Define debugger command to run before each prompt.
1829 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1830 B<$prc> I<number> Redo a previous command (default previous command).
1831 B<$prc> I<-number> Redo number'th-to-last command.
1832 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1833 See 'B<O> I<recallCommand>' too.
1834 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1835 . ( $rc eq $sh ? "" : "
1836 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1837 See 'B<O> I<shellBang>' too.
1838 B<H> I<-number> Display last number commands (default all).
1839 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1840 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1841 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1842 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1843 I<command> Execute as a perl statement in current package.
1844 B<v> Show versions of loaded modules.
1845 B<R> Pure-man-restart of debugger, some of debugger state
1846 and command-line options may be lost.
1847 Currently the following setting are preserved:
1848 history, breakpoints and actions, debugger B<O>ptions
1849 and the following command-line options: I<-w>, I<-I>, I<-e>.
1850 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1851 B<h h> Summary of debugger commands.
1852 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1855 $summary = <<"END_SUM";
1856 I<List/search source lines:> I<Control script execution:>
1857 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1858 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1859 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1860 B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s>
1861 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1862 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1863 I<Debugger controls:> B<L> List break/watch/actions
1864 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1865 B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint
1866 B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub
1867 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1868 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1869 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1870 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1871 B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1872 B<q> or B<^D> Quit B<R> Attempt a restart
1873 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1874 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1875 B<p> I<expr> Print expression (uses script's current package).
1876 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1877 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1878 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1880 # ')}}; # Fix balance of Emacs parsing
1884 my $message = shift;
1885 if (@Term::ReadLine::TermCap::rl_term_set) {
1886 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1887 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1889 print $OUT $message;
1895 $SIG{'ABRT'} = 'DEFAULT';
1896 kill 'ABRT', $$ if $panic++;
1897 if (defined &Carp::longmess) {
1898 local $SIG{__WARN__} = '';
1899 local $Carp::CarpLevel = 2; # mydie + confess
1900 &warn(Carp::longmess("Signal @_"));
1903 print $DB::OUT "Got signal @_\n";
1911 local $SIG{__WARN__} = '';
1912 local $SIG{__DIE__} = '';
1913 eval { require Carp } if defined $^S; # If error/warning during compilation,
1914 # require may be broken.
1915 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1916 return unless defined &Carp::longmess;
1917 my ($mysingle,$mytrace) = ($single,$trace);
1918 $single = 0; $trace = 0;
1919 my $mess = Carp::longmess(@_);
1920 ($single,$trace) = ($mysingle,$mytrace);
1927 local $SIG{__DIE__} = '';
1928 local $SIG{__WARN__} = '';
1929 my $i = 0; my $ineval = 0; my $sub;
1930 if ($dieLevel > 2) {
1931 local $SIG{__WARN__} = \&dbwarn;
1932 &warn(@_); # Yell no matter what
1935 if ($dieLevel < 2) {
1936 die @_ if $^S; # in eval propagate
1938 eval { require Carp } if defined $^S; # If error/warning during compilation,
1939 # require may be broken.
1940 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1941 unless defined &Carp::longmess;
1942 # We do not want to debug this chunk (automatic disabling works
1943 # inside DB::DB, but not in Carp).
1944 my ($mysingle,$mytrace) = ($single,$trace);
1945 $single = 0; $trace = 0;
1946 my $mess = Carp::longmess(@_);
1947 ($single,$trace) = ($mysingle,$mytrace);
1953 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1956 $SIG{__WARN__} = \&DB::dbwarn;
1958 $SIG{__WARN__} = $prevwarn;
1966 $prevdie = $SIG{__DIE__} unless $dieLevel;
1969 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1970 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1971 print $OUT "Stack dump during die enabled",
1972 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1974 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1976 $SIG{__DIE__} = $prevdie;
1977 print $OUT "Default die handler restored.\n";
1985 $prevsegv = $SIG{SEGV} unless $signalLevel;
1986 $prevbus = $SIG{BUS} unless $signalLevel;
1987 $signalLevel = shift;
1989 $SIG{SEGV} = \&DB::diesignal;
1990 $SIG{BUS} = \&DB::diesignal;
1992 $SIG{SEGV} = $prevsegv;
1993 $SIG{BUS} = $prevbus;
2001 return unless defined &$subr;
2003 $subr = \&$subr; # Hard reference
2006 $s = $_, last if $subr eq \&$_;
2014 $class = ref $class if ref $class;
2017 methods_via($class, '', 1);
2018 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2023 return if $packs{$class}++;
2025 my $prepend = $prefix ? "via $prefix: " : '';
2027 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2028 sort keys %{"$ {class}::"}) {
2029 next if $seen{ $name }++;
2030 print $DB::OUT "$prepend$name\n";
2032 return unless shift; # Recurse?
2033 for $name (@{"$ {class}::ISA"}) {
2034 $prepend = $prefix ? $prefix . " -> $name" : $name;
2035 methods_via($name, $prepend, 1);
2039 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2041 BEGIN { # This does not compile, alas.
2042 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2043 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2047 $deep = 100; # warning if stack gets this deep
2051 $SIG{INT} = \&DB::catch;
2052 # This may be enabled to debug debugger:
2053 #$warnLevel = 1 unless defined $warnLevel;
2054 #$dieLevel = 1 unless defined $dieLevel;
2055 #$signalLevel = 1 unless defined $signalLevel;
2057 $db_stop = 0; # Compiler warning
2059 $level = 0; # Level of recursive debugging
2060 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2061 # Triggers bug (?) in perl is we postpone this until runtime:
2062 @postponed = @stack = (0);
2067 BEGIN {$^W = $ini_warn;} # Switch warnings back
2069 #use Carp; # This did break, left for debuggin
2072 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2073 my($text, $line, $start) = @_;
2074 my ($itext, $search, $prefix, $pack) =
2075 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2077 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2078 (map { /$search/ ? ($1) : () } keys %sub)
2079 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2080 return sort grep /^\Q$text/, values %INC # files
2081 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2082 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2083 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2084 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2085 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2087 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2089 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2090 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2091 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2092 # We may want to complete to (eval 9), so $text may be wrong
2093 $prefix = length($1) - length($text);
2096 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2098 if ((substr $text, 0, 1) eq '&') { # subroutines
2099 $text = substr $text, 1;
2101 return sort map "$prefix$_",
2104 (map { /$search/ ? ($1) : () }
2107 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2108 $pack = ($1 eq 'main' ? '' : $1) . '::';
2109 $prefix = (substr $text, 0, 1) . $1 . '::';
2112 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2113 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2114 return db_complete($out[0], $line, $start);
2118 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2119 $pack = ($package eq 'main' ? '' : $package) . '::';
2120 $prefix = substr $text, 0, 1;
2121 $text = substr $text, 1;
2122 my @out = map "$prefix$_", grep /^\Q$text/,
2123 (grep /^_?[a-zA-Z]/, keys %$pack),
2124 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2125 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2126 return db_complete($out[0], $line, $start);
2130 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2131 my @out = grep /^\Q$text/, @options;
2132 my $val = option_val($out[0], undef);
2134 if (not defined $val or $val =~ /[\n\r]/) {
2135 # Can do nothing better
2136 } elsif ($val =~ /\s/) {
2138 foreach $l (split //, qq/\"\'\#\|/) {
2139 $out = "$l$val$l ", last if (index $val, $l) == -1;
2144 # Default to value if one completion, to question if many
2145 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2148 return $term->filename_list($text); # filenames
2152 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2156 $finished = $inhibit_exit; # So that some keys may be disabled.
2157 # Do not stop in at_exit() and destructors on exit:
2158 $DB::single = !$exiting && !$runnonstop;
2159 DB::fake::at_exit() unless $exiting or $runnonstop;
2165 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2168 package DB; # Do not trace this 1; below!