3 # Debugger for Perl 5.00x; perl5db.pl patch level:
6 $header = "perl5db.pl version $VERSION";
8 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
9 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
11 # modified Perl debugger, to be run from Emacs in perldb-mode
12 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
13 # Johan Vromans -- upgrade to 4.0 pl 10
14 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
17 # This file is automatically included if you do perl -d.
18 # It's probably not useful to include this yourself.
20 # Perl supplies the values for %sub. It effectively inserts
21 # a &DB'DB(); in front of every place that can have a
22 # breakpoint. Instead of a subroutine call it calls &DB::sub with
23 # $DB::sub being the called subroutine. It also inserts a BEGIN
24 # {require 'perl5db.pl'} before the first line.
26 # After each `require'd file is compiled, but before it is executed, a
27 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
28 # $filename is the expanded name of the `require'd file (as found as
31 # Additional services from Perl interpreter:
33 # if caller() is called from the package DB, it provides some
36 # The array @{$main::{'_<'.$filename} is the line-by-line contents of
39 # The hash %{'_<'.$filename} contains breakpoints and action (it is
40 # keyed by line number), and individual entries are settable (as
41 # opposed to the whole hash). Only true/false is important to the
42 # interpreter, though the values used by perl5db.pl have the form
43 # "$break_condition\0$action". Values are magical in numeric context.
45 # The scalar ${'_<'.$filename} contains "_<$filename".
47 # Note that no subroutine call is possible until &DB::sub is defined
48 # (for subroutines defined outside of the package DB). In fact the same is
49 # true if $deep is not defined.
54 # At start reads $rcfile that may set important options. This file
55 # may define a subroutine &afterinit that will be executed after the
56 # debugger is initialized.
58 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
59 # it as a rest of `O ...' line in debugger prompt.
61 # The options that can be specified only at startup:
62 # [To set in $rcfile, call &parse_options("optionName=new_value").]
64 # TTY - the TTY to use for debugging i/o.
66 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
67 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
68 # Term::Rendezvous. Current variant is to have the name of TTY in this
71 # ReadLine - If false, dummy ReadLine is used, so you can debug
72 # ReadLine applications.
74 # NonStop - if true, no i/o is performed until interrupt.
76 # LineInfo - file or pipe to print line number info to. If it is a
77 # pipe, a short "emacs like" message is used.
79 # Example $rcfile: (delete leading hashes!)
81 # &parse_options("NonStop=1 LineInfo=db.out");
82 # sub afterinit { $trace = 1; }
84 # The script will run without human intervention, putting trace
85 # information into db.out. (If you interrupt it, you would better
86 # reset LineInfo to something "interactive"!)
88 ##################################################################
91 # A lot of things changed after 0.94. First of all, core now informs
92 # debugger about entry into XSUBs, overloaded operators, tied operations,
93 # BEGIN and END. Handy with `O f=2'.
95 # This can make debugger a little bit too verbose, please be patient
96 # and report your problems promptly.
98 # Now the option frame has 3 values: 0,1,2.
100 # Note that if DESTROY returns a reference to the object (or object),
101 # the deletion of data may be postponed until the next function call,
102 # due to the need to examine the return value.
104 # Changes: 0.95: `v' command shows versions.
105 # Changes: 0.96: `v' command shows version of readline.
106 # primitive completion works (dynamic variables, subs for `b' and `l',
107 # options). Can `p %var'
108 # Better help (`h <' now works). New commands <<, >>, {, {{.
109 # {dump|print}_trace() coded (to be able to do it from <<cmd).
110 # `c sub' documented.
111 # At last enough magic combined to stop after the end of debuggee.
112 # !! should work now (thanks to Emacs bracket matching an extra
113 # `]' in a regexp is caught).
114 # `L', `D' and `A' span files now (as documented).
115 # Breakpoints in `require'd code are possible (used in `R').
116 # Some additional words on internal work of debugger.
117 # `b load filename' implemented.
118 # `b postpone subr' implemented.
119 # now only `q' exits debugger (overwriteable on $inhibit_exit).
120 # When restarting debugger breakpoints/actions persist.
121 # Buglet: When restarting debugger only one breakpoint/action per
122 # autoloaded function persists.
123 # Changes: 0.97: NonStop will not stop in at_exit().
124 # Option AutoTrace implemented.
125 # Trace printed differently if frames are printed too.
126 # new `inhibitExit' option.
127 # printing of a very long statement interruptible.
128 # Changes: 0.98: New command `m' for printing possible methods
129 # 'l -' is a synonim for `-'.
130 # Cosmetic bugs in printing stack trace.
131 # `frame' & 8 to print "expanded args" in stack trace.
132 # Can list/break in imported subs.
133 # new `maxTraceLen' option.
134 # frame & 4 and frame & 8 granted.
136 # nonstoppable lines do not have `:' near the line number.
137 # `b compile subname' implemented.
138 # Will not use $` any more.
139 # `-' behaves sane now.
140 # Changes: 0.99: Completion for `f', `m'.
141 # `m' will remove duplicate names instead of duplicate functions.
142 # `b load' strips trailing whitespace.
143 # completion ignores leading `|'; takes into account current package
144 # when completing a subroutine name (same for `l').
146 ####################################################################
148 # Needed for the statement after exec():
150 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
151 local($^W) = 0; # Switch run-time warnings off during init.
154 $dumpvar::arrayDepth,
155 $dumpvar::dumpDBFiles,
156 $dumpvar::dumpPackages,
157 $dumpvar::quoteHighBit,
158 $dumpvar::printUndef,
167 # Command-line + PERLLIB:
170 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
172 $trace = $signal = $single = 0; # Uninitialized warning suppression
173 # (local $^W cannot help - other packages!).
174 $inhibit_exit = $option{PrintRet} = 1;
176 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
177 compactDump veryCompact quote HighBit undefPrint
178 globPrint PrintRet UsageOnly frame AutoTrace
179 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
180 recallCommand ShellBang pager tkRunning ornaments
181 signalLevel warnLevel dieLevel inhibit_exit
182 ImmediateStop bareStringify);
185 hashDepth => \$dumpvar::hashDepth,
186 arrayDepth => \$dumpvar::arrayDepth,
187 DumpDBFiles => \$dumpvar::dumpDBFiles,
188 DumpPackages => \$dumpvar::dumpPackages,
189 DumpReused => \$dumpvar::dumpReused,
190 HighBit => \$dumpvar::quoteHighBit,
191 undefPrint => \$dumpvar::printUndef,
192 globPrint => \$dumpvar::globPrint,
193 UsageOnly => \$dumpvar::usageOnly,
194 bareStringify => \$dumpvar::bareStringify,
196 AutoTrace => \$trace,
197 inhibit_exit => \$inhibit_exit,
198 maxTraceLen => \$maxtrace,
199 ImmediateStop => \$ImmediateStop,
203 compactDump => \&dumpvar::compactDump,
204 veryCompact => \&dumpvar::veryCompact,
205 quote => \&dumpvar::quote,
208 ReadLine => \&ReadLine,
209 NonStop => \&NonStop,
210 LineInfo => \&LineInfo,
211 recallCommand => \&recallCommand,
212 ShellBang => \&shellBang,
214 signalLevel => \&signalLevel,
215 warnLevel => \&warnLevel,
216 dieLevel => \&dieLevel,
217 tkRunning => \&tkRunning,
218 ornaments => \&ornaments,
222 compactDump => 'dumpvar.pl',
223 veryCompact => 'dumpvar.pl',
224 quote => 'dumpvar.pl',
227 # These guys may be defined in $ENV{PERL5DB} :
228 $rl = 1 unless defined $rl;
229 $warnLevel = 1 unless defined $warnLevel;
230 $dieLevel = 1 unless defined $dieLevel;
231 $signalLevel = 1 unless defined $signalLevel;
232 $pre = [] unless defined $pre;
233 $post = [] unless defined $post;
234 $pretype = [] unless defined $pretype;
235 warnLevel($warnLevel);
237 signalLevel($signalLevel);
238 &pager((defined($ENV{PAGER})
242 : 'more'))) unless defined $pager;
243 &recallCommand("!") unless defined $prc;
244 &shellBang("!") unless defined $psh;
245 $maxtrace = 400 unless defined $maxtrace;
250 $rcfile="perldb.ini";
255 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
256 do "$ENV{LOGDIR}/$rcfile";
257 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
258 do "$ENV{HOME}/$rcfile";
261 if (defined $ENV{PERLDB_OPTS}) {
262 parse_options($ENV{PERLDB_OPTS});
265 if (exists $ENV{PERLDB_RESTART}) {
266 delete $ENV{PERLDB_RESTART};
268 @hist = get_list('PERLDB_HIST');
269 %break_on_load = get_list("PERLDB_ON_LOAD");
270 %postponed = get_list("PERLDB_POSTPONE");
271 my @had_breakpoints= get_list("PERLDB_VISITED");
272 for (0 .. $#had_breakpoints) {
273 my %pf = get_list("PERLDB_FILE_$_");
274 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
276 my %opt = get_list("PERLDB_OPT");
278 while (($opt,$val) = each %opt) {
279 $val =~ s/[\\\']/\\$1/g;
280 parse_options("$opt'$val'");
282 @INC = get_list("PERLDB_INC");
284 $pretype = [get_list("PERLDB_PRETYPE")];
285 $pre = [get_list("PERLDB_PRE")];
286 $post = [get_list("PERLDB_POST")];
287 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
293 # Is Perl being run from Emacs?
294 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
295 $rl = 0, shift(@main::ARGV) if $emacs;
297 #require Term::ReadLine;
299 if ($^O =~ /cygwin/) {
300 # /dev/tty is binary. use stdin for textmode
302 } elsif (-e "/dev/tty") {
303 $console = "/dev/tty";
304 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
307 $console = "sys\$command";
310 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
315 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
323 $console = $tty if defined $tty;
325 if (defined $console) {
326 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
327 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
328 || open(OUT,">&STDOUT"); # so we don't dongle stdout
331 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
332 $console = 'STDIN/OUT';
334 # so open("|more") can read from STDOUT and so we don't dingle stdin
339 $| = 1; # for DB::OUT
342 $LINEINFO = $OUT unless defined $LINEINFO;
343 $lineinfo = $console unless defined $lineinfo;
345 $| = 1; # for real STDOUT
347 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
348 unless ($runnonstop) {
349 print $OUT "\nLoading DB routines from $header\n";
350 print $OUT ("Emacs support ",
351 $emacs ? "enabled" : "available",
353 print $OUT "\nEnter h or `h h' for help, run `perldoc perldebug' for more help.\n\n";
360 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
363 if (defined &afterinit) { # May be defined in $rcfile
369 ############################################################ Subroutines
372 # _After_ the perl program is compiled, $single is set to 1:
373 if ($single and not $second_time++) {
374 if ($runnonstop) { # Disable until signal
375 for ($i=0; $i <= $stack_depth; ) {
379 # return; # Would not print trace!
380 } elsif ($ImmediateStop) {
385 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
387 ($package, $filename, $line) = caller;
388 $filename_ini = $filename;
389 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
390 "package $package;"; # this won't let them modify, alas
391 local(*dbline) = $main::{'_<' . $filename};
393 if (($stop,$action) = split(/\0/,$dbline{$line})) {
397 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
398 $dbline{$line} =~ s/;9($|\0)/$1/;
401 my $was_signal = $signal;
403 for (my $n = 0; $n <= $#to_watch; $n++) {
404 $evalarg = $to_watch[$n];
405 local $onetimeDump; # Do not output results
406 my ($val) = &eval; # Fix context (&eval is doing array)?
407 $val = ( (defined $val) ? "'$val'" : 'undef' );
408 if ($val ne $old_watch[$n]) {
411 Watchpoint $n:\t$to_watch[$n] changed:
412 old value:\t$old_watch[$n]
415 $old_watch[$n] = $val;
419 if ($trace & 4) { # User-installed watch
420 return if watchfunction($package, $filename, $line)
421 and not $single and not $was_signal and not ($trace & ~4);
423 $was_signal = $signal;
425 if ($single || ($trace & 1) || $was_signal) {
427 $position = "\032\032$filename:$line:0\n";
428 print $LINEINFO $position;
429 } elsif ($package eq 'DB::fake') {
432 Debugged program terminated. Use B<q> to quit or B<R> to restart,
433 use B<O> I<inhibit_exit> to avoid stopping after program termination,
434 B<h q>, B<h R> or B<h O> to get additional info.
437 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
438 "package $package;"; # this won't let them modify, alas
441 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
442 $prefix .= "$sub($filename:";
443 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
444 if (length($prefix) > 30) {
445 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
450 $position = "$prefix$line$infix$dbline[$line]$after";
453 print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
455 print $LINEINFO $position;
457 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
458 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
460 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
461 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
462 $position .= $incr_pos;
464 print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
466 print $LINEINFO $incr_pos;
471 $evalarg = $action, &eval if $action;
472 if ($single || $was_signal) {
473 local $level = $level + 1;
474 foreach $evalarg (@$pre) {
477 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
480 $incr = -1; # for backward motion.
481 @typeahead = (@$pretype, @typeahead);
483 while (($term || &setterm),
484 ($term_pid == $$ or &resetterm),
485 defined ($cmd=&readline(" DB" . ('<' x $level) .
486 ($#hist+1) . ('>' x $level) .
490 $cmd =~ s/\\$/\n/ && do {
491 $cmd .= &readline(" cont: ");
494 $cmd =~ /^$/ && ($cmd = $laststep);
495 push(@hist,$cmd) if length($cmd) > 1;
497 ($i) = split(/\s+/,$cmd);
498 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
499 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
500 $cmd =~ /^h$/ && do {
503 $cmd =~ /^h\s+h$/ && do {
504 print_help($summary);
506 $cmd =~ /^h\s+(\S)$/ && do {
508 if ($help =~ /^(?:[IB]<)$asked/m) {
509 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
513 print_help("B<$asked> is not a debugger command.\n");
516 $cmd =~ /^t$/ && do {
517 ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
518 print $OUT "Trace = " .
519 (($trace & 1) ? "on" : "off" ) . "\n";
521 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
522 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
523 foreach $subname (sort(keys %sub)) {
524 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
525 print $OUT $subname,"\n";
529 $cmd =~ /^v$/ && do {
530 list_versions(); next CMD};
531 $cmd =~ s/^X\b/V $package/;
532 $cmd =~ /^V$/ && do {
533 $cmd = "V $package"; };
534 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
535 local ($savout) = select($OUT);
537 @vars = split(' ',$2);
538 do 'dumpvar.pl' unless defined &main::dumpvar;
539 if (defined &main::dumpvar) {
542 &main::dumpvar($packname,@vars);
544 print $OUT "dumpvar.pl not available.\n";
548 $cmd =~ s/^x\b/ / && do { # So that will be evaled
549 $onetimeDump = 'dump'; };
550 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
551 methods($1); next CMD};
552 $cmd =~ s/^m\b/ / && do { # So this will be evaled
553 $onetimeDump = 'methods'; };
554 $cmd =~ /^f\b\s*(.*)/ && do {
558 print $OUT "The old f command is now the r command.\n";
559 print $OUT "The new f command switches filenames.\n";
562 if (!defined $main::{'_<' . $file}) {
563 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
564 $try = substr($try,2);
565 print $OUT "Choosing $try matching `$file':\n";
569 if (!defined $main::{'_<' . $file}) {
570 print $OUT "No file matching `$file' is loaded.\n";
572 } elsif ($file ne $filename) {
573 *dbline = $main::{'_<' . $file};
579 print $OUT "Already in $file.\n";
583 $cmd =~ s/^l\s+-\s*$/-/;
584 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
586 $subname =~ s/\'/::/;
587 $subname = $package."::".$subname
588 unless $subname =~ /::/;
589 $subname = "main".$subname if substr($subname,0,2) eq "::";
590 @pieces = split(/:/,find_sub($subname));
591 $subrange = pop @pieces;
592 $file = join(':', @pieces);
593 if ($file ne $filename) {
594 *dbline = $main::{'_<' . $file};
599 if (eval($subrange) < -$window) {
600 $subrange =~ s/-.*/+/;
602 $cmd = "l $subrange";
604 print $OUT "Subroutine $subname not found.\n";
607 $cmd =~ /^\.$/ && do {
608 $incr = -1; # for backward motion.
610 $filename = $filename_ini;
611 *dbline = $main::{'_<' . $filename};
613 print $LINEINFO $position;
615 $cmd =~ /^w\b\s*(\d*)$/ && do {
619 #print $OUT 'l ' . $start . '-' . ($start + $incr);
620 $cmd = 'l ' . $start . '-' . ($start + $incr); };
621 $cmd =~ /^-$/ && do {
622 $start -= $incr + $window + 1;
623 $start = 1 if $start <= 0;
625 $cmd = 'l ' . ($start) . '+'; };
626 $cmd =~ /^l$/ && do {
628 $cmd = 'l ' . $start . '-' . ($start + $incr); };
629 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
632 $incr = $window - 1 unless $incr;
633 $cmd = 'l ' . $start . '-' . ($start + $incr); };
634 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
635 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
636 $end = $max if $end > $max;
638 $i = $line if $i eq '.';
642 print $OUT "\032\032$filename:$i:0\n";
645 for (; $i <= $end; $i++) {
646 ($stop,$action) = split(/\0/, $dbline{$i});
648 and $filename eq $filename_ini)
650 : ($dbline[$i]+0 ? ':' : ' ') ;
651 $arrow .= 'b' if $stop;
652 $arrow .= 'a' if $action;
653 print $OUT "$i$arrow\t", $dbline[$i];
654 $i++, last if $signal;
656 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
658 $start = $i; # remember in case they want more
659 $start = $max if $start > $max;
661 $cmd =~ /^D$/ && do {
662 print $OUT "Deleting all breakpoints...\n";
664 for $file (keys %had_breakpoints) {
665 local *dbline = $main::{'_<' . $file};
669 for ($i = 1; $i <= $max ; $i++) {
670 if (defined $dbline{$i}) {
671 $dbline{$i} =~ s/^[^\0]+//;
672 if ($dbline{$i} =~ s/^\0?$//) {
679 undef %postponed_file;
680 undef %break_on_load;
681 undef %had_breakpoints;
683 $cmd =~ /^L$/ && do {
685 for $file (keys %had_breakpoints) {
686 local *dbline = $main::{'_<' . $file};
690 for ($i = 1; $i <= $max; $i++) {
691 if (defined $dbline{$i}) {
692 print "$file:\n" unless $was++;
693 print $OUT " $i:\t", $dbline[$i];
694 ($stop,$action) = split(/\0/, $dbline{$i});
695 print $OUT " break if (", $stop, ")\n"
697 print $OUT " action: ", $action, "\n"
704 print $OUT "Postponed breakpoints in subroutines:\n";
706 for $subname (keys %postponed) {
707 print $OUT " $subname\t$postponed{$subname}\n";
711 my @have = map { # Combined keys
712 keys %{$postponed_file{$_}}
713 } keys %postponed_file;
715 print $OUT "Postponed breakpoints in files:\n";
717 for $file (keys %postponed_file) {
718 my $db = $postponed_file{$file};
719 print $OUT " $file:\n";
720 for $line (sort {$a <=> $b} keys %$db) {
721 print $OUT " $line:\n";
722 my ($stop,$action) = split(/\0/, $$db{$line});
723 print $OUT " break if (", $stop, ")\n"
725 print $OUT " action: ", $action, "\n"
732 if (%break_on_load) {
733 print $OUT "Breakpoints on load:\n";
735 for $file (keys %break_on_load) {
736 print $OUT " $file\n";
741 print $OUT "Watch-expressions:\n";
743 for $expr (@to_watch) {
744 print $OUT " $expr\n";
749 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
750 my $file = $1; $file =~ s/\s+$//;
752 $break_on_load{$file} = 1;
753 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
754 $file .= '.pm', redo unless $file =~ /\./;
756 $had_breakpoints{$file} = 1;
757 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
759 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
760 my $cond = $3 || '1';
761 my ($subname, $break) = ($2, $1 eq 'postpone');
762 $subname =~ s/\'/::/;
763 $subname = "${'package'}::" . $subname
764 unless $subname =~ /::/;
765 $subname = "main".$subname if substr($subname,0,2) eq "::";
766 $postponed{$subname} = $break
767 ? "break +0 if $cond" : "compile";
769 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
772 $subname =~ s/\'/::/;
773 $subname = "${'package'}::" . $subname
774 unless $subname =~ /::/;
775 $subname = "main".$subname if substr($subname,0,2) eq "::";
776 # Filename below can contain ':'
777 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
781 *dbline = $main::{'_<' . $filename};
782 $had_breakpoints{$filename} = 1;
784 ++$i while $dbline[$i] == 0 && $i < $max;
785 $dbline{$i} =~ s/^[^\0]*/$cond/;
787 print $OUT "Subroutine $subname not found.\n";
790 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
793 if ($dbline[$i] == 0) {
794 print $OUT "Line $i not breakable.\n";
796 $had_breakpoints{$filename} = 1;
797 $dbline{$i} =~ s/^[^\0]*/$cond/;
800 $cmd =~ /^d\b\s*(\d+)?/ && do {
802 $dbline{$i} =~ s/^[^\0]*//;
803 delete $dbline{$i} if $dbline{$i} eq '';
805 $cmd =~ /^A$/ && do {
807 for $file (keys %had_breakpoints) {
808 local *dbline = $main::{'_<' . $file};
812 for ($i = 1; $i <= $max ; $i++) {
813 if (defined $dbline{$i}) {
814 $dbline{$i} =~ s/\0[^\0]*//;
815 delete $dbline{$i} if $dbline{$i} eq '';
820 $cmd =~ /^O\s*$/ && do {
825 $cmd =~ /^O\s*(\S.*)/ && do {
828 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
829 push @$pre, action($1);
831 $cmd =~ /^>>\s*(.*)/ && do {
832 push @$post, action($1);
834 $cmd =~ /^<\s*(.*)/ && do {
835 $pre = [], next CMD unless $1;
838 $cmd =~ /^>\s*(.*)/ && do {
839 $post = [], next CMD unless $1;
840 $post = [action($1)];
842 $cmd =~ /^\{\{\s*(.*)/ && do {
845 $cmd =~ /^\{\s*(.*)/ && do {
846 $pretype = [], next CMD unless $1;
849 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
851 if ($dbline[$i] == 0) {
852 print $OUT "Line $i may not have an action.\n";
854 $dbline{$i} =~ s/\0[^\0]*//;
855 $dbline{$i} .= "\0" . action($j);
858 $cmd =~ /^n$/ && do {
859 end_report(), next CMD if $finished and $level <= 1;
863 $cmd =~ /^s$/ && do {
864 end_report(), next CMD if $finished and $level <= 1;
868 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
869 end_report(), next CMD if $finished and $level <= 1;
871 if ($i =~ /\D/) { # subroutine name
872 $subname = $package."::".$subname
873 unless $subname =~ /::/;
874 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
878 *dbline = $main::{'_<' . $filename};
879 $had_breakpoints{$filename}++;
881 ++$i while $dbline[$i] == 0 && $i < $max;
883 print $OUT "Subroutine $subname not found.\n";
888 if ($dbline[$i] == 0) {
889 print $OUT "Line $i not breakable.\n";
892 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
894 for ($i=0; $i <= $stack_depth; ) {
898 $cmd =~ /^r$/ && do {
899 end_report(), next CMD if $finished and $level <= 1;
900 $stack[$stack_depth] |= 1;
901 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
903 $cmd =~ /^R$/ && do {
904 print $OUT "Warning: some settings and command-line options may be lost!\n";
905 my (@script, @flags, $cl);
906 push @flags, '-w' if $ini_warn;
907 # Put all the old includes at the start to get
910 push @flags, '-I', $_;
912 # Arrange for setting the old INC:
913 set_list("PERLDB_INC", @ini_INC);
915 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
916 chomp ($cl = $ {'::_<-e'}[$_]);
917 push @script, '-e', $cl;
922 set_list("PERLDB_HIST",
923 $term->Features->{getHistory}
924 ? $term->GetHistory : @hist);
925 my @had_breakpoints = keys %had_breakpoints;
926 set_list("PERLDB_VISITED", @had_breakpoints);
927 set_list("PERLDB_OPT", %option);
928 set_list("PERLDB_ON_LOAD", %break_on_load);
930 for (0 .. $#had_breakpoints) {
931 my $file = $had_breakpoints[$_];
932 *dbline = $main::{'_<' . $file};
933 next unless %dbline or $postponed_file{$file};
934 (push @hard, $file), next
935 if $file =~ /^\(eval \d+\)$/;
937 @add = %{$postponed_file{$file}}
938 if $postponed_file{$file};
939 set_list("PERLDB_FILE_$_", %dbline, @add);
941 for (@hard) { # Yes, really-really...
942 # Find the subroutines in this eval
943 *dbline = $main::{'_<' . $_};
944 my ($quoted, $sub, %subs, $line) = quotemeta $_;
945 for $sub (keys %sub) {
946 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
947 $subs{$sub} = [$1, $2];
951 "No subroutines in $_, ignoring breakpoints.\n";
954 LINES: for $line (keys %dbline) {
955 # One breakpoint per sub only:
956 my ($offset, $sub, $found);
957 SUBS: for $sub (keys %subs) {
958 if ($subs{$sub}->[1] >= $line # Not after the subroutine
959 and (not defined $offset # Not caught
960 or $offset < 0 )) { # or badly caught
962 $offset = $line - $subs{$sub}->[0];
963 $offset = "+$offset", last SUBS if $offset >= 0;
966 if (defined $offset) {
968 "break $offset if $dbline{$line}";
970 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
974 set_list("PERLDB_POSTPONE", %postponed);
975 set_list("PERLDB_PRETYPE", @$pretype);
976 set_list("PERLDB_PRE", @$pre);
977 set_list("PERLDB_POST", @$post);
978 set_list("PERLDB_TYPEAHEAD", @typeahead);
979 $ENV{PERLDB_RESTART} = 1;
980 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
981 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
982 print $OUT "exec failed: $!\n";
984 $cmd =~ /^T$/ && do {
985 print_trace($OUT, 1); # skip DB
987 $cmd =~ /^W\s*$/ && do {
989 @to_watch = @old_watch = ();
991 $cmd =~ /^W\b\s*(.*)/s && do {
995 $val = (defined $val) ? "'$val'" : 'undef' ;
996 push @old_watch, $val;
999 $cmd =~ /^\/(.*)$/ && do {
1001 $inpat =~ s:([^\\])/$:$1:;
1003 eval '$inpat =~ m'."\a$inpat\a";
1015 $start = 1 if ($start > $max);
1016 last if ($start == $end);
1017 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1019 print $OUT "\032\032$filename:$start:0\n";
1021 print $OUT "$start:\t", $dbline[$start], "\n";
1026 print $OUT "/$pat/: not found\n" if ($start == $end);
1028 $cmd =~ /^\?(.*)$/ && do {
1030 $inpat =~ s:([^\\])\?$:$1:;
1032 eval '$inpat =~ m'."\a$inpat\a";
1044 $start = $max if ($start <= 0);
1045 last if ($start == $end);
1046 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1048 print $OUT "\032\032$filename:$start:0\n";
1050 print $OUT "$start:\t", $dbline[$start], "\n";
1055 print $OUT "?$pat?: not found\n" if ($start == $end);
1057 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1058 pop(@hist) if length($cmd) > 1;
1059 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1061 print $OUT $cmd, "\n";
1063 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1066 $cmd =~ /^$rc([^$rc].*)$/ && do {
1068 pop(@hist) if length($cmd) > 1;
1069 for ($i = $#hist; $i; --$i) {
1070 last if $hist[$i] =~ /$pat/;
1073 print $OUT "No such command!\n\n";
1077 print $OUT $cmd, "\n";
1079 $cmd =~ /^$sh$/ && do {
1080 &system($ENV{SHELL}||"/bin/sh");
1082 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1083 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1085 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1086 $end = $2?($#hist-$2):0;
1087 $hist = 0 if $hist < 0;
1088 for ($i=$#hist; $i>$end; $i--) {
1089 print $OUT "$i: ",$hist[$i],"\n"
1090 unless $hist[$i] =~ /^.?$/;
1093 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1094 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1095 $cmd =~ /^=/ && do {
1096 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1097 $alias{$k}="s~$k~$v~";
1098 print $OUT "$k = $v\n";
1099 } elsif ($cmd =~ /^=\s*$/) {
1100 foreach $k (sort keys(%alias)) {
1101 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1102 print $OUT "$k = $v\n";
1104 print $OUT "$k\t$alias{$k}\n";
1109 $cmd =~ /^\|\|?\s*[^|]/ && do {
1110 if ($pager =~ /^\|/) {
1111 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1112 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1114 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1116 unless ($piped=open(OUT,$pager)) {
1117 &warn("Can't pipe output to `$pager'");
1118 if ($pager =~ /^\|/) {
1119 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1120 open(STDOUT,">&SAVEOUT")
1121 || &warn("Can't restore STDOUT");
1124 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1128 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1129 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1130 $selected= select(OUT);
1132 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1133 $cmd =~ s/^\|+\s*//;
1135 # XXX Local variants do not work!
1136 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1137 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1138 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1140 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1142 $onetimeDump = undef;
1143 } elsif ($term_pid == $$) {
1148 if ($pager =~ /^\|/) {
1149 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1150 &warn( "Pager `$pager' failed: ",
1151 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1152 ( $? & 128 ) ? " (core dumped)" : "",
1153 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1154 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1155 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1156 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1157 # Will stop ignoring SIGPIPE if done like nohup(1)
1158 # does SIGINT but Perl doesn't give us a choice.
1160 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1163 select($selected), $selected= "" unless $selected eq "";
1167 $exiting = 1 unless defined $cmd;
1168 foreach $evalarg (@$post) {
1171 } # if ($single || $signal)
1172 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1176 # The following code may be executed now:
1180 my ($al, $ret, @ret) = "";
1181 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1184 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1185 $#stack = $stack_depth;
1186 $stack[-1] = $single;
1188 $single |= 4 if $stack_depth == $deep;
1190 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
1191 # Why -1? But it works! :-(
1192 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1193 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1196 $single |= $stack[$stack_depth--];
1198 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1199 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1200 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1201 if ($doret eq $stack_depth or $frame & 16) {
1202 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1203 print $fh ' ' x $stack_depth if $frame & 16;
1204 print $fh "list context return from $sub:\n";
1205 dumpit($fh, \@ret );
1210 if (defined wantarray) {
1215 $single |= $stack[$stack_depth--];
1217 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1218 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1219 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1220 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1221 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1222 print $fh (' ' x $stack_depth) if $frame & 16;
1223 print $fh (defined wantarray
1224 ? "scalar context return from $sub: "
1225 : "void context return from $sub\n");
1226 dumpit( $fh, $ret ) if defined wantarray;
1234 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1235 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1238 # The following takes its argument via $evalarg to preserve current @_
1243 my $otrace = $trace;
1244 my $osingle = $single;
1246 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1252 local $saved[0]; # Preserve the old value of $@
1256 } elsif ($onetimeDump eq 'dump') {
1257 dumpit($OUT, \@res);
1258 } elsif ($onetimeDump eq 'methods') {
1265 my $subname = shift;
1266 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1267 my $offset = $1 || 0;
1268 # Filename below can contain ':'
1269 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1272 local *dbline = $main::{'_<' . $file};
1273 local $^W = 0; # != 0 is magical below
1274 $had_breakpoints{$file}++;
1276 ++$i until $dbline[$i] != 0 or $i >= $max;
1277 $dbline{$i} = delete $postponed{$subname};
1279 print $OUT "Subroutine $subname not found.\n";
1283 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1284 #print $OUT "In postponed_sub for `$subname'.\n";
1288 if ($ImmediateStop) {
1292 return &postponed_sub
1293 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1294 # Cannot be done before the file is compiled
1295 local *dbline = shift;
1296 my $filename = $dbline;
1297 $filename =~ s/^_<//;
1298 $signal = 1, print $OUT "'$filename' loaded...\n"
1299 if $break_on_load{$filename};
1300 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1301 return unless $postponed_file{$filename};
1302 $had_breakpoints{$filename}++;
1303 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1305 for $key (keys %{$postponed_file{$filename}}) {
1306 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1308 delete $postponed_file{$filename};
1312 local ($savout) = select(shift);
1313 my $osingle = $single;
1314 my $otrace = $trace;
1315 $single = $trace = 0;
1318 unless (defined &main::dumpValue) {
1321 if (defined &main::dumpValue) {
1322 &main::dumpValue(shift);
1324 print $OUT "dumpvar.pl not available.\n";
1331 # Tied method do not create a context, so may get wrong message:
1335 my @sub = dump_trace($_[0] + 1, $_[1]);
1336 my $short = $_[2]; # Print short report, next one for sub name
1338 for ($i=0; $i <= $#sub; $i++) {
1341 my $args = defined $sub[$i]{args}
1342 ? "(@{ $sub[$i]{args} })"
1344 $args = (substr $args, 0, $maxtrace - 3) . '...'
1345 if length $args > $maxtrace;
1346 my $file = $sub[$i]{file};
1347 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1349 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1351 my $sub = @_ >= 4 ? $_[3] : $s;
1352 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1354 print $fh "$sub[$i]{context} = $s$args" .
1355 " called from $file" .
1356 " line $sub[$i]{line}\n";
1363 my $count = shift || 1e9;
1366 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1367 my $nothard = not $frame & 8;
1368 local $frame = 0; # Do not want to trace this.
1369 my $otrace = $trace;
1372 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1377 if (not defined $arg) {
1379 } elsif ($nothard and tied $arg) {
1381 } elsif ($nothard and $type = ref $arg) {
1382 push @a, "ref($type)";
1384 local $_ = "$arg"; # Safe to stringify now - should not call f().
1387 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1388 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1389 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1393 $context = $context ? '@' : (defined $context ? "\$" : '.');
1394 $args = $h ? [@a] : undef;
1395 $e =~ s/\n\s*\;\s*\Z// if $e;
1396 $e =~ s/([\\\'])/\\$1/g if $e;
1398 $sub = "require '$e'";
1399 } elsif (defined $r) {
1401 } elsif ($sub eq '(eval)') {
1402 $sub = "eval {...}";
1404 push(@sub, {context => $context, sub => $sub, args => $args,
1405 file => $file, line => $line});
1414 while ($action =~ s/\\$//) {
1425 &readline("cont: ");
1429 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1430 # many non-Unix systems can do system() but have problems with fork().
1431 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1432 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1433 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1434 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1436 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1437 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1438 close(SAVEIN); close(SAVEOUT);
1439 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1440 ( $? & 128 ) ? " (core dumped)" : "",
1441 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1448 eval { require Term::ReadLine } or die $@;
1451 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1452 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1455 my $sel = select($OUT);
1459 eval "require Term::Rendezvous;" or die $@;
1460 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1461 my $term_rv = new Term::Rendezvous $rv;
1463 $OUT = $term_rv->OUT;
1467 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1469 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1471 $rl_attribs = $term->Attribs;
1472 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1473 if defined $rl_attribs->{basic_word_break_characters}
1474 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1475 $rl_attribs->{special_prefixes} = '$@&%';
1476 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1477 $rl_attribs->{completion_function} = \&db_complete;
1479 $LINEINFO = $OUT unless defined $LINEINFO;
1480 $lineinfo = $console unless defined $lineinfo;
1482 if ($term->Features->{setHistory} and "@hist" ne "?") {
1483 $term->SetHistory(@hist);
1485 ornaments($ornaments) if defined $ornaments;
1489 sub resetterm { # We forked, so we need a different TTY
1491 if (defined &get_fork_TTY) {
1493 } elsif (not defined $fork_TTY
1494 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1495 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1496 # Possibly _inside_ XTERM
1497 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1502 if (defined $fork_TTY) {
1507 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1508 Define B<\$DB::fork_TTY>
1509 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1510 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1511 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1512 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1519 my $left = @typeahead;
1520 my $got = shift @typeahead;
1521 print $OUT "auto(-$left)", shift, $got, "\n";
1522 $term->AddHistory($got)
1523 if length($got) > 1 and defined $term->Features->{addHistory};
1528 $term->readline(@_);
1532 my ($opt, $val)= @_;
1533 $val = option_val($opt,'N/A');
1534 $val =~ s/([\\\'])/\\$1/g;
1535 printf $OUT "%20s = '%s'\n", $opt, $val;
1539 my ($opt, $default)= @_;
1541 if (defined $optionVars{$opt}
1542 and defined $ {$optionVars{$opt}}) {
1543 $val = $ {$optionVars{$opt}};
1544 } elsif (defined $optionAction{$opt}
1545 and defined &{$optionAction{$opt}}) {
1546 $val = &{$optionAction{$opt}}();
1547 } elsif (defined $optionAction{$opt}
1548 and not defined $option{$opt}
1549 or defined $optionVars{$opt}
1550 and not defined $ {$optionVars{$opt}}) {
1553 $val = $option{$opt};
1561 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1562 my ($opt,$sep) = ($1,$2);
1565 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1567 #&dump_option($opt);
1568 } elsif ($sep !~ /\S/) {
1570 } elsif ($sep eq "=") {
1573 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1574 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1575 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1576 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1578 $val =~ s/\\([\\$end])/$1/g;
1582 grep( /^\Q$opt/ && ($option = $_), @options );
1583 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1585 print $OUT "Unknown option `$opt'\n" unless $matches;
1586 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1587 $option{$option} = $val if $matches == 1 and defined $val;
1588 eval "local \$frame = 0; local \$doret = -2;
1589 require '$optionRequire{$option}'"
1590 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1591 $ {$optionVars{$option}} = $val
1593 and defined $optionVars{$option} and defined $val;
1594 & {$optionAction{$option}} ($val)
1596 and defined $optionAction{$option}
1597 and defined &{$optionAction{$option}} and defined $val;
1598 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1604 my ($stem,@list) = @_;
1606 $ENV{"$ {stem}_n"} = @list;
1607 for $i (0 .. $#list) {
1609 $val =~ s/\\/\\\\/g;
1610 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1611 $ENV{"$ {stem}_$i"} = $val;
1618 my $n = delete $ENV{"$ {stem}_n"};
1620 for $i (0 .. $n - 1) {
1621 $val = delete $ENV{"$ {stem}_$i"};
1622 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1630 return; # Put nothing on the stack - malloc/free land!
1634 my($msg)= join("",@_);
1635 $msg .= ": $!\n" unless $msg =~ /\n$/;
1640 if (@_ and $term and $term->Features->{newTTY}) {
1641 my ($in, $out) = shift;
1643 ($in, $out) = split /,/, $in, 2;
1647 open IN, $in or die "cannot open `$in' for read: $!";
1648 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1649 $term->newTTY(\*IN, \*OUT);
1653 } elsif ($term and @_) {
1654 &warn("Too late to set TTY, enabled on next `R'!\n");
1662 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1664 $notty = shift if @_;
1670 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1677 if ($ {$term->Features}{tkRunning}) {
1678 return $term->tkRunning(@_);
1680 print $OUT "tkRunning not supported by current ReadLine package.\n";
1687 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1689 $runnonstop = shift if @_;
1696 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1703 $sh = quotemeta shift;
1704 $sh .= "\\b" if $sh =~ /\w$/;
1708 $psh =~ s/\\(.)/$1/g;
1714 if (defined $term) {
1715 local ($warnLevel,$dieLevel) = (0, 1);
1716 return '' unless $term->Features->{ornaments};
1717 eval { $term->ornaments(@_) } || '';
1725 $rc = quotemeta shift;
1726 $rc .= "\\b" if $rc =~ /\w$/;
1730 $prc =~ s/\\(.)/$1/g;
1736 return $lineinfo unless @_;
1738 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1739 $emacs = ($stream =~ /^\|/);
1740 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1741 $LINEINFO = \*LINEINFO;
1742 my $save = select($LINEINFO);
1756 s/^Term::ReadLine::readline$/readline/;
1757 if (defined $ { $_ . '::VERSION' }) {
1758 $version{$file} = "$ { $_ . '::VERSION' } from ";
1760 $version{$file} .= $INC{$file};
1762 dumpit($OUT,\%version);
1768 B<s> [I<expr>] Single step [in I<expr>].
1769 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1770 <B<CR>> Repeat last B<n> or B<s> command.
1771 B<r> Return from current subroutine.
1772 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1773 at the specified position.
1774 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1775 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1776 B<l> I<line> List single I<line>.
1777 B<l> I<subname> List first window of lines from subroutine.
1778 B<l> List next window of lines.
1779 B<-> List previous window of lines.
1780 B<w> [I<line>] List window around I<line>.
1781 B<.> Return to the executed line.
1782 B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
1783 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1784 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1785 B<L> List all breakpoints and actions.
1786 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1787 B<t> Toggle trace mode.
1788 B<t> I<expr> Trace through execution of I<expr>.
1789 B<b> [I<line>] [I<condition>]
1790 Set breakpoint; I<line> defaults to the current execution line;
1791 I<condition> breaks if it evaluates to true, defaults to '1'.
1792 B<b> I<subname> [I<condition>]
1793 Set breakpoint at first line of subroutine.
1794 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1795 B<b> B<postpone> I<subname> [I<condition>]
1796 Set breakpoint at first line of subroutine after
1798 B<b> B<compile> I<subname>
1799 Stop after the subroutine is compiled.
1800 B<d> [I<line>] Delete the breakpoint for I<line>.
1801 B<D> Delete all breakpoints.
1802 B<a> [I<line>] I<command>
1803 Set an action to be done before the I<line> is executed.
1804 Sequence is: check for breakpoint/watchpoint, print line
1805 if necessary, do action, prompt user if necessary,
1807 B<A> Delete all actions.
1808 B<W> I<expr> Add a global watch-expression.
1809 B<W> Delete all watch-expressions.
1810 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1811 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1812 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1813 B<x> I<expr> Evals expression in array context, dumps the result.
1814 B<m> I<expr> Evals expression in array context, prints methods callable
1815 on the first element of the result.
1816 B<m> I<class> Prints methods callable via the given class.
1817 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1818 Set or query values of options. I<val> defaults to 1. I<opt> can
1819 be abbreviated. Several options can be listed.
1820 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1821 I<pager>: program for output of \"|cmd\";
1822 I<tkRunning>: run Tk while prompting (with ReadLine);
1823 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1824 I<inhibit_exit> Allows stepping off the end of the script.
1825 I<ImmediateStop> Debugger should stop as early as possible.
1826 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1827 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1828 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1829 I<globPrint>: whether to print contents of globs;
1830 I<DumpDBFiles>: dump arrays holding debugged files;
1831 I<DumpPackages>: dump symbol tables of packages;
1832 I<DumpReused>: dump contents of \"reused\" addresses;
1833 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1834 I<bareStringify>: Do not print the overload-stringified value;
1835 Option I<PrintRet> affects printing of return value after B<r> command,
1836 I<frame> affects printing messages on entry and exit from subroutines.
1837 I<AutoTrace> affects printing messages on every possible breaking point.
1838 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1839 I<ornaments> affects screen appearance of the command line.
1840 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1841 You can put additional initialization options I<TTY>, I<noTTY>,
1842 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1843 B<<> I<expr> Define Perl command to run before each prompt.
1844 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1845 B<>> I<expr> Define Perl command to run after each prompt.
1846 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1847 B<{> I<db_command> Define debugger command to run before each prompt.
1848 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1849 B<$prc> I<number> Redo a previous command (default previous command).
1850 B<$prc> I<-number> Redo number'th-to-last command.
1851 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1852 See 'B<O> I<recallCommand>' too.
1853 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1854 . ( $rc eq $sh ? "" : "
1855 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1856 See 'B<O> I<shellBang>' too.
1857 B<H> I<-number> Display last number commands (default all).
1858 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1859 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1860 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1861 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1862 I<command> Execute as a perl statement in current package.
1863 B<v> Show versions of loaded modules.
1864 B<R> Pure-man-restart of debugger, some of debugger state
1865 and command-line options may be lost.
1866 Currently the following setting are preserved:
1867 history, breakpoints and actions, debugger B<O>ptions
1868 and the following command-line options: I<-w>, I<-I>, I<-e>.
1869 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1870 Complete description of debugger is available in B<perldebug>
1871 section of Perl documention
1872 B<h h> Summary of debugger commands.
1873 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1876 $summary = <<"END_SUM";
1877 I<List/search source lines:> I<Control script execution:>
1878 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1879 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1880 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1881 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
1882 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1883 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1884 I<Debugger controls:> B<L> List break/watch/actions
1885 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1886 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
1887 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1888 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1889 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1890 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1891 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1892 B<q> or B<^D> Quit B<R> Attempt a restart
1893 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1894 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1895 B<p> I<expr> Print expression (uses script's current package).
1896 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1897 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1898 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1899 I<More help for> B<db_cmd>I<:> Type B<h> I<cmd_letter> Run B<perldoc perldebug> for more help.
1901 # ')}}; # Fix balance of Emacs parsing
1905 my $message = shift;
1906 if (@Term::ReadLine::TermCap::rl_term_set) {
1907 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1908 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1910 print $OUT $message;
1916 $SIG{'ABRT'} = 'DEFAULT';
1917 kill 'ABRT', $$ if $panic++;
1918 if (defined &Carp::longmess) {
1919 local $SIG{__WARN__} = '';
1920 local $Carp::CarpLevel = 2; # mydie + confess
1921 &warn(Carp::longmess("Signal @_"));
1924 print $DB::OUT "Got signal @_\n";
1932 local $SIG{__WARN__} = '';
1933 local $SIG{__DIE__} = '';
1934 eval { require Carp } if defined $^S; # If error/warning during compilation,
1935 # require may be broken.
1936 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1937 return unless defined &Carp::longmess;
1938 my ($mysingle,$mytrace) = ($single,$trace);
1939 $single = 0; $trace = 0;
1940 my $mess = Carp::longmess(@_);
1941 ($single,$trace) = ($mysingle,$mytrace);
1948 local $SIG{__DIE__} = '';
1949 local $SIG{__WARN__} = '';
1950 my $i = 0; my $ineval = 0; my $sub;
1951 if ($dieLevel > 2) {
1952 local $SIG{__WARN__} = \&dbwarn;
1953 &warn(@_); # Yell no matter what
1956 if ($dieLevel < 2) {
1957 die @_ if $^S; # in eval propagate
1959 eval { require Carp } if defined $^S; # If error/warning during compilation,
1960 # require may be broken.
1961 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1962 unless defined &Carp::longmess;
1963 # We do not want to debug this chunk (automatic disabling works
1964 # inside DB::DB, but not in Carp).
1965 my ($mysingle,$mytrace) = ($single,$trace);
1966 $single = 0; $trace = 0;
1967 my $mess = Carp::longmess(@_);
1968 ($single,$trace) = ($mysingle,$mytrace);
1974 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1977 $SIG{__WARN__} = \&DB::dbwarn;
1979 $SIG{__WARN__} = $prevwarn;
1987 $prevdie = $SIG{__DIE__} unless $dieLevel;
1990 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1991 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1992 print $OUT "Stack dump during die enabled",
1993 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1995 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1997 $SIG{__DIE__} = $prevdie;
1998 print $OUT "Default die handler restored.\n";
2006 $prevsegv = $SIG{SEGV} unless $signalLevel;
2007 $prevbus = $SIG{BUS} unless $signalLevel;
2008 $signalLevel = shift;
2010 $SIG{SEGV} = \&DB::diesignal;
2011 $SIG{BUS} = \&DB::diesignal;
2013 $SIG{SEGV} = $prevsegv;
2014 $SIG{BUS} = $prevbus;
2022 return unless defined &$subr;
2024 $subr = \&$subr; # Hard reference
2027 $s = $_, last if $subr eq \&$_;
2035 $class = ref $class if ref $class;
2038 methods_via($class, '', 1);
2039 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2044 return if $packs{$class}++;
2046 my $prepend = $prefix ? "via $prefix: " : '';
2048 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2049 sort keys %{"$ {class}::"}) {
2050 next if $seen{ $name }++;
2051 print $DB::OUT "$prepend$name\n";
2053 return unless shift; # Recurse?
2054 for $name (@{"$ {class}::ISA"}) {
2055 $prepend = $prefix ? $prefix . " -> $name" : $name;
2056 methods_via($name, $prepend, 1);
2060 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2062 BEGIN { # This does not compile, alas.
2063 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2064 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2068 $deep = 100; # warning if stack gets this deep
2072 $SIG{INT} = \&DB::catch;
2073 # This may be enabled to debug debugger:
2074 #$warnLevel = 1 unless defined $warnLevel;
2075 #$dieLevel = 1 unless defined $dieLevel;
2076 #$signalLevel = 1 unless defined $signalLevel;
2078 $db_stop = 0; # Compiler warning
2080 $level = 0; # Level of recursive debugging
2081 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2082 # Triggers bug (?) in perl is we postpone this until runtime:
2083 @postponed = @stack = (0);
2084 $stack_depth = 0; # Localized $#stack
2089 BEGIN {$^W = $ini_warn;} # Switch warnings back
2091 #use Carp; # This did break, left for debuggin
2094 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2095 my($text, $line, $start) = @_;
2096 my ($itext, $search, $prefix, $pack) =
2097 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2099 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2100 (map { /$search/ ? ($1) : () } keys %sub)
2101 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2102 return sort grep /^\Q$text/, values %INC # files
2103 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2104 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2105 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2106 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2107 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2109 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2111 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2112 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2113 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2114 # We may want to complete to (eval 9), so $text may be wrong
2115 $prefix = length($1) - length($text);
2118 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2120 if ((substr $text, 0, 1) eq '&') { # subroutines
2121 $text = substr $text, 1;
2123 return sort map "$prefix$_",
2126 (map { /$search/ ? ($1) : () }
2129 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2130 $pack = ($1 eq 'main' ? '' : $1) . '::';
2131 $prefix = (substr $text, 0, 1) . $1 . '::';
2134 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2135 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2136 return db_complete($out[0], $line, $start);
2140 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2141 $pack = ($package eq 'main' ? '' : $package) . '::';
2142 $prefix = substr $text, 0, 1;
2143 $text = substr $text, 1;
2144 my @out = map "$prefix$_", grep /^\Q$text/,
2145 (grep /^_?[a-zA-Z]/, keys %$pack),
2146 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2147 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2148 return db_complete($out[0], $line, $start);
2152 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2153 my @out = grep /^\Q$text/, @options;
2154 my $val = option_val($out[0], undef);
2156 if (not defined $val or $val =~ /[\n\r]/) {
2157 # Can do nothing better
2158 } elsif ($val =~ /\s/) {
2160 foreach $l (split //, qq/\"\'\#\|/) {
2161 $out = "$l$val$l ", last if (index $val, $l) == -1;
2166 # Default to value if one completion, to question if many
2167 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2170 return $term->filename_list($text); # filenames
2174 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2178 $finished = $inhibit_exit; # So that some keys may be disabled.
2179 # Do not stop in at_exit() and destructors on exit:
2180 $DB::single = !$exiting && !$runnonstop;
2181 DB::fake::at_exit() unless $exiting or $runnonstop;
2187 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2190 package DB; # Do not trace this 1; below!