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
182 ImmediateStop bareStringify);
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,
194 bareStringify => \$dumpvar::bareStringify,
196 AutoTrace => \$trace,
197 inhibit_exit => \$inhibit_exit,
198 maxTraceLen => \$maxtrace,
199 ImmediateStop => \$ImmediateStop,
203 compactDump => \&dumpvar::compactDump,
204 veryCompact => \&dumpvar::veryCompact,
205 quote => \&dumpvar::quote,
208 ReadLine => \&ReadLine,
209 NonStop => \&NonStop,
210 LineInfo => \&LineInfo,
211 recallCommand => \&recallCommand,
212 ShellBang => \&shellBang,
214 signalLevel => \&signalLevel,
215 warnLevel => \&warnLevel,
216 dieLevel => \&dieLevel,
217 tkRunning => \&tkRunning,
218 ornaments => \&ornaments,
222 compactDump => 'dumpvar.pl',
223 veryCompact => 'dumpvar.pl',
224 quote => 'dumpvar.pl',
227 # These guys may be defined in $ENV{PERL5DB} :
228 $rl = 1 unless defined $rl;
229 $warnLevel = 1 unless defined $warnLevel;
230 $dieLevel = 1 unless defined $dieLevel;
231 $signalLevel = 1 unless defined $signalLevel;
232 $pre = [] unless defined $pre;
233 $post = [] unless defined $post;
234 $pretype = [] unless defined $pretype;
235 warnLevel($warnLevel);
237 signalLevel($signalLevel);
238 &pager((defined($ENV{PAGER})
242 : 'more'))) unless defined $pager;
243 &recallCommand("!") unless defined $prc;
244 &shellBang("!") unless defined $psh;
245 $maxtrace = 400 unless defined $maxtrace;
250 $rcfile="perldb.ini";
255 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
256 do "$ENV{LOGDIR}/$rcfile";
257 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
258 do "$ENV{HOME}/$rcfile";
261 if (defined $ENV{PERLDB_OPTS}) {
262 parse_options($ENV{PERLDB_OPTS});
265 if (exists $ENV{PERLDB_RESTART}) {
266 delete $ENV{PERLDB_RESTART};
268 @hist = get_list('PERLDB_HIST');
269 %break_on_load = get_list("PERLDB_ON_LOAD");
270 %postponed = get_list("PERLDB_POSTPONE");
271 my @had_breakpoints= get_list("PERLDB_VISITED");
272 for (0 .. $#had_breakpoints) {
273 my %pf = get_list("PERLDB_FILE_$_");
274 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
276 my %opt = get_list("PERLDB_OPT");
278 while (($opt,$val) = each %opt) {
279 $val =~ s/[\\\']/\\$1/g;
280 parse_options("$opt'$val'");
282 @INC = get_list("PERLDB_INC");
284 $pretype = [get_list("PERLDB_PRETYPE")];
285 $pre = [get_list("PERLDB_PRE")];
286 $post = [get_list("PERLDB_POST")];
287 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
293 # Is Perl being run from Emacs?
294 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
295 $rl = 0, shift(@main::ARGV) if $emacs;
297 #require Term::ReadLine;
300 $console = "/dev/tty";
301 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
304 $console = "sys\$command";
307 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
312 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
316 $console = $tty if defined $tty;
318 if (defined $console) {
319 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
320 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
321 || open(OUT,">&STDOUT"); # so we don't dongle stdout
324 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
325 $console = 'STDIN/OUT';
327 # so open("|more") can read from STDOUT and so we don't dingle stdin
332 $| = 1; # for DB::OUT
335 $LINEINFO = $OUT unless defined $LINEINFO;
336 $lineinfo = $console unless defined $lineinfo;
338 $| = 1; # for real STDOUT
340 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
341 unless ($runnonstop) {
342 print $OUT "\nLoading DB routines from $header\n";
343 print $OUT ("Emacs support ",
344 $emacs ? "enabled" : "available",
346 print $OUT "\nEnter h or `h h' for help.\n\n";
353 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
356 if (defined &afterinit) { # May be defined in $rcfile
362 ############################################################ Subroutines
365 # _After_ the perl program is compiled, $single is set to 1:
366 if ($single and not $second_time++) {
367 if ($runnonstop) { # Disable until signal
368 for ($i=0; $i <= $stack_depth; ) {
372 # return; # Would not print trace!
373 } elsif ($ImmediateStop) {
378 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
380 ($package, $filename, $line) = caller;
381 $filename_ini = $filename;
382 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
383 "package $package;"; # this won't let them modify, alas
384 local(*dbline) = $main::{'_<' . $filename};
386 if (($stop,$action) = split(/\0/,$dbline{$line})) {
390 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
391 $dbline{$line} =~ s/;9($|\0)/$1/;
394 my $was_signal = $signal;
396 for (my $n = 0; $n <= $#to_watch; $n++) {
397 $evalarg = $to_watch[$n];
398 local $onetimeDump; # Do not output results
399 my ($val) = &eval; # Fix context (&eval is doing array)?
400 $val = ( (defined $val) ? "'$val'" : 'undef' );
401 if ($val ne $old_watch[$n]) {
404 Watchpoint $n:\t$to_watch[$n] changed:
405 old value:\t$old_watch[$n]
408 $old_watch[$n] = $val;
412 if ($trace & 4) { # User-installed watch
413 return if watchfunction($package, $filename, $line)
414 and not $single and not $was_signal and not ($trace & ~4);
416 $was_signal = $signal;
418 if ($single || ($trace & 1) || $was_signal) {
420 $position = "\032\032$filename:$line:0\n";
421 print $LINEINFO $position;
422 } elsif ($package eq 'DB::fake') {
425 Debugged program terminated. Use B<q> to quit or B<R> to restart,
426 use B<O> I<inhibit_exit> to avoid stopping after program termination,
427 B<h q>, B<h R> or B<h O> to get additional info.
430 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
431 "package $package;"; # this won't let them modify, alas
434 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
435 $prefix .= "$sub($filename:";
436 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
437 if (length($prefix) > 30) {
438 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
443 $position = "$prefix$line$infix$dbline[$line]$after";
446 print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
448 print $LINEINFO $position;
450 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
451 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
453 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
454 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
455 $position .= $incr_pos;
457 print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
459 print $LINEINFO $incr_pos;
464 $evalarg = $action, &eval if $action;
465 if ($single || $was_signal) {
466 local $level = $level + 1;
467 foreach $evalarg (@$pre) {
470 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
473 $incr = -1; # for backward motion.
474 @typeahead = @$pretype, @typeahead;
476 while (($term || &setterm),
477 ($term_pid == $$ or &resetterm),
478 defined ($cmd=&readline(" DB" . ('<' x $level) .
479 ($#hist+1) . ('>' x $level) .
483 $cmd =~ s/\\$/\n/ && do {
484 $cmd .= &readline(" cont: ");
487 $cmd =~ /^$/ && ($cmd = $laststep);
488 push(@hist,$cmd) if length($cmd) > 1;
490 ($i) = split(/\s+/,$cmd);
491 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
492 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
493 $cmd =~ /^h$/ && do {
496 $cmd =~ /^h\s+h$/ && do {
497 print_help($summary);
499 $cmd =~ /^h\s+(\S)$/ && do {
501 if ($help =~ /^(?:[IB]<)$asked/m) {
502 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
506 print_help("B<$asked> is not a debugger command.\n");
509 $cmd =~ /^t$/ && do {
510 ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
511 print $OUT "Trace = " .
512 (($trace & 1) ? "on" : "off" ) . "\n";
514 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
515 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
516 foreach $subname (sort(keys %sub)) {
517 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
518 print $OUT $subname,"\n";
522 $cmd =~ /^v$/ && do {
523 list_versions(); next CMD};
524 $cmd =~ s/^X\b/V $package/;
525 $cmd =~ /^V$/ && do {
526 $cmd = "V $package"; };
527 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
528 local ($savout) = select($OUT);
530 @vars = split(' ',$2);
531 do 'dumpvar.pl' unless defined &main::dumpvar;
532 if (defined &main::dumpvar) {
535 &main::dumpvar($packname,@vars);
537 print $OUT "dumpvar.pl not available.\n";
541 $cmd =~ s/^x\b/ / && do { # So that will be evaled
542 $onetimeDump = 'dump'; };
543 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
544 methods($1); next CMD};
545 $cmd =~ s/^m\b/ / && do { # So this will be evaled
546 $onetimeDump = 'methods'; };
547 $cmd =~ /^f\b\s*(.*)/ && do {
551 print $OUT "The old f command is now the r command.\n";
552 print $OUT "The new f command switches filenames.\n";
555 if (!defined $main::{'_<' . $file}) {
556 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
557 $try = substr($try,2);
558 print $OUT "Choosing $try matching `$file':\n";
562 if (!defined $main::{'_<' . $file}) {
563 print $OUT "No file matching `$file' is loaded.\n";
565 } elsif ($file ne $filename) {
566 *dbline = $main::{'_<' . $file};
572 print $OUT "Already in $file.\n";
576 $cmd =~ s/^l\s+-\s*$/-/;
577 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
579 $subname =~ s/\'/::/;
580 $subname = $package."::".$subname
581 unless $subname =~ /::/;
582 $subname = "main".$subname if substr($subname,0,2) eq "::";
583 @pieces = split(/:/,find_sub($subname));
584 $subrange = pop @pieces;
585 $file = join(':', @pieces);
586 if ($file ne $filename) {
587 *dbline = $main::{'_<' . $file};
592 if (eval($subrange) < -$window) {
593 $subrange =~ s/-.*/+/;
595 $cmd = "l $subrange";
597 print $OUT "Subroutine $subname not found.\n";
600 $cmd =~ /^\.$/ && do {
601 $incr = -1; # for backward motion.
603 $filename = $filename_ini;
604 *dbline = $main::{'_<' . $filename};
606 print $LINEINFO $position;
608 $cmd =~ /^w\b\s*(\d*)$/ && do {
612 #print $OUT 'l ' . $start . '-' . ($start + $incr);
613 $cmd = 'l ' . $start . '-' . ($start + $incr); };
614 $cmd =~ /^-$/ && do {
615 $start -= $incr + $window + 1;
616 $start = 1 if $start <= 0;
618 $cmd = 'l ' . ($start) . '+'; };
619 $cmd =~ /^l$/ && do {
621 $cmd = 'l ' . $start . '-' . ($start + $incr); };
622 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
625 $incr = $window - 1 unless $incr;
626 $cmd = 'l ' . $start . '-' . ($start + $incr); };
627 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
628 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
629 $end = $max if $end > $max;
631 $i = $line if $i eq '.';
635 print $OUT "\032\032$filename:$i:0\n";
638 for (; $i <= $end; $i++) {
639 ($stop,$action) = split(/\0/, $dbline{$i});
641 and $filename eq $filename_ini)
643 : ($dbline[$i]+0 ? ':' : ' ') ;
644 $arrow .= 'b' if $stop;
645 $arrow .= 'a' if $action;
646 print $OUT "$i$arrow\t", $dbline[$i];
647 $i++, last if $signal;
649 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
651 $start = $i; # remember in case they want more
652 $start = $max if $start > $max;
654 $cmd =~ /^D$/ && do {
655 print $OUT "Deleting all breakpoints...\n";
657 for $file (keys %had_breakpoints) {
658 local *dbline = $main::{'_<' . $file};
662 for ($i = 1; $i <= $max ; $i++) {
663 if (defined $dbline{$i}) {
664 $dbline{$i} =~ s/^[^\0]+//;
665 if ($dbline{$i} =~ s/^\0?$//) {
672 undef %postponed_file;
673 undef %break_on_load;
674 undef %had_breakpoints;
676 $cmd =~ /^L$/ && do {
678 for $file (keys %had_breakpoints) {
679 local *dbline = $main::{'_<' . $file};
683 for ($i = 1; $i <= $max; $i++) {
684 if (defined $dbline{$i}) {
685 print "$file:\n" unless $was++;
686 print $OUT " $i:\t", $dbline[$i];
687 ($stop,$action) = split(/\0/, $dbline{$i});
688 print $OUT " break if (", $stop, ")\n"
690 print $OUT " action: ", $action, "\n"
697 print $OUT "Postponed breakpoints in subroutines:\n";
699 for $subname (keys %postponed) {
700 print $OUT " $subname\t$postponed{$subname}\n";
704 my @have = map { # Combined keys
705 keys %{$postponed_file{$_}}
706 } keys %postponed_file;
708 print $OUT "Postponed breakpoints in files:\n";
710 for $file (keys %postponed_file) {
711 my $db = $postponed_file{$file};
712 print $OUT " $file:\n";
713 for $line (sort {$a <=> $b} keys %$db) {
714 print $OUT " $line:\n";
715 my ($stop,$action) = split(/\0/, $$db{$line});
716 print $OUT " break if (", $stop, ")\n"
718 print $OUT " action: ", $action, "\n"
725 if (%break_on_load) {
726 print $OUT "Breakpoints on load:\n";
728 for $file (keys %break_on_load) {
729 print $OUT " $file\n";
734 print $OUT "Watch-expressions:\n";
736 for $expr (@to_watch) {
737 print $OUT " $expr\n";
742 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
743 my $file = $1; $file =~ s/\s+$//;
745 $break_on_load{$file} = 1;
746 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
747 $file .= '.pm', redo unless $file =~ /\./;
749 $had_breakpoints{$file} = 1;
750 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
752 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
753 my $cond = $3 || '1';
754 my ($subname, $break) = ($2, $1 eq 'postpone');
755 $subname =~ s/\'/::/;
756 $subname = "${'package'}::" . $subname
757 unless $subname =~ /::/;
758 $subname = "main".$subname if substr($subname,0,2) eq "::";
759 $postponed{$subname} = $break
760 ? "break +0 if $cond" : "compile";
762 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
765 $subname =~ s/\'/::/;
766 $subname = "${'package'}::" . $subname
767 unless $subname =~ /::/;
768 $subname = "main".$subname if substr($subname,0,2) eq "::";
769 # Filename below can contain ':'
770 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
774 *dbline = $main::{'_<' . $filename};
775 $had_breakpoints{$filename} = 1;
777 ++$i while $dbline[$i] == 0 && $i < $max;
778 $dbline{$i} =~ s/^[^\0]*/$cond/;
780 print $OUT "Subroutine $subname not found.\n";
783 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
786 if ($dbline[$i] == 0) {
787 print $OUT "Line $i not breakable.\n";
789 $had_breakpoints{$filename} = 1;
790 $dbline{$i} =~ s/^[^\0]*/$cond/;
793 $cmd =~ /^d\b\s*(\d+)?/ && do {
795 $dbline{$i} =~ s/^[^\0]*//;
796 delete $dbline{$i} if $dbline{$i} eq '';
798 $cmd =~ /^A$/ && do {
800 for $file (keys %had_breakpoints) {
801 local *dbline = $main::{'_<' . $file};
805 for ($i = 1; $i <= $max ; $i++) {
806 if (defined $dbline{$i}) {
807 $dbline{$i} =~ s/\0[^\0]*//;
808 delete $dbline{$i} if $dbline{$i} eq '';
813 $cmd =~ /^O\s*$/ && do {
818 $cmd =~ /^O\s*(\S.*)/ && do {
821 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
822 push @$pre, action($1);
824 $cmd =~ /^>>\s*(.*)/ && do {
825 push @$post, action($1);
827 $cmd =~ /^<\s*(.*)/ && do {
828 $pre = [], next CMD unless $1;
831 $cmd =~ /^>\s*(.*)/ && do {
832 $post = [], next CMD unless $1;
833 $post = [action($1)];
835 $cmd =~ /^\{\{\s*(.*)/ && do {
838 $cmd =~ /^\{\s*(.*)/ && do {
839 $pretype = [], next CMD unless $1;
842 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
844 if ($dbline[$i] == 0) {
845 print $OUT "Line $i may not have an action.\n";
847 $dbline{$i} =~ s/\0[^\0]*//;
848 $dbline{$i} .= "\0" . action($j);
851 $cmd =~ /^n$/ && do {
852 end_report(), next CMD if $finished and $level <= 1;
856 $cmd =~ /^s$/ && do {
857 end_report(), next CMD if $finished and $level <= 1;
861 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
862 end_report(), next CMD if $finished and $level <= 1;
864 if ($i =~ /\D/) { # subroutine name
865 $subname = $package."::".$subname
866 unless $subname =~ /::/;
867 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
871 *dbline = $main::{'_<' . $filename};
872 $had_breakpoints{$filename}++;
874 ++$i while $dbline[$i] == 0 && $i < $max;
876 print $OUT "Subroutine $subname not found.\n";
881 if ($dbline[$i] == 0) {
882 print $OUT "Line $i not breakable.\n";
885 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
887 for ($i=0; $i <= $stack_depth; ) {
891 $cmd =~ /^r$/ && do {
892 end_report(), next CMD if $finished and $level <= 1;
893 $stack[$stack_depth] |= 1;
894 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
896 $cmd =~ /^R$/ && do {
897 print $OUT "Warning: some settings and command-line options may be lost!\n";
898 my (@script, @flags, $cl);
899 push @flags, '-w' if $ini_warn;
900 # Put all the old includes at the start to get
903 push @flags, '-I', $_;
905 # Arrange for setting the old INC:
906 set_list("PERLDB_INC", @ini_INC);
908 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
909 chomp ($cl = $ {'::_<-e'}[$_]);
910 push @script, '-e', $cl;
915 set_list("PERLDB_HIST",
916 $term->Features->{getHistory}
917 ? $term->GetHistory : @hist);
918 my @had_breakpoints = keys %had_breakpoints;
919 set_list("PERLDB_VISITED", @had_breakpoints);
920 set_list("PERLDB_OPT", %option);
921 set_list("PERLDB_ON_LOAD", %break_on_load);
923 for (0 .. $#had_breakpoints) {
924 my $file = $had_breakpoints[$_];
925 *dbline = $main::{'_<' . $file};
926 next unless %dbline or $postponed_file{$file};
927 (push @hard, $file), next
928 if $file =~ /^\(eval \d+\)$/;
930 @add = %{$postponed_file{$file}}
931 if $postponed_file{$file};
932 set_list("PERLDB_FILE_$_", %dbline, @add);
934 for (@hard) { # Yes, really-really...
935 # Find the subroutines in this eval
936 *dbline = $main::{'_<' . $_};
937 my ($quoted, $sub, %subs, $line) = quotemeta $_;
938 for $sub (keys %sub) {
939 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
940 $subs{$sub} = [$1, $2];
944 "No subroutines in $_, ignoring breakpoints.\n";
947 LINES: for $line (keys %dbline) {
948 # One breakpoint per sub only:
949 my ($offset, $sub, $found);
950 SUBS: for $sub (keys %subs) {
951 if ($subs{$sub}->[1] >= $line # Not after the subroutine
952 and (not defined $offset # Not caught
953 or $offset < 0 )) { # or badly caught
955 $offset = $line - $subs{$sub}->[0];
956 $offset = "+$offset", last SUBS if $offset >= 0;
959 if (defined $offset) {
961 "break $offset if $dbline{$line}";
963 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
967 set_list("PERLDB_POSTPONE", %postponed);
968 set_list("PERLDB_PRETYPE", @$pretype);
969 set_list("PERLDB_PRE", @$pre);
970 set_list("PERLDB_POST", @$post);
971 set_list("PERLDB_TYPEAHEAD", @typeahead);
972 $ENV{PERLDB_RESTART} = 1;
973 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
974 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
975 print $OUT "exec failed: $!\n";
977 $cmd =~ /^T$/ && do {
978 print_trace($OUT, 1); # skip DB
980 $cmd =~ /^W\s*$/ && do {
982 @to_watch = @old_watch = ();
984 $cmd =~ /^W\b\s*(.*)/s && do {
988 $val = (defined $val) ? "'$val'" : 'undef' ;
989 push @old_watch, $val;
992 $cmd =~ /^\/(.*)$/ && do {
994 $inpat =~ s:([^\\])/$:$1:;
996 eval '$inpat =~ m'."\a$inpat\a";
1008 $start = 1 if ($start > $max);
1009 last if ($start == $end);
1010 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1012 print $OUT "\032\032$filename:$start:0\n";
1014 print $OUT "$start:\t", $dbline[$start], "\n";
1019 print $OUT "/$pat/: not found\n" if ($start == $end);
1021 $cmd =~ /^\?(.*)$/ && do {
1023 $inpat =~ s:([^\\])\?$:$1:;
1025 eval '$inpat =~ m'."\a$inpat\a";
1037 $start = $max if ($start <= 0);
1038 last if ($start == $end);
1039 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1041 print $OUT "\032\032$filename:$start:0\n";
1043 print $OUT "$start:\t", $dbline[$start], "\n";
1048 print $OUT "?$pat?: not found\n" if ($start == $end);
1050 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1051 pop(@hist) if length($cmd) > 1;
1052 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1056 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1059 $cmd =~ /^$rc([^$rc].*)$/ && do {
1061 pop(@hist) if length($cmd) > 1;
1062 for ($i = $#hist; $i; --$i) {
1063 last if $hist[$i] =~ /$pat/;
1066 print $OUT "No such command!\n\n";
1072 $cmd =~ /^$sh$/ && do {
1073 &system($ENV{SHELL}||"/bin/sh");
1075 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1076 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1078 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1079 $end = $2?($#hist-$2):0;
1080 $hist = 0 if $hist < 0;
1081 for ($i=$#hist; $i>$end; $i--) {
1082 print $OUT "$i: ",$hist[$i],"\n"
1083 unless $hist[$i] =~ /^.?$/;
1086 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1087 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1088 $cmd =~ /^=/ && do {
1089 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1090 $alias{$k}="s~$k~$v~";
1091 print $OUT "$k = $v\n";
1092 } elsif ($cmd =~ /^=\s*$/) {
1093 foreach $k (sort keys(%alias)) {
1094 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1095 print $OUT "$k = $v\n";
1097 print $OUT "$k\t$alias{$k}\n";
1102 $cmd =~ /^\|\|?\s*[^|]/ && do {
1103 if ($pager =~ /^\|/) {
1104 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1105 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1107 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1109 unless ($piped=open(OUT,$pager)) {
1110 &warn("Can't pipe output to `$pager'");
1111 if ($pager =~ /^\|/) {
1112 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1113 open(STDOUT,">&SAVEOUT")
1114 || &warn("Can't restore STDOUT");
1117 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1121 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1122 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1123 $selected= select(OUT);
1125 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1126 $cmd =~ s/^\|+\s*//;
1128 # XXX Local variants do not work!
1129 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1130 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1131 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1133 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1135 $onetimeDump = undef;
1136 } elsif ($term_pid == $$) {
1141 if ($pager =~ /^\|/) {
1142 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1143 &warn( "Pager `$pager' failed: ",
1144 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1145 ( $? & 128 ) ? " (core dumped)" : "",
1146 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1147 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1148 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1149 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1150 # Will stop ignoring SIGPIPE if done like nohup(1)
1151 # does SIGINT but Perl doesn't give us a choice.
1153 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1156 select($selected), $selected= "" unless $selected eq "";
1160 $exiting = 1 unless defined $cmd;
1161 foreach $evalarg (@$post) {
1164 } # if ($single || $signal)
1165 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1169 # The following code may be executed now:
1173 my ($al, $ret, @ret) = "";
1174 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1177 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1178 $#stack = $stack_depth;
1179 $stack[-1] = $single;
1181 $single |= 4 if $stack_depth == $deep;
1183 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
1184 # Why -1? But it works! :-(
1185 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1186 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1189 $single |= $stack[$stack_depth--];
1191 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1192 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1193 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1194 if ($doret eq $stack_depth or $frame & 16) {
1195 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1196 print $fh ' ' x $stack_depth if $frame & 16;
1197 print $fh "list context return from $sub:\n";
1198 dumpit($fh, \@ret );
1203 if (defined wantarray) {
1208 $single |= $stack[$stack_depth--];
1210 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1211 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1212 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1213 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1214 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1215 print $fh (' ' x $stack_depth) if $frame & 16;
1216 print $fh (defined wantarray
1217 ? "scalar context return from $sub: "
1218 : "void context return from $sub\n");
1219 dumpit( $fh, $ret ) if defined wantarray;
1227 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1228 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1231 # The following takes its argument via $evalarg to preserve current @_
1236 my $otrace = $trace;
1237 my $osingle = $single;
1239 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1245 local $saved[0]; # Preserve the old value of $@
1249 } elsif ($onetimeDump eq 'dump') {
1250 dumpit($OUT, \@res);
1251 } elsif ($onetimeDump eq 'methods') {
1258 my $subname = shift;
1259 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1260 my $offset = $1 || 0;
1261 # Filename below can contain ':'
1262 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1265 local *dbline = $main::{'_<' . $file};
1266 local $^W = 0; # != 0 is magical below
1267 $had_breakpoints{$file}++;
1269 ++$i until $dbline[$i] != 0 or $i >= $max;
1270 $dbline{$i} = delete $postponed{$subname};
1272 print $OUT "Subroutine $subname not found.\n";
1276 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1277 #print $OUT "In postponed_sub for `$subname'.\n";
1281 if ($ImmediateStop) {
1285 return &postponed_sub
1286 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1287 # Cannot be done before the file is compiled
1288 local *dbline = shift;
1289 my $filename = $dbline;
1290 $filename =~ s/^_<//;
1291 $signal = 1, print $OUT "'$filename' loaded...\n"
1292 if $break_on_load{$filename};
1293 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1294 return unless $postponed_file{$filename};
1295 $had_breakpoints{$filename}++;
1296 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1298 for $key (keys %{$postponed_file{$filename}}) {
1299 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1301 delete $postponed_file{$filename};
1305 local ($savout) = select(shift);
1306 my $osingle = $single;
1307 my $otrace = $trace;
1308 $single = $trace = 0;
1311 unless (defined &main::dumpValue) {
1314 if (defined &main::dumpValue) {
1315 &main::dumpValue(shift);
1317 print $OUT "dumpvar.pl not available.\n";
1324 # Tied method do not create a context, so may get wrong message:
1328 my @sub = dump_trace($_[0] + 1, $_[1]);
1329 my $short = $_[2]; # Print short report, next one for sub name
1331 for ($i=0; $i <= $#sub; $i++) {
1334 my $args = defined $sub[$i]{args}
1335 ? "(@{ $sub[$i]{args} })"
1337 $args = (substr $args, 0, $maxtrace - 3) . '...'
1338 if length $args > $maxtrace;
1339 my $file = $sub[$i]{file};
1340 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1342 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1344 my $sub = @_ >= 4 ? $_[3] : $s;
1345 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1347 print $fh "$sub[$i]{context} = $s$args" .
1348 " called from $file" .
1349 " line $sub[$i]{line}\n";
1356 my $count = shift || 1e9;
1359 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1360 my $nothard = not $frame & 8;
1361 local $frame = 0; # Do not want to trace this.
1362 my $otrace = $trace;
1365 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1370 if (not defined $arg) {
1372 } elsif ($nothard and tied $arg) {
1374 } elsif ($nothard and $type = ref $arg) {
1375 push @a, "ref($type)";
1377 local $_ = "$arg"; # Safe to stringify now - should not call f().
1380 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1381 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1382 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1386 $context = $context ? '@' : (defined $context ? "\$" : '.');
1387 $args = $h ? [@a] : undef;
1388 $e =~ s/\n\s*\;\s*\Z// if $e;
1389 $e =~ s/([\\\'])/\\$1/g if $e;
1391 $sub = "require '$e'";
1392 } elsif (defined $r) {
1394 } elsif ($sub eq '(eval)') {
1395 $sub = "eval {...}";
1397 push(@sub, {context => $context, sub => $sub, args => $args,
1398 file => $file, line => $line});
1407 while ($action =~ s/\\$//) {
1418 &readline("cont: ");
1422 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1423 # many non-Unix systems can do system() but have problems with fork().
1424 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1425 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1426 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1427 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1429 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1430 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1431 close(SAVEIN); close(SAVEOUT);
1432 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1433 ( $? & 128 ) ? " (core dumped)" : "",
1434 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1441 eval { require Term::ReadLine } or die $@;
1444 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1445 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1448 my $sel = select($OUT);
1452 eval "require Term::Rendezvous;" or die $@;
1453 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1454 my $term_rv = new Term::Rendezvous $rv;
1456 $OUT = $term_rv->OUT;
1460 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1462 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1464 $rl_attribs = $term->Attribs;
1465 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1466 if defined $rl_attribs->{basic_word_break_characters}
1467 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1468 $rl_attribs->{special_prefixes} = '$@&%';
1469 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1470 $rl_attribs->{completion_function} = \&db_complete;
1472 $LINEINFO = $OUT unless defined $LINEINFO;
1473 $lineinfo = $console unless defined $lineinfo;
1475 if ($term->Features->{setHistory} and "@hist" ne "?") {
1476 $term->SetHistory(@hist);
1478 ornaments($ornaments) if defined $ornaments;
1482 sub resetterm { # We forked, so we need a different TTY
1484 if (defined &get_fork_TTY) {
1486 } elsif (not defined $fork_TTY
1487 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1488 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1489 # Possibly _inside_ XTERM
1490 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1495 if (defined $fork_TTY) {
1500 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1501 Define B<\$DB::fork_TTY>
1502 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1503 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1504 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1505 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1512 my $left = @typeahead;
1513 my $got = shift @typeahead;
1514 print $OUT "auto(-$left)", shift, $got, "\n";
1515 $term->AddHistory($got)
1516 if length($got) > 1 and defined $term->Features->{addHistory};
1521 $term->readline(@_);
1525 my ($opt, $val)= @_;
1526 $val = option_val($opt,'N/A');
1527 $val =~ s/([\\\'])/\\$1/g;
1528 printf $OUT "%20s = '%s'\n", $opt, $val;
1532 my ($opt, $default)= @_;
1534 if (defined $optionVars{$opt}
1535 and defined $ {$optionVars{$opt}}) {
1536 $val = $ {$optionVars{$opt}};
1537 } elsif (defined $optionAction{$opt}
1538 and defined &{$optionAction{$opt}}) {
1539 $val = &{$optionAction{$opt}}();
1540 } elsif (defined $optionAction{$opt}
1541 and not defined $option{$opt}
1542 or defined $optionVars{$opt}
1543 and not defined $ {$optionVars{$opt}}) {
1546 $val = $option{$opt};
1554 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1555 my ($opt,$sep) = ($1,$2);
1558 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1560 #&dump_option($opt);
1561 } elsif ($sep !~ /\S/) {
1563 } elsif ($sep eq "=") {
1566 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1567 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1568 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1569 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1571 $val =~ s/\\([\\$end])/$1/g;
1575 grep( /^\Q$opt/ && ($option = $_), @options );
1576 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1578 print $OUT "Unknown option `$opt'\n" unless $matches;
1579 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1580 $option{$option} = $val if $matches == 1 and defined $val;
1581 eval "local \$frame = 0; local \$doret = -2;
1582 require '$optionRequire{$option}'"
1583 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1584 $ {$optionVars{$option}} = $val
1586 and defined $optionVars{$option} and defined $val;
1587 & {$optionAction{$option}} ($val)
1589 and defined $optionAction{$option}
1590 and defined &{$optionAction{$option}} and defined $val;
1591 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1597 my ($stem,@list) = @_;
1599 $ENV{"$ {stem}_n"} = @list;
1600 for $i (0 .. $#list) {
1602 $val =~ s/\\/\\\\/g;
1603 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1604 $ENV{"$ {stem}_$i"} = $val;
1611 my $n = delete $ENV{"$ {stem}_n"};
1613 for $i (0 .. $n - 1) {
1614 $val = delete $ENV{"$ {stem}_$i"};
1615 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1623 return; # Put nothing on the stack - malloc/free land!
1627 my($msg)= join("",@_);
1628 $msg .= ": $!\n" unless $msg =~ /\n$/;
1633 if (@_ and $term and $term->Features->{newTTY}) {
1634 my ($in, $out) = shift;
1636 ($in, $out) = split /,/, $in, 2;
1640 open IN, $in or die "cannot open `$in' for read: $!";
1641 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1642 $term->newTTY(\*IN, \*OUT);
1646 } elsif ($term and @_) {
1647 &warn("Too late to set TTY, enabled on next `R'!\n");
1655 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1657 $notty = shift if @_;
1663 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1670 if ($ {$term->Features}{tkRunning}) {
1671 return $term->tkRunning(@_);
1673 print $OUT "tkRunning not supported by current ReadLine package.\n";
1680 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1682 $runnonstop = shift if @_;
1689 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1696 $sh = quotemeta shift;
1697 $sh .= "\\b" if $sh =~ /\w$/;
1701 $psh =~ s/\\(.)/$1/g;
1707 if (defined $term) {
1708 local ($warnLevel,$dieLevel) = (0, 1);
1709 return '' unless $term->Features->{ornaments};
1710 eval { $term->ornaments(@_) } || '';
1718 $rc = quotemeta shift;
1719 $rc .= "\\b" if $rc =~ /\w$/;
1723 $prc =~ s/\\(.)/$1/g;
1729 return $lineinfo unless @_;
1731 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1732 $emacs = ($stream =~ /^\|/);
1733 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1734 $LINEINFO = \*LINEINFO;
1735 my $save = select($LINEINFO);
1749 s/^Term::ReadLine::readline$/readline/;
1750 if (defined $ { $_ . '::VERSION' }) {
1751 $version{$file} = "$ { $_ . '::VERSION' } from ";
1753 $version{$file} .= $INC{$file};
1755 dumpit($OUT,\%version);
1761 B<s> [I<expr>] Single step [in I<expr>].
1762 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1763 <B<CR>> Repeat last B<n> or B<s> command.
1764 B<r> Return from current subroutine.
1765 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1766 at the specified position.
1767 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1768 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1769 B<l> I<line> List single I<line>.
1770 B<l> I<subname> List first window of lines from subroutine.
1771 B<l> List next window of lines.
1772 B<-> List previous window of lines.
1773 B<w> [I<line>] List window around I<line>.
1774 B<.> Return to the executed line.
1775 B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
1776 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1777 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1778 B<L> List all breakpoints and actions.
1779 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1780 B<t> Toggle trace mode.
1781 B<t> I<expr> Trace through execution of I<expr>.
1782 B<b> [I<line>] [I<condition>]
1783 Set breakpoint; I<line> defaults to the current execution line;
1784 I<condition> breaks if it evaluates to true, defaults to '1'.
1785 B<b> I<subname> [I<condition>]
1786 Set breakpoint at first line of subroutine.
1787 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1788 B<b> B<postpone> I<subname> [I<condition>]
1789 Set breakpoint at first line of subroutine after
1791 B<b> B<compile> I<subname>
1792 Stop after the subroutine is compiled.
1793 B<d> [I<line>] Delete the breakpoint for I<line>.
1794 B<D> Delete all breakpoints.
1795 B<a> [I<line>] I<command>
1796 Set an action to be done before the I<line> is executed.
1797 Sequence is: check for breakpoint/watchpoint, print line
1798 if necessary, do action, prompt user if necessary,
1800 B<A> Delete all actions.
1801 B<W> I<expr> Add a global watch-expression.
1802 B<W> Delete all watch-expressions.
1803 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1804 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1805 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1806 B<x> I<expr> Evals expression in array context, dumps the result.
1807 B<m> I<expr> Evals expression in array context, prints methods callable
1808 on the first element of the result.
1809 B<m> I<class> Prints methods callable via the given class.
1810 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1811 Set or query values of options. I<val> defaults to 1. I<opt> can
1812 be abbreviated. Several options can be listed.
1813 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1814 I<pager>: program for output of \"|cmd\";
1815 I<tkRunning>: run Tk while prompting (with ReadLine);
1816 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1817 I<inhibit_exit> Allows stepping off the end of the script.
1818 I<ImmediateStop> Debugger should stop as early as possible.
1819 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1820 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1821 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1822 I<globPrint>: whether to print contents of globs;
1823 I<DumpDBFiles>: dump arrays holding debugged files;
1824 I<DumpPackages>: dump symbol tables of packages;
1825 I<DumpReused>: dump contents of \"reused\" addresses;
1826 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1827 I<bareStringify>: Do not print the overload-stringified value;
1828 Option I<PrintRet> affects printing of return value after B<r> command,
1829 I<frame> affects printing messages on entry and exit from subroutines.
1830 I<AutoTrace> affects printing messages on every possible breaking point.
1831 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1832 I<ornaments> affects screen appearance of the command line.
1833 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1834 You can put additional initialization options I<TTY>, I<noTTY>,
1835 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1836 B<<> I<expr> Define Perl command to run before each prompt.
1837 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1838 B<>> I<expr> Define Perl command to run after each prompt.
1839 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1840 B<{> I<db_command> Define debugger command to run before each prompt.
1841 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1842 B<$prc> I<number> Redo a previous command (default previous command).
1843 B<$prc> I<-number> Redo number'th-to-last command.
1844 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1845 See 'B<O> I<recallCommand>' too.
1846 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1847 . ( $rc eq $sh ? "" : "
1848 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1849 See 'B<O> I<shellBang>' too.
1850 B<H> I<-number> Display last number commands (default all).
1851 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1852 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1853 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1854 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1855 I<command> Execute as a perl statement in current package.
1856 B<v> Show versions of loaded modules.
1857 B<R> Pure-man-restart of debugger, some of debugger state
1858 and command-line options may be lost.
1859 Currently the following setting are preserved:
1860 history, breakpoints and actions, debugger B<O>ptions
1861 and the following command-line options: I<-w>, I<-I>, I<-e>.
1862 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1863 B<h h> Summary of debugger commands.
1864 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1867 $summary = <<"END_SUM";
1868 I<List/search source lines:> I<Control script execution:>
1869 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1870 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1871 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1872 B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s>
1873 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1874 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1875 I<Debugger controls:> B<L> List break/watch/actions
1876 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1877 B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint
1878 B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub
1879 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1880 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1881 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1882 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1883 B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1884 B<q> or B<^D> Quit B<R> Attempt a restart
1885 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1886 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1887 B<p> I<expr> Print expression (uses script's current package).
1888 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1889 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1890 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1892 # ')}}; # Fix balance of Emacs parsing
1896 my $message = shift;
1897 if (@Term::ReadLine::TermCap::rl_term_set) {
1898 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1899 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1901 print $OUT $message;
1907 $SIG{'ABRT'} = 'DEFAULT';
1908 kill 'ABRT', $$ if $panic++;
1909 if (defined &Carp::longmess) {
1910 local $SIG{__WARN__} = '';
1911 local $Carp::CarpLevel = 2; # mydie + confess
1912 &warn(Carp::longmess("Signal @_"));
1915 print $DB::OUT "Got signal @_\n";
1923 local $SIG{__WARN__} = '';
1924 local $SIG{__DIE__} = '';
1925 eval { require Carp } if defined $^S; # If error/warning during compilation,
1926 # require may be broken.
1927 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1928 return unless defined &Carp::longmess;
1929 my ($mysingle,$mytrace) = ($single,$trace);
1930 $single = 0; $trace = 0;
1931 my $mess = Carp::longmess(@_);
1932 ($single,$trace) = ($mysingle,$mytrace);
1939 local $SIG{__DIE__} = '';
1940 local $SIG{__WARN__} = '';
1941 my $i = 0; my $ineval = 0; my $sub;
1942 if ($dieLevel > 2) {
1943 local $SIG{__WARN__} = \&dbwarn;
1944 &warn(@_); # Yell no matter what
1947 if ($dieLevel < 2) {
1948 die @_ if $^S; # in eval propagate
1950 eval { require Carp } if defined $^S; # If error/warning during compilation,
1951 # require may be broken.
1952 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1953 unless defined &Carp::longmess;
1954 # We do not want to debug this chunk (automatic disabling works
1955 # inside DB::DB, but not in Carp).
1956 my ($mysingle,$mytrace) = ($single,$trace);
1957 $single = 0; $trace = 0;
1958 my $mess = Carp::longmess(@_);
1959 ($single,$trace) = ($mysingle,$mytrace);
1965 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1968 $SIG{__WARN__} = \&DB::dbwarn;
1970 $SIG{__WARN__} = $prevwarn;
1978 $prevdie = $SIG{__DIE__} unless $dieLevel;
1981 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1982 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1983 print $OUT "Stack dump during die enabled",
1984 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1986 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1988 $SIG{__DIE__} = $prevdie;
1989 print $OUT "Default die handler restored.\n";
1997 $prevsegv = $SIG{SEGV} unless $signalLevel;
1998 $prevbus = $SIG{BUS} unless $signalLevel;
1999 $signalLevel = shift;
2001 $SIG{SEGV} = \&DB::diesignal;
2002 $SIG{BUS} = \&DB::diesignal;
2004 $SIG{SEGV} = $prevsegv;
2005 $SIG{BUS} = $prevbus;
2013 return unless defined &$subr;
2015 $subr = \&$subr; # Hard reference
2018 $s = $_, last if $subr eq \&$_;
2026 $class = ref $class if ref $class;
2029 methods_via($class, '', 1);
2030 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2035 return if $packs{$class}++;
2037 my $prepend = $prefix ? "via $prefix: " : '';
2039 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2040 sort keys %{"$ {class}::"}) {
2041 next if $seen{ $name }++;
2042 print $DB::OUT "$prepend$name\n";
2044 return unless shift; # Recurse?
2045 for $name (@{"$ {class}::ISA"}) {
2046 $prepend = $prefix ? $prefix . " -> $name" : $name;
2047 methods_via($name, $prepend, 1);
2051 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2053 BEGIN { # This does not compile, alas.
2054 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2055 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2059 $deep = 100; # warning if stack gets this deep
2063 $SIG{INT} = \&DB::catch;
2064 # This may be enabled to debug debugger:
2065 #$warnLevel = 1 unless defined $warnLevel;
2066 #$dieLevel = 1 unless defined $dieLevel;
2067 #$signalLevel = 1 unless defined $signalLevel;
2069 $db_stop = 0; # Compiler warning
2071 $level = 0; # Level of recursive debugging
2072 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2073 # Triggers bug (?) in perl is we postpone this until runtime:
2074 @postponed = @stack = (0);
2075 $stack_depth = 0; # Localized $#stack
2080 BEGIN {$^W = $ini_warn;} # Switch warnings back
2082 #use Carp; # This did break, left for debuggin
2085 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2086 my($text, $line, $start) = @_;
2087 my ($itext, $search, $prefix, $pack) =
2088 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2090 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2091 (map { /$search/ ? ($1) : () } keys %sub)
2092 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2093 return sort grep /^\Q$text/, values %INC # files
2094 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2095 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2096 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2097 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2098 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2100 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2102 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2103 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2104 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2105 # We may want to complete to (eval 9), so $text may be wrong
2106 $prefix = length($1) - length($text);
2109 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2111 if ((substr $text, 0, 1) eq '&') { # subroutines
2112 $text = substr $text, 1;
2114 return sort map "$prefix$_",
2117 (map { /$search/ ? ($1) : () }
2120 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2121 $pack = ($1 eq 'main' ? '' : $1) . '::';
2122 $prefix = (substr $text, 0, 1) . $1 . '::';
2125 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2126 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2127 return db_complete($out[0], $line, $start);
2131 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2132 $pack = ($package eq 'main' ? '' : $package) . '::';
2133 $prefix = substr $text, 0, 1;
2134 $text = substr $text, 1;
2135 my @out = map "$prefix$_", grep /^\Q$text/,
2136 (grep /^_?[a-zA-Z]/, keys %$pack),
2137 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2138 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2139 return db_complete($out[0], $line, $start);
2143 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2144 my @out = grep /^\Q$text/, @options;
2145 my $val = option_val($out[0], undef);
2147 if (not defined $val or $val =~ /[\n\r]/) {
2148 # Can do nothing better
2149 } elsif ($val =~ /\s/) {
2151 foreach $l (split //, qq/\"\'\#\|/) {
2152 $out = "$l$val$l ", last if (index $val, $l) == -1;
2157 # Default to value if one completion, to question if many
2158 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2161 return $term->filename_list($text); # filenames
2165 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2169 $finished = $inhibit_exit; # So that some keys may be disabled.
2170 # Do not stop in at_exit() and destructors on exit:
2171 $DB::single = !$exiting && !$runnonstop;
2172 DB::fake::at_exit() unless $exiting or $runnonstop;
2178 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2181 package DB; # Do not trace this 1; below!