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;
299 if ($^O =~ /cygwin/) {
300 # /dev/tty is binary. use stdin for textmode
302 } elsif (-e "/dev/tty") {
303 $console = "/dev/tty";
304 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
307 $console = "sys\$command";
310 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
315 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
319 $console = $tty if defined $tty;
321 if (defined $console) {
322 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
323 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
324 || open(OUT,">&STDOUT"); # so we don't dongle stdout
327 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
328 $console = 'STDIN/OUT';
330 # so open("|more") can read from STDOUT and so we don't dingle stdin
335 $| = 1; # for DB::OUT
338 $LINEINFO = $OUT unless defined $LINEINFO;
339 $lineinfo = $console unless defined $lineinfo;
341 $| = 1; # for real STDOUT
343 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
344 unless ($runnonstop) {
345 print $OUT "\nLoading DB routines from $header\n";
346 print $OUT ("Emacs support ",
347 $emacs ? "enabled" : "available",
349 print $OUT "\nEnter h or `h h' for help.\n\n";
356 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
359 if (defined &afterinit) { # May be defined in $rcfile
365 ############################################################ Subroutines
368 # _After_ the perl program is compiled, $single is set to 1:
369 if ($single and not $second_time++) {
370 if ($runnonstop) { # Disable until signal
371 for ($i=0; $i <= $stack_depth; ) {
375 # return; # Would not print trace!
376 } elsif ($ImmediateStop) {
381 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
383 ($package, $filename, $line) = caller;
384 $filename_ini = $filename;
385 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
386 "package $package;"; # this won't let them modify, alas
387 local(*dbline) = $main::{'_<' . $filename};
389 if (($stop,$action) = split(/\0/,$dbline{$line})) {
393 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
394 $dbline{$line} =~ s/;9($|\0)/$1/;
397 my $was_signal = $signal;
399 for (my $n = 0; $n <= $#to_watch; $n++) {
400 $evalarg = $to_watch[$n];
401 local $onetimeDump; # Do not output results
402 my ($val) = &eval; # Fix context (&eval is doing array)?
403 $val = ( (defined $val) ? "'$val'" : 'undef' );
404 if ($val ne $old_watch[$n]) {
407 Watchpoint $n:\t$to_watch[$n] changed:
408 old value:\t$old_watch[$n]
411 $old_watch[$n] = $val;
415 if ($trace & 4) { # User-installed watch
416 return if watchfunction($package, $filename, $line)
417 and not $single and not $was_signal and not ($trace & ~4);
419 $was_signal = $signal;
421 if ($single || ($trace & 1) || $was_signal) {
423 $position = "\032\032$filename:$line:0\n";
424 print $LINEINFO $position;
425 } elsif ($package eq 'DB::fake') {
428 Debugged program terminated. Use B<q> to quit or B<R> to restart,
429 use B<O> I<inhibit_exit> to avoid stopping after program termination,
430 B<h q>, B<h R> or B<h O> to get additional info.
433 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
434 "package $package;"; # this won't let them modify, alas
437 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
438 $prefix .= "$sub($filename:";
439 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
440 if (length($prefix) > 30) {
441 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
446 $position = "$prefix$line$infix$dbline[$line]$after";
449 print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
451 print $LINEINFO $position;
453 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
454 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
456 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
457 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
458 $position .= $incr_pos;
460 print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
462 print $LINEINFO $incr_pos;
467 $evalarg = $action, &eval if $action;
468 if ($single || $was_signal) {
469 local $level = $level + 1;
470 foreach $evalarg (@$pre) {
473 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
476 $incr = -1; # for backward motion.
477 @typeahead = @$pretype, @typeahead;
479 while (($term || &setterm),
480 ($term_pid == $$ or &resetterm),
481 defined ($cmd=&readline(" DB" . ('<' x $level) .
482 ($#hist+1) . ('>' x $level) .
486 $cmd =~ s/\\$/\n/ && do {
487 $cmd .= &readline(" cont: ");
490 $cmd =~ /^$/ && ($cmd = $laststep);
491 push(@hist,$cmd) if length($cmd) > 1;
493 ($i) = split(/\s+/,$cmd);
494 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
495 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
496 $cmd =~ /^h$/ && do {
499 $cmd =~ /^h\s+h$/ && do {
500 print_help($summary);
502 $cmd =~ /^h\s+(\S)$/ && do {
504 if ($help =~ /^(?:[IB]<)$asked/m) {
505 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
509 print_help("B<$asked> is not a debugger command.\n");
512 $cmd =~ /^t$/ && do {
513 ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
514 print $OUT "Trace = " .
515 (($trace & 1) ? "on" : "off" ) . "\n";
517 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
518 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
519 foreach $subname (sort(keys %sub)) {
520 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
521 print $OUT $subname,"\n";
525 $cmd =~ /^v$/ && do {
526 list_versions(); next CMD};
527 $cmd =~ s/^X\b/V $package/;
528 $cmd =~ /^V$/ && do {
529 $cmd = "V $package"; };
530 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
531 local ($savout) = select($OUT);
533 @vars = split(' ',$2);
534 do 'dumpvar.pl' unless defined &main::dumpvar;
535 if (defined &main::dumpvar) {
538 &main::dumpvar($packname,@vars);
540 print $OUT "dumpvar.pl not available.\n";
544 $cmd =~ s/^x\b/ / && do { # So that will be evaled
545 $onetimeDump = 'dump'; };
546 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
547 methods($1); next CMD};
548 $cmd =~ s/^m\b/ / && do { # So this will be evaled
549 $onetimeDump = 'methods'; };
550 $cmd =~ /^f\b\s*(.*)/ && do {
554 print $OUT "The old f command is now the r command.\n";
555 print $OUT "The new f command switches filenames.\n";
558 if (!defined $main::{'_<' . $file}) {
559 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
560 $try = substr($try,2);
561 print $OUT "Choosing $try matching `$file':\n";
565 if (!defined $main::{'_<' . $file}) {
566 print $OUT "No file matching `$file' is loaded.\n";
568 } elsif ($file ne $filename) {
569 *dbline = $main::{'_<' . $file};
575 print $OUT "Already in $file.\n";
579 $cmd =~ s/^l\s+-\s*$/-/;
580 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
582 $subname =~ s/\'/::/;
583 $subname = $package."::".$subname
584 unless $subname =~ /::/;
585 $subname = "main".$subname if substr($subname,0,2) eq "::";
586 @pieces = split(/:/,find_sub($subname));
587 $subrange = pop @pieces;
588 $file = join(':', @pieces);
589 if ($file ne $filename) {
590 *dbline = $main::{'_<' . $file};
595 if (eval($subrange) < -$window) {
596 $subrange =~ s/-.*/+/;
598 $cmd = "l $subrange";
600 print $OUT "Subroutine $subname not found.\n";
603 $cmd =~ /^\.$/ && do {
604 $incr = -1; # for backward motion.
606 $filename = $filename_ini;
607 *dbline = $main::{'_<' . $filename};
609 print $LINEINFO $position;
611 $cmd =~ /^w\b\s*(\d*)$/ && do {
615 #print $OUT 'l ' . $start . '-' . ($start + $incr);
616 $cmd = 'l ' . $start . '-' . ($start + $incr); };
617 $cmd =~ /^-$/ && do {
618 $start -= $incr + $window + 1;
619 $start = 1 if $start <= 0;
621 $cmd = 'l ' . ($start) . '+'; };
622 $cmd =~ /^l$/ && do {
624 $cmd = 'l ' . $start . '-' . ($start + $incr); };
625 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
628 $incr = $window - 1 unless $incr;
629 $cmd = 'l ' . $start . '-' . ($start + $incr); };
630 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
631 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
632 $end = $max if $end > $max;
634 $i = $line if $i eq '.';
638 print $OUT "\032\032$filename:$i:0\n";
641 for (; $i <= $end; $i++) {
642 ($stop,$action) = split(/\0/, $dbline{$i});
644 and $filename eq $filename_ini)
646 : ($dbline[$i]+0 ? ':' : ' ') ;
647 $arrow .= 'b' if $stop;
648 $arrow .= 'a' if $action;
649 print $OUT "$i$arrow\t", $dbline[$i];
650 $i++, last if $signal;
652 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
654 $start = $i; # remember in case they want more
655 $start = $max if $start > $max;
657 $cmd =~ /^D$/ && do {
658 print $OUT "Deleting all breakpoints...\n";
660 for $file (keys %had_breakpoints) {
661 local *dbline = $main::{'_<' . $file};
665 for ($i = 1; $i <= $max ; $i++) {
666 if (defined $dbline{$i}) {
667 $dbline{$i} =~ s/^[^\0]+//;
668 if ($dbline{$i} =~ s/^\0?$//) {
675 undef %postponed_file;
676 undef %break_on_load;
677 undef %had_breakpoints;
679 $cmd =~ /^L$/ && do {
681 for $file (keys %had_breakpoints) {
682 local *dbline = $main::{'_<' . $file};
686 for ($i = 1; $i <= $max; $i++) {
687 if (defined $dbline{$i}) {
688 print "$file:\n" unless $was++;
689 print $OUT " $i:\t", $dbline[$i];
690 ($stop,$action) = split(/\0/, $dbline{$i});
691 print $OUT " break if (", $stop, ")\n"
693 print $OUT " action: ", $action, "\n"
700 print $OUT "Postponed breakpoints in subroutines:\n";
702 for $subname (keys %postponed) {
703 print $OUT " $subname\t$postponed{$subname}\n";
707 my @have = map { # Combined keys
708 keys %{$postponed_file{$_}}
709 } keys %postponed_file;
711 print $OUT "Postponed breakpoints in files:\n";
713 for $file (keys %postponed_file) {
714 my $db = $postponed_file{$file};
715 print $OUT " $file:\n";
716 for $line (sort {$a <=> $b} keys %$db) {
717 print $OUT " $line:\n";
718 my ($stop,$action) = split(/\0/, $$db{$line});
719 print $OUT " break if (", $stop, ")\n"
721 print $OUT " action: ", $action, "\n"
728 if (%break_on_load) {
729 print $OUT "Breakpoints on load:\n";
731 for $file (keys %break_on_load) {
732 print $OUT " $file\n";
737 print $OUT "Watch-expressions:\n";
739 for $expr (@to_watch) {
740 print $OUT " $expr\n";
745 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
746 my $file = $1; $file =~ s/\s+$//;
748 $break_on_load{$file} = 1;
749 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
750 $file .= '.pm', redo unless $file =~ /\./;
752 $had_breakpoints{$file} = 1;
753 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
755 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
756 my $cond = $3 || '1';
757 my ($subname, $break) = ($2, $1 eq 'postpone');
758 $subname =~ s/\'/::/;
759 $subname = "${'package'}::" . $subname
760 unless $subname =~ /::/;
761 $subname = "main".$subname if substr($subname,0,2) eq "::";
762 $postponed{$subname} = $break
763 ? "break +0 if $cond" : "compile";
765 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
768 $subname =~ s/\'/::/;
769 $subname = "${'package'}::" . $subname
770 unless $subname =~ /::/;
771 $subname = "main".$subname if substr($subname,0,2) eq "::";
772 # Filename below can contain ':'
773 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
777 *dbline = $main::{'_<' . $filename};
778 $had_breakpoints{$filename} = 1;
780 ++$i while $dbline[$i] == 0 && $i < $max;
781 $dbline{$i} =~ s/^[^\0]*/$cond/;
783 print $OUT "Subroutine $subname not found.\n";
786 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
789 if ($dbline[$i] == 0) {
790 print $OUT "Line $i not breakable.\n";
792 $had_breakpoints{$filename} = 1;
793 $dbline{$i} =~ s/^[^\0]*/$cond/;
796 $cmd =~ /^d\b\s*(\d+)?/ && do {
798 $dbline{$i} =~ s/^[^\0]*//;
799 delete $dbline{$i} if $dbline{$i} eq '';
801 $cmd =~ /^A$/ && do {
803 for $file (keys %had_breakpoints) {
804 local *dbline = $main::{'_<' . $file};
808 for ($i = 1; $i <= $max ; $i++) {
809 if (defined $dbline{$i}) {
810 $dbline{$i} =~ s/\0[^\0]*//;
811 delete $dbline{$i} if $dbline{$i} eq '';
816 $cmd =~ /^O\s*$/ && do {
821 $cmd =~ /^O\s*(\S.*)/ && do {
824 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
825 push @$pre, action($1);
827 $cmd =~ /^>>\s*(.*)/ && do {
828 push @$post, action($1);
830 $cmd =~ /^<\s*(.*)/ && do {
831 $pre = [], next CMD unless $1;
834 $cmd =~ /^>\s*(.*)/ && do {
835 $post = [], next CMD unless $1;
836 $post = [action($1)];
838 $cmd =~ /^\{\{\s*(.*)/ && do {
841 $cmd =~ /^\{\s*(.*)/ && do {
842 $pretype = [], next CMD unless $1;
845 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
847 if ($dbline[$i] == 0) {
848 print $OUT "Line $i may not have an action.\n";
850 $dbline{$i} =~ s/\0[^\0]*//;
851 $dbline{$i} .= "\0" . action($j);
854 $cmd =~ /^n$/ && do {
855 end_report(), next CMD if $finished and $level <= 1;
859 $cmd =~ /^s$/ && do {
860 end_report(), next CMD if $finished and $level <= 1;
864 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
865 end_report(), next CMD if $finished and $level <= 1;
867 if ($i =~ /\D/) { # subroutine name
868 $subname = $package."::".$subname
869 unless $subname =~ /::/;
870 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
874 *dbline = $main::{'_<' . $filename};
875 $had_breakpoints{$filename}++;
877 ++$i while $dbline[$i] == 0 && $i < $max;
879 print $OUT "Subroutine $subname not found.\n";
884 if ($dbline[$i] == 0) {
885 print $OUT "Line $i not breakable.\n";
888 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
890 for ($i=0; $i <= $stack_depth; ) {
894 $cmd =~ /^r$/ && do {
895 end_report(), next CMD if $finished and $level <= 1;
896 $stack[$stack_depth] |= 1;
897 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
899 $cmd =~ /^R$/ && do {
900 print $OUT "Warning: some settings and command-line options may be lost!\n";
901 my (@script, @flags, $cl);
902 push @flags, '-w' if $ini_warn;
903 # Put all the old includes at the start to get
906 push @flags, '-I', $_;
908 # Arrange for setting the old INC:
909 set_list("PERLDB_INC", @ini_INC);
911 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
912 chomp ($cl = $ {'::_<-e'}[$_]);
913 push @script, '-e', $cl;
918 set_list("PERLDB_HIST",
919 $term->Features->{getHistory}
920 ? $term->GetHistory : @hist);
921 my @had_breakpoints = keys %had_breakpoints;
922 set_list("PERLDB_VISITED", @had_breakpoints);
923 set_list("PERLDB_OPT", %option);
924 set_list("PERLDB_ON_LOAD", %break_on_load);
926 for (0 .. $#had_breakpoints) {
927 my $file = $had_breakpoints[$_];
928 *dbline = $main::{'_<' . $file};
929 next unless %dbline or $postponed_file{$file};
930 (push @hard, $file), next
931 if $file =~ /^\(eval \d+\)$/;
933 @add = %{$postponed_file{$file}}
934 if $postponed_file{$file};
935 set_list("PERLDB_FILE_$_", %dbline, @add);
937 for (@hard) { # Yes, really-really...
938 # Find the subroutines in this eval
939 *dbline = $main::{'_<' . $_};
940 my ($quoted, $sub, %subs, $line) = quotemeta $_;
941 for $sub (keys %sub) {
942 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
943 $subs{$sub} = [$1, $2];
947 "No subroutines in $_, ignoring breakpoints.\n";
950 LINES: for $line (keys %dbline) {
951 # One breakpoint per sub only:
952 my ($offset, $sub, $found);
953 SUBS: for $sub (keys %subs) {
954 if ($subs{$sub}->[1] >= $line # Not after the subroutine
955 and (not defined $offset # Not caught
956 or $offset < 0 )) { # or badly caught
958 $offset = $line - $subs{$sub}->[0];
959 $offset = "+$offset", last SUBS if $offset >= 0;
962 if (defined $offset) {
964 "break $offset if $dbline{$line}";
966 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
970 set_list("PERLDB_POSTPONE", %postponed);
971 set_list("PERLDB_PRETYPE", @$pretype);
972 set_list("PERLDB_PRE", @$pre);
973 set_list("PERLDB_POST", @$post);
974 set_list("PERLDB_TYPEAHEAD", @typeahead);
975 $ENV{PERLDB_RESTART} = 1;
976 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
977 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
978 print $OUT "exec failed: $!\n";
980 $cmd =~ /^T$/ && do {
981 print_trace($OUT, 1); # skip DB
983 $cmd =~ /^W\s*$/ && do {
985 @to_watch = @old_watch = ();
987 $cmd =~ /^W\b\s*(.*)/s && do {
991 $val = (defined $val) ? "'$val'" : 'undef' ;
992 push @old_watch, $val;
995 $cmd =~ /^\/(.*)$/ && do {
997 $inpat =~ s:([^\\])/$:$1:;
999 eval '$inpat =~ m'."\a$inpat\a";
1011 $start = 1 if ($start > $max);
1012 last if ($start == $end);
1013 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1015 print $OUT "\032\032$filename:$start:0\n";
1017 print $OUT "$start:\t", $dbline[$start], "\n";
1022 print $OUT "/$pat/: not found\n" if ($start == $end);
1024 $cmd =~ /^\?(.*)$/ && do {
1026 $inpat =~ s:([^\\])\?$:$1:;
1028 eval '$inpat =~ m'."\a$inpat\a";
1040 $start = $max if ($start <= 0);
1041 last if ($start == $end);
1042 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1044 print $OUT "\032\032$filename:$start:0\n";
1046 print $OUT "$start:\t", $dbline[$start], "\n";
1051 print $OUT "?$pat?: not found\n" if ($start == $end);
1053 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1054 pop(@hist) if length($cmd) > 1;
1055 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1057 print $OUT $cmd, "\n";
1059 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1062 $cmd =~ /^$rc([^$rc].*)$/ && do {
1064 pop(@hist) if length($cmd) > 1;
1065 for ($i = $#hist; $i; --$i) {
1066 last if $hist[$i] =~ /$pat/;
1069 print $OUT "No such command!\n\n";
1073 print $OUT $cmd, "\n";
1075 $cmd =~ /^$sh$/ && do {
1076 &system($ENV{SHELL}||"/bin/sh");
1078 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1079 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1081 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1082 $end = $2?($#hist-$2):0;
1083 $hist = 0 if $hist < 0;
1084 for ($i=$#hist; $i>$end; $i--) {
1085 print $OUT "$i: ",$hist[$i],"\n"
1086 unless $hist[$i] =~ /^.?$/;
1089 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1090 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1091 $cmd =~ /^=/ && do {
1092 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1093 $alias{$k}="s~$k~$v~";
1094 print $OUT "$k = $v\n";
1095 } elsif ($cmd =~ /^=\s*$/) {
1096 foreach $k (sort keys(%alias)) {
1097 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1098 print $OUT "$k = $v\n";
1100 print $OUT "$k\t$alias{$k}\n";
1105 $cmd =~ /^\|\|?\s*[^|]/ && do {
1106 if ($pager =~ /^\|/) {
1107 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1108 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1110 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1112 unless ($piped=open(OUT,$pager)) {
1113 &warn("Can't pipe output to `$pager'");
1114 if ($pager =~ /^\|/) {
1115 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1116 open(STDOUT,">&SAVEOUT")
1117 || &warn("Can't restore STDOUT");
1120 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1124 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1125 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1126 $selected= select(OUT);
1128 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1129 $cmd =~ s/^\|+\s*//;
1131 # XXX Local variants do not work!
1132 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1133 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1134 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1136 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1138 $onetimeDump = undef;
1139 } elsif ($term_pid == $$) {
1144 if ($pager =~ /^\|/) {
1145 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1146 &warn( "Pager `$pager' failed: ",
1147 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1148 ( $? & 128 ) ? " (core dumped)" : "",
1149 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1150 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1151 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1152 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1153 # Will stop ignoring SIGPIPE if done like nohup(1)
1154 # does SIGINT but Perl doesn't give us a choice.
1156 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1159 select($selected), $selected= "" unless $selected eq "";
1163 $exiting = 1 unless defined $cmd;
1164 foreach $evalarg (@$post) {
1167 } # if ($single || $signal)
1168 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1172 # The following code may be executed now:
1176 my ($al, $ret, @ret) = "";
1177 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1180 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1181 $#stack = $stack_depth;
1182 $stack[-1] = $single;
1184 $single |= 4 if $stack_depth == $deep;
1186 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
1187 # Why -1? But it works! :-(
1188 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1189 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1192 $single |= $stack[$stack_depth--];
1194 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1195 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1196 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1197 if ($doret eq $stack_depth or $frame & 16) {
1198 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1199 print $fh ' ' x $stack_depth if $frame & 16;
1200 print $fh "list context return from $sub:\n";
1201 dumpit($fh, \@ret );
1206 if (defined wantarray) {
1211 $single |= $stack[$stack_depth--];
1213 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1214 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1215 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1216 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1217 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1218 print $fh (' ' x $stack_depth) if $frame & 16;
1219 print $fh (defined wantarray
1220 ? "scalar context return from $sub: "
1221 : "void context return from $sub\n");
1222 dumpit( $fh, $ret ) if defined wantarray;
1230 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1231 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1234 # The following takes its argument via $evalarg to preserve current @_
1239 my $otrace = $trace;
1240 my $osingle = $single;
1242 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1248 local $saved[0]; # Preserve the old value of $@
1252 } elsif ($onetimeDump eq 'dump') {
1253 dumpit($OUT, \@res);
1254 } elsif ($onetimeDump eq 'methods') {
1261 my $subname = shift;
1262 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1263 my $offset = $1 || 0;
1264 # Filename below can contain ':'
1265 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1268 local *dbline = $main::{'_<' . $file};
1269 local $^W = 0; # != 0 is magical below
1270 $had_breakpoints{$file}++;
1272 ++$i until $dbline[$i] != 0 or $i >= $max;
1273 $dbline{$i} = delete $postponed{$subname};
1275 print $OUT "Subroutine $subname not found.\n";
1279 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1280 #print $OUT "In postponed_sub for `$subname'.\n";
1284 if ($ImmediateStop) {
1288 return &postponed_sub
1289 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1290 # Cannot be done before the file is compiled
1291 local *dbline = shift;
1292 my $filename = $dbline;
1293 $filename =~ s/^_<//;
1294 $signal = 1, print $OUT "'$filename' loaded...\n"
1295 if $break_on_load{$filename};
1296 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1297 return unless $postponed_file{$filename};
1298 $had_breakpoints{$filename}++;
1299 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1301 for $key (keys %{$postponed_file{$filename}}) {
1302 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1304 delete $postponed_file{$filename};
1308 local ($savout) = select(shift);
1309 my $osingle = $single;
1310 my $otrace = $trace;
1311 $single = $trace = 0;
1314 unless (defined &main::dumpValue) {
1317 if (defined &main::dumpValue) {
1318 &main::dumpValue(shift);
1320 print $OUT "dumpvar.pl not available.\n";
1327 # Tied method do not create a context, so may get wrong message:
1331 my @sub = dump_trace($_[0] + 1, $_[1]);
1332 my $short = $_[2]; # Print short report, next one for sub name
1334 for ($i=0; $i <= $#sub; $i++) {
1337 my $args = defined $sub[$i]{args}
1338 ? "(@{ $sub[$i]{args} })"
1340 $args = (substr $args, 0, $maxtrace - 3) . '...'
1341 if length $args > $maxtrace;
1342 my $file = $sub[$i]{file};
1343 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1345 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1347 my $sub = @_ >= 4 ? $_[3] : $s;
1348 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1350 print $fh "$sub[$i]{context} = $s$args" .
1351 " called from $file" .
1352 " line $sub[$i]{line}\n";
1359 my $count = shift || 1e9;
1362 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1363 my $nothard = not $frame & 8;
1364 local $frame = 0; # Do not want to trace this.
1365 my $otrace = $trace;
1368 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1373 if (not defined $arg) {
1375 } elsif ($nothard and tied $arg) {
1377 } elsif ($nothard and $type = ref $arg) {
1378 push @a, "ref($type)";
1380 local $_ = "$arg"; # Safe to stringify now - should not call f().
1383 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1384 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1385 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1389 $context = $context ? '@' : (defined $context ? "\$" : '.');
1390 $args = $h ? [@a] : undef;
1391 $e =~ s/\n\s*\;\s*\Z// if $e;
1392 $e =~ s/([\\\'])/\\$1/g if $e;
1394 $sub = "require '$e'";
1395 } elsif (defined $r) {
1397 } elsif ($sub eq '(eval)') {
1398 $sub = "eval {...}";
1400 push(@sub, {context => $context, sub => $sub, args => $args,
1401 file => $file, line => $line});
1410 while ($action =~ s/\\$//) {
1421 &readline("cont: ");
1425 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1426 # many non-Unix systems can do system() but have problems with fork().
1427 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1428 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1429 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1430 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1432 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1433 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1434 close(SAVEIN); close(SAVEOUT);
1435 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1436 ( $? & 128 ) ? " (core dumped)" : "",
1437 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1444 eval { require Term::ReadLine } or die $@;
1447 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1448 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1451 my $sel = select($OUT);
1455 eval "require Term::Rendezvous;" or die $@;
1456 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1457 my $term_rv = new Term::Rendezvous $rv;
1459 $OUT = $term_rv->OUT;
1463 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1465 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1467 $rl_attribs = $term->Attribs;
1468 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1469 if defined $rl_attribs->{basic_word_break_characters}
1470 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1471 $rl_attribs->{special_prefixes} = '$@&%';
1472 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1473 $rl_attribs->{completion_function} = \&db_complete;
1475 $LINEINFO = $OUT unless defined $LINEINFO;
1476 $lineinfo = $console unless defined $lineinfo;
1478 if ($term->Features->{setHistory} and "@hist" ne "?") {
1479 $term->SetHistory(@hist);
1481 ornaments($ornaments) if defined $ornaments;
1485 sub resetterm { # We forked, so we need a different TTY
1487 if (defined &get_fork_TTY) {
1489 } elsif (not defined $fork_TTY
1490 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1491 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1492 # Possibly _inside_ XTERM
1493 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1498 if (defined $fork_TTY) {
1503 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1504 Define B<\$DB::fork_TTY>
1505 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1506 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1507 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1508 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1515 my $left = @typeahead;
1516 my $got = shift @typeahead;
1517 print $OUT "auto(-$left)", shift, $got, "\n";
1518 $term->AddHistory($got)
1519 if length($got) > 1 and defined $term->Features->{addHistory};
1524 $term->readline(@_);
1528 my ($opt, $val)= @_;
1529 $val = option_val($opt,'N/A');
1530 $val =~ s/([\\\'])/\\$1/g;
1531 printf $OUT "%20s = '%s'\n", $opt, $val;
1535 my ($opt, $default)= @_;
1537 if (defined $optionVars{$opt}
1538 and defined $ {$optionVars{$opt}}) {
1539 $val = $ {$optionVars{$opt}};
1540 } elsif (defined $optionAction{$opt}
1541 and defined &{$optionAction{$opt}}) {
1542 $val = &{$optionAction{$opt}}();
1543 } elsif (defined $optionAction{$opt}
1544 and not defined $option{$opt}
1545 or defined $optionVars{$opt}
1546 and not defined $ {$optionVars{$opt}}) {
1549 $val = $option{$opt};
1557 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1558 my ($opt,$sep) = ($1,$2);
1561 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1563 #&dump_option($opt);
1564 } elsif ($sep !~ /\S/) {
1566 } elsif ($sep eq "=") {
1569 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1570 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1571 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1572 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1574 $val =~ s/\\([\\$end])/$1/g;
1578 grep( /^\Q$opt/ && ($option = $_), @options );
1579 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1581 print $OUT "Unknown option `$opt'\n" unless $matches;
1582 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1583 $option{$option} = $val if $matches == 1 and defined $val;
1584 eval "local \$frame = 0; local \$doret = -2;
1585 require '$optionRequire{$option}'"
1586 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1587 $ {$optionVars{$option}} = $val
1589 and defined $optionVars{$option} and defined $val;
1590 & {$optionAction{$option}} ($val)
1592 and defined $optionAction{$option}
1593 and defined &{$optionAction{$option}} and defined $val;
1594 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1600 my ($stem,@list) = @_;
1602 $ENV{"$ {stem}_n"} = @list;
1603 for $i (0 .. $#list) {
1605 $val =~ s/\\/\\\\/g;
1606 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1607 $ENV{"$ {stem}_$i"} = $val;
1614 my $n = delete $ENV{"$ {stem}_n"};
1616 for $i (0 .. $n - 1) {
1617 $val = delete $ENV{"$ {stem}_$i"};
1618 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1626 return; # Put nothing on the stack - malloc/free land!
1630 my($msg)= join("",@_);
1631 $msg .= ": $!\n" unless $msg =~ /\n$/;
1636 if (@_ and $term and $term->Features->{newTTY}) {
1637 my ($in, $out) = shift;
1639 ($in, $out) = split /,/, $in, 2;
1643 open IN, $in or die "cannot open `$in' for read: $!";
1644 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1645 $term->newTTY(\*IN, \*OUT);
1649 } elsif ($term and @_) {
1650 &warn("Too late to set TTY, enabled on next `R'!\n");
1658 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1660 $notty = shift if @_;
1666 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1673 if ($ {$term->Features}{tkRunning}) {
1674 return $term->tkRunning(@_);
1676 print $OUT "tkRunning not supported by current ReadLine package.\n";
1683 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1685 $runnonstop = shift if @_;
1692 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1699 $sh = quotemeta shift;
1700 $sh .= "\\b" if $sh =~ /\w$/;
1704 $psh =~ s/\\(.)/$1/g;
1710 if (defined $term) {
1711 local ($warnLevel,$dieLevel) = (0, 1);
1712 return '' unless $term->Features->{ornaments};
1713 eval { $term->ornaments(@_) } || '';
1721 $rc = quotemeta shift;
1722 $rc .= "\\b" if $rc =~ /\w$/;
1726 $prc =~ s/\\(.)/$1/g;
1732 return $lineinfo unless @_;
1734 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1735 $emacs = ($stream =~ /^\|/);
1736 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1737 $LINEINFO = \*LINEINFO;
1738 my $save = select($LINEINFO);
1752 s/^Term::ReadLine::readline$/readline/;
1753 if (defined $ { $_ . '::VERSION' }) {
1754 $version{$file} = "$ { $_ . '::VERSION' } from ";
1756 $version{$file} .= $INC{$file};
1758 dumpit($OUT,\%version);
1764 B<s> [I<expr>] Single step [in I<expr>].
1765 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1766 <B<CR>> Repeat last B<n> or B<s> command.
1767 B<r> Return from current subroutine.
1768 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1769 at the specified position.
1770 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1771 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1772 B<l> I<line> List single I<line>.
1773 B<l> I<subname> List first window of lines from subroutine.
1774 B<l> List next window of lines.
1775 B<-> List previous window of lines.
1776 B<w> [I<line>] List window around I<line>.
1777 B<.> Return to the executed line.
1778 B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
1779 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1780 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1781 B<L> List all breakpoints and actions.
1782 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1783 B<t> Toggle trace mode.
1784 B<t> I<expr> Trace through execution of I<expr>.
1785 B<b> [I<line>] [I<condition>]
1786 Set breakpoint; I<line> defaults to the current execution line;
1787 I<condition> breaks if it evaluates to true, defaults to '1'.
1788 B<b> I<subname> [I<condition>]
1789 Set breakpoint at first line of subroutine.
1790 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1791 B<b> B<postpone> I<subname> [I<condition>]
1792 Set breakpoint at first line of subroutine after
1794 B<b> B<compile> I<subname>
1795 Stop after the subroutine is compiled.
1796 B<d> [I<line>] Delete the breakpoint for I<line>.
1797 B<D> Delete all breakpoints.
1798 B<a> [I<line>] I<command>
1799 Set an action to be done before the I<line> is executed.
1800 Sequence is: check for breakpoint/watchpoint, print line
1801 if necessary, do action, prompt user if necessary,
1803 B<A> Delete all actions.
1804 B<W> I<expr> Add a global watch-expression.
1805 B<W> Delete all watch-expressions.
1806 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1807 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1808 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1809 B<x> I<expr> Evals expression in array context, dumps the result.
1810 B<m> I<expr> Evals expression in array context, prints methods callable
1811 on the first element of the result.
1812 B<m> I<class> Prints methods callable via the given class.
1813 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1814 Set or query values of options. I<val> defaults to 1. I<opt> can
1815 be abbreviated. Several options can be listed.
1816 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1817 I<pager>: program for output of \"|cmd\";
1818 I<tkRunning>: run Tk while prompting (with ReadLine);
1819 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1820 I<inhibit_exit> Allows stepping off the end of the script.
1821 I<ImmediateStop> Debugger should stop as early as possible.
1822 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1823 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1824 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1825 I<globPrint>: whether to print contents of globs;
1826 I<DumpDBFiles>: dump arrays holding debugged files;
1827 I<DumpPackages>: dump symbol tables of packages;
1828 I<DumpReused>: dump contents of \"reused\" addresses;
1829 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1830 I<bareStringify>: Do not print the overload-stringified value;
1831 Option I<PrintRet> affects printing of return value after B<r> command,
1832 I<frame> affects printing messages on entry and exit from subroutines.
1833 I<AutoTrace> affects printing messages on every possible breaking point.
1834 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1835 I<ornaments> affects screen appearance of the command line.
1836 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1837 You can put additional initialization options I<TTY>, I<noTTY>,
1838 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1839 B<<> I<expr> Define Perl command to run before each prompt.
1840 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1841 B<>> I<expr> Define Perl command to run after each prompt.
1842 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1843 B<{> I<db_command> Define debugger command to run before each prompt.
1844 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1845 B<$prc> I<number> Redo a previous command (default previous command).
1846 B<$prc> I<-number> Redo number'th-to-last command.
1847 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1848 See 'B<O> I<recallCommand>' too.
1849 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1850 . ( $rc eq $sh ? "" : "
1851 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1852 See 'B<O> I<shellBang>' too.
1853 B<H> I<-number> Display last number commands (default all).
1854 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1855 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1856 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1857 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1858 I<command> Execute as a perl statement in current package.
1859 B<v> Show versions of loaded modules.
1860 B<R> Pure-man-restart of debugger, some of debugger state
1861 and command-line options may be lost.
1862 Currently the following setting are preserved:
1863 history, breakpoints and actions, debugger B<O>ptions
1864 and the following command-line options: I<-w>, I<-I>, I<-e>.
1865 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1866 B<h h> Summary of debugger commands.
1867 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1870 $summary = <<"END_SUM";
1871 I<List/search source lines:> I<Control script execution:>
1872 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1873 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1874 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1875 B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s>
1876 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1877 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1878 I<Debugger controls:> B<L> List break/watch/actions
1879 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1880 B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint
1881 B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub
1882 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1883 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1884 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1885 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1886 B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1887 B<q> or B<^D> Quit B<R> Attempt a restart
1888 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1889 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1890 B<p> I<expr> Print expression (uses script's current package).
1891 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1892 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1893 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1895 # ')}}; # Fix balance of Emacs parsing
1899 my $message = shift;
1900 if (@Term::ReadLine::TermCap::rl_term_set) {
1901 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1902 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1904 print $OUT $message;
1910 $SIG{'ABRT'} = 'DEFAULT';
1911 kill 'ABRT', $$ if $panic++;
1912 if (defined &Carp::longmess) {
1913 local $SIG{__WARN__} = '';
1914 local $Carp::CarpLevel = 2; # mydie + confess
1915 &warn(Carp::longmess("Signal @_"));
1918 print $DB::OUT "Got signal @_\n";
1926 local $SIG{__WARN__} = '';
1927 local $SIG{__DIE__} = '';
1928 eval { require Carp } if defined $^S; # If error/warning during compilation,
1929 # require may be broken.
1930 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1931 return unless defined &Carp::longmess;
1932 my ($mysingle,$mytrace) = ($single,$trace);
1933 $single = 0; $trace = 0;
1934 my $mess = Carp::longmess(@_);
1935 ($single,$trace) = ($mysingle,$mytrace);
1942 local $SIG{__DIE__} = '';
1943 local $SIG{__WARN__} = '';
1944 my $i = 0; my $ineval = 0; my $sub;
1945 if ($dieLevel > 2) {
1946 local $SIG{__WARN__} = \&dbwarn;
1947 &warn(@_); # Yell no matter what
1950 if ($dieLevel < 2) {
1951 die @_ if $^S; # in eval propagate
1953 eval { require Carp } if defined $^S; # If error/warning during compilation,
1954 # require may be broken.
1955 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1956 unless defined &Carp::longmess;
1957 # We do not want to debug this chunk (automatic disabling works
1958 # inside DB::DB, but not in Carp).
1959 my ($mysingle,$mytrace) = ($single,$trace);
1960 $single = 0; $trace = 0;
1961 my $mess = Carp::longmess(@_);
1962 ($single,$trace) = ($mysingle,$mytrace);
1968 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1971 $SIG{__WARN__} = \&DB::dbwarn;
1973 $SIG{__WARN__} = $prevwarn;
1981 $prevdie = $SIG{__DIE__} unless $dieLevel;
1984 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1985 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1986 print $OUT "Stack dump during die enabled",
1987 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1989 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1991 $SIG{__DIE__} = $prevdie;
1992 print $OUT "Default die handler restored.\n";
2000 $prevsegv = $SIG{SEGV} unless $signalLevel;
2001 $prevbus = $SIG{BUS} unless $signalLevel;
2002 $signalLevel = shift;
2004 $SIG{SEGV} = \&DB::diesignal;
2005 $SIG{BUS} = \&DB::diesignal;
2007 $SIG{SEGV} = $prevsegv;
2008 $SIG{BUS} = $prevbus;
2016 return unless defined &$subr;
2018 $subr = \&$subr; # Hard reference
2021 $s = $_, last if $subr eq \&$_;
2029 $class = ref $class if ref $class;
2032 methods_via($class, '', 1);
2033 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2038 return if $packs{$class}++;
2040 my $prepend = $prefix ? "via $prefix: " : '';
2042 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2043 sort keys %{"$ {class}::"}) {
2044 next if $seen{ $name }++;
2045 print $DB::OUT "$prepend$name\n";
2047 return unless shift; # Recurse?
2048 for $name (@{"$ {class}::ISA"}) {
2049 $prepend = $prefix ? $prefix . " -> $name" : $name;
2050 methods_via($name, $prepend, 1);
2054 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2056 BEGIN { # This does not compile, alas.
2057 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2058 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2062 $deep = 100; # warning if stack gets this deep
2066 $SIG{INT} = \&DB::catch;
2067 # This may be enabled to debug debugger:
2068 #$warnLevel = 1 unless defined $warnLevel;
2069 #$dieLevel = 1 unless defined $dieLevel;
2070 #$signalLevel = 1 unless defined $signalLevel;
2072 $db_stop = 0; # Compiler warning
2074 $level = 0; # Level of recursive debugging
2075 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2076 # Triggers bug (?) in perl is we postpone this until runtime:
2077 @postponed = @stack = (0);
2078 $stack_depth = 0; # Localized $#stack
2083 BEGIN {$^W = $ini_warn;} # Switch warnings back
2085 #use Carp; # This did break, left for debuggin
2088 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2089 my($text, $line, $start) = @_;
2090 my ($itext, $search, $prefix, $pack) =
2091 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2093 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2094 (map { /$search/ ? ($1) : () } keys %sub)
2095 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2096 return sort grep /^\Q$text/, values %INC # files
2097 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2098 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2099 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2100 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2101 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2103 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2105 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2106 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2107 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2108 # We may want to complete to (eval 9), so $text may be wrong
2109 $prefix = length($1) - length($text);
2112 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2114 if ((substr $text, 0, 1) eq '&') { # subroutines
2115 $text = substr $text, 1;
2117 return sort map "$prefix$_",
2120 (map { /$search/ ? ($1) : () }
2123 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2124 $pack = ($1 eq 'main' ? '' : $1) . '::';
2125 $prefix = (substr $text, 0, 1) . $1 . '::';
2128 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2129 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2130 return db_complete($out[0], $line, $start);
2134 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2135 $pack = ($package eq 'main' ? '' : $package) . '::';
2136 $prefix = substr $text, 0, 1;
2137 $text = substr $text, 1;
2138 my @out = map "$prefix$_", grep /^\Q$text/,
2139 (grep /^_?[a-zA-Z]/, keys %$pack),
2140 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2141 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2142 return db_complete($out[0], $line, $start);
2146 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2147 my @out = grep /^\Q$text/, @options;
2148 my $val = option_val($out[0], undef);
2150 if (not defined $val or $val =~ /[\n\r]/) {
2151 # Can do nothing better
2152 } elsif ($val =~ /\s/) {
2154 foreach $l (split //, qq/\"\'\#\|/) {
2155 $out = "$l$val$l ", last if (index $val, $l) == -1;
2160 # Default to value if one completion, to question if many
2161 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2164 return $term->filename_list($text); # filenames
2168 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2172 $finished = $inhibit_exit; # So that some keys may be disabled.
2173 # Do not stop in at_exit() and destructors on exit:
2174 $DB::single = !$exiting && !$runnonstop;
2175 DB::fake::at_exit() unless $exiting or $runnonstop;
2181 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2184 package DB; # Do not trace this 1; below!