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: $to_watch[$n] changed:
394 old value: $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;
414 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
415 $prefix .= "$sub($filename:";
416 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
417 if (length($prefix) > 30) {
418 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
423 $position = "$prefix$line$infix$dbline[$line]$after";
426 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
428 print $LINEINFO $position;
430 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
431 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
433 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
434 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
435 $position .= $incr_pos;
437 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
439 print $LINEINFO $incr_pos;
444 $evalarg = $action, &eval if $action;
445 if ($single || $was_signal) {
446 local $level = $level + 1;
447 foreach $evalarg (@$pre) {
450 print $OUT $#stack . " levels deep in subroutine calls!\n"
453 $incr = -1; # for backward motion.
454 @typeahead = @$pretype, @typeahead;
456 while (($term || &setterm),
457 ($term_pid == $$ or &resetterm),
458 defined ($cmd=&readline(" DB" . ('<' x $level) .
459 ($#hist+1) . ('>' x $level) .
463 $cmd =~ s/\\$/\n/ && do {
464 $cmd .= &readline(" cont: ");
467 $cmd =~ /^$/ && ($cmd = $laststep);
468 push(@hist,$cmd) if length($cmd) > 1;
470 ($i) = split(/\s+/,$cmd);
471 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
472 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
473 $cmd =~ /^h$/ && do {
476 $cmd =~ /^h\s+h$/ && do {
477 print_help($summary);
479 $cmd =~ /^h\s+(\S)$/ && do {
481 if ($help =~ /^(?:[IB]<)$asked/m) {
482 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
486 print_help("B<$asked> is not a debugger command.\n");
489 $cmd =~ /^t$/ && do {
490 ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
491 print $OUT "Trace = " .
492 (($trace & 1) ? "on" : "off" ) . "\n";
494 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
495 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
496 foreach $subname (sort(keys %sub)) {
497 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
498 print $OUT $subname,"\n";
502 $cmd =~ /^v$/ && do {
503 list_versions(); next CMD};
504 $cmd =~ s/^X\b/V $package/;
505 $cmd =~ /^V$/ && do {
506 $cmd = "V $package"; };
507 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
508 local ($savout) = select($OUT);
510 @vars = split(' ',$2);
511 do 'dumpvar.pl' unless defined &main::dumpvar;
512 if (defined &main::dumpvar) {
515 &main::dumpvar($packname,@vars);
517 print $OUT "dumpvar.pl not available.\n";
521 $cmd =~ s/^x\b/ / && do { # So that will be evaled
522 $onetimeDump = 'dump'; };
523 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
524 methods($1); next CMD};
525 $cmd =~ s/^m\b/ / && do { # So this will be evaled
526 $onetimeDump = 'methods'; };
527 $cmd =~ /^f\b\s*(.*)/ && do {
531 print $OUT "The old f command is now the r command.\n";
532 print $OUT "The new f command switches filenames.\n";
535 if (!defined $main::{'_<' . $file}) {
536 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
537 $try = substr($try,2);
538 print $OUT "Choosing $try matching `$file':\n";
542 if (!defined $main::{'_<' . $file}) {
543 print $OUT "No file matching `$file' is loaded.\n";
545 } elsif ($file ne $filename) {
546 *dbline = $main::{'_<' . $file};
552 print $OUT "Already in $file.\n";
556 $cmd =~ s/^l\s+-\s*$/-/;
557 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
559 $subname =~ s/\'/::/;
560 $subname = $package."::".$subname
561 unless $subname =~ /::/;
562 $subname = "main".$subname if substr($subname,0,2) eq "::";
563 @pieces = split(/:/,find_sub($subname));
564 $subrange = pop @pieces;
565 $file = join(':', @pieces);
566 if ($file ne $filename) {
567 *dbline = $main::{'_<' . $file};
572 if (eval($subrange) < -$window) {
573 $subrange =~ s/-.*/+/;
575 $cmd = "l $subrange";
577 print $OUT "Subroutine $subname not found.\n";
580 $cmd =~ /^\.$/ && do {
581 $incr = -1; # for backward motion.
583 $filename = $filename_ini;
584 *dbline = $main::{'_<' . $filename};
586 print $LINEINFO $position;
588 $cmd =~ /^w\b\s*(\d*)$/ && do {
592 #print $OUT 'l ' . $start . '-' . ($start + $incr);
593 $cmd = 'l ' . $start . '-' . ($start + $incr); };
594 $cmd =~ /^-$/ && do {
595 $start -= $incr + $window + 1;
596 $start = 1 if $start <= 0;
598 $cmd = 'l ' . ($start) . '+'; };
599 $cmd =~ /^l$/ && do {
601 $cmd = 'l ' . $start . '-' . ($start + $incr); };
602 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
605 $incr = $window - 1 unless $incr;
606 $cmd = 'l ' . $start . '-' . ($start + $incr); };
607 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
608 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
609 $end = $max if $end > $max;
611 $i = $line if $i eq '.';
615 print $OUT "\032\032$filename:$i:0\n";
618 for (; $i <= $end; $i++) {
619 ($stop,$action) = split(/\0/, $dbline{$i});
621 and $filename eq $filename_ini)
623 : ($dbline[$i]+0 ? ':' : ' ') ;
624 $arrow .= 'b' if $stop;
625 $arrow .= 'a' if $action;
626 print $OUT "$i$arrow\t", $dbline[$i];
630 $start = $i; # remember in case they want more
631 $start = $max if $start > $max;
633 $cmd =~ /^D$/ && do {
634 print $OUT "Deleting all breakpoints...\n";
636 for $file (keys %had_breakpoints) {
637 local *dbline = $main::{'_<' . $file};
641 for ($i = 1; $i <= $max ; $i++) {
642 if (defined $dbline{$i}) {
643 $dbline{$i} =~ s/^[^\0]+//;
644 if ($dbline{$i} =~ s/^\0?$//) {
651 undef %postponed_file;
652 undef %break_on_load;
653 undef %had_breakpoints;
655 $cmd =~ /^L$/ && do {
657 for $file (keys %had_breakpoints) {
658 local *dbline = $main::{'_<' . $file};
662 for ($i = 1; $i <= $max; $i++) {
663 if (defined $dbline{$i}) {
664 print "$file:\n" unless $was++;
665 print $OUT " $i:\t", $dbline[$i];
666 ($stop,$action) = split(/\0/, $dbline{$i});
667 print $OUT " break if (", $stop, ")\n"
669 print $OUT " action: ", $action, "\n"
676 print $OUT "Postponed breakpoints in subroutines:\n";
678 for $subname (keys %postponed) {
679 print $OUT " $subname\t$postponed{$subname}\n";
683 my @have = map { # Combined keys
684 keys %{$postponed_file{$_}}
685 } keys %postponed_file;
687 print $OUT "Postponed breakpoints in files:\n";
689 for $file (keys %postponed_file) {
690 my $db = $postponed_file{$file};
691 print $OUT " $file:\n";
692 for $line (sort {$a <=> $b} keys %$db) {
693 print $OUT " $line:\n";
694 my ($stop,$action) = split(/\0/, $$db{$line});
695 print $OUT " break if (", $stop, ")\n"
697 print $OUT " action: ", $action, "\n"
704 if (%break_on_load) {
705 print $OUT "Breakpoints on load:\n";
707 for $file (keys %break_on_load) {
708 print $OUT " $file\n";
713 print $OUT "Watch-expressions:\n";
715 for $expr (@to_watch) {
716 print $OUT " $expr\n";
721 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
722 my $file = $1; $file =~ s/\s+$//;
724 $break_on_load{$file} = 1;
725 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
726 $file .= '.pm', redo unless $file =~ /\./;
728 $had_breakpoints{$file} = 1;
729 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
731 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
732 my $cond = $3 || '1';
733 my ($subname, $break) = ($2, $1 eq 'postpone');
734 $subname =~ s/\'/::/;
735 $subname = "${'package'}::" . $subname
736 unless $subname =~ /::/;
737 $subname = "main".$subname if substr($subname,0,2) eq "::";
738 $postponed{$subname} = $break
739 ? "break +0 if $cond" : "compile";
741 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
744 $subname =~ s/\'/::/;
745 $subname = "${'package'}::" . $subname
746 unless $subname =~ /::/;
747 $subname = "main".$subname if substr($subname,0,2) eq "::";
748 # Filename below can contain ':'
749 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
753 *dbline = $main::{'_<' . $filename};
754 $had_breakpoints{$filename} = 1;
756 ++$i while $dbline[$i] == 0 && $i < $max;
757 $dbline{$i} =~ s/^[^\0]*/$cond/;
759 print $OUT "Subroutine $subname not found.\n";
762 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
765 if ($dbline[$i] == 0) {
766 print $OUT "Line $i not breakable.\n";
768 $had_breakpoints{$filename} = 1;
769 $dbline{$i} =~ s/^[^\0]*/$cond/;
772 $cmd =~ /^d\b\s*(\d+)?/ && do {
774 $dbline{$i} =~ s/^[^\0]*//;
775 delete $dbline{$i} if $dbline{$i} eq '';
777 $cmd =~ /^A$/ && do {
779 for $file (keys %had_breakpoints) {
780 local *dbline = $main::{'_<' . $file};
784 for ($i = 1; $i <= $max ; $i++) {
785 if (defined $dbline{$i}) {
786 $dbline{$i} =~ s/\0[^\0]*//;
787 delete $dbline{$i} if $dbline{$i} eq '';
792 $cmd =~ /^O\s*$/ && do {
797 $cmd =~ /^O\s*(\S.*)/ && do {
800 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
801 push @$pre, action($1);
803 $cmd =~ /^>>\s*(.*)/ && do {
804 push @$post, action($1);
806 $cmd =~ /^<\s*(.*)/ && do {
807 $pre = [], next CMD unless $1;
810 $cmd =~ /^>\s*(.*)/ && do {
811 $post = [], next CMD unless $1;
812 $post = [action($1)];
814 $cmd =~ /^\{\{\s*(.*)/ && do {
817 $cmd =~ /^\{\s*(.*)/ && do {
818 $pretype = [], next CMD unless $1;
821 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
823 if ($dbline[$i] == 0) {
824 print $OUT "Line $i may not have an action.\n";
826 $dbline{$i} =~ s/\0[^\0]*//;
827 $dbline{$i} .= "\0" . action($j);
830 $cmd =~ /^n$/ && do {
831 end_report(), next CMD if $finished and $level <= 1;
835 $cmd =~ /^s$/ && do {
836 end_report(), next CMD if $finished and $level <= 1;
840 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
841 end_report(), next CMD if $finished and $level <= 1;
843 if ($i =~ /\D/) { # subroutine name
844 $subname = $package."::".$subname
845 unless $subname =~ /::/;
846 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
850 *dbline = $main::{'_<' . $filename};
851 $had_breakpoints{$filename}++;
853 ++$i while $dbline[$i] == 0 && $i < $max;
855 print $OUT "Subroutine $subname not found.\n";
860 if ($dbline[$i] == 0) {
861 print $OUT "Line $i not breakable.\n";
864 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
866 for ($i=0; $i <= $#stack; ) {
870 $cmd =~ /^r$/ && do {
871 end_report(), next CMD if $finished and $level <= 1;
872 $stack[$#stack] |= 1;
873 $doret = $option{PrintRet} ? $#stack - 1 : -2;
875 $cmd =~ /^R$/ && do {
876 print $OUT "Warning: some settings and command-line options may be lost!\n";
877 my (@script, @flags, $cl);
878 push @flags, '-w' if $ini_warn;
879 # Put all the old includes at the start to get
882 push @flags, '-I', $_;
884 # Arrange for setting the old INC:
885 set_list("PERLDB_INC", @ini_INC);
887 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
888 chomp ($cl = $ {'::_<-e'}[$_]);
889 push @script, '-e', $cl;
894 set_list("PERLDB_HIST",
895 $term->Features->{getHistory}
896 ? $term->GetHistory : @hist);
897 my @had_breakpoints = keys %had_breakpoints;
898 set_list("PERLDB_VISITED", @had_breakpoints);
899 set_list("PERLDB_OPT", %option);
900 set_list("PERLDB_ON_LOAD", %break_on_load);
902 for (0 .. $#had_breakpoints) {
903 my $file = $had_breakpoints[$_];
904 *dbline = $main::{'_<' . $file};
905 next unless %dbline or $postponed_file{$file};
906 (push @hard, $file), next
907 if $file =~ /^\(eval \d+\)$/;
909 @add = %{$postponed_file{$file}}
910 if $postponed_file{$file};
911 set_list("PERLDB_FILE_$_", %dbline, @add);
913 for (@hard) { # Yes, really-really...
914 # Find the subroutines in this eval
915 *dbline = $main::{'_<' . $_};
916 my ($quoted, $sub, %subs, $line) = quotemeta $_;
917 for $sub (keys %sub) {
918 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
919 $subs{$sub} = [$1, $2];
923 "No subroutines in $_, ignoring breakpoints.\n";
926 LINES: for $line (keys %dbline) {
927 # One breakpoint per sub only:
928 my ($offset, $sub, $found);
929 SUBS: for $sub (keys %subs) {
930 if ($subs{$sub}->[1] >= $line # Not after the subroutine
931 and (not defined $offset # Not caught
932 or $offset < 0 )) { # or badly caught
934 $offset = $line - $subs{$sub}->[0];
935 $offset = "+$offset", last SUBS if $offset >= 0;
938 if (defined $offset) {
940 "break $offset if $dbline{$line}";
942 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
946 set_list("PERLDB_POSTPONE", %postponed);
947 set_list("PERLDB_PRETYPE", @$pretype);
948 set_list("PERLDB_PRE", @$pre);
949 set_list("PERLDB_POST", @$post);
950 set_list("PERLDB_TYPEAHEAD", @typeahead);
951 $ENV{PERLDB_RESTART} = 1;
952 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
953 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
954 print $OUT "exec failed: $!\n";
956 $cmd =~ /^T$/ && do {
957 print_trace($OUT, 1); # skip DB
959 $cmd =~ /^W\s*$/ && do {
961 @to_watch = @old_watch = ();
963 $cmd =~ /^W\b\s*(.*)/s && do {
967 $val = (defined $val) ? "'$val'" : 'undef' ;
968 push @old_watch, $val;
971 $cmd =~ /^\/(.*)$/ && do {
973 $inpat =~ s:([^\\])/$:$1:;
975 eval '$inpat =~ m'."\a$inpat\a";
987 $start = 1 if ($start > $max);
988 last if ($start == $end);
989 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
991 print $OUT "\032\032$filename:$start:0\n";
993 print $OUT "$start:\t", $dbline[$start], "\n";
998 print $OUT "/$pat/: not found\n" if ($start == $end);
1000 $cmd =~ /^\?(.*)$/ && do {
1002 $inpat =~ s:([^\\])\?$:$1:;
1004 eval '$inpat =~ m'."\a$inpat\a";
1016 $start = $max if ($start <= 0);
1017 last if ($start == $end);
1018 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1020 print $OUT "\032\032$filename:$start:0\n";
1022 print $OUT "$start:\t", $dbline[$start], "\n";
1027 print $OUT "?$pat?: not found\n" if ($start == $end);
1029 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1030 pop(@hist) if length($cmd) > 1;
1031 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1032 $cmd = $hist[$i] . "\n";
1035 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1038 $cmd =~ /^$rc([^$rc].*)$/ && do {
1040 pop(@hist) if length($cmd) > 1;
1041 for ($i = $#hist; $i; --$i) {
1042 last if $hist[$i] =~ /$pat/;
1045 print $OUT "No such command!\n\n";
1048 $cmd = $hist[$i] . "\n";
1051 $cmd =~ /^$sh$/ && do {
1052 &system($ENV{SHELL}||"/bin/sh");
1054 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1055 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1057 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1058 $end = $2?($#hist-$2):0;
1059 $hist = 0 if $hist < 0;
1060 for ($i=$#hist; $i>$end; $i--) {
1061 print $OUT "$i: ",$hist[$i],"\n"
1062 unless $hist[$i] =~ /^.?$/;
1065 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1066 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1067 $cmd =~ /^=/ && do {
1068 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1069 $alias{$k}="s~$k~$v~";
1070 print $OUT "$k = $v\n";
1071 } elsif ($cmd =~ /^=\s*$/) {
1072 foreach $k (sort keys(%alias)) {
1073 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1074 print $OUT "$k = $v\n";
1076 print $OUT "$k\t$alias{$k}\n";
1081 $cmd =~ /^\|\|?\s*[^|]/ && do {
1082 if ($pager =~ /^\|/) {
1083 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1084 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1086 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1088 unless ($piped=open(OUT,$pager)) {
1089 &warn("Can't pipe output to `$pager'");
1090 if ($pager =~ /^\|/) {
1091 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1092 open(STDOUT,">&SAVEOUT")
1093 || &warn("Can't restore STDOUT");
1096 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1100 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1101 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1102 $selected= select(OUT);
1104 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1105 $cmd =~ s/^\|+\s*//;
1107 # XXX Local variants do not work!
1108 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1109 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1110 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1112 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1114 $onetimeDump = undef;
1115 } elsif ($term_pid == $$) {
1120 if ($pager =~ /^\|/) {
1121 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1122 &warn( "Pager `$pager' failed: ",
1123 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1124 ( $? & 128 ) ? " (core dumped)" : "",
1125 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1126 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1127 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1128 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1129 # Will stop ignoring SIGPIPE if done like nohup(1)
1130 # does SIGINT but Perl doesn't give us a choice.
1132 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1135 select($selected), $selected= "" unless $selected eq "";
1139 $exiting = 1 unless defined $cmd;
1140 foreach $evalarg (@$post) {
1143 } # if ($single || $signal)
1144 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1148 # The following code may be executed now:
1152 my ($al, $ret, @ret) = "";
1153 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1156 push(@stack, $single);
1158 $single |= 4 if $#stack == $deep;
1160 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1161 # Why -1? But it works! :-(
1162 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1163 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1166 $single |= pop(@stack);
1168 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1169 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1170 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1171 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1172 "list context return from $sub:\n"), dumpit( \@ret ),
1173 $doret = -2 if $doret eq $#stack or $frame & 16;
1176 if (defined wantarray) {
1181 $single |= pop(@stack);
1183 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1184 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1185 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1186 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1187 "scalar context return from $sub: "), dumpit( $ret ),
1188 $doret = -2 if $doret eq $#stack or $frame & 16;
1194 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1195 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1198 # The following takes its argument via $evalarg to preserve current @_
1203 local (@stack) = @stack; # guard against recursive debugging
1204 my $otrace = $trace;
1205 my $osingle = $single;
1207 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1213 local $saved[0]; # Preserve the old value of $@
1217 } elsif ($onetimeDump eq 'dump') {
1219 } elsif ($onetimeDump eq 'methods') {
1226 my $subname = shift;
1227 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1228 my $offset = $1 || 0;
1229 # Filename below can contain ':'
1230 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1233 local *dbline = $main::{'_<' . $file};
1234 local $^W = 0; # != 0 is magical below
1235 $had_breakpoints{$file}++;
1237 ++$i until $dbline[$i] != 0 or $i >= $max;
1238 $dbline{$i} = delete $postponed{$subname};
1240 print $OUT "Subroutine $subname not found.\n";
1244 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1245 #print $OUT "In postponed_sub for `$subname'.\n";
1249 return &postponed_sub
1250 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1251 # Cannot be done before the file is compiled
1252 local *dbline = shift;
1253 my $filename = $dbline;
1254 $filename =~ s/^_<//;
1255 $signal = 1, print $OUT "'$filename' loaded...\n"
1256 if $break_on_load{$filename};
1257 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1258 return unless $postponed_file{$filename};
1259 $had_breakpoints{$filename}++;
1260 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1262 for $key (keys %{$postponed_file{$filename}}) {
1263 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1265 delete $postponed_file{$filename};
1269 local ($savout) = select($OUT);
1270 my $osingle = $single;
1271 my $otrace = $trace;
1272 $single = $trace = 0;
1275 unless (defined &main::dumpValue) {
1278 if (defined &main::dumpValue) {
1279 &main::dumpValue(shift);
1281 print $OUT "dumpvar.pl not available.\n";
1288 # Tied method do not create a context, so may get wrong message:
1292 my @sub = dump_trace($_[0] + 1, $_[1]);
1293 my $short = $_[2]; # Print short report, next one for sub name
1295 for ($i=0; $i <= $#sub; $i++) {
1298 my $args = defined $sub[$i]{args}
1299 ? "(@{ $sub[$i]{args} })"
1301 $args = (substr $args, 0, $maxtrace - 3) . '...'
1302 if length $args > $maxtrace;
1303 my $file = $sub[$i]{file};
1304 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1306 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1308 my $sub = @_ >= 4 ? $_[3] : $s;
1309 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1311 print $fh "$sub[$i]{context} = $s$args" .
1312 " called from $file" .
1313 " line $sub[$i]{line}\n";
1320 my $count = shift || 1e9;
1323 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1324 my $nothard = not $frame & 8;
1325 local $frame = 0; # Do not want to trace this.
1326 my $otrace = $trace;
1329 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1334 if (not defined $arg) {
1336 } elsif ($nothard and tied $arg) {
1338 } elsif ($nothard and $type = ref $arg) {
1339 push @a, "ref($type)";
1341 local $_ = "$arg"; # Safe to stringify now - should not call f().
1344 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1345 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1346 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1350 $context = $context ? '@' : "\$";
1351 $args = $h ? [@a] : undef;
1352 $e =~ s/\n\s*\;\s*\Z// if $e;
1353 $e =~ s/([\\\'])/\\$1/g if $e;
1355 $sub = "require '$e'";
1356 } elsif (defined $r) {
1358 } elsif ($sub eq '(eval)') {
1359 $sub = "eval {...}";
1361 push(@sub, {context => $context, sub => $sub, args => $args,
1362 file => $file, line => $line});
1371 while ($action =~ s/\\$//) {
1382 &readline("cont: ");
1386 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1387 # many non-Unix systems can do system() but have problems with fork().
1388 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1389 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1390 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1391 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1393 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1394 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1395 close(SAVEIN); close(SAVEOUT);
1396 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1397 ( $? & 128 ) ? " (core dumped)" : "",
1398 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1405 local @stack = @stack; # Prevent growth by failing `use'.
1406 eval { require Term::ReadLine } or die $@;
1409 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1410 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1413 my $sel = select($OUT);
1417 eval "require Term::Rendezvous;" or die $@;
1418 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1419 my $term_rv = new Term::Rendezvous $rv;
1421 $OUT = $term_rv->OUT;
1425 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1427 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1429 $rl_attribs = $term->Attribs;
1430 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1431 if defined $rl_attribs->{basic_word_break_characters}
1432 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1433 $rl_attribs->{special_prefixes} = '$@&%';
1434 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1435 $rl_attribs->{completion_function} = \&db_complete;
1437 $LINEINFO = $OUT unless defined $LINEINFO;
1438 $lineinfo = $console unless defined $lineinfo;
1440 if ($term->Features->{setHistory} and "@hist" ne "?") {
1441 $term->SetHistory(@hist);
1443 ornaments($ornaments) if defined $ornaments;
1447 sub resetterm { # We forked, so we need a different TTY
1449 if (defined &get_fork_TTY) {
1451 } elsif (not defined $fork_TTY
1452 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1453 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1454 # Possibly _inside_ XTERM
1455 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1460 if (defined $fork_TTY) {
1464 print $OUT "Forked, but do not know how to change a TTY.\n",
1465 "Define \$DB::fork_TTY or get_fork_TTY().\n";
1471 my $left = @typeahead;
1472 my $got = shift @typeahead;
1473 print $OUT "auto(-$left)", shift, $got, "\n";
1474 $term->AddHistory($got)
1475 if length($got) > 1 and defined $term->Features->{addHistory};
1480 $term->readline(@_);
1484 my ($opt, $val)= @_;
1485 $val = option_val($opt,'N/A');
1486 $val =~ s/([\\\'])/\\$1/g;
1487 printf $OUT "%20s = '%s'\n", $opt, $val;
1491 my ($opt, $default)= @_;
1493 if (defined $optionVars{$opt}
1494 and defined $ {$optionVars{$opt}}) {
1495 $val = $ {$optionVars{$opt}};
1496 } elsif (defined $optionAction{$opt}
1497 and defined &{$optionAction{$opt}}) {
1498 $val = &{$optionAction{$opt}}();
1499 } elsif (defined $optionAction{$opt}
1500 and not defined $option{$opt}
1501 or defined $optionVars{$opt}
1502 and not defined $ {$optionVars{$opt}}) {
1505 $val = $option{$opt};
1513 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1514 my ($opt,$sep) = ($1,$2);
1517 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1519 #&dump_option($opt);
1520 } elsif ($sep !~ /\S/) {
1522 } elsif ($sep eq "=") {
1525 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1526 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1527 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1528 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1530 $val =~ s/\\([\\$end])/$1/g;
1534 grep( /^\Q$opt/ && ($option = $_), @options );
1535 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1537 print $OUT "Unknown option `$opt'\n" unless $matches;
1538 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1539 $option{$option} = $val if $matches == 1 and defined $val;
1540 eval "local \$frame = 0; local \$doret = -2;
1541 require '$optionRequire{$option}'"
1542 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1543 $ {$optionVars{$option}} = $val
1545 and defined $optionVars{$option} and defined $val;
1546 & {$optionAction{$option}} ($val)
1548 and defined $optionAction{$option}
1549 and defined &{$optionAction{$option}} and defined $val;
1550 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1556 my ($stem,@list) = @_;
1558 $ENV{"$ {stem}_n"} = @list;
1559 for $i (0 .. $#list) {
1561 $val =~ s/\\/\\\\/g;
1562 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1563 $ENV{"$ {stem}_$i"} = $val;
1570 my $n = delete $ENV{"$ {stem}_n"};
1572 for $i (0 .. $n - 1) {
1573 $val = delete $ENV{"$ {stem}_$i"};
1574 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1582 return; # Put nothing on the stack - malloc/free land!
1586 my($msg)= join("",@_);
1587 $msg .= ": $!\n" unless $msg =~ /\n$/;
1592 if (@_ and $term and $term->Features->{newTTY}) {
1593 my ($in, $out) = shift;
1595 ($in, $out) = split /,/, $in, 2;
1599 open IN, $in or die "cannot open `$in' for read: $!";
1600 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1601 $term->newTTY(\*IN, \*OUT);
1605 } elsif ($term and @_) {
1606 &warn("Too late to set TTY, enabled on next `R'!\n");
1614 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1616 $notty = shift if @_;
1622 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1629 if ($ {$term->Features}{tkRunning}) {
1630 return $term->tkRunning(@_);
1632 print $OUT "tkRunning not supported by current ReadLine package.\n";
1639 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1641 $runnonstop = shift if @_;
1648 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1655 $sh = quotemeta shift;
1656 $sh .= "\\b" if $sh =~ /\w$/;
1660 $psh =~ s/\\(.)/$1/g;
1666 if (defined $term) {
1667 local ($warnLevel,$dieLevel) = (0, 1);
1668 return '' unless $term->Features->{ornaments};
1669 eval { $term->ornaments(@_) } || '';
1677 $rc = quotemeta shift;
1678 $rc .= "\\b" if $rc =~ /\w$/;
1682 $prc =~ s/\\(.)/$1/g;
1688 return $lineinfo unless @_;
1690 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1691 $emacs = ($stream =~ /^\|/);
1692 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1693 $LINEINFO = \*LINEINFO;
1694 my $save = select($LINEINFO);
1708 s/^Term::ReadLine::readline$/readline/;
1709 if (defined $ { $_ . '::VERSION' }) {
1710 $version{$file} = "$ { $_ . '::VERSION' } from ";
1712 $version{$file} .= $INC{$file};
1714 do 'dumpvar.pl' unless defined &main::dumpValue;
1715 if (defined &main::dumpValue) {
1717 &main::dumpValue(\%version);
1719 print $OUT "dumpvar.pl not available.\n";
1726 B<s> [I<expr>] Single step [in I<expr>].
1727 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1728 <B<CR>> Repeat last B<n> or B<s> command.
1729 B<r> Return from current subroutine.
1730 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1731 at the specified position.
1732 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1733 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1734 B<l> I<line> List single I<line>.
1735 B<l> I<subname> List first window of lines from subroutine.
1736 B<l> List next window of lines.
1737 B<-> List previous window of lines.
1738 B<w> [I<line>] List window around I<line>.
1739 B<.> Return to the executed line.
1740 B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
1741 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1742 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1743 B<L> List all breakpoints and actions.
1744 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1745 B<t> Toggle trace mode.
1746 B<t> I<expr> Trace through execution of I<expr>.
1747 B<b> [I<line>] [I<condition>]
1748 Set breakpoint; I<line> defaults to the current execution line;
1749 I<condition> breaks if it evaluates to true, defaults to '1'.
1750 B<b> I<subname> [I<condition>]
1751 Set breakpoint at first line of subroutine.
1752 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1753 B<b> B<postpone> I<subname> [I<condition>]
1754 Set breakpoint at first line of subroutine after
1756 B<b> B<compile> I<subname>
1757 Stop after the subroutine is compiled.
1758 B<d> [I<line>] Delete the breakpoint for I<line>.
1759 B<D> Delete all breakpoints.
1760 B<a> [I<line>] I<command>
1761 Set an action to be done before the I<line> is executed.
1762 Sequence is: check for breakpoint/watchpoint, print line
1763 if necessary, do action, prompt user if necessary,
1765 B<A> Delete all actions.
1766 B<W> I<expr> Add a global watch-expression.
1767 B<W> Delete all watch-expressions.
1768 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1769 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1770 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1771 B<x> I<expr> Evals expression in array context, dumps the result.
1772 B<m> I<expr> Evals expression in array context, prints methods callable
1773 on the first element of the result.
1774 B<m> I<class> Prints methods callable via the given class.
1775 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1776 Set or query values of options. I<val> defaults to 1. I<opt> can
1777 be abbreviated. Several options can be listed.
1778 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1779 I<pager>: program for output of \"|cmd\";
1780 I<tkRunning>: run Tk while prompting (with ReadLine);
1781 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1782 I<inhibit_exit> Allows stepping off the end of the script.
1783 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1784 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1785 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1786 I<globPrint>: whether to print contents of globs;
1787 I<DumpDBFiles>: dump arrays holding debugged files;
1788 I<DumpPackages>: dump symbol tables of packages;
1789 I<DumpReused>: dump contents of \"reused\" addresses;
1790 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1791 Option I<PrintRet> affects printing of return value after B<r> command,
1792 I<frame> affects printing messages on entry and exit from subroutines.
1793 I<AutoTrace> affects printing messages on every possible breaking point.
1794 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1795 I<ornaments> affects screen appearance of the command line.
1796 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1797 You can put additional initialization options I<TTY>, I<noTTY>,
1798 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1799 B<<> I<expr> Define Perl command to run before each prompt.
1800 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1801 B<>> I<expr> Define Perl command to run after each prompt.
1802 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1803 B<{> I<db_command> Define debugger command to run before each prompt.
1804 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1805 B<$prc> I<number> Redo a previous command (default previous command).
1806 B<$prc> I<-number> Redo number'th-to-last command.
1807 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1808 See 'B<O> I<recallCommand>' too.
1809 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1810 . ( $rc eq $sh ? "" : "
1811 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1812 See 'B<O> I<shellBang>' too.
1813 B<H> I<-number> Display last number commands (default all).
1814 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1815 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1816 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1817 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1818 I<command> Execute as a perl statement in current package.
1819 B<v> Show versions of loaded modules.
1820 B<R> Pure-man-restart of debugger, some of debugger state
1821 and command-line options may be lost.
1822 Currently the following setting are preserved:
1823 history, breakpoints and actions, debugger B<O>ptions
1824 and the following command-line options: I<-w>, I<-I>, I<-e>.
1825 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1826 B<h h> Summary of debugger commands.
1827 B<q> or B<^D> Quit. Set \$DB::finished to 0 to debug global destruction.
1830 $summary = <<"END_SUM";
1831 I<List/search source lines:> I<Control script execution:>
1832 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1833 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1834 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1835 B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s>
1836 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1837 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1838 I<Debugger controls:> B<L> List break/watch/actions
1839 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1840 B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint
1841 B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub
1842 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1843 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1844 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1845 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1846 B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1847 B<q> or B<^D> Quit B<R> Attempt a restart
1848 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1849 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1850 B<p> I<expr> Print expression (uses script's current package).
1851 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1852 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1853 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1855 # ')}}; # Fix balance of Emacs parsing
1859 my $message = shift;
1860 if (@Term::ReadLine::TermCap::rl_term_set) {
1861 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1862 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1864 print $OUT $message;
1870 $SIG{'ABRT'} = 'DEFAULT';
1871 kill 'ABRT', $$ if $panic++;
1872 if (defined &Carp::longmess) {
1873 local $SIG{__WARN__} = '';
1874 local $Carp::CarpLevel = 2; # mydie + confess
1875 &warn(Carp::longmess("Signal @_"));
1878 print $DB::OUT "Got signal @_\n";
1886 local $SIG{__WARN__} = '';
1887 local $SIG{__DIE__} = '';
1888 eval { require Carp } if defined $^S; # If error/warning during compilation,
1889 # require may be broken.
1890 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1891 return unless defined &Carp::longmess;
1892 my ($mysingle,$mytrace) = ($single,$trace);
1893 $single = 0; $trace = 0;
1894 my $mess = Carp::longmess(@_);
1895 ($single,$trace) = ($mysingle,$mytrace);
1902 local $SIG{__DIE__} = '';
1903 local $SIG{__WARN__} = '';
1904 my $i = 0; my $ineval = 0; my $sub;
1905 if ($dieLevel > 2) {
1906 local $SIG{__WARN__} = \&dbwarn;
1907 &warn(@_); # Yell no matter what
1910 if ($dieLevel < 2) {
1911 die @_ if $^S; # in eval propagate
1913 eval { require Carp } if defined $^S; # If error/warning during compilation,
1914 # require may be broken.
1915 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1916 unless defined &Carp::longmess;
1917 # We do not want to debug this chunk (automatic disabling works
1918 # inside DB::DB, but not in Carp).
1919 my ($mysingle,$mytrace) = ($single,$trace);
1920 $single = 0; $trace = 0;
1921 my $mess = Carp::longmess(@_);
1922 ($single,$trace) = ($mysingle,$mytrace);
1928 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1931 $SIG{__WARN__} = \&DB::dbwarn;
1933 $SIG{__WARN__} = $prevwarn;
1941 $prevdie = $SIG{__DIE__} unless $dieLevel;
1944 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1945 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1946 print $OUT "Stack dump during die enabled",
1947 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1949 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1951 $SIG{__DIE__} = $prevdie;
1952 print $OUT "Default die handler restored.\n";
1960 $prevsegv = $SIG{SEGV} unless $signalLevel;
1961 $prevbus = $SIG{BUS} unless $signalLevel;
1962 $signalLevel = shift;
1964 $SIG{SEGV} = \&DB::diesignal;
1965 $SIG{BUS} = \&DB::diesignal;
1967 $SIG{SEGV} = $prevsegv;
1968 $SIG{BUS} = $prevbus;
1976 return unless defined &$subr;
1978 $subr = \&$subr; # Hard reference
1981 $s = $_, last if $subr eq \&$_;
1989 $class = ref $class if ref $class;
1992 methods_via($class, '', 1);
1993 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
1998 return if $packs{$class}++;
2000 my $prepend = $prefix ? "via $prefix: " : '';
2002 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2003 sort keys %{"$ {class}::"}) {
2004 next if $seen{ $name }++;
2005 print $DB::OUT "$prepend$name\n";
2007 return unless shift; # Recurse?
2008 for $name (@{"$ {class}::ISA"}) {
2009 $prepend = $prefix ? $prefix . " -> $name" : $name;
2010 methods_via($name, $prepend, 1);
2014 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2016 BEGIN { # This does not compile, alas.
2017 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2018 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2022 $deep = 100; # warning if stack gets this deep
2026 $SIG{INT} = \&DB::catch;
2027 # This may be enabled to debug debugger:
2028 #$warnLevel = 1 unless defined $warnLevel;
2029 #$dieLevel = 1 unless defined $dieLevel;
2030 #$signalLevel = 1 unless defined $signalLevel;
2032 $db_stop = 0; # Compiler warning
2034 $level = 0; # Level of recursive debugging
2035 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2036 # Triggers bug (?) in perl is we postpone this until runtime:
2037 @postponed = @stack = (0);
2042 BEGIN {$^W = $ini_warn;} # Switch warnings back
2044 #use Carp; # This did break, left for debuggin
2047 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2048 my($text, $line, $start) = @_;
2049 my ($itext, $search, $prefix, $pack) =
2050 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2052 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2053 (map { /$search/ ? ($1) : () } keys %sub)
2054 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2055 return sort grep /^\Q$text/, values %INC # files
2056 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2057 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2058 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2059 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2060 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2062 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2064 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2065 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2066 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2067 # We may want to complete to (eval 9), so $text may be wrong
2068 $prefix = length($1) - length($text);
2071 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2073 if ((substr $text, 0, 1) eq '&') { # subroutines
2074 $text = substr $text, 1;
2076 return sort map "$prefix$_",
2079 (map { /$search/ ? ($1) : () }
2082 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2083 $pack = ($1 eq 'main' ? '' : $1) . '::';
2084 $prefix = (substr $text, 0, 1) . $1 . '::';
2087 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2088 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2089 return db_complete($out[0], $line, $start);
2093 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2094 $pack = ($package eq 'main' ? '' : $package) . '::';
2095 $prefix = substr $text, 0, 1;
2096 $text = substr $text, 1;
2097 my @out = map "$prefix$_", grep /^\Q$text/,
2098 (grep /^_?[a-zA-Z]/, keys %$pack),
2099 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2100 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2101 return db_complete($out[0], $line, $start);
2105 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2106 my @out = grep /^\Q$text/, @options;
2107 my $val = option_val($out[0], undef);
2109 if (not defined $val or $val =~ /[\n\r]/) {
2110 # Can do nothing better
2111 } elsif ($val =~ /\s/) {
2113 foreach $l (split //, qq/\"\'\#\|/) {
2114 $out = "$l$val$l ", last if (index $val, $l) == -1;
2119 # Default to value if one completion, to question if many
2120 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2123 return $term->filename_list($text); # filenames
2127 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2131 $finished = $inhibit_exit; # So that some keys may be disabled.
2132 # Do not stop in at_exit() and destructors on exit:
2133 $DB::single = !$exiting && !$runnonstop;
2134 DB::fake::at_exit() unless $exiting or $runnonstop;
2140 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2143 package DB; # Do not trace this 1; below!