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}) ? $ENV{PAGER} : "|more") unless defined $pager;
239 &recallCommand("!") unless defined $prc;
240 &shellBang("!") unless defined $psh;
241 $maxtrace = 400 unless defined $maxtrace;
246 $rcfile="perldb.ini";
251 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
252 do "$ENV{LOGDIR}/$rcfile";
253 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
254 do "$ENV{HOME}/$rcfile";
257 if (defined $ENV{PERLDB_OPTS}) {
258 parse_options($ENV{PERLDB_OPTS});
261 if (exists $ENV{PERLDB_RESTART}) {
262 delete $ENV{PERLDB_RESTART};
264 @hist = get_list('PERLDB_HIST');
265 %break_on_load = get_list("PERLDB_ON_LOAD");
266 %postponed = get_list("PERLDB_POSTPONE");
267 my @had_breakpoints= get_list("PERLDB_VISITED");
268 for (0 .. $#had_breakpoints) {
269 my %pf = get_list("PERLDB_FILE_$_");
270 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
272 my %opt = get_list("PERLDB_OPT");
274 while (($opt,$val) = each %opt) {
275 $val =~ s/[\\\']/\\$1/g;
276 parse_options("$opt'$val'");
278 @INC = get_list("PERLDB_INC");
280 $pretype = [get_list("PERLDB_PRETYPE")];
281 $pre = [get_list("PERLDB_PRE")];
282 $post = [get_list("PERLDB_POST")];
283 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
289 # Is Perl being run from Emacs?
290 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
291 $rl = 0, shift(@main::ARGV) if $emacs;
293 #require Term::ReadLine;
296 $console = "/dev/tty";
297 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
300 $console = "sys\$command";
303 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
308 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
312 $console = $tty if defined $tty;
314 if (defined $console) {
315 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
316 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
317 || open(OUT,">&STDOUT"); # so we don't dongle stdout
320 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
321 $console = 'STDIN/OUT';
323 # so open("|more") can read from STDOUT and so we don't dingle stdin
328 $| = 1; # for DB::OUT
331 $LINEINFO = $OUT unless defined $LINEINFO;
332 $lineinfo = $console unless defined $lineinfo;
334 $| = 1; # for real STDOUT
336 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
337 unless ($runnonstop) {
338 print $OUT "\nLoading DB routines from $header\n";
339 print $OUT ("Emacs support ",
340 $emacs ? "enabled" : "available",
342 print $OUT "\nEnter h or `h h' for help.\n\n";
349 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
352 if (defined &afterinit) { # May be defined in $rcfile
358 ############################################################ Subroutines
361 # _After_ the perl program is compiled, $single is set to 1:
362 if ($single and not $second_time++) {
363 if ($runnonstop) { # Disable until signal
364 for ($i=0; $i <= $#stack; ) {
368 # return; # Would not print trace!
369 } elsif ($ImmediateStop) {
374 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
376 ($package, $filename, $line) = caller;
377 $filename_ini = $filename;
378 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
379 "package $package;"; # this won't let them modify, alas
380 local(*dbline) = $main::{'_<' . $filename};
382 if (($stop,$action) = split(/\0/,$dbline{$line})) {
386 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
387 $dbline{$line} =~ s/;9($|\0)/$1/;
390 my $was_signal = $signal;
392 for (my $n = 0; $n <= $#to_watch; $n++) {
393 $evalarg = $to_watch[$n];
394 local $onetimeDump; # Do not output results
395 my ($val) = &eval; # Fix context (&eval is doing array)?
396 $val = ( (defined $val) ? "'$val'" : 'undef' );
397 if ($val ne $old_watch[$n]) {
400 Watchpoint $n:\t$to_watch[$n] changed:
401 old value:\t$old_watch[$n]
404 $old_watch[$n] = $val;
408 if ($trace & 4) { # User-installed watch
409 return if watchfunction($package, $filename, $line)
410 and not $single and not $was_signal and not ($trace & ~4);
412 $was_signal = $signal;
414 if ($single || ($trace & 1) || $was_signal) {
417 $position = "\032\032$filename:$line:0\n";
418 print $LINEINFO $position;
419 } elsif ($package eq 'DB::fake') {
421 Debugged program terminated. Use B<q> to quit or B<R> to restart,
422 use B<O> I<inhibit_exit> to avoid stopping after program termination,
423 B<h q>, B<h R> or B<h O> to get additional info.
426 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
427 "package $package;"; # this won't let them modify, alas
430 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
431 $prefix .= "$sub($filename:";
432 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
433 if (length($prefix) > 30) {
434 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
439 $position = "$prefix$line$infix$dbline[$line]$after";
442 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
444 print $LINEINFO $position;
446 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
447 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
449 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
450 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
451 $position .= $incr_pos;
453 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
455 print $LINEINFO $incr_pos;
460 $evalarg = $action, &eval if $action;
461 if ($single || $was_signal) {
462 local $level = $level + 1;
463 foreach $evalarg (@$pre) {
466 print $OUT $#stack . " levels deep in subroutine calls!\n"
469 $incr = -1; # for backward motion.
470 @typeahead = @$pretype, @typeahead;
472 while (($term || &setterm),
473 ($term_pid == $$ or &resetterm),
474 defined ($cmd=&readline(" DB" . ('<' x $level) .
475 ($#hist+1) . ('>' x $level) .
479 $cmd =~ s/\\$/\n/ && do {
480 $cmd .= &readline(" cont: ");
483 $cmd =~ /^$/ && ($cmd = $laststep);
484 push(@hist,$cmd) if length($cmd) > 1;
486 ($i) = split(/\s+/,$cmd);
487 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
488 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
489 $cmd =~ /^h$/ && do {
492 $cmd =~ /^h\s+h$/ && do {
493 print_help($summary);
495 $cmd =~ /^h\s+(\S)$/ && do {
497 if ($help =~ /^(?:[IB]<)$asked/m) {
498 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
502 print_help("B<$asked> is not a debugger command.\n");
505 $cmd =~ /^t$/ && do {
506 ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
507 print $OUT "Trace = " .
508 (($trace & 1) ? "on" : "off" ) . "\n";
510 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
511 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
512 foreach $subname (sort(keys %sub)) {
513 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
514 print $OUT $subname,"\n";
518 $cmd =~ /^v$/ && do {
519 list_versions(); next CMD};
520 $cmd =~ s/^X\b/V $package/;
521 $cmd =~ /^V$/ && do {
522 $cmd = "V $package"; };
523 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
524 local ($savout) = select($OUT);
526 @vars = split(' ',$2);
527 do 'dumpvar.pl' unless defined &main::dumpvar;
528 if (defined &main::dumpvar) {
531 &main::dumpvar($packname,@vars);
533 print $OUT "dumpvar.pl not available.\n";
537 $cmd =~ s/^x\b/ / && do { # So that will be evaled
538 $onetimeDump = 'dump'; };
539 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
540 methods($1); next CMD};
541 $cmd =~ s/^m\b/ / && do { # So this will be evaled
542 $onetimeDump = 'methods'; };
543 $cmd =~ /^f\b\s*(.*)/ && do {
547 print $OUT "The old f command is now the r command.\n";
548 print $OUT "The new f command switches filenames.\n";
551 if (!defined $main::{'_<' . $file}) {
552 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
553 $try = substr($try,2);
554 print $OUT "Choosing $try matching `$file':\n";
558 if (!defined $main::{'_<' . $file}) {
559 print $OUT "No file matching `$file' is loaded.\n";
561 } elsif ($file ne $filename) {
562 *dbline = $main::{'_<' . $file};
568 print $OUT "Already in $file.\n";
572 $cmd =~ s/^l\s+-\s*$/-/;
573 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
575 $subname =~ s/\'/::/;
576 $subname = $package."::".$subname
577 unless $subname =~ /::/;
578 $subname = "main".$subname if substr($subname,0,2) eq "::";
579 @pieces = split(/:/,find_sub($subname));
580 $subrange = pop @pieces;
581 $file = join(':', @pieces);
582 if ($file ne $filename) {
583 *dbline = $main::{'_<' . $file};
588 if (eval($subrange) < -$window) {
589 $subrange =~ s/-.*/+/;
591 $cmd = "l $subrange";
593 print $OUT "Subroutine $subname not found.\n";
596 $cmd =~ /^\.$/ && do {
597 $incr = -1; # for backward motion.
599 $filename = $filename_ini;
600 *dbline = $main::{'_<' . $filename};
602 print $LINEINFO $position;
604 $cmd =~ /^w\b\s*(\d*)$/ && do {
608 #print $OUT 'l ' . $start . '-' . ($start + $incr);
609 $cmd = 'l ' . $start . '-' . ($start + $incr); };
610 $cmd =~ /^-$/ && do {
611 $start -= $incr + $window + 1;
612 $start = 1 if $start <= 0;
614 $cmd = 'l ' . ($start) . '+'; };
615 $cmd =~ /^l$/ && do {
617 $cmd = 'l ' . $start . '-' . ($start + $incr); };
618 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
621 $incr = $window - 1 unless $incr;
622 $cmd = 'l ' . $start . '-' . ($start + $incr); };
623 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
624 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
625 $end = $max if $end > $max;
627 $i = $line if $i eq '.';
631 print $OUT "\032\032$filename:$i:0\n";
634 for (; $i <= $end; $i++) {
635 ($stop,$action) = split(/\0/, $dbline{$i});
637 and $filename eq $filename_ini)
639 : ($dbline[$i]+0 ? ':' : ' ') ;
640 $arrow .= 'b' if $stop;
641 $arrow .= 'a' if $action;
642 print $OUT "$i$arrow\t", $dbline[$i];
646 $start = $i; # remember in case they want more
647 $start = $max if $start > $max;
649 $cmd =~ /^D$/ && do {
650 print $OUT "Deleting all breakpoints...\n";
652 for $file (keys %had_breakpoints) {
653 local *dbline = $main::{'_<' . $file};
657 for ($i = 1; $i <= $max ; $i++) {
658 if (defined $dbline{$i}) {
659 $dbline{$i} =~ s/^[^\0]+//;
660 if ($dbline{$i} =~ s/^\0?$//) {
667 undef %postponed_file;
668 undef %break_on_load;
669 undef %had_breakpoints;
671 $cmd =~ /^L$/ && do {
673 for $file (keys %had_breakpoints) {
674 local *dbline = $main::{'_<' . $file};
678 for ($i = 1; $i <= $max; $i++) {
679 if (defined $dbline{$i}) {
680 print "$file:\n" unless $was++;
681 print $OUT " $i:\t", $dbline[$i];
682 ($stop,$action) = split(/\0/, $dbline{$i});
683 print $OUT " break if (", $stop, ")\n"
685 print $OUT " action: ", $action, "\n"
692 print $OUT "Postponed breakpoints in subroutines:\n";
694 for $subname (keys %postponed) {
695 print $OUT " $subname\t$postponed{$subname}\n";
699 my @have = map { # Combined keys
700 keys %{$postponed_file{$_}}
701 } keys %postponed_file;
703 print $OUT "Postponed breakpoints in files:\n";
705 for $file (keys %postponed_file) {
706 my $db = $postponed_file{$file};
707 print $OUT " $file:\n";
708 for $line (sort {$a <=> $b} keys %$db) {
709 print $OUT " $line:\n";
710 my ($stop,$action) = split(/\0/, $$db{$line});
711 print $OUT " break if (", $stop, ")\n"
713 print $OUT " action: ", $action, "\n"
720 if (%break_on_load) {
721 print $OUT "Breakpoints on load:\n";
723 for $file (keys %break_on_load) {
724 print $OUT " $file\n";
729 print $OUT "Watch-expressions:\n";
731 for $expr (@to_watch) {
732 print $OUT " $expr\n";
737 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
738 my $file = $1; $file =~ s/\s+$//;
740 $break_on_load{$file} = 1;
741 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
742 $file .= '.pm', redo unless $file =~ /\./;
744 $had_breakpoints{$file} = 1;
745 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
747 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
748 my $cond = $3 || '1';
749 my ($subname, $break) = ($2, $1 eq 'postpone');
750 $subname =~ s/\'/::/;
751 $subname = "${'package'}::" . $subname
752 unless $subname =~ /::/;
753 $subname = "main".$subname if substr($subname,0,2) eq "::";
754 $postponed{$subname} = $break
755 ? "break +0 if $cond" : "compile";
757 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
760 $subname =~ s/\'/::/;
761 $subname = "${'package'}::" . $subname
762 unless $subname =~ /::/;
763 $subname = "main".$subname if substr($subname,0,2) eq "::";
764 # Filename below can contain ':'
765 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
769 *dbline = $main::{'_<' . $filename};
770 $had_breakpoints{$filename} = 1;
772 ++$i while $dbline[$i] == 0 && $i < $max;
773 $dbline{$i} =~ s/^[^\0]*/$cond/;
775 print $OUT "Subroutine $subname not found.\n";
778 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
781 if ($dbline[$i] == 0) {
782 print $OUT "Line $i not breakable.\n";
784 $had_breakpoints{$filename} = 1;
785 $dbline{$i} =~ s/^[^\0]*/$cond/;
788 $cmd =~ /^d\b\s*(\d+)?/ && do {
790 $dbline{$i} =~ s/^[^\0]*//;
791 delete $dbline{$i} if $dbline{$i} eq '';
793 $cmd =~ /^A$/ && do {
795 for $file (keys %had_breakpoints) {
796 local *dbline = $main::{'_<' . $file};
800 for ($i = 1; $i <= $max ; $i++) {
801 if (defined $dbline{$i}) {
802 $dbline{$i} =~ s/\0[^\0]*//;
803 delete $dbline{$i} if $dbline{$i} eq '';
808 $cmd =~ /^O\s*$/ && do {
813 $cmd =~ /^O\s*(\S.*)/ && do {
816 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
817 push @$pre, action($1);
819 $cmd =~ /^>>\s*(.*)/ && do {
820 push @$post, action($1);
822 $cmd =~ /^<\s*(.*)/ && do {
823 $pre = [], next CMD unless $1;
826 $cmd =~ /^>\s*(.*)/ && do {
827 $post = [], next CMD unless $1;
828 $post = [action($1)];
830 $cmd =~ /^\{\{\s*(.*)/ && do {
833 $cmd =~ /^\{\s*(.*)/ && do {
834 $pretype = [], next CMD unless $1;
837 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
839 if ($dbline[$i] == 0) {
840 print $OUT "Line $i may not have an action.\n";
842 $dbline{$i} =~ s/\0[^\0]*//;
843 $dbline{$i} .= "\0" . action($j);
846 $cmd =~ /^n$/ && do {
847 end_report(), next CMD if $finished and $level <= 1;
851 $cmd =~ /^s$/ && do {
852 end_report(), next CMD if $finished and $level <= 1;
856 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
857 end_report(), next CMD if $finished and $level <= 1;
859 if ($i =~ /\D/) { # subroutine name
860 $subname = $package."::".$subname
861 unless $subname =~ /::/;
862 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
866 *dbline = $main::{'_<' . $filename};
867 $had_breakpoints{$filename}++;
869 ++$i while $dbline[$i] == 0 && $i < $max;
871 print $OUT "Subroutine $subname not found.\n";
876 if ($dbline[$i] == 0) {
877 print $OUT "Line $i not breakable.\n";
880 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
882 for ($i=0; $i <= $#stack; ) {
886 $cmd =~ /^r$/ && do {
887 end_report(), next CMD if $finished and $level <= 1;
888 $stack[$#stack] |= 1;
889 $doret = $option{PrintRet} ? $#stack - 1 : -2;
891 $cmd =~ /^R$/ && do {
892 print $OUT "Warning: some settings and command-line options may be lost!\n";
893 my (@script, @flags, $cl);
894 push @flags, '-w' if $ini_warn;
895 # Put all the old includes at the start to get
898 push @flags, '-I', $_;
900 # Arrange for setting the old INC:
901 set_list("PERLDB_INC", @ini_INC);
903 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
904 chomp ($cl = $ {'::_<-e'}[$_]);
905 push @script, '-e', $cl;
910 set_list("PERLDB_HIST",
911 $term->Features->{getHistory}
912 ? $term->GetHistory : @hist);
913 my @had_breakpoints = keys %had_breakpoints;
914 set_list("PERLDB_VISITED", @had_breakpoints);
915 set_list("PERLDB_OPT", %option);
916 set_list("PERLDB_ON_LOAD", %break_on_load);
918 for (0 .. $#had_breakpoints) {
919 my $file = $had_breakpoints[$_];
920 *dbline = $main::{'_<' . $file};
921 next unless %dbline or $postponed_file{$file};
922 (push @hard, $file), next
923 if $file =~ /^\(eval \d+\)$/;
925 @add = %{$postponed_file{$file}}
926 if $postponed_file{$file};
927 set_list("PERLDB_FILE_$_", %dbline, @add);
929 for (@hard) { # Yes, really-really...
930 # Find the subroutines in this eval
931 *dbline = $main::{'_<' . $_};
932 my ($quoted, $sub, %subs, $line) = quotemeta $_;
933 for $sub (keys %sub) {
934 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
935 $subs{$sub} = [$1, $2];
939 "No subroutines in $_, ignoring breakpoints.\n";
942 LINES: for $line (keys %dbline) {
943 # One breakpoint per sub only:
944 my ($offset, $sub, $found);
945 SUBS: for $sub (keys %subs) {
946 if ($subs{$sub}->[1] >= $line # Not after the subroutine
947 and (not defined $offset # Not caught
948 or $offset < 0 )) { # or badly caught
950 $offset = $line - $subs{$sub}->[0];
951 $offset = "+$offset", last SUBS if $offset >= 0;
954 if (defined $offset) {
956 "break $offset if $dbline{$line}";
958 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
962 set_list("PERLDB_POSTPONE", %postponed);
963 set_list("PERLDB_PRETYPE", @$pretype);
964 set_list("PERLDB_PRE", @$pre);
965 set_list("PERLDB_POST", @$post);
966 set_list("PERLDB_TYPEAHEAD", @typeahead);
967 $ENV{PERLDB_RESTART} = 1;
968 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
969 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
970 print $OUT "exec failed: $!\n";
972 $cmd =~ /^T$/ && do {
973 print_trace($OUT, 1); # skip DB
975 $cmd =~ /^W\s*$/ && do {
977 @to_watch = @old_watch = ();
979 $cmd =~ /^W\b\s*(.*)/s && do {
983 $val = (defined $val) ? "'$val'" : 'undef' ;
984 push @old_watch, $val;
987 $cmd =~ /^\/(.*)$/ && do {
989 $inpat =~ s:([^\\])/$:$1:;
991 eval '$inpat =~ m'."\a$inpat\a";
1003 $start = 1 if ($start > $max);
1004 last if ($start == $end);
1005 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1007 print $OUT "\032\032$filename:$start:0\n";
1009 print $OUT "$start:\t", $dbline[$start], "\n";
1014 print $OUT "/$pat/: not found\n" if ($start == $end);
1016 $cmd =~ /^\?(.*)$/ && do {
1018 $inpat =~ s:([^\\])\?$:$1:;
1020 eval '$inpat =~ m'."\a$inpat\a";
1032 $start = $max if ($start <= 0);
1033 last if ($start == $end);
1034 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1036 print $OUT "\032\032$filename:$start:0\n";
1038 print $OUT "$start:\t", $dbline[$start], "\n";
1043 print $OUT "?$pat?: not found\n" if ($start == $end);
1045 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1046 pop(@hist) if length($cmd) > 1;
1047 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1051 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1054 $cmd =~ /^$rc([^$rc].*)$/ && do {
1056 pop(@hist) if length($cmd) > 1;
1057 for ($i = $#hist; $i; --$i) {
1058 last if $hist[$i] =~ /$pat/;
1061 print $OUT "No such command!\n\n";
1067 $cmd =~ /^$sh$/ && do {
1068 &system($ENV{SHELL}||"/bin/sh");
1070 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1071 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1073 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1074 $end = $2?($#hist-$2):0;
1075 $hist = 0 if $hist < 0;
1076 for ($i=$#hist; $i>$end; $i--) {
1077 print $OUT "$i: ",$hist[$i],"\n"
1078 unless $hist[$i] =~ /^.?$/;
1081 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1082 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1083 $cmd =~ /^=/ && do {
1084 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1085 $alias{$k}="s~$k~$v~";
1086 print $OUT "$k = $v\n";
1087 } elsif ($cmd =~ /^=\s*$/) {
1088 foreach $k (sort keys(%alias)) {
1089 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1090 print $OUT "$k = $v\n";
1092 print $OUT "$k\t$alias{$k}\n";
1097 $cmd =~ /^\|\|?\s*[^|]/ && do {
1098 if ($pager =~ /^\|/) {
1099 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1100 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1102 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1104 unless ($piped=open(OUT,$pager)) {
1105 &warn("Can't pipe output to `$pager'");
1106 if ($pager =~ /^\|/) {
1107 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1108 open(STDOUT,">&SAVEOUT")
1109 || &warn("Can't restore STDOUT");
1112 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1116 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1117 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1118 $selected= select(OUT);
1120 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1121 $cmd =~ s/^\|+\s*//;
1123 # XXX Local variants do not work!
1124 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1125 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1126 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1128 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1130 $onetimeDump = undef;
1131 } elsif ($term_pid == $$) {
1136 if ($pager =~ /^\|/) {
1137 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1138 &warn( "Pager `$pager' failed: ",
1139 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1140 ( $? & 128 ) ? " (core dumped)" : "",
1141 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1142 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1143 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1144 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1145 # Will stop ignoring SIGPIPE if done like nohup(1)
1146 # does SIGINT but Perl doesn't give us a choice.
1148 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1151 select($selected), $selected= "" unless $selected eq "";
1155 $exiting = 1 unless defined $cmd;
1156 foreach $evalarg (@$post) {
1159 } # if ($single || $signal)
1160 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1164 # The following code may be executed now:
1168 my ($al, $ret, @ret) = "";
1169 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1172 push(@stack, $single);
1174 $single |= 4 if $#stack == $deep;
1176 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1177 # Why -1? But it works! :-(
1178 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1179 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1182 $single |= pop(@stack);
1184 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1185 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1186 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1187 if ($doret eq $#stack or $frame & 16) {
1188 my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
1189 print $fh ' ' x $#stack if $frame & 16;
1190 print $fh "list context return from $sub:\n";
1191 dumpit($fh, \@ret );
1196 if (defined wantarray) {
1201 $single |= pop(@stack);
1203 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1204 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1205 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1206 if ($doret eq $#stack or $frame & 16 and defined wantarray) {
1207 my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
1208 print $fh (' ' x $#stack) if $frame & 16;
1209 print $fh (defined wantarray
1210 ? "scalar context return from $sub: "
1211 : "void context return from $sub\n");
1212 dumpit( $fh, $ret ) if defined wantarray;
1220 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1221 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1224 # The following takes its argument via $evalarg to preserve current @_
1229 local (@stack) = @stack; # guard against recursive debugging
1230 my $otrace = $trace;
1231 my $osingle = $single;
1233 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1239 local $saved[0]; # Preserve the old value of $@
1243 } elsif ($onetimeDump eq 'dump') {
1244 dumpit($OUT, \@res);
1245 } elsif ($onetimeDump eq 'methods') {
1252 my $subname = shift;
1253 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1254 my $offset = $1 || 0;
1255 # Filename below can contain ':'
1256 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1259 local *dbline = $main::{'_<' . $file};
1260 local $^W = 0; # != 0 is magical below
1261 $had_breakpoints{$file}++;
1263 ++$i until $dbline[$i] != 0 or $i >= $max;
1264 $dbline{$i} = delete $postponed{$subname};
1266 print $OUT "Subroutine $subname not found.\n";
1270 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1271 #print $OUT "In postponed_sub for `$subname'.\n";
1275 if ($ImmediateStop) {
1279 return &postponed_sub
1280 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1281 # Cannot be done before the file is compiled
1282 local *dbline = shift;
1283 my $filename = $dbline;
1284 $filename =~ s/^_<//;
1285 $signal = 1, print $OUT "'$filename' loaded...\n"
1286 if $break_on_load{$filename};
1287 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1288 return unless $postponed_file{$filename};
1289 $had_breakpoints{$filename}++;
1290 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1292 for $key (keys %{$postponed_file{$filename}}) {
1293 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1295 delete $postponed_file{$filename};
1299 local ($savout) = select(shift);
1300 my $osingle = $single;
1301 my $otrace = $trace;
1302 $single = $trace = 0;
1305 unless (defined &main::dumpValue) {
1308 if (defined &main::dumpValue) {
1309 &main::dumpValue(shift);
1311 print $OUT "dumpvar.pl not available.\n";
1318 # Tied method do not create a context, so may get wrong message:
1322 my @sub = dump_trace($_[0] + 1, $_[1]);
1323 my $short = $_[2]; # Print short report, next one for sub name
1325 for ($i=0; $i <= $#sub; $i++) {
1328 my $args = defined $sub[$i]{args}
1329 ? "(@{ $sub[$i]{args} })"
1331 $args = (substr $args, 0, $maxtrace - 3) . '...'
1332 if length $args > $maxtrace;
1333 my $file = $sub[$i]{file};
1334 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1336 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1338 my $sub = @_ >= 4 ? $_[3] : $s;
1339 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1341 print $fh "$sub[$i]{context} = $s$args" .
1342 " called from $file" .
1343 " line $sub[$i]{line}\n";
1350 my $count = shift || 1e9;
1353 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1354 my $nothard = not $frame & 8;
1355 local $frame = 0; # Do not want to trace this.
1356 my $otrace = $trace;
1359 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1364 if (not defined $arg) {
1366 } elsif ($nothard and tied $arg) {
1368 } elsif ($nothard and $type = ref $arg) {
1369 push @a, "ref($type)";
1371 local $_ = "$arg"; # Safe to stringify now - should not call f().
1374 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1375 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1376 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1380 $context = $context ? '@' : (defined $context ? "\$" : '.');
1381 $args = $h ? [@a] : undef;
1382 $e =~ s/\n\s*\;\s*\Z// if $e;
1383 $e =~ s/([\\\'])/\\$1/g if $e;
1385 $sub = "require '$e'";
1386 } elsif (defined $r) {
1388 } elsif ($sub eq '(eval)') {
1389 $sub = "eval {...}";
1391 push(@sub, {context => $context, sub => $sub, args => $args,
1392 file => $file, line => $line});
1401 while ($action =~ s/\\$//) {
1412 &readline("cont: ");
1416 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1417 # many non-Unix systems can do system() but have problems with fork().
1418 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1419 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1420 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1421 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1423 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1424 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1425 close(SAVEIN); close(SAVEOUT);
1426 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1427 ( $? & 128 ) ? " (core dumped)" : "",
1428 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1435 local @stack = @stack; # Prevent growth by failing `use'.
1436 eval { require Term::ReadLine } or die $@;
1439 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1440 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1443 my $sel = select($OUT);
1447 eval "require Term::Rendezvous;" or die $@;
1448 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1449 my $term_rv = new Term::Rendezvous $rv;
1451 $OUT = $term_rv->OUT;
1455 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1457 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1459 $rl_attribs = $term->Attribs;
1460 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1461 if defined $rl_attribs->{basic_word_break_characters}
1462 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1463 $rl_attribs->{special_prefixes} = '$@&%';
1464 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1465 $rl_attribs->{completion_function} = \&db_complete;
1467 $LINEINFO = $OUT unless defined $LINEINFO;
1468 $lineinfo = $console unless defined $lineinfo;
1470 if ($term->Features->{setHistory} and "@hist" ne "?") {
1471 $term->SetHistory(@hist);
1473 ornaments($ornaments) if defined $ornaments;
1477 sub resetterm { # We forked, so we need a different TTY
1479 if (defined &get_fork_TTY) {
1481 } elsif (not defined $fork_TTY
1482 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1483 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1484 # Possibly _inside_ XTERM
1485 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1490 if (defined $fork_TTY) {
1495 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1496 Define B<\$DB::fork_TTY>
1497 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1498 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1499 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1500 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1507 my $left = @typeahead;
1508 my $got = shift @typeahead;
1509 print $OUT "auto(-$left)", shift, $got, "\n";
1510 $term->AddHistory($got)
1511 if length($got) > 1 and defined $term->Features->{addHistory};
1516 $term->readline(@_);
1520 my ($opt, $val)= @_;
1521 $val = option_val($opt,'N/A');
1522 $val =~ s/([\\\'])/\\$1/g;
1523 printf $OUT "%20s = '%s'\n", $opt, $val;
1527 my ($opt, $default)= @_;
1529 if (defined $optionVars{$opt}
1530 and defined $ {$optionVars{$opt}}) {
1531 $val = $ {$optionVars{$opt}};
1532 } elsif (defined $optionAction{$opt}
1533 and defined &{$optionAction{$opt}}) {
1534 $val = &{$optionAction{$opt}}();
1535 } elsif (defined $optionAction{$opt}
1536 and not defined $option{$opt}
1537 or defined $optionVars{$opt}
1538 and not defined $ {$optionVars{$opt}}) {
1541 $val = $option{$opt};
1549 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1550 my ($opt,$sep) = ($1,$2);
1553 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1555 #&dump_option($opt);
1556 } elsif ($sep !~ /\S/) {
1558 } elsif ($sep eq "=") {
1561 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1562 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1563 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1564 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1566 $val =~ s/\\([\\$end])/$1/g;
1570 grep( /^\Q$opt/ && ($option = $_), @options );
1571 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1573 print $OUT "Unknown option `$opt'\n" unless $matches;
1574 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1575 $option{$option} = $val if $matches == 1 and defined $val;
1576 eval "local \$frame = 0; local \$doret = -2;
1577 require '$optionRequire{$option}'"
1578 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1579 $ {$optionVars{$option}} = $val
1581 and defined $optionVars{$option} and defined $val;
1582 & {$optionAction{$option}} ($val)
1584 and defined $optionAction{$option}
1585 and defined &{$optionAction{$option}} and defined $val;
1586 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1592 my ($stem,@list) = @_;
1594 $ENV{"$ {stem}_n"} = @list;
1595 for $i (0 .. $#list) {
1597 $val =~ s/\\/\\\\/g;
1598 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1599 $ENV{"$ {stem}_$i"} = $val;
1606 my $n = delete $ENV{"$ {stem}_n"};
1608 for $i (0 .. $n - 1) {
1609 $val = delete $ENV{"$ {stem}_$i"};
1610 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1618 return; # Put nothing on the stack - malloc/free land!
1622 my($msg)= join("",@_);
1623 $msg .= ": $!\n" unless $msg =~ /\n$/;
1628 if (@_ and $term and $term->Features->{newTTY}) {
1629 my ($in, $out) = shift;
1631 ($in, $out) = split /,/, $in, 2;
1635 open IN, $in or die "cannot open `$in' for read: $!";
1636 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1637 $term->newTTY(\*IN, \*OUT);
1641 } elsif ($term and @_) {
1642 &warn("Too late to set TTY, enabled on next `R'!\n");
1650 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1652 $notty = shift if @_;
1658 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1665 if ($ {$term->Features}{tkRunning}) {
1666 return $term->tkRunning(@_);
1668 print $OUT "tkRunning not supported by current ReadLine package.\n";
1675 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1677 $runnonstop = shift if @_;
1684 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1691 $sh = quotemeta shift;
1692 $sh .= "\\b" if $sh =~ /\w$/;
1696 $psh =~ s/\\(.)/$1/g;
1702 if (defined $term) {
1703 local ($warnLevel,$dieLevel) = (0, 1);
1704 return '' unless $term->Features->{ornaments};
1705 eval { $term->ornaments(@_) } || '';
1713 $rc = quotemeta shift;
1714 $rc .= "\\b" if $rc =~ /\w$/;
1718 $prc =~ s/\\(.)/$1/g;
1724 return $lineinfo unless @_;
1726 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1727 $emacs = ($stream =~ /^\|/);
1728 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1729 $LINEINFO = \*LINEINFO;
1730 my $save = select($LINEINFO);
1744 s/^Term::ReadLine::readline$/readline/;
1745 if (defined $ { $_ . '::VERSION' }) {
1746 $version{$file} = "$ { $_ . '::VERSION' } from ";
1748 $version{$file} .= $INC{$file};
1750 do 'dumpvar.pl' unless defined &main::dumpValue;
1751 if (defined &main::dumpValue) {
1753 &main::dumpValue(\%version);
1755 print $OUT "dumpvar.pl not available.\n";
1762 B<s> [I<expr>] Single step [in I<expr>].
1763 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1764 <B<CR>> Repeat last B<n> or B<s> command.
1765 B<r> Return from current subroutine.
1766 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1767 at the specified position.
1768 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1769 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1770 B<l> I<line> List single I<line>.
1771 B<l> I<subname> List first window of lines from subroutine.
1772 B<l> List next window of lines.
1773 B<-> List previous window of lines.
1774 B<w> [I<line>] List window around I<line>.
1775 B<.> Return to the executed line.
1776 B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
1777 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1778 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1779 B<L> List all breakpoints and actions.
1780 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1781 B<t> Toggle trace mode.
1782 B<t> I<expr> Trace through execution of I<expr>.
1783 B<b> [I<line>] [I<condition>]
1784 Set breakpoint; I<line> defaults to the current execution line;
1785 I<condition> breaks if it evaluates to true, defaults to '1'.
1786 B<b> I<subname> [I<condition>]
1787 Set breakpoint at first line of subroutine.
1788 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1789 B<b> B<postpone> I<subname> [I<condition>]
1790 Set breakpoint at first line of subroutine after
1792 B<b> B<compile> I<subname>
1793 Stop after the subroutine is compiled.
1794 B<d> [I<line>] Delete the breakpoint for I<line>.
1795 B<D> Delete all breakpoints.
1796 B<a> [I<line>] I<command>
1797 Set an action to be done before the I<line> is executed.
1798 Sequence is: check for breakpoint/watchpoint, print line
1799 if necessary, do action, prompt user if necessary,
1801 B<A> Delete all actions.
1802 B<W> I<expr> Add a global watch-expression.
1803 B<W> Delete all watch-expressions.
1804 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1805 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1806 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1807 B<x> I<expr> Evals expression in array context, dumps the result.
1808 B<m> I<expr> Evals expression in array context, prints methods callable
1809 on the first element of the result.
1810 B<m> I<class> Prints methods callable via the given class.
1811 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1812 Set or query values of options. I<val> defaults to 1. I<opt> can
1813 be abbreviated. Several options can be listed.
1814 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1815 I<pager>: program for output of \"|cmd\";
1816 I<tkRunning>: run Tk while prompting (with ReadLine);
1817 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1818 I<inhibit_exit> Allows stepping off the end of the script.
1819 I<ImmediateStop> Debugger should stop as early as possible.
1820 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1821 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1822 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1823 I<globPrint>: whether to print contents of globs;
1824 I<DumpDBFiles>: dump arrays holding debugged files;
1825 I<DumpPackages>: dump symbol tables of packages;
1826 I<DumpReused>: dump contents of \"reused\" addresses;
1827 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1828 I<bareStringify>: Do not print the overload-stringified value;
1829 Option I<PrintRet> affects printing of return value after B<r> command,
1830 I<frame> affects printing messages on entry and exit from subroutines.
1831 I<AutoTrace> affects printing messages on every possible breaking point.
1832 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1833 I<ornaments> affects screen appearance of the command line.
1834 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1835 You can put additional initialization options I<TTY>, I<noTTY>,
1836 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1837 B<<> I<expr> Define Perl command to run before each prompt.
1838 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1839 B<>> I<expr> Define Perl command to run after each prompt.
1840 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1841 B<{> I<db_command> Define debugger command to run before each prompt.
1842 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1843 B<$prc> I<number> Redo a previous command (default previous command).
1844 B<$prc> I<-number> Redo number'th-to-last command.
1845 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1846 See 'B<O> I<recallCommand>' too.
1847 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1848 . ( $rc eq $sh ? "" : "
1849 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1850 See 'B<O> I<shellBang>' too.
1851 B<H> I<-number> Display last number commands (default all).
1852 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1853 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1854 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1855 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1856 I<command> Execute as a perl statement in current package.
1857 B<v> Show versions of loaded modules.
1858 B<R> Pure-man-restart of debugger, some of debugger state
1859 and command-line options may be lost.
1860 Currently the following setting are preserved:
1861 history, breakpoints and actions, debugger B<O>ptions
1862 and the following command-line options: I<-w>, I<-I>, I<-e>.
1863 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1864 B<h h> Summary of debugger commands.
1865 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
1868 $summary = <<"END_SUM";
1869 I<List/search source lines:> I<Control script execution:>
1870 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1871 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1872 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1873 B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s>
1874 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1875 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1876 I<Debugger controls:> B<L> List break/watch/actions
1877 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1878 B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint
1879 B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub
1880 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1881 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1882 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1883 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1884 B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1885 B<q> or B<^D> Quit B<R> Attempt a restart
1886 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1887 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1888 B<p> I<expr> Print expression (uses script's current package).
1889 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1890 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1891 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1893 # ')}}; # Fix balance of Emacs parsing
1897 my $message = shift;
1898 if (@Term::ReadLine::TermCap::rl_term_set) {
1899 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1900 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1902 print $OUT $message;
1908 $SIG{'ABRT'} = 'DEFAULT';
1909 kill 'ABRT', $$ if $panic++;
1910 if (defined &Carp::longmess) {
1911 local $SIG{__WARN__} = '';
1912 local $Carp::CarpLevel = 2; # mydie + confess
1913 &warn(Carp::longmess("Signal @_"));
1916 print $DB::OUT "Got signal @_\n";
1924 local $SIG{__WARN__} = '';
1925 local $SIG{__DIE__} = '';
1926 eval { require Carp } if defined $^S; # If error/warning during compilation,
1927 # require may be broken.
1928 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1929 return unless defined &Carp::longmess;
1930 my ($mysingle,$mytrace) = ($single,$trace);
1931 $single = 0; $trace = 0;
1932 my $mess = Carp::longmess(@_);
1933 ($single,$trace) = ($mysingle,$mytrace);
1940 local $SIG{__DIE__} = '';
1941 local $SIG{__WARN__} = '';
1942 my $i = 0; my $ineval = 0; my $sub;
1943 if ($dieLevel > 2) {
1944 local $SIG{__WARN__} = \&dbwarn;
1945 &warn(@_); # Yell no matter what
1948 if ($dieLevel < 2) {
1949 die @_ if $^S; # in eval propagate
1951 eval { require Carp } if defined $^S; # If error/warning during compilation,
1952 # require may be broken.
1953 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1954 unless defined &Carp::longmess;
1955 # We do not want to debug this chunk (automatic disabling works
1956 # inside DB::DB, but not in Carp).
1957 my ($mysingle,$mytrace) = ($single,$trace);
1958 $single = 0; $trace = 0;
1959 my $mess = Carp::longmess(@_);
1960 ($single,$trace) = ($mysingle,$mytrace);
1966 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1969 $SIG{__WARN__} = \&DB::dbwarn;
1971 $SIG{__WARN__} = $prevwarn;
1979 $prevdie = $SIG{__DIE__} unless $dieLevel;
1982 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1983 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1984 print $OUT "Stack dump during die enabled",
1985 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1987 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1989 $SIG{__DIE__} = $prevdie;
1990 print $OUT "Default die handler restored.\n";
1998 $prevsegv = $SIG{SEGV} unless $signalLevel;
1999 $prevbus = $SIG{BUS} unless $signalLevel;
2000 $signalLevel = shift;
2002 $SIG{SEGV} = \&DB::diesignal;
2003 $SIG{BUS} = \&DB::diesignal;
2005 $SIG{SEGV} = $prevsegv;
2006 $SIG{BUS} = $prevbus;
2014 return unless defined &$subr;
2016 $subr = \&$subr; # Hard reference
2019 $s = $_, last if $subr eq \&$_;
2027 $class = ref $class if ref $class;
2030 methods_via($class, '', 1);
2031 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2036 return if $packs{$class}++;
2038 my $prepend = $prefix ? "via $prefix: " : '';
2040 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2041 sort keys %{"$ {class}::"}) {
2042 next if $seen{ $name }++;
2043 print $DB::OUT "$prepend$name\n";
2045 return unless shift; # Recurse?
2046 for $name (@{"$ {class}::ISA"}) {
2047 $prepend = $prefix ? $prefix . " -> $name" : $name;
2048 methods_via($name, $prepend, 1);
2052 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2054 BEGIN { # This does not compile, alas.
2055 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2056 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2060 $deep = 100; # warning if stack gets this deep
2064 $SIG{INT} = \&DB::catch;
2065 # This may be enabled to debug debugger:
2066 #$warnLevel = 1 unless defined $warnLevel;
2067 #$dieLevel = 1 unless defined $dieLevel;
2068 #$signalLevel = 1 unless defined $signalLevel;
2070 $db_stop = 0; # Compiler warning
2072 $level = 0; # Level of recursive debugging
2073 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2074 # Triggers bug (?) in perl is we postpone this until runtime:
2075 @postponed = @stack = (0);
2080 BEGIN {$^W = $ini_warn;} # Switch warnings back
2082 #use Carp; # This did break, left for debuggin
2085 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2086 my($text, $line, $start) = @_;
2087 my ($itext, $search, $prefix, $pack) =
2088 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2090 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2091 (map { /$search/ ? ($1) : () } keys %sub)
2092 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2093 return sort grep /^\Q$text/, values %INC # files
2094 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2095 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2096 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2097 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2098 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2100 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2102 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2103 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2104 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2105 # We may want to complete to (eval 9), so $text may be wrong
2106 $prefix = length($1) - length($text);
2109 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2111 if ((substr $text, 0, 1) eq '&') { # subroutines
2112 $text = substr $text, 1;
2114 return sort map "$prefix$_",
2117 (map { /$search/ ? ($1) : () }
2120 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2121 $pack = ($1 eq 'main' ? '' : $1) . '::';
2122 $prefix = (substr $text, 0, 1) . $1 . '::';
2125 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2126 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2127 return db_complete($out[0], $line, $start);
2131 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2132 $pack = ($package eq 'main' ? '' : $package) . '::';
2133 $prefix = substr $text, 0, 1;
2134 $text = substr $text, 1;
2135 my @out = map "$prefix$_", grep /^\Q$text/,
2136 (grep /^_?[a-zA-Z]/, keys %$pack),
2137 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2138 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2139 return db_complete($out[0], $line, $start);
2143 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2144 my @out = grep /^\Q$text/, @options;
2145 my $val = option_val($out[0], undef);
2147 if (not defined $val or $val =~ /[\n\r]/) {
2148 # Can do nothing better
2149 } elsif ($val =~ /\s/) {
2151 foreach $l (split //, qq/\"\'\#\|/) {
2152 $out = "$l$val$l ", last if (index $val, $l) == -1;
2157 # Default to value if one completion, to question if many
2158 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2161 return $term->filename_list($text); # filenames
2165 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2169 $finished = $inhibit_exit; # So that some keys may be disabled.
2170 # Do not stop in at_exit() and destructors on exit:
2171 $DB::single = !$exiting && !$runnonstop;
2172 DB::fake::at_exit() unless $exiting or $runnonstop;
2178 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2181 package DB; # Do not trace this 1; below!