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 # RemotePort - host:port to connect to on remote host for remote debugging.
81 # Example $rcfile: (delete leading hashes!)
83 # &parse_options("NonStop=1 LineInfo=db.out");
84 # sub afterinit { $trace = 1; }
86 # The script will run without human intervention, putting trace
87 # information into db.out. (If you interrupt it, you would better
88 # reset LineInfo to something "interactive"!)
90 ##################################################################
93 # A lot of things changed after 0.94. First of all, core now informs
94 # debugger about entry into XSUBs, overloaded operators, tied operations,
95 # BEGIN and END. Handy with `O f=2'.
97 # This can make debugger a little bit too verbose, please be patient
98 # and report your problems promptly.
100 # Now the option frame has 3 values: 0,1,2.
102 # Note that if DESTROY returns a reference to the object (or object),
103 # the deletion of data may be postponed until the next function call,
104 # due to the need to examine the return value.
106 # Changes: 0.95: `v' command shows versions.
107 # Changes: 0.96: `v' command shows version of readline.
108 # primitive completion works (dynamic variables, subs for `b' and `l',
109 # options). Can `p %var'
110 # Better help (`h <' now works). New commands <<, >>, {, {{.
111 # {dump|print}_trace() coded (to be able to do it from <<cmd).
112 # `c sub' documented.
113 # At last enough magic combined to stop after the end of debuggee.
114 # !! should work now (thanks to Emacs bracket matching an extra
115 # `]' in a regexp is caught).
116 # `L', `D' and `A' span files now (as documented).
117 # Breakpoints in `require'd code are possible (used in `R').
118 # Some additional words on internal work of debugger.
119 # `b load filename' implemented.
120 # `b postpone subr' implemented.
121 # now only `q' exits debugger (overwriteable on $inhibit_exit).
122 # When restarting debugger breakpoints/actions persist.
123 # Buglet: When restarting debugger only one breakpoint/action per
124 # autoloaded function persists.
125 # Changes: 0.97: NonStop will not stop in at_exit().
126 # Option AutoTrace implemented.
127 # Trace printed differently if frames are printed too.
128 # new `inhibitExit' option.
129 # printing of a very long statement interruptible.
130 # Changes: 0.98: New command `m' for printing possible methods
131 # 'l -' is a synonim for `-'.
132 # Cosmetic bugs in printing stack trace.
133 # `frame' & 8 to print "expanded args" in stack trace.
134 # Can list/break in imported subs.
135 # new `maxTraceLen' option.
136 # frame & 4 and frame & 8 granted.
138 # nonstoppable lines do not have `:' near the line number.
139 # `b compile subname' implemented.
140 # Will not use $` any more.
141 # `-' behaves sane now.
142 # Changes: 0.99: Completion for `f', `m'.
143 # `m' will remove duplicate names instead of duplicate functions.
144 # `b load' strips trailing whitespace.
145 # completion ignores leading `|'; takes into account current package
146 # when completing a subroutine name (same for `l').
148 ####################################################################
150 # Needed for the statement after exec():
152 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
153 local($^W) = 0; # Switch run-time warnings off during init.
156 $dumpvar::arrayDepth,
157 $dumpvar::dumpDBFiles,
158 $dumpvar::dumpPackages,
159 $dumpvar::quoteHighBit,
160 $dumpvar::printUndef,
169 # Command-line + PERLLIB:
172 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
174 $trace = $signal = $single = 0; # Uninitialized warning suppression
175 # (local $^W cannot help - other packages!).
176 $inhibit_exit = $option{PrintRet} = 1;
178 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
179 compactDump veryCompact quote HighBit undefPrint
180 globPrint PrintRet UsageOnly frame AutoTrace
181 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
182 recallCommand ShellBang pager tkRunning ornaments
183 signalLevel warnLevel dieLevel inhibit_exit
184 ImmediateStop bareStringify
188 hashDepth => \$dumpvar::hashDepth,
189 arrayDepth => \$dumpvar::arrayDepth,
190 DumpDBFiles => \$dumpvar::dumpDBFiles,
191 DumpPackages => \$dumpvar::dumpPackages,
192 DumpReused => \$dumpvar::dumpReused,
193 HighBit => \$dumpvar::quoteHighBit,
194 undefPrint => \$dumpvar::printUndef,
195 globPrint => \$dumpvar::globPrint,
196 UsageOnly => \$dumpvar::usageOnly,
197 bareStringify => \$dumpvar::bareStringify,
199 AutoTrace => \$trace,
200 inhibit_exit => \$inhibit_exit,
201 maxTraceLen => \$maxtrace,
202 ImmediateStop => \$ImmediateStop,
203 RemotePort => \$remoteport,
207 compactDump => \&dumpvar::compactDump,
208 veryCompact => \&dumpvar::veryCompact,
209 quote => \&dumpvar::quote,
212 ReadLine => \&ReadLine,
213 NonStop => \&NonStop,
214 LineInfo => \&LineInfo,
215 recallCommand => \&recallCommand,
216 ShellBang => \&shellBang,
218 signalLevel => \&signalLevel,
219 warnLevel => \&warnLevel,
220 dieLevel => \&dieLevel,
221 tkRunning => \&tkRunning,
222 ornaments => \&ornaments,
223 RemotePort => \&RemotePort,
227 compactDump => 'dumpvar.pl',
228 veryCompact => 'dumpvar.pl',
229 quote => 'dumpvar.pl',
232 # These guys may be defined in $ENV{PERL5DB} :
233 $rl = 1 unless defined $rl;
234 $warnLevel = 1 unless defined $warnLevel;
235 $dieLevel = 1 unless defined $dieLevel;
236 $signalLevel = 1 unless defined $signalLevel;
237 $pre = [] unless defined $pre;
238 $post = [] unless defined $post;
239 $pretype = [] unless defined $pretype;
240 warnLevel($warnLevel);
242 signalLevel($signalLevel);
243 &pager((defined($ENV{PAGER})
247 : 'more'))) unless defined $pager;
248 &recallCommand("!") unless defined $prc;
249 &shellBang("!") unless defined $psh;
250 $maxtrace = 400 unless defined $maxtrace;
255 $rcfile="perldb.ini";
260 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
261 do "$ENV{LOGDIR}/$rcfile";
262 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
263 do "$ENV{HOME}/$rcfile";
266 if (defined $ENV{PERLDB_OPTS}) {
267 parse_options($ENV{PERLDB_OPTS});
270 if (exists $ENV{PERLDB_RESTART}) {
271 delete $ENV{PERLDB_RESTART};
273 @hist = get_list('PERLDB_HIST');
274 %break_on_load = get_list("PERLDB_ON_LOAD");
275 %postponed = get_list("PERLDB_POSTPONE");
276 my @had_breakpoints= get_list("PERLDB_VISITED");
277 for (0 .. $#had_breakpoints) {
278 my %pf = get_list("PERLDB_FILE_$_");
279 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
281 my %opt = get_list("PERLDB_OPT");
283 while (($opt,$val) = each %opt) {
284 $val =~ s/[\\\']/\\$1/g;
285 parse_options("$opt'$val'");
287 @INC = get_list("PERLDB_INC");
289 $pretype = [get_list("PERLDB_PRETYPE")];
290 $pre = [get_list("PERLDB_PRE")];
291 $post = [get_list("PERLDB_POST")];
292 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
298 # Is Perl being run from Emacs?
299 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
300 $rl = 0, shift(@main::ARGV) if $emacs;
302 #require Term::ReadLine;
304 if ($^O =~ /cygwin/) {
305 # /dev/tty is binary. use stdin for textmode
307 } elsif (-e "/dev/tty") {
308 $console = "/dev/tty";
309 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
312 $console = "sys\$command";
315 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
320 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
328 $console = $tty if defined $tty;
330 if (defined $remoteport) {
332 $OUT = new IO::Socket::INET( Timeout => '10',
333 PeerAddr => $remoteport,
336 if (!$OUT) { die "Could not create socket to connect to remote host."; }
340 if (defined $console) {
341 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
342 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
343 || open(OUT,">&STDOUT"); # so we don't dongle stdout
346 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
347 $console = 'STDIN/OUT';
349 # so open("|more") can read from STDOUT and so we don't dingle stdin
355 $| = 1; # for DB::OUT
358 $LINEINFO = $OUT unless defined $LINEINFO;
359 $lineinfo = $console unless defined $lineinfo;
361 $| = 1; # for real STDOUT
363 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
364 unless ($runnonstop) {
365 print $OUT "\nLoading DB routines from $header\n";
366 print $OUT ("Emacs support ",
367 $emacs ? "enabled" : "available",
369 print $OUT "\nEnter h or `h h' for help, run `perldoc perldebug' for more help.\n\n";
376 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
379 if (defined &afterinit) { # May be defined in $rcfile
385 ############################################################ Subroutines
388 # _After_ the perl program is compiled, $single is set to 1:
389 if ($single and not $second_time++) {
390 if ($runnonstop) { # Disable until signal
391 for ($i=0; $i <= $stack_depth; ) {
395 # return; # Would not print trace!
396 } elsif ($ImmediateStop) {
401 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
403 ($package, $filename, $line) = caller;
404 $filename_ini = $filename;
405 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
406 "package $package;"; # this won't let them modify, alas
407 local(*dbline) = $main::{'_<' . $filename};
409 if (($stop,$action) = split(/\0/,$dbline{$line})) {
413 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
414 $dbline{$line} =~ s/;9($|\0)/$1/;
417 my $was_signal = $signal;
419 for (my $n = 0; $n <= $#to_watch; $n++) {
420 $evalarg = $to_watch[$n];
421 local $onetimeDump; # Do not output results
422 my ($val) = &eval; # Fix context (&eval is doing array)?
423 $val = ( (defined $val) ? "'$val'" : 'undef' );
424 if ($val ne $old_watch[$n]) {
427 Watchpoint $n:\t$to_watch[$n] changed:
428 old value:\t$old_watch[$n]
431 $old_watch[$n] = $val;
435 if ($trace & 4) { # User-installed watch
436 return if watchfunction($package, $filename, $line)
437 and not $single and not $was_signal and not ($trace & ~4);
439 $was_signal = $signal;
441 if ($single || ($trace & 1) || $was_signal) {
443 $position = "\032\032$filename:$line:0\n";
444 print $LINEINFO $position;
445 } elsif ($package eq 'DB::fake') {
448 Debugged program terminated. Use B<q> to quit or B<R> to restart,
449 use B<O> I<inhibit_exit> to avoid stopping after program termination,
450 B<h q>, B<h R> or B<h O> to get additional info.
453 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
454 "package $package;"; # this won't let them modify, alas
457 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
458 $prefix .= "$sub($filename:";
459 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
460 if (length($prefix) > 30) {
461 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
466 $position = "$prefix$line$infix$dbline[$line]$after";
469 print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
471 print $LINEINFO $position;
473 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
474 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
476 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
477 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
478 $position .= $incr_pos;
480 print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
482 print $LINEINFO $incr_pos;
487 $evalarg = $action, &eval if $action;
488 if ($single || $was_signal) {
489 local $level = $level + 1;
490 foreach $evalarg (@$pre) {
493 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
496 $incr = -1; # for backward motion.
497 @typeahead = (@$pretype, @typeahead);
499 while (($term || &setterm),
500 ($term_pid == $$ or &resetterm),
501 defined ($cmd=&readline(" DB" . ('<' x $level) .
502 ($#hist+1) . ('>' x $level) .
506 $cmd =~ s/\\$/\n/ && do {
507 $cmd .= &readline(" cont: ");
510 $cmd =~ /^$/ && ($cmd = $laststep);
511 push(@hist,$cmd) if length($cmd) > 1;
513 ($i) = split(/\s+/,$cmd);
514 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
515 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
516 $cmd =~ /^h$/ && do {
519 $cmd =~ /^h\s+h$/ && do {
520 print_help($summary);
522 $cmd =~ /^h\s+(\S)$/ && do {
524 if ($help =~ /^(?:[IB]<)$asked/m) {
525 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
529 print_help("B<$asked> is not a debugger command.\n");
532 $cmd =~ /^t$/ && do {
533 ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
534 print $OUT "Trace = " .
535 (($trace & 1) ? "on" : "off" ) . "\n";
537 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
538 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
539 foreach $subname (sort(keys %sub)) {
540 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
541 print $OUT $subname,"\n";
545 $cmd =~ /^v$/ && do {
546 list_versions(); next CMD};
547 $cmd =~ s/^X\b/V $package/;
548 $cmd =~ /^V$/ && do {
549 $cmd = "V $package"; };
550 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
551 local ($savout) = select($OUT);
553 @vars = split(' ',$2);
554 do 'dumpvar.pl' unless defined &main::dumpvar;
555 if (defined &main::dumpvar) {
558 &main::dumpvar($packname,@vars);
560 print $OUT "dumpvar.pl not available.\n";
564 $cmd =~ s/^x\b/ / && do { # So that will be evaled
565 $onetimeDump = 'dump'; };
566 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
567 methods($1); next CMD};
568 $cmd =~ s/^m\b/ / && do { # So this will be evaled
569 $onetimeDump = 'methods'; };
570 $cmd =~ /^f\b\s*(.*)/ && do {
574 print $OUT "The old f command is now the r command.\n";
575 print $OUT "The new f command switches filenames.\n";
578 if (!defined $main::{'_<' . $file}) {
579 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
580 $try = substr($try,2);
581 print $OUT "Choosing $try matching `$file':\n";
585 if (!defined $main::{'_<' . $file}) {
586 print $OUT "No file matching `$file' is loaded.\n";
588 } elsif ($file ne $filename) {
589 *dbline = $main::{'_<' . $file};
595 print $OUT "Already in $file.\n";
599 $cmd =~ s/^l\s+-\s*$/-/;
600 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
602 $subname =~ s/\'/::/;
603 $subname = $package."::".$subname
604 unless $subname =~ /::/;
605 $subname = "main".$subname if substr($subname,0,2) eq "::";
606 @pieces = split(/:/,find_sub($subname));
607 $subrange = pop @pieces;
608 $file = join(':', @pieces);
609 if ($file ne $filename) {
610 *dbline = $main::{'_<' . $file};
615 if (eval($subrange) < -$window) {
616 $subrange =~ s/-.*/+/;
618 $cmd = "l $subrange";
620 print $OUT "Subroutine $subname not found.\n";
623 $cmd =~ /^\.$/ && do {
624 $incr = -1; # for backward motion.
626 $filename = $filename_ini;
627 *dbline = $main::{'_<' . $filename};
629 print $LINEINFO $position;
631 $cmd =~ /^w\b\s*(\d*)$/ && do {
635 #print $OUT 'l ' . $start . '-' . ($start + $incr);
636 $cmd = 'l ' . $start . '-' . ($start + $incr); };
637 $cmd =~ /^-$/ && do {
638 $start -= $incr + $window + 1;
639 $start = 1 if $start <= 0;
641 $cmd = 'l ' . ($start) . '+'; };
642 $cmd =~ /^l$/ && do {
644 $cmd = 'l ' . $start . '-' . ($start + $incr); };
645 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
648 $incr = $window - 1 unless $incr;
649 $cmd = 'l ' . $start . '-' . ($start + $incr); };
650 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
651 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
652 $end = $max if $end > $max;
654 $i = $line if $i eq '.';
658 print $OUT "\032\032$filename:$i:0\n";
661 for (; $i <= $end; $i++) {
662 ($stop,$action) = split(/\0/, $dbline{$i});
664 and $filename eq $filename_ini)
666 : ($dbline[$i]+0 ? ':' : ' ') ;
667 $arrow .= 'b' if $stop;
668 $arrow .= 'a' if $action;
669 print $OUT "$i$arrow\t", $dbline[$i];
670 $i++, last if $signal;
672 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
674 $start = $i; # remember in case they want more
675 $start = $max if $start > $max;
677 $cmd =~ /^D$/ && do {
678 print $OUT "Deleting all breakpoints...\n";
680 for $file (keys %had_breakpoints) {
681 local *dbline = $main::{'_<' . $file};
685 for ($i = 1; $i <= $max ; $i++) {
686 if (defined $dbline{$i}) {
687 $dbline{$i} =~ s/^[^\0]+//;
688 if ($dbline{$i} =~ s/^\0?$//) {
695 undef %postponed_file;
696 undef %break_on_load;
697 undef %had_breakpoints;
699 $cmd =~ /^L$/ && do {
701 for $file (keys %had_breakpoints) {
702 local *dbline = $main::{'_<' . $file};
706 for ($i = 1; $i <= $max; $i++) {
707 if (defined $dbline{$i}) {
708 print $OUT "$file:\n" unless $was++;
709 print $OUT " $i:\t", $dbline[$i];
710 ($stop,$action) = split(/\0/, $dbline{$i});
711 print $OUT " break if (", $stop, ")\n"
713 print $OUT " action: ", $action, "\n"
720 print $OUT "Postponed breakpoints in subroutines:\n";
722 for $subname (keys %postponed) {
723 print $OUT " $subname\t$postponed{$subname}\n";
727 my @have = map { # Combined keys
728 keys %{$postponed_file{$_}}
729 } keys %postponed_file;
731 print $OUT "Postponed breakpoints in files:\n";
733 for $file (keys %postponed_file) {
734 my $db = $postponed_file{$file};
735 print $OUT " $file:\n";
736 for $line (sort {$a <=> $b} keys %$db) {
737 print $OUT " $line:\n";
738 my ($stop,$action) = split(/\0/, $$db{$line});
739 print $OUT " break if (", $stop, ")\n"
741 print $OUT " action: ", $action, "\n"
748 if (%break_on_load) {
749 print $OUT "Breakpoints on load:\n";
751 for $file (keys %break_on_load) {
752 print $OUT " $file\n";
757 print $OUT "Watch-expressions:\n";
759 for $expr (@to_watch) {
760 print $OUT " $expr\n";
765 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
766 my $file = $1; $file =~ s/\s+$//;
768 $break_on_load{$file} = 1;
769 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
770 $file .= '.pm', redo unless $file =~ /\./;
772 $had_breakpoints{$file} = 1;
773 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
775 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
776 my $cond = $3 || '1';
777 my ($subname, $break) = ($2, $1 eq 'postpone');
778 $subname =~ s/\'/::/;
779 $subname = "${'package'}::" . $subname
780 unless $subname =~ /::/;
781 $subname = "main".$subname if substr($subname,0,2) eq "::";
782 $postponed{$subname} = $break
783 ? "break +0 if $cond" : "compile";
785 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
788 $subname =~ s/\'/::/;
789 $subname = "${'package'}::" . $subname
790 unless $subname =~ /::/;
791 $subname = "main".$subname if substr($subname,0,2) eq "::";
792 # Filename below can contain ':'
793 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
797 *dbline = $main::{'_<' . $filename};
798 $had_breakpoints{$filename} = 1;
800 ++$i while $dbline[$i] == 0 && $i < $max;
801 $dbline{$i} =~ s/^[^\0]*/$cond/;
803 print $OUT "Subroutine $subname not found.\n";
806 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
809 if ($dbline[$i] == 0) {
810 print $OUT "Line $i not breakable.\n";
812 $had_breakpoints{$filename} = 1;
813 $dbline{$i} =~ s/^[^\0]*/$cond/;
816 $cmd =~ /^d\b\s*(\d+)?/ && do {
818 $dbline{$i} =~ s/^[^\0]*//;
819 delete $dbline{$i} if $dbline{$i} eq '';
821 $cmd =~ /^A$/ && do {
823 for $file (keys %had_breakpoints) {
824 local *dbline = $main::{'_<' . $file};
828 for ($i = 1; $i <= $max ; $i++) {
829 if (defined $dbline{$i}) {
830 $dbline{$i} =~ s/\0[^\0]*//;
831 delete $dbline{$i} if $dbline{$i} eq '';
836 $cmd =~ /^O\s*$/ && do {
841 $cmd =~ /^O\s*(\S.*)/ && do {
844 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
845 push @$pre, action($1);
847 $cmd =~ /^>>\s*(.*)/ && do {
848 push @$post, action($1);
850 $cmd =~ /^<\s*(.*)/ && do {
851 $pre = [], next CMD unless $1;
854 $cmd =~ /^>\s*(.*)/ && do {
855 $post = [], next CMD unless $1;
856 $post = [action($1)];
858 $cmd =~ /^\{\{\s*(.*)/ && do {
861 $cmd =~ /^\{\s*(.*)/ && do {
862 $pretype = [], next CMD unless $1;
865 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
867 if ($dbline[$i] == 0) {
868 print $OUT "Line $i may not have an action.\n";
870 $dbline{$i} =~ s/\0[^\0]*//;
871 $dbline{$i} .= "\0" . action($j);
874 $cmd =~ /^n$/ && do {
875 end_report(), next CMD if $finished and $level <= 1;
879 $cmd =~ /^s$/ && do {
880 end_report(), next CMD if $finished and $level <= 1;
884 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
885 end_report(), next CMD if $finished and $level <= 1;
887 if ($i =~ /\D/) { # subroutine name
888 $subname = $package."::".$subname
889 unless $subname =~ /::/;
890 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
894 *dbline = $main::{'_<' . $filename};
895 $had_breakpoints{$filename}++;
897 ++$i while $dbline[$i] == 0 && $i < $max;
899 print $OUT "Subroutine $subname not found.\n";
904 if ($dbline[$i] == 0) {
905 print $OUT "Line $i not breakable.\n";
908 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
910 for ($i=0; $i <= $stack_depth; ) {
914 $cmd =~ /^r$/ && do {
915 end_report(), next CMD if $finished and $level <= 1;
916 $stack[$stack_depth] |= 1;
917 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
919 $cmd =~ /^R$/ && do {
920 print $OUT "Warning: some settings and command-line options may be lost!\n";
921 my (@script, @flags, $cl);
922 push @flags, '-w' if $ini_warn;
923 # Put all the old includes at the start to get
926 push @flags, '-I', $_;
928 # Arrange for setting the old INC:
929 set_list("PERLDB_INC", @ini_INC);
931 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
932 chomp ($cl = $ {'::_<-e'}[$_]);
933 push @script, '-e', $cl;
938 set_list("PERLDB_HIST",
939 $term->Features->{getHistory}
940 ? $term->GetHistory : @hist);
941 my @had_breakpoints = keys %had_breakpoints;
942 set_list("PERLDB_VISITED", @had_breakpoints);
943 set_list("PERLDB_OPT", %option);
944 set_list("PERLDB_ON_LOAD", %break_on_load);
946 for (0 .. $#had_breakpoints) {
947 my $file = $had_breakpoints[$_];
948 *dbline = $main::{'_<' . $file};
949 next unless %dbline or $postponed_file{$file};
950 (push @hard, $file), next
951 if $file =~ /^\(eval \d+\)$/;
953 @add = %{$postponed_file{$file}}
954 if $postponed_file{$file};
955 set_list("PERLDB_FILE_$_", %dbline, @add);
957 for (@hard) { # Yes, really-really...
958 # Find the subroutines in this eval
959 *dbline = $main::{'_<' . $_};
960 my ($quoted, $sub, %subs, $line) = quotemeta $_;
961 for $sub (keys %sub) {
962 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
963 $subs{$sub} = [$1, $2];
967 "No subroutines in $_, ignoring breakpoints.\n";
970 LINES: for $line (keys %dbline) {
971 # One breakpoint per sub only:
972 my ($offset, $sub, $found);
973 SUBS: for $sub (keys %subs) {
974 if ($subs{$sub}->[1] >= $line # Not after the subroutine
975 and (not defined $offset # Not caught
976 or $offset < 0 )) { # or badly caught
978 $offset = $line - $subs{$sub}->[0];
979 $offset = "+$offset", last SUBS if $offset >= 0;
982 if (defined $offset) {
984 "break $offset if $dbline{$line}";
986 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
990 set_list("PERLDB_POSTPONE", %postponed);
991 set_list("PERLDB_PRETYPE", @$pretype);
992 set_list("PERLDB_PRE", @$pre);
993 set_list("PERLDB_POST", @$post);
994 set_list("PERLDB_TYPEAHEAD", @typeahead);
995 $ENV{PERLDB_RESTART} = 1;
996 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
997 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
998 print $OUT "exec failed: $!\n";
1000 $cmd =~ /^T$/ && do {
1001 print_trace($OUT, 1); # skip DB
1003 $cmd =~ /^W\s*$/ && do {
1005 @to_watch = @old_watch = ();
1007 $cmd =~ /^W\b\s*(.*)/s && do {
1011 $val = (defined $val) ? "'$val'" : 'undef' ;
1012 push @old_watch, $val;
1015 $cmd =~ /^\/(.*)$/ && do {
1017 $inpat =~ s:([^\\])/$:$1:;
1019 eval '$inpat =~ m'."\a$inpat\a";
1031 $start = 1 if ($start > $max);
1032 last if ($start == $end);
1033 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1035 print $OUT "\032\032$filename:$start:0\n";
1037 print $OUT "$start:\t", $dbline[$start], "\n";
1042 print $OUT "/$pat/: not found\n" if ($start == $end);
1044 $cmd =~ /^\?(.*)$/ && do {
1046 $inpat =~ s:([^\\])\?$:$1:;
1048 eval '$inpat =~ m'."\a$inpat\a";
1060 $start = $max if ($start <= 0);
1061 last if ($start == $end);
1062 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1064 print $OUT "\032\032$filename:$start:0\n";
1066 print $OUT "$start:\t", $dbline[$start], "\n";
1071 print $OUT "?$pat?: not found\n" if ($start == $end);
1073 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1074 pop(@hist) if length($cmd) > 1;
1075 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1077 print $OUT $cmd, "\n";
1079 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1082 $cmd =~ /^$rc([^$rc].*)$/ && do {
1084 pop(@hist) if length($cmd) > 1;
1085 for ($i = $#hist; $i; --$i) {
1086 last if $hist[$i] =~ /$pat/;
1089 print $OUT "No such command!\n\n";
1093 print $OUT $cmd, "\n";
1095 $cmd =~ /^$sh$/ && do {
1096 &system($ENV{SHELL}||"/bin/sh");
1098 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1099 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1101 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1102 $end = $2?($#hist-$2):0;
1103 $hist = 0 if $hist < 0;
1104 for ($i=$#hist; $i>$end; $i--) {
1105 print $OUT "$i: ",$hist[$i],"\n"
1106 unless $hist[$i] =~ /^.?$/;
1109 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1110 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1111 $cmd =~ /^=/ && do {
1112 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1113 $alias{$k}="s~$k~$v~";
1114 print $OUT "$k = $v\n";
1115 } elsif ($cmd =~ /^=\s*$/) {
1116 foreach $k (sort keys(%alias)) {
1117 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1118 print $OUT "$k = $v\n";
1120 print $OUT "$k\t$alias{$k}\n";
1125 $cmd =~ /^\|\|?\s*[^|]/ && do {
1126 if ($pager =~ /^\|/) {
1127 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1128 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1130 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1132 unless ($piped=open(OUT,$pager)) {
1133 &warn("Can't pipe output to `$pager'");
1134 if ($pager =~ /^\|/) {
1135 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1136 open(STDOUT,">&SAVEOUT")
1137 || &warn("Can't restore STDOUT");
1140 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1144 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1145 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1146 $selected= select(OUT);
1148 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1149 $cmd =~ s/^\|+\s*//;
1151 # XXX Local variants do not work!
1152 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1153 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1154 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1156 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1158 $onetimeDump = undef;
1159 } elsif ($term_pid == $$) {
1164 if ($pager =~ /^\|/) {
1165 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1166 &warn( "Pager `$pager' failed: ",
1167 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1168 ( $? & 128 ) ? " (core dumped)" : "",
1169 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1170 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1171 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1172 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1173 # Will stop ignoring SIGPIPE if done like nohup(1)
1174 # does SIGINT but Perl doesn't give us a choice.
1176 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1179 select($selected), $selected= "" unless $selected eq "";
1183 $exiting = 1 unless defined $cmd;
1184 foreach $evalarg (@$post) {
1187 } # if ($single || $signal)
1188 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1192 # The following code may be executed now:
1196 my ($al, $ret, @ret) = "";
1197 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1200 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1201 $#stack = $stack_depth;
1202 $stack[-1] = $single;
1204 $single |= 4 if $stack_depth == $deep;
1206 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
1207 # Why -1? But it works! :-(
1208 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1209 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1212 $single |= $stack[$stack_depth--];
1214 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1215 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1216 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1217 if ($doret eq $stack_depth or $frame & 16) {
1218 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1219 print $fh ' ' x $stack_depth if $frame & 16;
1220 print $fh "list context return from $sub:\n";
1221 dumpit($fh, \@ret );
1226 if (defined wantarray) {
1231 $single |= $stack[$stack_depth--];
1233 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1234 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1235 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1236 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1237 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1238 print $fh (' ' x $stack_depth) if $frame & 16;
1239 print $fh (defined wantarray
1240 ? "scalar context return from $sub: "
1241 : "void context return from $sub\n");
1242 dumpit( $fh, $ret ) if defined wantarray;
1250 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1251 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1254 # The following takes its argument via $evalarg to preserve current @_
1259 my $otrace = $trace;
1260 my $osingle = $single;
1262 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1268 local $saved[0]; # Preserve the old value of $@
1272 } elsif ($onetimeDump eq 'dump') {
1273 dumpit($OUT, \@res);
1274 } elsif ($onetimeDump eq 'methods') {
1281 my $subname = shift;
1282 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1283 my $offset = $1 || 0;
1284 # Filename below can contain ':'
1285 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1288 local *dbline = $main::{'_<' . $file};
1289 local $^W = 0; # != 0 is magical below
1290 $had_breakpoints{$file}++;
1292 ++$i until $dbline[$i] != 0 or $i >= $max;
1293 $dbline{$i} = delete $postponed{$subname};
1295 print $OUT "Subroutine $subname not found.\n";
1299 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1300 #print $OUT "In postponed_sub for `$subname'.\n";
1304 if ($ImmediateStop) {
1308 return &postponed_sub
1309 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1310 # Cannot be done before the file is compiled
1311 local *dbline = shift;
1312 my $filename = $dbline;
1313 $filename =~ s/^_<//;
1314 $signal = 1, print $OUT "'$filename' loaded...\n"
1315 if $break_on_load{$filename};
1316 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1317 return unless $postponed_file{$filename};
1318 $had_breakpoints{$filename}++;
1319 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1321 for $key (keys %{$postponed_file{$filename}}) {
1322 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1324 delete $postponed_file{$filename};
1328 local ($savout) = select(shift);
1329 my $osingle = $single;
1330 my $otrace = $trace;
1331 $single = $trace = 0;
1334 unless (defined &main::dumpValue) {
1337 if (defined &main::dumpValue) {
1338 &main::dumpValue(shift);
1340 print $OUT "dumpvar.pl not available.\n";
1347 # Tied method do not create a context, so may get wrong message:
1351 my @sub = dump_trace($_[0] + 1, $_[1]);
1352 my $short = $_[2]; # Print short report, next one for sub name
1354 for ($i=0; $i <= $#sub; $i++) {
1357 my $args = defined $sub[$i]{args}
1358 ? "(@{ $sub[$i]{args} })"
1360 $args = (substr $args, 0, $maxtrace - 3) . '...'
1361 if length $args > $maxtrace;
1362 my $file = $sub[$i]{file};
1363 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1365 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1367 my $sub = @_ >= 4 ? $_[3] : $s;
1368 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1370 print $fh "$sub[$i]{context} = $s$args" .
1371 " called from $file" .
1372 " line $sub[$i]{line}\n";
1379 my $count = shift || 1e9;
1382 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1383 my $nothard = not $frame & 8;
1384 local $frame = 0; # Do not want to trace this.
1385 my $otrace = $trace;
1388 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1393 if (not defined $arg) {
1395 } elsif ($nothard and tied $arg) {
1397 } elsif ($nothard and $type = ref $arg) {
1398 push @a, "ref($type)";
1400 local $_ = "$arg"; # Safe to stringify now - should not call f().
1403 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1404 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1405 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1409 $context = $context ? '@' : (defined $context ? "\$" : '.');
1410 $args = $h ? [@a] : undef;
1411 $e =~ s/\n\s*\;\s*\Z// if $e;
1412 $e =~ s/([\\\'])/\\$1/g if $e;
1414 $sub = "require '$e'";
1415 } elsif (defined $r) {
1417 } elsif ($sub eq '(eval)') {
1418 $sub = "eval {...}";
1420 push(@sub, {context => $context, sub => $sub, args => $args,
1421 file => $file, line => $line});
1430 while ($action =~ s/\\$//) {
1441 &readline("cont: ");
1445 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1446 # many non-Unix systems can do system() but have problems with fork().
1447 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1448 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1449 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1450 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1452 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1453 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1454 close(SAVEIN); close(SAVEOUT);
1455 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1456 ( $? & 128 ) ? " (core dumped)" : "",
1457 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1464 eval { require Term::ReadLine } or die $@;
1467 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1468 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1471 my $sel = select($OUT);
1475 eval "require Term::Rendezvous;" or die $@;
1476 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1477 my $term_rv = new Term::Rendezvous $rv;
1479 $OUT = $term_rv->OUT;
1483 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1485 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1487 $rl_attribs = $term->Attribs;
1488 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1489 if defined $rl_attribs->{basic_word_break_characters}
1490 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1491 $rl_attribs->{special_prefixes} = '$@&%';
1492 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1493 $rl_attribs->{completion_function} = \&db_complete;
1495 $LINEINFO = $OUT unless defined $LINEINFO;
1496 $lineinfo = $console unless defined $lineinfo;
1498 if ($term->Features->{setHistory} and "@hist" ne "?") {
1499 $term->SetHistory(@hist);
1501 ornaments($ornaments) if defined $ornaments;
1505 sub resetterm { # We forked, so we need a different TTY
1507 if (defined &get_fork_TTY) {
1509 } elsif (not defined $fork_TTY
1510 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1511 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1512 # Possibly _inside_ XTERM
1513 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1518 if (defined $fork_TTY) {
1523 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1524 Define B<\$DB::fork_TTY>
1525 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1526 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1527 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1528 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1535 my $left = @typeahead;
1536 my $got = shift @typeahead;
1537 print $OUT "auto(-$left)", shift, $got, "\n";
1538 $term->AddHistory($got)
1539 if length($got) > 1 and defined $term->Features->{addHistory};
1544 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1547 $IN->recv( $stuff, 2048 );
1551 $term->readline(@_);
1556 my ($opt, $val)= @_;
1557 $val = option_val($opt,'N/A');
1558 $val =~ s/([\\\'])/\\$1/g;
1559 printf $OUT "%20s = '%s'\n", $opt, $val;
1563 my ($opt, $default)= @_;
1565 if (defined $optionVars{$opt}
1566 and defined $ {$optionVars{$opt}}) {
1567 $val = $ {$optionVars{$opt}};
1568 } elsif (defined $optionAction{$opt}
1569 and defined &{$optionAction{$opt}}) {
1570 $val = &{$optionAction{$opt}}();
1571 } elsif (defined $optionAction{$opt}
1572 and not defined $option{$opt}
1573 or defined $optionVars{$opt}
1574 and not defined $ {$optionVars{$opt}}) {
1577 $val = $option{$opt};
1585 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1586 my ($opt,$sep) = ($1,$2);
1589 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1591 #&dump_option($opt);
1592 } elsif ($sep !~ /\S/) {
1594 } elsif ($sep eq "=") {
1597 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1598 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1599 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1600 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1602 $val =~ s/\\([\\$end])/$1/g;
1606 grep( /^\Q$opt/ && ($option = $_), @options );
1607 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1609 print $OUT "Unknown option `$opt'\n" unless $matches;
1610 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1611 $option{$option} = $val if $matches == 1 and defined $val;
1612 eval "local \$frame = 0; local \$doret = -2;
1613 require '$optionRequire{$option}'"
1614 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1615 $ {$optionVars{$option}} = $val
1617 and defined $optionVars{$option} and defined $val;
1618 & {$optionAction{$option}} ($val)
1620 and defined $optionAction{$option}
1621 and defined &{$optionAction{$option}} and defined $val;
1622 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1628 my ($stem,@list) = @_;
1630 $ENV{"$ {stem}_n"} = @list;
1631 for $i (0 .. $#list) {
1633 $val =~ s/\\/\\\\/g;
1634 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1635 $ENV{"$ {stem}_$i"} = $val;
1642 my $n = delete $ENV{"$ {stem}_n"};
1644 for $i (0 .. $n - 1) {
1645 $val = delete $ENV{"$ {stem}_$i"};
1646 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1654 return; # Put nothing on the stack - malloc/free land!
1658 my($msg)= join("",@_);
1659 $msg .= ": $!\n" unless $msg =~ /\n$/;
1664 if (@_ and $term and $term->Features->{newTTY}) {
1665 my ($in, $out) = shift;
1667 ($in, $out) = split /,/, $in, 2;
1671 open IN, $in or die "cannot open `$in' for read: $!";
1672 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1673 $term->newTTY(\*IN, \*OUT);
1677 } elsif ($term and @_) {
1678 &warn("Too late to set TTY, enabled on next `R'!\n");
1686 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1688 $notty = shift if @_;
1694 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1702 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
1704 $remoteport = shift if @_;
1709 if ($ {$term->Features}{tkRunning}) {
1710 return $term->tkRunning(@_);
1712 print $OUT "tkRunning not supported by current ReadLine package.\n";
1719 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1721 $runnonstop = shift if @_;
1728 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1735 $sh = quotemeta shift;
1736 $sh .= "\\b" if $sh =~ /\w$/;
1740 $psh =~ s/\\(.)/$1/g;
1746 if (defined $term) {
1747 local ($warnLevel,$dieLevel) = (0, 1);
1748 return '' unless $term->Features->{ornaments};
1749 eval { $term->ornaments(@_) } || '';
1757 $rc = quotemeta shift;
1758 $rc .= "\\b" if $rc =~ /\w$/;
1762 $prc =~ s/\\(.)/$1/g;
1768 return $lineinfo unless @_;
1770 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1771 $emacs = ($stream =~ /^\|/);
1772 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1773 $LINEINFO = \*LINEINFO;
1774 my $save = select($LINEINFO);
1788 s/^Term::ReadLine::readline$/readline/;
1789 if (defined $ { $_ . '::VERSION' }) {
1790 $version{$file} = "$ { $_ . '::VERSION' } from ";
1792 $version{$file} .= $INC{$file};
1794 dumpit($OUT,\%version);
1800 B<s> [I<expr>] Single step [in I<expr>].
1801 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1802 <B<CR>> Repeat last B<n> or B<s> command.
1803 B<r> Return from current subroutine.
1804 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1805 at the specified position.
1806 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1807 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1808 B<l> I<line> List single I<line>.
1809 B<l> I<subname> List first window of lines from subroutine.
1810 B<l> List next window of lines.
1811 B<-> List previous window of lines.
1812 B<w> [I<line>] List window around I<line>.
1813 B<.> Return to the executed line.
1814 B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
1815 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1816 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1817 B<L> List all breakpoints and actions.
1818 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1819 B<t> Toggle trace mode.
1820 B<t> I<expr> Trace through execution of I<expr>.
1821 B<b> [I<line>] [I<condition>]
1822 Set breakpoint; I<line> defaults to the current execution line;
1823 I<condition> breaks if it evaluates to true, defaults to '1'.
1824 B<b> I<subname> [I<condition>]
1825 Set breakpoint at first line of subroutine.
1826 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1827 B<b> B<postpone> I<subname> [I<condition>]
1828 Set breakpoint at first line of subroutine after
1830 B<b> B<compile> I<subname>
1831 Stop after the subroutine is compiled.
1832 B<d> [I<line>] Delete the breakpoint for I<line>.
1833 B<D> Delete all breakpoints.
1834 B<a> [I<line>] I<command>
1835 Set an action to be done before the I<line> is executed.
1836 Sequence is: check for breakpoint/watchpoint, print line
1837 if necessary, do action, prompt user if necessary,
1839 B<A> Delete all actions.
1840 B<W> I<expr> Add a global watch-expression.
1841 B<W> Delete all watch-expressions.
1842 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1843 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1844 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1845 B<x> I<expr> Evals expression in array context, dumps the result.
1846 B<m> I<expr> Evals expression in array context, prints methods callable
1847 on the first element of the result.
1848 B<m> I<class> Prints methods callable via the given class.
1849 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1850 Set or query values of options. I<val> defaults to 1. I<opt> can
1851 be abbreviated. Several options can be listed.
1852 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1853 I<pager>: program for output of \"|cmd\";
1854 I<tkRunning>: run Tk while prompting (with ReadLine);
1855 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1856 I<inhibit_exit> Allows stepping off the end of the script.
1857 I<ImmediateStop> Debugger should stop as early as possible.
1858 I<RemotePort>: Remote hostname:port for remote debugging
1859 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1860 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1861 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1862 I<globPrint>: whether to print contents of globs;
1863 I<DumpDBFiles>: dump arrays holding debugged files;
1864 I<DumpPackages>: dump symbol tables of packages;
1865 I<DumpReused>: dump contents of \"reused\" addresses;
1866 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1867 I<bareStringify>: Do not print the overload-stringified value;
1868 Option I<PrintRet> affects printing of return value after B<r> command,
1869 I<frame> affects printing messages on entry and exit from subroutines.
1870 I<AutoTrace> affects printing messages on every possible breaking point.
1871 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1872 I<ornaments> affects screen appearance of the command line.
1873 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1874 You can put additional initialization options I<TTY>, I<noTTY>,
1875 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
1876 `B<R>' after you set them).
1877 B<<> I<expr> Define Perl command to run before each prompt.
1878 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1879 B<>> I<expr> Define Perl command to run after each prompt.
1880 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1881 B<{> I<db_command> Define debugger command to run before each prompt.
1882 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1883 B<$prc> I<number> Redo a previous command (default previous command).
1884 B<$prc> I<-number> Redo number'th-to-last command.
1885 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1886 See 'B<O> I<recallCommand>' too.
1887 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1888 . ( $rc eq $sh ? "" : "
1889 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1890 See 'B<O> I<shellBang>' too.
1891 B<H> I<-number> Display last number commands (default all).
1892 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1893 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1894 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1895 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1896 I<command> Execute as a perl statement in current package.
1897 B<v> Show versions of loaded modules.
1898 B<R> Pure-man-restart of debugger, some of debugger state
1899 and command-line options may be lost.
1900 Currently the following setting are preserved:
1901 history, breakpoints and actions, debugger B<O>ptions
1902 and the following command-line options: I<-w>, I<-I>, I<-e>.
1903 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1904 Complete description of debugger is available in B<perldebug>
1905 section of Perl documention
1906 B<h h> Summary of debugger commands.
1907 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1910 $summary = <<"END_SUM";
1911 I<List/search source lines:> I<Control script execution:>
1912 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1913 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1914 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1915 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
1916 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1917 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1918 I<Debugger controls:> B<L> List break/watch/actions
1919 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1920 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
1921 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1922 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1923 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1924 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1925 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1926 B<q> or B<^D> Quit B<R> Attempt a restart
1927 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1928 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1929 B<p> I<expr> Print expression (uses script's current package).
1930 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1931 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1932 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1933 I<More help for> B<db_cmd>I<:> Type B<h> I<cmd_letter> Run B<perldoc perldebug> for more help.
1935 # ')}}; # Fix balance of Emacs parsing
1939 my $message = shift;
1940 if (@Term::ReadLine::TermCap::rl_term_set) {
1941 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1942 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1944 print $OUT $message;
1950 $SIG{'ABRT'} = 'DEFAULT';
1951 kill 'ABRT', $$ if $panic++;
1952 if (defined &Carp::longmess) {
1953 local $SIG{__WARN__} = '';
1954 local $Carp::CarpLevel = 2; # mydie + confess
1955 &warn(Carp::longmess("Signal @_"));
1958 print $DB::OUT "Got signal @_\n";
1966 local $SIG{__WARN__} = '';
1967 local $SIG{__DIE__} = '';
1968 eval { require Carp } if defined $^S; # If error/warning during compilation,
1969 # require may be broken.
1970 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1971 return unless defined &Carp::longmess;
1972 my ($mysingle,$mytrace) = ($single,$trace);
1973 $single = 0; $trace = 0;
1974 my $mess = Carp::longmess(@_);
1975 ($single,$trace) = ($mysingle,$mytrace);
1982 local $SIG{__DIE__} = '';
1983 local $SIG{__WARN__} = '';
1984 my $i = 0; my $ineval = 0; my $sub;
1985 if ($dieLevel > 2) {
1986 local $SIG{__WARN__} = \&dbwarn;
1987 &warn(@_); # Yell no matter what
1990 if ($dieLevel < 2) {
1991 die @_ if $^S; # in eval propagate
1993 eval { require Carp } if defined $^S; # If error/warning during compilation,
1994 # require may be broken.
1995 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1996 unless defined &Carp::longmess;
1997 # We do not want to debug this chunk (automatic disabling works
1998 # inside DB::DB, but not in Carp).
1999 my ($mysingle,$mytrace) = ($single,$trace);
2000 $single = 0; $trace = 0;
2001 my $mess = Carp::longmess(@_);
2002 ($single,$trace) = ($mysingle,$mytrace);
2008 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2011 $SIG{__WARN__} = \&DB::dbwarn;
2013 $SIG{__WARN__} = $prevwarn;
2021 $prevdie = $SIG{__DIE__} unless $dieLevel;
2024 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2025 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2026 print $OUT "Stack dump during die enabled",
2027 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2029 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2031 $SIG{__DIE__} = $prevdie;
2032 print $OUT "Default die handler restored.\n";
2040 $prevsegv = $SIG{SEGV} unless $signalLevel;
2041 $prevbus = $SIG{BUS} unless $signalLevel;
2042 $signalLevel = shift;
2044 $SIG{SEGV} = \&DB::diesignal;
2045 $SIG{BUS} = \&DB::diesignal;
2047 $SIG{SEGV} = $prevsegv;
2048 $SIG{BUS} = $prevbus;
2056 return unless defined &$subr;
2058 $subr = \&$subr; # Hard reference
2061 $s = $_, last if $subr eq \&$_;
2069 $class = ref $class if ref $class;
2072 methods_via($class, '', 1);
2073 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2078 return if $packs{$class}++;
2080 my $prepend = $prefix ? "via $prefix: " : '';
2082 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2083 sort keys %{"$ {class}::"}) {
2084 next if $seen{ $name }++;
2085 print $DB::OUT "$prepend$name\n";
2087 return unless shift; # Recurse?
2088 for $name (@{"$ {class}::ISA"}) {
2089 $prepend = $prefix ? $prefix . " -> $name" : $name;
2090 methods_via($name, $prepend, 1);
2094 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2096 BEGIN { # This does not compile, alas.
2097 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2098 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2102 $deep = 100; # warning if stack gets this deep
2106 $SIG{INT} = \&DB::catch;
2107 # This may be enabled to debug debugger:
2108 #$warnLevel = 1 unless defined $warnLevel;
2109 #$dieLevel = 1 unless defined $dieLevel;
2110 #$signalLevel = 1 unless defined $signalLevel;
2112 $db_stop = 0; # Compiler warning
2114 $level = 0; # Level of recursive debugging
2115 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2116 # Triggers bug (?) in perl is we postpone this until runtime:
2117 @postponed = @stack = (0);
2118 $stack_depth = 0; # Localized $#stack
2123 BEGIN {$^W = $ini_warn;} # Switch warnings back
2125 #use Carp; # This did break, left for debuggin
2128 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2129 my($text, $line, $start) = @_;
2130 my ($itext, $search, $prefix, $pack) =
2131 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2133 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2134 (map { /$search/ ? ($1) : () } keys %sub)
2135 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2136 return sort grep /^\Q$text/, values %INC # files
2137 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2138 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2139 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2140 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2141 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2143 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2145 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2146 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2147 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2148 # We may want to complete to (eval 9), so $text may be wrong
2149 $prefix = length($1) - length($text);
2152 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2154 if ((substr $text, 0, 1) eq '&') { # subroutines
2155 $text = substr $text, 1;
2157 return sort map "$prefix$_",
2160 (map { /$search/ ? ($1) : () }
2163 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2164 $pack = ($1 eq 'main' ? '' : $1) . '::';
2165 $prefix = (substr $text, 0, 1) . $1 . '::';
2168 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2169 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2170 return db_complete($out[0], $line, $start);
2174 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2175 $pack = ($package eq 'main' ? '' : $package) . '::';
2176 $prefix = substr $text, 0, 1;
2177 $text = substr $text, 1;
2178 my @out = map "$prefix$_", grep /^\Q$text/,
2179 (grep /^_?[a-zA-Z]/, keys %$pack),
2180 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2181 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2182 return db_complete($out[0], $line, $start);
2186 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2187 my @out = grep /^\Q$text/, @options;
2188 my $val = option_val($out[0], undef);
2190 if (not defined $val or $val =~ /[\n\r]/) {
2191 # Can do nothing better
2192 } elsif ($val =~ /\s/) {
2194 foreach $l (split //, qq/\"\'\#\|/) {
2195 $out = "$l$val$l ", last if (index $val, $l) == -1;
2200 # Default to value if one completion, to question if many
2201 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2204 return $term->filename_list($text); # filenames
2208 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2212 $finished = $inhibit_exit; # So that some keys may be disabled.
2213 # Do not stop in at_exit() and destructors on exit:
2214 $DB::single = !$exiting && !$runnonstop;
2215 DB::fake::at_exit() unless $exiting or $runnonstop;
2221 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2224 package DB; # Do not trace this 1; below!