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);
184 hashDepth => \$dumpvar::hashDepth,
185 arrayDepth => \$dumpvar::arrayDepth,
186 DumpDBFiles => \$dumpvar::dumpDBFiles,
187 DumpPackages => \$dumpvar::dumpPackages,
188 DumpReused => \$dumpvar::dumpReused,
189 HighBit => \$dumpvar::quoteHighBit,
190 undefPrint => \$dumpvar::printUndef,
191 globPrint => \$dumpvar::globPrint,
192 UsageOnly => \$dumpvar::usageOnly,
194 AutoTrace => \$trace,
195 inhibit_exit => \$inhibit_exit,
196 maxTraceLen => \$maxtrace,
200 compactDump => \&dumpvar::compactDump,
201 veryCompact => \&dumpvar::veryCompact,
202 quote => \&dumpvar::quote,
205 ReadLine => \&ReadLine,
206 NonStop => \&NonStop,
207 LineInfo => \&LineInfo,
208 recallCommand => \&recallCommand,
209 ShellBang => \&shellBang,
211 signalLevel => \&signalLevel,
212 warnLevel => \&warnLevel,
213 dieLevel => \&dieLevel,
214 tkRunning => \&tkRunning,
215 ornaments => \&ornaments,
219 compactDump => 'dumpvar.pl',
220 veryCompact => 'dumpvar.pl',
221 quote => 'dumpvar.pl',
224 # These guys may be defined in $ENV{PERL5DB} :
225 $rl = 1 unless defined $rl;
226 $warnLevel = 1 unless defined $warnLevel;
227 $dieLevel = 1 unless defined $dieLevel;
228 $signalLevel = 1 unless defined $signalLevel;
229 $pre = [] unless defined $pre;
230 $post = [] unless defined $post;
231 $pretype = [] unless defined $pretype;
232 warnLevel($warnLevel);
234 signalLevel($signalLevel);
235 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
236 &recallCommand("!") unless defined $prc;
237 &shellBang("!") unless defined $psh;
238 $maxtrace = 400 unless defined $maxtrace;
243 $rcfile="perldb.ini";
248 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
249 do "$ENV{LOGDIR}/$rcfile";
250 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
251 do "$ENV{HOME}/$rcfile";
254 if (defined $ENV{PERLDB_OPTS}) {
255 parse_options($ENV{PERLDB_OPTS});
258 if (exists $ENV{PERLDB_RESTART}) {
259 delete $ENV{PERLDB_RESTART};
261 @hist = get_list('PERLDB_HIST');
262 %break_on_load = get_list("PERLDB_ON_LOAD");
263 %postponed = get_list("PERLDB_POSTPONE");
264 my @had_breakpoints= get_list("PERLDB_VISITED");
265 for (0 .. $#had_breakpoints) {
266 my %pf = get_list("PERLDB_FILE_$_");
267 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
269 my %opt = get_list("PERLDB_OPT");
271 while (($opt,$val) = each %opt) {
272 $val =~ s/[\\\']/\\$1/g;
273 parse_options("$opt'$val'");
275 @INC = get_list("PERLDB_INC");
277 $pretype = [get_list("PERLDB_PRETYPE")];
278 $pre = [get_list("PERLDB_PRE")];
279 $post = [get_list("PERLDB_POST")];
280 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
286 # Is Perl being run from Emacs?
287 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
288 $rl = 0, shift(@main::ARGV) if $emacs;
290 #require Term::ReadLine;
293 $console = "/dev/tty";
294 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
297 $console = "sys\$command";
300 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
305 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
309 $console = $tty if defined $tty;
311 if (defined $console) {
312 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
313 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
314 || open(OUT,">&STDOUT"); # so we don't dongle stdout
317 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
318 $console = 'STDIN/OUT';
320 # so open("|more") can read from STDOUT and so we don't dingle stdin
325 $| = 1; # for DB::OUT
328 $LINEINFO = $OUT unless defined $LINEINFO;
329 $lineinfo = $console unless defined $lineinfo;
331 $| = 1; # for real STDOUT
333 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
334 unless ($runnonstop) {
335 print $OUT "\nLoading DB routines from $header\n";
336 print $OUT ("Emacs support ",
337 $emacs ? "enabled" : "available",
339 print $OUT "\nEnter h or `h h' for help.\n\n";
346 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
349 if (defined &afterinit) { # May be defined in $rcfile
355 ############################################################ Subroutines
358 # _After_ the perl program is compiled, $single is set to 1:
359 if ($single and not $second_time++) {
360 if ($runnonstop) { # Disable until signal
361 for ($i=0; $i <= $#stack; ) {
365 # return; # Would not print trace!
368 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
370 ($package, $filename, $line) = caller;
371 $filename_ini = $filename;
372 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
373 "package $package;"; # this won't let them modify, alas
374 local(*dbline) = $main::{'_<' . $filename};
376 if (($stop,$action) = split(/\0/,$dbline{$line})) {
380 $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
381 $dbline{$line} =~ s/;9($|\0)/$1/;
384 my $was_signal = $signal;
386 for (my $n = 0; $n <= $#to_watch; $n++) {
387 $evalarg = $to_watch[$n];
388 my ($val) = &eval; # Fix context (&eval is doing array)?
389 $val = ( (defined $val) ? "'$val'" : 'undef' );
390 if ($val ne $old_watch[$n]) {
393 Watchpoint $n:\t$to_watch[$n] changed:
394 old value:\t$old_watch[$n]
397 $old_watch[$n] = $val;
401 if ($trace & 4) { # User-installed watch
402 return if watchfunction($package, $filename, $line)
403 and not $single and not $was_signal and not ($trace & ~4);
405 $was_signal = $signal;
407 if ($single || ($trace & 1) || $was_signal) {
410 $position = "\032\032$filename:$line:0\n";
411 print $LINEINFO $position;
412 } elsif ($package eq 'DB::fake') {
414 Debugged program terminated. Use B<q> to quit or B<R> to restart,
415 use B<O> I<inhibit_exit> to avoid stopping after program termination,
416 B<h q>, B<h R> or B<h O> to get additional info.
419 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
420 "package $package;"; # this won't let them modify, alas
423 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
424 $prefix .= "$sub($filename:";
425 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
426 if (length($prefix) > 30) {
427 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
432 $position = "$prefix$line$infix$dbline[$line]$after";
435 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
437 print $LINEINFO $position;
439 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
440 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
442 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
443 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
444 $position .= $incr_pos;
446 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
448 print $LINEINFO $incr_pos;
453 $evalarg = $action, &eval if $action;
454 if ($single || $was_signal) {
455 local $level = $level + 1;
456 foreach $evalarg (@$pre) {
459 print $OUT $#stack . " levels deep in subroutine calls!\n"
462 $incr = -1; # for backward motion.
463 @typeahead = @$pretype, @typeahead;
465 while (($term || &setterm),
466 ($term_pid == $$ or &resetterm),
467 defined ($cmd=&readline(" DB" . ('<' x $level) .
468 ($#hist+1) . ('>' x $level) .
472 $cmd =~ s/\\$/\n/ && do {
473 $cmd .= &readline(" cont: ");
476 $cmd =~ /^$/ && ($cmd = $laststep);
477 push(@hist,$cmd) if length($cmd) > 1;
479 ($i) = split(/\s+/,$cmd);
480 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
481 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
482 $cmd =~ /^h$/ && do {
485 $cmd =~ /^h\s+h$/ && do {
486 print_help($summary);
488 $cmd =~ /^h\s+(\S)$/ && do {
490 if ($help =~ /^(?:[IB]<)$asked/m) {
491 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
495 print_help("B<$asked> is not a debugger command.\n");
498 $cmd =~ /^t$/ && do {
499 ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
500 print $OUT "Trace = " .
501 (($trace & 1) ? "on" : "off" ) . "\n";
503 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
504 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
505 foreach $subname (sort(keys %sub)) {
506 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
507 print $OUT $subname,"\n";
511 $cmd =~ /^v$/ && do {
512 list_versions(); next CMD};
513 $cmd =~ s/^X\b/V $package/;
514 $cmd =~ /^V$/ && do {
515 $cmd = "V $package"; };
516 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
517 local ($savout) = select($OUT);
519 @vars = split(' ',$2);
520 do 'dumpvar.pl' unless defined &main::dumpvar;
521 if (defined &main::dumpvar) {
524 &main::dumpvar($packname,@vars);
526 print $OUT "dumpvar.pl not available.\n";
530 $cmd =~ s/^x\b/ / && do { # So that will be evaled
531 $onetimeDump = 'dump'; };
532 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
533 methods($1); next CMD};
534 $cmd =~ s/^m\b/ / && do { # So this will be evaled
535 $onetimeDump = 'methods'; };
536 $cmd =~ /^f\b\s*(.*)/ && do {
540 print $OUT "The old f command is now the r command.\n";
541 print $OUT "The new f command switches filenames.\n";
544 if (!defined $main::{'_<' . $file}) {
545 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
546 $try = substr($try,2);
547 print $OUT "Choosing $try matching `$file':\n";
551 if (!defined $main::{'_<' . $file}) {
552 print $OUT "No file matching `$file' is loaded.\n";
554 } elsif ($file ne $filename) {
555 *dbline = $main::{'_<' . $file};
561 print $OUT "Already in $file.\n";
565 $cmd =~ s/^l\s+-\s*$/-/;
566 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
568 $subname =~ s/\'/::/;
569 $subname = $package."::".$subname
570 unless $subname =~ /::/;
571 $subname = "main".$subname if substr($subname,0,2) eq "::";
572 @pieces = split(/:/,find_sub($subname));
573 $subrange = pop @pieces;
574 $file = join(':', @pieces);
575 if ($file ne $filename) {
576 *dbline = $main::{'_<' . $file};
581 if (eval($subrange) < -$window) {
582 $subrange =~ s/-.*/+/;
584 $cmd = "l $subrange";
586 print $OUT "Subroutine $subname not found.\n";
589 $cmd =~ /^\.$/ && do {
590 $incr = -1; # for backward motion.
592 $filename = $filename_ini;
593 *dbline = $main::{'_<' . $filename};
595 print $LINEINFO $position;
597 $cmd =~ /^w\b\s*(\d*)$/ && do {
601 #print $OUT 'l ' . $start . '-' . ($start + $incr);
602 $cmd = 'l ' . $start . '-' . ($start + $incr); };
603 $cmd =~ /^-$/ && do {
604 $start -= $incr + $window + 1;
605 $start = 1 if $start <= 0;
607 $cmd = 'l ' . ($start) . '+'; };
608 $cmd =~ /^l$/ && do {
610 $cmd = 'l ' . $start . '-' . ($start + $incr); };
611 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
614 $incr = $window - 1 unless $incr;
615 $cmd = 'l ' . $start . '-' . ($start + $incr); };
616 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
617 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
618 $end = $max if $end > $max;
620 $i = $line if $i eq '.';
624 print $OUT "\032\032$filename:$i:0\n";
627 for (; $i <= $end; $i++) {
628 ($stop,$action) = split(/\0/, $dbline{$i});
630 and $filename eq $filename_ini)
632 : ($dbline[$i]+0 ? ':' : ' ') ;
633 $arrow .= 'b' if $stop;
634 $arrow .= 'a' if $action;
635 print $OUT "$i$arrow\t", $dbline[$i];
639 $start = $i; # remember in case they want more
640 $start = $max if $start > $max;
642 $cmd =~ /^D$/ && do {
643 print $OUT "Deleting all breakpoints...\n";
645 for $file (keys %had_breakpoints) {
646 local *dbline = $main::{'_<' . $file};
650 for ($i = 1; $i <= $max ; $i++) {
651 if (defined $dbline{$i}) {
652 $dbline{$i} =~ s/^[^\0]+//;
653 if ($dbline{$i} =~ s/^\0?$//) {
660 undef %postponed_file;
661 undef %break_on_load;
662 undef %had_breakpoints;
664 $cmd =~ /^L$/ && do {
666 for $file (keys %had_breakpoints) {
667 local *dbline = $main::{'_<' . $file};
671 for ($i = 1; $i <= $max; $i++) {
672 if (defined $dbline{$i}) {
673 print "$file:\n" unless $was++;
674 print $OUT " $i:\t", $dbline[$i];
675 ($stop,$action) = split(/\0/, $dbline{$i});
676 print $OUT " break if (", $stop, ")\n"
678 print $OUT " action: ", $action, "\n"
685 print $OUT "Postponed breakpoints in subroutines:\n";
687 for $subname (keys %postponed) {
688 print $OUT " $subname\t$postponed{$subname}\n";
692 my @have = map { # Combined keys
693 keys %{$postponed_file{$_}}
694 } keys %postponed_file;
696 print $OUT "Postponed breakpoints in files:\n";
698 for $file (keys %postponed_file) {
699 my $db = $postponed_file{$file};
700 print $OUT " $file:\n";
701 for $line (sort {$a <=> $b} keys %$db) {
702 print $OUT " $line:\n";
703 my ($stop,$action) = split(/\0/, $$db{$line});
704 print $OUT " break if (", $stop, ")\n"
706 print $OUT " action: ", $action, "\n"
713 if (%break_on_load) {
714 print $OUT "Breakpoints on load:\n";
716 for $file (keys %break_on_load) {
717 print $OUT " $file\n";
722 print $OUT "Watch-expressions:\n";
724 for $expr (@to_watch) {
725 print $OUT " $expr\n";
730 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
731 my $file = $1; $file =~ s/\s+$//;
733 $break_on_load{$file} = 1;
734 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
735 $file .= '.pm', redo unless $file =~ /\./;
737 $had_breakpoints{$file} = 1;
738 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
740 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
741 my $cond = $3 || '1';
742 my ($subname, $break) = ($2, $1 eq 'postpone');
743 $subname =~ s/\'/::/;
744 $subname = "${'package'}::" . $subname
745 unless $subname =~ /::/;
746 $subname = "main".$subname if substr($subname,0,2) eq "::";
747 $postponed{$subname} = $break
748 ? "break +0 if $cond" : "compile";
750 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
753 $subname =~ s/\'/::/;
754 $subname = "${'package'}::" . $subname
755 unless $subname =~ /::/;
756 $subname = "main".$subname if substr($subname,0,2) eq "::";
757 # Filename below can contain ':'
758 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
762 *dbline = $main::{'_<' . $filename};
763 $had_breakpoints{$filename} = 1;
765 ++$i while $dbline[$i] == 0 && $i < $max;
766 $dbline{$i} =~ s/^[^\0]*/$cond/;
768 print $OUT "Subroutine $subname not found.\n";
771 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
774 if ($dbline[$i] == 0) {
775 print $OUT "Line $i not breakable.\n";
777 $had_breakpoints{$filename} = 1;
778 $dbline{$i} =~ s/^[^\0]*/$cond/;
781 $cmd =~ /^d\b\s*(\d+)?/ && do {
783 $dbline{$i} =~ s/^[^\0]*//;
784 delete $dbline{$i} if $dbline{$i} eq '';
786 $cmd =~ /^A$/ && do {
788 for $file (keys %had_breakpoints) {
789 local *dbline = $main::{'_<' . $file};
793 for ($i = 1; $i <= $max ; $i++) {
794 if (defined $dbline{$i}) {
795 $dbline{$i} =~ s/\0[^\0]*//;
796 delete $dbline{$i} if $dbline{$i} eq '';
801 $cmd =~ /^O\s*$/ && do {
806 $cmd =~ /^O\s*(\S.*)/ && do {
809 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
810 push @$pre, action($1);
812 $cmd =~ /^>>\s*(.*)/ && do {
813 push @$post, action($1);
815 $cmd =~ /^<\s*(.*)/ && do {
816 $pre = [], next CMD unless $1;
819 $cmd =~ /^>\s*(.*)/ && do {
820 $post = [], next CMD unless $1;
821 $post = [action($1)];
823 $cmd =~ /^\{\{\s*(.*)/ && do {
826 $cmd =~ /^\{\s*(.*)/ && do {
827 $pretype = [], next CMD unless $1;
830 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
832 if ($dbline[$i] == 0) {
833 print $OUT "Line $i may not have an action.\n";
835 $dbline{$i} =~ s/\0[^\0]*//;
836 $dbline{$i} .= "\0" . action($j);
839 $cmd =~ /^n$/ && do {
840 end_report(), next CMD if $finished and $level <= 1;
844 $cmd =~ /^s$/ && do {
845 end_report(), next CMD if $finished and $level <= 1;
849 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
850 end_report(), next CMD if $finished and $level <= 1;
852 if ($i =~ /\D/) { # subroutine name
853 $subname = $package."::".$subname
854 unless $subname =~ /::/;
855 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
859 *dbline = $main::{'_<' . $filename};
860 $had_breakpoints{$filename}++;
862 ++$i while $dbline[$i] == 0 && $i < $max;
864 print $OUT "Subroutine $subname not found.\n";
869 if ($dbline[$i] == 0) {
870 print $OUT "Line $i not breakable.\n";
873 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
875 for ($i=0; $i <= $#stack; ) {
879 $cmd =~ /^r$/ && do {
880 end_report(), next CMD if $finished and $level <= 1;
881 $stack[$#stack] |= 1;
882 $doret = $option{PrintRet} ? $#stack - 1 : -2;
884 $cmd =~ /^R$/ && do {
885 print $OUT "Warning: some settings and command-line options may be lost!\n";
886 my (@script, @flags, $cl);
887 push @flags, '-w' if $ini_warn;
888 # Put all the old includes at the start to get
891 push @flags, '-I', $_;
893 # Arrange for setting the old INC:
894 set_list("PERLDB_INC", @ini_INC);
896 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
897 chomp ($cl = $ {'::_<-e'}[$_]);
898 push @script, '-e', $cl;
903 set_list("PERLDB_HIST",
904 $term->Features->{getHistory}
905 ? $term->GetHistory : @hist);
906 my @had_breakpoints = keys %had_breakpoints;
907 set_list("PERLDB_VISITED", @had_breakpoints);
908 set_list("PERLDB_OPT", %option);
909 set_list("PERLDB_ON_LOAD", %break_on_load);
911 for (0 .. $#had_breakpoints) {
912 my $file = $had_breakpoints[$_];
913 *dbline = $main::{'_<' . $file};
914 next unless %dbline or $postponed_file{$file};
915 (push @hard, $file), next
916 if $file =~ /^\(eval \d+\)$/;
918 @add = %{$postponed_file{$file}}
919 if $postponed_file{$file};
920 set_list("PERLDB_FILE_$_", %dbline, @add);
922 for (@hard) { # Yes, really-really...
923 # Find the subroutines in this eval
924 *dbline = $main::{'_<' . $_};
925 my ($quoted, $sub, %subs, $line) = quotemeta $_;
926 for $sub (keys %sub) {
927 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
928 $subs{$sub} = [$1, $2];
932 "No subroutines in $_, ignoring breakpoints.\n";
935 LINES: for $line (keys %dbline) {
936 # One breakpoint per sub only:
937 my ($offset, $sub, $found);
938 SUBS: for $sub (keys %subs) {
939 if ($subs{$sub}->[1] >= $line # Not after the subroutine
940 and (not defined $offset # Not caught
941 or $offset < 0 )) { # or badly caught
943 $offset = $line - $subs{$sub}->[0];
944 $offset = "+$offset", last SUBS if $offset >= 0;
947 if (defined $offset) {
949 "break $offset if $dbline{$line}";
951 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
955 set_list("PERLDB_POSTPONE", %postponed);
956 set_list("PERLDB_PRETYPE", @$pretype);
957 set_list("PERLDB_PRE", @$pre);
958 set_list("PERLDB_POST", @$post);
959 set_list("PERLDB_TYPEAHEAD", @typeahead);
960 $ENV{PERLDB_RESTART} = 1;
961 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
962 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
963 print $OUT "exec failed: $!\n";
965 $cmd =~ /^T$/ && do {
966 print_trace($OUT, 1); # skip DB
968 $cmd =~ /^W\s*$/ && do {
970 @to_watch = @old_watch = ();
972 $cmd =~ /^W\b\s*(.*)/s && do {
976 $val = (defined $val) ? "'$val'" : 'undef' ;
977 push @old_watch, $val;
980 $cmd =~ /^\/(.*)$/ && do {
982 $inpat =~ s:([^\\])/$:$1:;
984 eval '$inpat =~ m'."\a$inpat\a";
996 $start = 1 if ($start > $max);
997 last if ($start == $end);
998 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1000 print $OUT "\032\032$filename:$start:0\n";
1002 print $OUT "$start:\t", $dbline[$start], "\n";
1007 print $OUT "/$pat/: not found\n" if ($start == $end);
1009 $cmd =~ /^\?(.*)$/ && do {
1011 $inpat =~ s:([^\\])\?$:$1:;
1013 eval '$inpat =~ m'."\a$inpat\a";
1025 $start = $max if ($start <= 0);
1026 last if ($start == $end);
1027 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1029 print $OUT "\032\032$filename:$start:0\n";
1031 print $OUT "$start:\t", $dbline[$start], "\n";
1036 print $OUT "?$pat?: not found\n" if ($start == $end);
1038 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1039 pop(@hist) if length($cmd) > 1;
1040 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1041 $cmd = $hist[$i] . "\n";
1044 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1047 $cmd =~ /^$rc([^$rc].*)$/ && do {
1049 pop(@hist) if length($cmd) > 1;
1050 for ($i = $#hist; $i; --$i) {
1051 last if $hist[$i] =~ /$pat/;
1054 print $OUT "No such command!\n\n";
1057 $cmd = $hist[$i] . "\n";
1060 $cmd =~ /^$sh$/ && do {
1061 &system($ENV{SHELL}||"/bin/sh");
1063 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1064 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1066 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1067 $end = $2?($#hist-$2):0;
1068 $hist = 0 if $hist < 0;
1069 for ($i=$#hist; $i>$end; $i--) {
1070 print $OUT "$i: ",$hist[$i],"\n"
1071 unless $hist[$i] =~ /^.?$/;
1074 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1075 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1076 $cmd =~ /^=/ && do {
1077 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1078 $alias{$k}="s~$k~$v~";
1079 print $OUT "$k = $v\n";
1080 } elsif ($cmd =~ /^=\s*$/) {
1081 foreach $k (sort keys(%alias)) {
1082 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1083 print $OUT "$k = $v\n";
1085 print $OUT "$k\t$alias{$k}\n";
1090 $cmd =~ /^\|\|?\s*[^|]/ && do {
1091 if ($pager =~ /^\|/) {
1092 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1093 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1095 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1097 unless ($piped=open(OUT,$pager)) {
1098 &warn("Can't pipe output to `$pager'");
1099 if ($pager =~ /^\|/) {
1100 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1101 open(STDOUT,">&SAVEOUT")
1102 || &warn("Can't restore STDOUT");
1105 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1109 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1110 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1111 $selected= select(OUT);
1113 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1114 $cmd =~ s/^\|+\s*//;
1116 # XXX Local variants do not work!
1117 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1118 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1119 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1121 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1123 $onetimeDump = undef;
1124 } elsif ($term_pid == $$) {
1129 if ($pager =~ /^\|/) {
1130 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1131 &warn( "Pager `$pager' failed: ",
1132 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1133 ( $? & 128 ) ? " (core dumped)" : "",
1134 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1135 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1136 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1137 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1138 # Will stop ignoring SIGPIPE if done like nohup(1)
1139 # does SIGINT but Perl doesn't give us a choice.
1141 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1144 select($selected), $selected= "" unless $selected eq "";
1148 $exiting = 1 unless defined $cmd;
1149 foreach $evalarg (@$post) {
1152 } # if ($single || $signal)
1153 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1157 # The following code may be executed now:
1161 my ($al, $ret, @ret) = "";
1162 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1165 push(@stack, $single);
1167 $single |= 4 if $#stack == $deep;
1169 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1170 # Why -1? But it works! :-(
1171 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1172 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1175 $single |= pop(@stack);
1177 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1178 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1179 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1180 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1181 "list context return from $sub:\n"), dumpit( \@ret ),
1182 $doret = -2 if $doret eq $#stack or $frame & 16;
1185 if (defined wantarray) {
1190 $single |= pop(@stack);
1192 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1193 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1194 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1195 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1196 "scalar context return from $sub: "), dumpit( $ret ),
1197 $doret = -2 if $doret eq $#stack or $frame & 16;
1203 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1204 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1207 # The following takes its argument via $evalarg to preserve current @_
1212 local (@stack) = @stack; # guard against recursive debugging
1213 my $otrace = $trace;
1214 my $osingle = $single;
1216 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1222 local $saved[0]; # Preserve the old value of $@
1226 } elsif ($onetimeDump eq 'dump') {
1228 } elsif ($onetimeDump eq 'methods') {
1235 my $subname = shift;
1236 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1237 my $offset = $1 || 0;
1238 # Filename below can contain ':'
1239 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1242 local *dbline = $main::{'_<' . $file};
1243 local $^W = 0; # != 0 is magical below
1244 $had_breakpoints{$file}++;
1246 ++$i until $dbline[$i] != 0 or $i >= $max;
1247 $dbline{$i} = delete $postponed{$subname};
1249 print $OUT "Subroutine $subname not found.\n";
1253 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1254 #print $OUT "In postponed_sub for `$subname'.\n";
1258 return &postponed_sub
1259 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1260 # Cannot be done before the file is compiled
1261 local *dbline = shift;
1262 my $filename = $dbline;
1263 $filename =~ s/^_<//;
1264 $signal = 1, print $OUT "'$filename' loaded...\n"
1265 if $break_on_load{$filename};
1266 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1267 return unless $postponed_file{$filename};
1268 $had_breakpoints{$filename}++;
1269 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1271 for $key (keys %{$postponed_file{$filename}}) {
1272 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1274 delete $postponed_file{$filename};
1278 local ($savout) = select($OUT);
1279 my $osingle = $single;
1280 my $otrace = $trace;
1281 $single = $trace = 0;
1284 unless (defined &main::dumpValue) {
1287 if (defined &main::dumpValue) {
1288 &main::dumpValue(shift);
1290 print $OUT "dumpvar.pl not available.\n";
1297 # Tied method do not create a context, so may get wrong message:
1301 my @sub = dump_trace($_[0] + 1, $_[1]);
1302 my $short = $_[2]; # Print short report, next one for sub name
1304 for ($i=0; $i <= $#sub; $i++) {
1307 my $args = defined $sub[$i]{args}
1308 ? "(@{ $sub[$i]{args} })"
1310 $args = (substr $args, 0, $maxtrace - 3) . '...'
1311 if length $args > $maxtrace;
1312 my $file = $sub[$i]{file};
1313 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1315 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1317 my $sub = @_ >= 4 ? $_[3] : $s;
1318 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1320 print $fh "$sub[$i]{context} = $s$args" .
1321 " called from $file" .
1322 " line $sub[$i]{line}\n";
1329 my $count = shift || 1e9;
1332 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1333 my $nothard = not $frame & 8;
1334 local $frame = 0; # Do not want to trace this.
1335 my $otrace = $trace;
1338 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1343 if (not defined $arg) {
1345 } elsif ($nothard and tied $arg) {
1347 } elsif ($nothard and $type = ref $arg) {
1348 push @a, "ref($type)";
1350 local $_ = "$arg"; # Safe to stringify now - should not call f().
1353 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1354 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1355 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1359 $context = $context ? '@' : "\$";
1360 $args = $h ? [@a] : undef;
1361 $e =~ s/\n\s*\;\s*\Z// if $e;
1362 $e =~ s/([\\\'])/\\$1/g if $e;
1364 $sub = "require '$e'";
1365 } elsif (defined $r) {
1367 } elsif ($sub eq '(eval)') {
1368 $sub = "eval {...}";
1370 push(@sub, {context => $context, sub => $sub, args => $args,
1371 file => $file, line => $line});
1380 while ($action =~ s/\\$//) {
1391 &readline("cont: ");
1395 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1396 # many non-Unix systems can do system() but have problems with fork().
1397 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1398 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1399 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1400 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1402 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1403 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1404 close(SAVEIN); close(SAVEOUT);
1405 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1406 ( $? & 128 ) ? " (core dumped)" : "",
1407 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1414 local @stack = @stack; # Prevent growth by failing `use'.
1415 eval { require Term::ReadLine } or die $@;
1418 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1419 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1422 my $sel = select($OUT);
1426 eval "require Term::Rendezvous;" or die $@;
1427 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1428 my $term_rv = new Term::Rendezvous $rv;
1430 $OUT = $term_rv->OUT;
1434 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1436 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1438 $rl_attribs = $term->Attribs;
1439 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1440 if defined $rl_attribs->{basic_word_break_characters}
1441 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1442 $rl_attribs->{special_prefixes} = '$@&%';
1443 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1444 $rl_attribs->{completion_function} = \&db_complete;
1446 $LINEINFO = $OUT unless defined $LINEINFO;
1447 $lineinfo = $console unless defined $lineinfo;
1449 if ($term->Features->{setHistory} and "@hist" ne "?") {
1450 $term->SetHistory(@hist);
1452 ornaments($ornaments) if defined $ornaments;
1456 sub resetterm { # We forked, so we need a different TTY
1458 if (defined &get_fork_TTY) {
1460 } elsif (not defined $fork_TTY
1461 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1462 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1463 # Possibly _inside_ XTERM
1464 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1469 if (defined $fork_TTY) {
1474 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1475 Define B<\$DB::fork_TTY>
1476 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1477 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1478 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1479 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1486 my $left = @typeahead;
1487 my $got = shift @typeahead;
1488 print $OUT "auto(-$left)", shift, $got, "\n";
1489 $term->AddHistory($got)
1490 if length($got) > 1 and defined $term->Features->{addHistory};
1495 $term->readline(@_);
1499 my ($opt, $val)= @_;
1500 $val = option_val($opt,'N/A');
1501 $val =~ s/([\\\'])/\\$1/g;
1502 printf $OUT "%20s = '%s'\n", $opt, $val;
1506 my ($opt, $default)= @_;
1508 if (defined $optionVars{$opt}
1509 and defined $ {$optionVars{$opt}}) {
1510 $val = $ {$optionVars{$opt}};
1511 } elsif (defined $optionAction{$opt}
1512 and defined &{$optionAction{$opt}}) {
1513 $val = &{$optionAction{$opt}}();
1514 } elsif (defined $optionAction{$opt}
1515 and not defined $option{$opt}
1516 or defined $optionVars{$opt}
1517 and not defined $ {$optionVars{$opt}}) {
1520 $val = $option{$opt};
1528 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1529 my ($opt,$sep) = ($1,$2);
1532 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1534 #&dump_option($opt);
1535 } elsif ($sep !~ /\S/) {
1537 } elsif ($sep eq "=") {
1540 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1541 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1542 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1543 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1545 $val =~ s/\\([\\$end])/$1/g;
1549 grep( /^\Q$opt/ && ($option = $_), @options );
1550 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1552 print $OUT "Unknown option `$opt'\n" unless $matches;
1553 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1554 $option{$option} = $val if $matches == 1 and defined $val;
1555 eval "local \$frame = 0; local \$doret = -2;
1556 require '$optionRequire{$option}'"
1557 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1558 $ {$optionVars{$option}} = $val
1560 and defined $optionVars{$option} and defined $val;
1561 & {$optionAction{$option}} ($val)
1563 and defined $optionAction{$option}
1564 and defined &{$optionAction{$option}} and defined $val;
1565 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1571 my ($stem,@list) = @_;
1573 $ENV{"$ {stem}_n"} = @list;
1574 for $i (0 .. $#list) {
1576 $val =~ s/\\/\\\\/g;
1577 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1578 $ENV{"$ {stem}_$i"} = $val;
1585 my $n = delete $ENV{"$ {stem}_n"};
1587 for $i (0 .. $n - 1) {
1588 $val = delete $ENV{"$ {stem}_$i"};
1589 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1597 return; # Put nothing on the stack - malloc/free land!
1601 my($msg)= join("",@_);
1602 $msg .= ": $!\n" unless $msg =~ /\n$/;
1607 if (@_ and $term and $term->Features->{newTTY}) {
1608 my ($in, $out) = shift;
1610 ($in, $out) = split /,/, $in, 2;
1614 open IN, $in or die "cannot open `$in' for read: $!";
1615 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1616 $term->newTTY(\*IN, \*OUT);
1620 } elsif ($term and @_) {
1621 &warn("Too late to set TTY, enabled on next `R'!\n");
1629 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1631 $notty = shift if @_;
1637 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1644 if ($ {$term->Features}{tkRunning}) {
1645 return $term->tkRunning(@_);
1647 print $OUT "tkRunning not supported by current ReadLine package.\n";
1654 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1656 $runnonstop = shift if @_;
1663 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1670 $sh = quotemeta shift;
1671 $sh .= "\\b" if $sh =~ /\w$/;
1675 $psh =~ s/\\(.)/$1/g;
1681 if (defined $term) {
1682 local ($warnLevel,$dieLevel) = (0, 1);
1683 return '' unless $term->Features->{ornaments};
1684 eval { $term->ornaments(@_) } || '';
1692 $rc = quotemeta shift;
1693 $rc .= "\\b" if $rc =~ /\w$/;
1697 $prc =~ s/\\(.)/$1/g;
1703 return $lineinfo unless @_;
1705 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1706 $emacs = ($stream =~ /^\|/);
1707 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1708 $LINEINFO = \*LINEINFO;
1709 my $save = select($LINEINFO);
1723 s/^Term::ReadLine::readline$/readline/;
1724 if (defined $ { $_ . '::VERSION' }) {
1725 $version{$file} = "$ { $_ . '::VERSION' } from ";
1727 $version{$file} .= $INC{$file};
1729 do 'dumpvar.pl' unless defined &main::dumpValue;
1730 if (defined &main::dumpValue) {
1732 &main::dumpValue(\%version);
1734 print $OUT "dumpvar.pl not available.\n";
1741 B<s> [I<expr>] Single step [in I<expr>].
1742 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1743 <B<CR>> Repeat last B<n> or B<s> command.
1744 B<r> Return from current subroutine.
1745 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1746 at the specified position.
1747 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1748 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1749 B<l> I<line> List single I<line>.
1750 B<l> I<subname> List first window of lines from subroutine.
1751 B<l> List next window of lines.
1752 B<-> List previous window of lines.
1753 B<w> [I<line>] List window around I<line>.
1754 B<.> Return to the executed line.
1755 B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
1756 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1757 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1758 B<L> List all breakpoints and actions.
1759 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1760 B<t> Toggle trace mode.
1761 B<t> I<expr> Trace through execution of I<expr>.
1762 B<b> [I<line>] [I<condition>]
1763 Set breakpoint; I<line> defaults to the current execution line;
1764 I<condition> breaks if it evaluates to true, defaults to '1'.
1765 B<b> I<subname> [I<condition>]
1766 Set breakpoint at first line of subroutine.
1767 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1768 B<b> B<postpone> I<subname> [I<condition>]
1769 Set breakpoint at first line of subroutine after
1771 B<b> B<compile> I<subname>
1772 Stop after the subroutine is compiled.
1773 B<d> [I<line>] Delete the breakpoint for I<line>.
1774 B<D> Delete all breakpoints.
1775 B<a> [I<line>] I<command>
1776 Set an action to be done before the I<line> is executed.
1777 Sequence is: check for breakpoint/watchpoint, print line
1778 if necessary, do action, prompt user if necessary,
1780 B<A> Delete all actions.
1781 B<W> I<expr> Add a global watch-expression.
1782 B<W> Delete all watch-expressions.
1783 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1784 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1785 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1786 B<x> I<expr> Evals expression in array context, dumps the result.
1787 B<m> I<expr> Evals expression in array context, prints methods callable
1788 on the first element of the result.
1789 B<m> I<class> Prints methods callable via the given class.
1790 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1791 Set or query values of options. I<val> defaults to 1. I<opt> can
1792 be abbreviated. Several options can be listed.
1793 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1794 I<pager>: program for output of \"|cmd\";
1795 I<tkRunning>: run Tk while prompting (with ReadLine);
1796 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1797 I<inhibit_exit> Allows stepping off the end of the script.
1798 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1799 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1800 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1801 I<globPrint>: whether to print contents of globs;
1802 I<DumpDBFiles>: dump arrays holding debugged files;
1803 I<DumpPackages>: dump symbol tables of packages;
1804 I<DumpReused>: dump contents of \"reused\" addresses;
1805 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1806 Option I<PrintRet> affects printing of return value after B<r> command,
1807 I<frame> affects printing messages on entry and exit from subroutines.
1808 I<AutoTrace> affects printing messages on every possible breaking point.
1809 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1810 I<ornaments> affects screen appearance of the command line.
1811 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1812 You can put additional initialization options I<TTY>, I<noTTY>,
1813 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1814 B<<> I<expr> Define Perl command to run before each prompt.
1815 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1816 B<>> I<expr> Define Perl command to run after each prompt.
1817 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1818 B<{> I<db_command> Define debugger command to run before each prompt.
1819 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1820 B<$prc> I<number> Redo a previous command (default previous command).
1821 B<$prc> I<-number> Redo number'th-to-last command.
1822 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1823 See 'B<O> I<recallCommand>' too.
1824 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1825 . ( $rc eq $sh ? "" : "
1826 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1827 See 'B<O> I<shellBang>' too.
1828 B<H> I<-number> Display last number commands (default all).
1829 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1830 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1831 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1832 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1833 I<command> Execute as a perl statement in current package.
1834 B<v> Show versions of loaded modules.
1835 B<R> Pure-man-restart of debugger, some of debugger state
1836 and command-line options may be lost.
1837 Currently the following setting are preserved:
1838 history, breakpoints and actions, debugger B<O>ptions
1839 and the following command-line options: I<-w>, I<-I>, I<-e>.
1840 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1841 B<h h> Summary of debugger commands.
1842 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1845 $summary = <<"END_SUM";
1846 I<List/search source lines:> I<Control script execution:>
1847 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1848 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1849 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1850 B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s>
1851 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1852 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1853 I<Debugger controls:> B<L> List break/watch/actions
1854 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1855 B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint
1856 B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub
1857 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1858 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1859 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1860 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1861 B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1862 B<q> or B<^D> Quit B<R> Attempt a restart
1863 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1864 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1865 B<p> I<expr> Print expression (uses script's current package).
1866 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1867 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1868 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1870 # ')}}; # Fix balance of Emacs parsing
1874 my $message = shift;
1875 if (@Term::ReadLine::TermCap::rl_term_set) {
1876 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1877 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1879 print $OUT $message;
1885 $SIG{'ABRT'} = 'DEFAULT';
1886 kill 'ABRT', $$ if $panic++;
1887 if (defined &Carp::longmess) {
1888 local $SIG{__WARN__} = '';
1889 local $Carp::CarpLevel = 2; # mydie + confess
1890 &warn(Carp::longmess("Signal @_"));
1893 print $DB::OUT "Got signal @_\n";
1901 local $SIG{__WARN__} = '';
1902 local $SIG{__DIE__} = '';
1903 eval { require Carp } if defined $^S; # If error/warning during compilation,
1904 # require may be broken.
1905 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1906 return unless defined &Carp::longmess;
1907 my ($mysingle,$mytrace) = ($single,$trace);
1908 $single = 0; $trace = 0;
1909 my $mess = Carp::longmess(@_);
1910 ($single,$trace) = ($mysingle,$mytrace);
1917 local $SIG{__DIE__} = '';
1918 local $SIG{__WARN__} = '';
1919 my $i = 0; my $ineval = 0; my $sub;
1920 if ($dieLevel > 2) {
1921 local $SIG{__WARN__} = \&dbwarn;
1922 &warn(@_); # Yell no matter what
1925 if ($dieLevel < 2) {
1926 die @_ if $^S; # in eval propagate
1928 eval { require Carp } if defined $^S; # If error/warning during compilation,
1929 # require may be broken.
1930 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1931 unless defined &Carp::longmess;
1932 # We do not want to debug this chunk (automatic disabling works
1933 # inside DB::DB, but not in Carp).
1934 my ($mysingle,$mytrace) = ($single,$trace);
1935 $single = 0; $trace = 0;
1936 my $mess = Carp::longmess(@_);
1937 ($single,$trace) = ($mysingle,$mytrace);
1943 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1946 $SIG{__WARN__} = \&DB::dbwarn;
1948 $SIG{__WARN__} = $prevwarn;
1956 $prevdie = $SIG{__DIE__} unless $dieLevel;
1959 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1960 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1961 print $OUT "Stack dump during die enabled",
1962 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1964 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1966 $SIG{__DIE__} = $prevdie;
1967 print $OUT "Default die handler restored.\n";
1975 $prevsegv = $SIG{SEGV} unless $signalLevel;
1976 $prevbus = $SIG{BUS} unless $signalLevel;
1977 $signalLevel = shift;
1979 $SIG{SEGV} = \&DB::diesignal;
1980 $SIG{BUS} = \&DB::diesignal;
1982 $SIG{SEGV} = $prevsegv;
1983 $SIG{BUS} = $prevbus;
1991 return unless defined &$subr;
1993 $subr = \&$subr; # Hard reference
1996 $s = $_, last if $subr eq \&$_;
2004 $class = ref $class if ref $class;
2007 methods_via($class, '', 1);
2008 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2013 return if $packs{$class}++;
2015 my $prepend = $prefix ? "via $prefix: " : '';
2017 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2018 sort keys %{"$ {class}::"}) {
2019 next if $seen{ $name }++;
2020 print $DB::OUT "$prepend$name\n";
2022 return unless shift; # Recurse?
2023 for $name (@{"$ {class}::ISA"}) {
2024 $prepend = $prefix ? $prefix . " -> $name" : $name;
2025 methods_via($name, $prepend, 1);
2029 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2031 BEGIN { # This does not compile, alas.
2032 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2033 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2037 $deep = 100; # warning if stack gets this deep
2041 $SIG{INT} = \&DB::catch;
2042 # This may be enabled to debug debugger:
2043 #$warnLevel = 1 unless defined $warnLevel;
2044 #$dieLevel = 1 unless defined $dieLevel;
2045 #$signalLevel = 1 unless defined $signalLevel;
2047 $db_stop = 0; # Compiler warning
2049 $level = 0; # Level of recursive debugging
2050 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2051 # Triggers bug (?) in perl is we postpone this until runtime:
2052 @postponed = @stack = (0);
2057 BEGIN {$^W = $ini_warn;} # Switch warnings back
2059 #use Carp; # This did break, left for debuggin
2062 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2063 my($text, $line, $start) = @_;
2064 my ($itext, $search, $prefix, $pack) =
2065 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2067 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2068 (map { /$search/ ? ($1) : () } keys %sub)
2069 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2070 return sort grep /^\Q$text/, values %INC # files
2071 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2072 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2073 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2074 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2075 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2077 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2079 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2080 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2081 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2082 # We may want to complete to (eval 9), so $text may be wrong
2083 $prefix = length($1) - length($text);
2086 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2088 if ((substr $text, 0, 1) eq '&') { # subroutines
2089 $text = substr $text, 1;
2091 return sort map "$prefix$_",
2094 (map { /$search/ ? ($1) : () }
2097 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2098 $pack = ($1 eq 'main' ? '' : $1) . '::';
2099 $prefix = (substr $text, 0, 1) . $1 . '::';
2102 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2103 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2104 return db_complete($out[0], $line, $start);
2108 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2109 $pack = ($package eq 'main' ? '' : $package) . '::';
2110 $prefix = substr $text, 0, 1;
2111 $text = substr $text, 1;
2112 my @out = map "$prefix$_", grep /^\Q$text/,
2113 (grep /^_?[a-zA-Z]/, keys %$pack),
2114 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2115 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2116 return db_complete($out[0], $line, $start);
2120 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2121 my @out = grep /^\Q$text/, @options;
2122 my $val = option_val($out[0], undef);
2124 if (not defined $val or $val =~ /[\n\r]/) {
2125 # Can do nothing better
2126 } elsif ($val =~ /\s/) {
2128 foreach $l (split //, qq/\"\'\#\|/) {
2129 $out = "$l$val$l ", last if (index $val, $l) == -1;
2134 # Default to value if one completion, to question if many
2135 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2138 return $term->filename_list($text); # filenames
2142 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2146 $finished = $inhibit_exit; # So that some keys may be disabled.
2147 # Do not stop in at_exit() and destructors on exit:
2148 $DB::single = !$exiting && !$runnonstop;
2149 DB::fake::at_exit() unless $exiting or $runnonstop;
2155 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2158 package DB; # Do not trace this 1; below!