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
177 compactDump veryCompact quote HighBit undefPrint
178 globPrint PrintRet UsageOnly frame AutoTrace
179 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
180 recallCommand ShellBang pager tkRunning ornaments
181 signalLevel warnLevel dieLevel inhibit_exit);
184 hashDepth => \$dumpvar::hashDepth,
185 arrayDepth => \$dumpvar::arrayDepth,
186 DumpDBFiles => \$dumpvar::dumpDBFiles,
187 DumpPackages => \$dumpvar::dumpPackages,
188 HighBit => \$dumpvar::quoteHighBit,
189 undefPrint => \$dumpvar::printUndef,
190 globPrint => \$dumpvar::globPrint,
191 UsageOnly => \$dumpvar::usageOnly,
193 AutoTrace => \$trace,
194 inhibit_exit => \$inhibit_exit,
195 maxTraceLen => \$maxtrace,
199 compactDump => \&dumpvar::compactDump,
200 veryCompact => \&dumpvar::veryCompact,
201 quote => \&dumpvar::quote,
204 ReadLine => \&ReadLine,
205 NonStop => \&NonStop,
206 LineInfo => \&LineInfo,
207 recallCommand => \&recallCommand,
208 ShellBang => \&shellBang,
210 signalLevel => \&signalLevel,
211 warnLevel => \&warnLevel,
212 dieLevel => \&dieLevel,
213 tkRunning => \&tkRunning,
214 ornaments => \&ornaments,
218 compactDump => 'dumpvar.pl',
219 veryCompact => 'dumpvar.pl',
220 quote => 'dumpvar.pl',
223 # These guys may be defined in $ENV{PERL5DB} :
224 $rl = 1 unless defined $rl;
225 $warnLevel = 1 unless defined $warnLevel;
226 $dieLevel = 1 unless defined $dieLevel;
227 $signalLevel = 1 unless defined $signalLevel;
228 $pre = [] unless defined $pre;
229 $post = [] unless defined $post;
230 $pretype = [] unless defined $pretype;
231 warnLevel($warnLevel);
233 signalLevel($signalLevel);
234 &pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
235 &recallCommand("!") unless defined $prc;
236 &shellBang("!") unless defined $psh;
237 $maxtrace = 400 unless defined $maxtrace;
242 $rcfile="perldb.ini";
247 } elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
248 do "$ENV{LOGDIR}/$rcfile";
249 } elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
250 do "$ENV{HOME}/$rcfile";
253 if (defined $ENV{PERLDB_OPTS}) {
254 parse_options($ENV{PERLDB_OPTS});
257 if (exists $ENV{PERLDB_RESTART}) {
258 delete $ENV{PERLDB_RESTART};
260 @hist = get_list('PERLDB_HIST');
261 %break_on_load = get_list("PERLDB_ON_LOAD");
262 %postponed = get_list("PERLDB_POSTPONE");
263 my @had_breakpoints= get_list("PERLDB_VISITED");
264 for (0 .. $#had_breakpoints) {
265 my %pf = get_list("PERLDB_FILE_$_");
266 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
268 my %opt = get_list("PERLDB_OPT");
270 while (($opt,$val) = each %opt) {
271 $val =~ s/[\\\']/\\$1/g;
272 parse_options("$opt'$val'");
274 @INC = get_list("PERLDB_INC");
276 $pretype = [get_list("PERLDB_PRETYPE")];
277 $pre = [get_list("PERLDB_PRE")];
278 $post = [get_list("PERLDB_POST")];
279 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
285 # Is Perl being run from Emacs?
286 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
287 $rl = 0, shift(@main::ARGV) if $emacs;
289 #require Term::ReadLine;
292 $console = "/dev/tty";
293 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
296 $console = "sys\$command";
299 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
304 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
308 $console = $tty if defined $tty;
310 if (defined $console) {
311 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
312 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
313 || open(OUT,">&STDOUT"); # so we don't dongle stdout
316 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
317 $console = 'STDIN/OUT';
319 # so open("|more") can read from STDOUT and so we don't dingle stdin
324 $| = 1; # for DB::OUT
327 $LINEINFO = $OUT unless defined $LINEINFO;
328 $lineinfo = $console unless defined $lineinfo;
330 $| = 1; # for real STDOUT
332 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
333 unless ($runnonstop) {
334 print $OUT "\nLoading DB routines from $header\n";
335 print $OUT ("Emacs support ",
336 $emacs ? "enabled" : "available",
338 print $OUT "\nEnter h or `h h' for help.\n\n";
345 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
348 if (defined &afterinit) { # May be defined in $rcfile
354 ############################################################ Subroutines
357 # _After_ the perl program is compiled, $single is set to 1:
358 if ($single and not $second_time++) {
359 if ($runnonstop) { # Disable until signal
360 for ($i=0; $i <= $#stack; ) {
364 # return; # Would not print trace!
367 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
369 ($package, $filename, $line) = caller;
370 $filename_ini = $filename;
371 $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
372 "package $package;"; # this won't let them modify, alas
373 local(*dbline) = $main::{'_<' . $filename};
375 if (($stop,$action) = split(/\0/,$dbline{$line})) {
379 $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
380 $dbline{$line} =~ s/;9($|\0)/$1/;
383 my $was_signal = $signal;
385 for (my $n = 0; $n <= $#to_watch; $n++) {
386 $evalarg = $to_watch[$n];
387 my ($val) = &eval; # Fix context (&eval is doing array)?
388 $val = ( (defined $val) ? "'$val'" : 'undef' );
389 if ($val ne $old_watch[$n]) {
392 Watchpoint $n: $to_watch[$n] changed:
393 old value: $old_watch[$n]
396 $old_watch[$n] = $val;
400 if ($trace & 4) { # User-installed watch
401 return if watchfunction($package, $filename, $line)
402 and not $single and not $was_signal and not ($trace & ~4);
404 $was_signal = $signal;
406 if ($single || ($trace & 1) || $was_signal) {
409 $position = "\032\032$filename:$line:0\n";
410 print $LINEINFO $position;
413 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
414 $prefix .= "$sub($filename:";
415 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
416 if (length($prefix) > 30) {
417 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
422 $position = "$prefix$line$infix$dbline[$line]$after";
425 print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
427 print $LINEINFO $position;
429 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
430 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
432 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
433 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
434 $position .= $incr_pos;
436 print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
438 print $LINEINFO $incr_pos;
443 $evalarg = $action, &eval if $action;
444 if ($single || $was_signal) {
445 local $level = $level + 1;
446 foreach $evalarg (@$pre) {
449 print $OUT $#stack . " levels deep in subroutine calls!\n"
452 $incr = -1; # for backward motion.
453 @typeahead = @$pretype, @typeahead;
455 while (($term || &setterm),
456 ($term_pid == $$ or &resetterm),
457 defined ($cmd=&readline(" DB" . ('<' x $level) .
458 ($#hist+1) . ('>' x $level) .
462 $cmd =~ s/\\$/\n/ && do {
463 $cmd .= &readline(" cont: ");
466 $cmd =~ /^$/ && ($cmd = $laststep);
467 push(@hist,$cmd) if length($cmd) > 1;
469 ($i) = split(/\s+/,$cmd);
470 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
471 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
472 $cmd =~ /^h$/ && do {
475 $cmd =~ /^h\s+h$/ && do {
476 print_help($summary);
478 $cmd =~ /^h\s+(\S)$/ && do {
480 if ($help =~ /^(?:[IB]<)$asked/m) {
481 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
485 print_help("B<$asked> is not a debugger command.\n");
488 $cmd =~ /^t$/ && do {
489 ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
490 print $OUT "Trace = " .
491 (($trace & 1) ? "on" : "off" ) . "\n";
493 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
494 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
495 foreach $subname (sort(keys %sub)) {
496 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
497 print $OUT $subname,"\n";
501 $cmd =~ /^v$/ && do {
502 list_versions(); next CMD};
503 $cmd =~ s/^X\b/V $package/;
504 $cmd =~ /^V$/ && do {
505 $cmd = "V $package"; };
506 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
507 local ($savout) = select($OUT);
509 @vars = split(' ',$2);
510 do 'dumpvar.pl' unless defined &main::dumpvar;
511 if (defined &main::dumpvar) {
514 &main::dumpvar($packname,@vars);
516 print $OUT "dumpvar.pl not available.\n";
520 $cmd =~ s/^x\b/ / && do { # So that will be evaled
521 $onetimeDump = 'dump'; };
522 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
523 methods($1); next CMD};
524 $cmd =~ s/^m\b/ / && do { # So this will be evaled
525 $onetimeDump = 'methods'; };
526 $cmd =~ /^f\b\s*(.*)/ && do {
530 print $OUT "The old f command is now the r command.\n";
531 print $OUT "The new f command switches filenames.\n";
534 if (!defined $main::{'_<' . $file}) {
535 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
536 $try = substr($try,2);
537 print $OUT "Choosing $try matching `$file':\n";
541 if (!defined $main::{'_<' . $file}) {
542 print $OUT "No file matching `$file' is loaded.\n";
544 } elsif ($file ne $filename) {
545 *dbline = $main::{'_<' . $file};
551 print $OUT "Already in $file.\n";
555 $cmd =~ s/^l\s+-\s*$/-/;
556 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
558 $subname =~ s/\'/::/;
559 $subname = $package."::".$subname
560 unless $subname =~ /::/;
561 $subname = "main".$subname if substr($subname,0,2) eq "::";
562 @pieces = split(/:/,find_sub($subname));
563 $subrange = pop @pieces;
564 $file = join(':', @pieces);
565 if ($file ne $filename) {
566 *dbline = $main::{'_<' . $file};
571 if (eval($subrange) < -$window) {
572 $subrange =~ s/-.*/+/;
574 $cmd = "l $subrange";
576 print $OUT "Subroutine $subname not found.\n";
579 $cmd =~ /^\.$/ && do {
580 $incr = -1; # for backward motion.
582 $filename = $filename_ini;
583 *dbline = $main::{'_<' . $filename};
585 print $LINEINFO $position;
587 $cmd =~ /^w\b\s*(\d*)$/ && do {
591 #print $OUT 'l ' . $start . '-' . ($start + $incr);
592 $cmd = 'l ' . $start . '-' . ($start + $incr); };
593 $cmd =~ /^-$/ && do {
594 $start -= $incr + $window + 1;
595 $start = 1 if $start <= 0;
597 $cmd = 'l ' . ($start) . '+'; };
598 $cmd =~ /^l$/ && do {
600 $cmd = 'l ' . $start . '-' . ($start + $incr); };
601 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
604 $incr = $window - 1 unless $incr;
605 $cmd = 'l ' . $start . '-' . ($start + $incr); };
606 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
607 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
608 $end = $max if $end > $max;
610 $i = $line if $i eq '.';
614 print $OUT "\032\032$filename:$i:0\n";
617 for (; $i <= $end; $i++) {
618 ($stop,$action) = split(/\0/, $dbline{$i});
620 and $filename eq $filename_ini)
622 : ($dbline[$i]+0 ? ':' : ' ') ;
623 $arrow .= 'b' if $stop;
624 $arrow .= 'a' if $action;
625 print $OUT "$i$arrow\t", $dbline[$i];
629 $start = $i; # remember in case they want more
630 $start = $max if $start > $max;
632 $cmd =~ /^D$/ && do {
633 print $OUT "Deleting all breakpoints...\n";
635 for $file (keys %had_breakpoints) {
636 local *dbline = $main::{'_<' . $file};
640 for ($i = 1; $i <= $max ; $i++) {
641 if (defined $dbline{$i}) {
642 $dbline{$i} =~ s/^[^\0]+//;
643 if ($dbline{$i} =~ s/^\0?$//) {
650 undef %postponed_file;
651 undef %break_on_load;
652 undef %had_breakpoints;
654 $cmd =~ /^L$/ && do {
656 for $file (keys %had_breakpoints) {
657 local *dbline = $main::{'_<' . $file};
661 for ($i = 1; $i <= $max; $i++) {
662 if (defined $dbline{$i}) {
663 print "$file:\n" unless $was++;
664 print $OUT " $i:\t", $dbline[$i];
665 ($stop,$action) = split(/\0/, $dbline{$i});
666 print $OUT " break if (", $stop, ")\n"
668 print $OUT " action: ", $action, "\n"
675 print $OUT "Postponed breakpoints in subroutines:\n";
677 for $subname (keys %postponed) {
678 print $OUT " $subname\t$postponed{$subname}\n";
682 my @have = map { # Combined keys
683 keys %{$postponed_file{$_}}
684 } keys %postponed_file;
686 print $OUT "Postponed breakpoints in files:\n";
688 for $file (keys %postponed_file) {
689 my $db = $postponed_file{$file};
690 print $OUT " $file:\n";
691 for $line (sort {$a <=> $b} keys %$db) {
692 print $OUT " $line:\n";
693 my ($stop,$action) = split(/\0/, $$db{$line});
694 print $OUT " break if (", $stop, ")\n"
696 print $OUT " action: ", $action, "\n"
703 if (%break_on_load) {
704 print $OUT "Breakpoints on load:\n";
706 for $file (keys %break_on_load) {
707 print $OUT " $file\n";
712 print $OUT "Watch-expressions:\n";
714 for $expr (@to_watch) {
715 print $OUT " $expr\n";
720 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
721 my $file = $1; $file =~ s/\s+$//;
723 $break_on_load{$file} = 1;
724 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
725 $file .= '.pm', redo unless $file =~ /\./;
727 $had_breakpoints{$file} = 1;
728 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
730 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
731 my $cond = $3 || '1';
732 my ($subname, $break) = ($2, $1 eq 'postpone');
733 $subname =~ s/\'/::/;
734 $subname = "${'package'}::" . $subname
735 unless $subname =~ /::/;
736 $subname = "main".$subname if substr($subname,0,2) eq "::";
737 $postponed{$subname} = $break
738 ? "break +0 if $cond" : "compile";
740 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
743 $subname =~ s/\'/::/;
744 $subname = "${'package'}::" . $subname
745 unless $subname =~ /::/;
746 $subname = "main".$subname if substr($subname,0,2) eq "::";
747 # Filename below can contain ':'
748 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
752 *dbline = $main::{'_<' . $filename};
753 $had_breakpoints{$filename} = 1;
755 ++$i while $dbline[$i] == 0 && $i < $max;
756 $dbline{$i} =~ s/^[^\0]*/$cond/;
758 print $OUT "Subroutine $subname not found.\n";
761 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
764 if ($dbline[$i] == 0) {
765 print $OUT "Line $i not breakable.\n";
767 $had_breakpoints{$filename} = 1;
768 $dbline{$i} =~ s/^[^\0]*/$cond/;
771 $cmd =~ /^d\b\s*(\d+)?/ && do {
773 $dbline{$i} =~ s/^[^\0]*//;
774 delete $dbline{$i} if $dbline{$i} eq '';
776 $cmd =~ /^A$/ && do {
778 for $file (keys %had_breakpoints) {
779 local *dbline = $main::{'_<' . $file};
783 for ($i = 1; $i <= $max ; $i++) {
784 if (defined $dbline{$i}) {
785 $dbline{$i} =~ s/\0[^\0]*//;
786 delete $dbline{$i} if $dbline{$i} eq '';
791 $cmd =~ /^O\s*$/ && do {
796 $cmd =~ /^O\s*(\S.*)/ && do {
799 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
800 push @$pre, action($1);
802 $cmd =~ /^>>\s*(.*)/ && do {
803 push @$post, action($1);
805 $cmd =~ /^<\s*(.*)/ && do {
806 $pre = [], next CMD unless $1;
809 $cmd =~ /^>\s*(.*)/ && do {
810 $post = [], next CMD unless $1;
811 $post = [action($1)];
813 $cmd =~ /^\{\{\s*(.*)/ && do {
816 $cmd =~ /^\{\s*(.*)/ && do {
817 $pretype = [], next CMD unless $1;
820 $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
822 if ($dbline[$i] == 0) {
823 print $OUT "Line $i may not have an action.\n";
825 $dbline{$i} =~ s/\0[^\0]*//;
826 $dbline{$i} .= "\0" . action($j);
829 $cmd =~ /^n$/ && do {
830 end_report(), next CMD if $finished and $level <= 1;
834 $cmd =~ /^s$/ && do {
835 end_report(), next CMD if $finished and $level <= 1;
839 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
840 end_report(), next CMD if $finished and $level <= 1;
842 if ($i =~ /\D/) { # subroutine name
843 $subname = $package."::".$subname
844 unless $subname =~ /::/;
845 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
849 *dbline = $main::{'_<' . $filename};
850 $had_breakpoints{$filename}++;
852 ++$i while $dbline[$i] == 0 && $i < $max;
854 print $OUT "Subroutine $subname not found.\n";
859 if ($dbline[$i] == 0) {
860 print $OUT "Line $i not breakable.\n";
863 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
865 for ($i=0; $i <= $#stack; ) {
869 $cmd =~ /^r$/ && do {
870 end_report(), next CMD if $finished and $level <= 1;
871 $stack[$#stack] |= 1;
872 $doret = $option{PrintRet} ? $#stack - 1 : -2;
874 $cmd =~ /^R$/ && do {
875 print $OUT "Warning: some settings and command-line options may be lost!\n";
876 my (@script, @flags, $cl);
877 push @flags, '-w' if $ini_warn;
878 # Put all the old includes at the start to get
881 push @flags, '-I', $_;
883 # Arrange for setting the old INC:
884 set_list("PERLDB_INC", @ini_INC);
886 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
887 chomp ($cl = $ {'::_<-e'}[$_]);
888 push @script, '-e', $cl;
893 set_list("PERLDB_HIST",
894 $term->Features->{getHistory}
895 ? $term->GetHistory : @hist);
896 my @had_breakpoints = keys %had_breakpoints;
897 set_list("PERLDB_VISITED", @had_breakpoints);
898 set_list("PERLDB_OPT", %option);
899 set_list("PERLDB_ON_LOAD", %break_on_load);
901 for (0 .. $#had_breakpoints) {
902 my $file = $had_breakpoints[$_];
903 *dbline = $main::{'_<' . $file};
904 next unless %dbline or $postponed_file{$file};
905 (push @hard, $file), next
906 if $file =~ /^\(eval \d+\)$/;
908 @add = %{$postponed_file{$file}}
909 if $postponed_file{$file};
910 set_list("PERLDB_FILE_$_", %dbline, @add);
912 for (@hard) { # Yes, really-really...
913 # Find the subroutines in this eval
914 *dbline = $main::{'_<' . $_};
915 my ($quoted, $sub, %subs, $line) = quotemeta $_;
916 for $sub (keys %sub) {
917 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
918 $subs{$sub} = [$1, $2];
922 "No subroutines in $_, ignoring breakpoints.\n";
925 LINES: for $line (keys %dbline) {
926 # One breakpoint per sub only:
927 my ($offset, $sub, $found);
928 SUBS: for $sub (keys %subs) {
929 if ($subs{$sub}->[1] >= $line # Not after the subroutine
930 and (not defined $offset # Not caught
931 or $offset < 0 )) { # or badly caught
933 $offset = $line - $subs{$sub}->[0];
934 $offset = "+$offset", last SUBS if $offset >= 0;
937 if (defined $offset) {
939 "break $offset if $dbline{$line}";
941 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
945 set_list("PERLDB_POSTPONE", %postponed);
946 set_list("PERLDB_PRETYPE", @$pretype);
947 set_list("PERLDB_PRE", @$pre);
948 set_list("PERLDB_POST", @$post);
949 set_list("PERLDB_TYPEAHEAD", @typeahead);
950 $ENV{PERLDB_RESTART} = 1;
951 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
952 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
953 print $OUT "exec failed: $!\n";
955 $cmd =~ /^T$/ && do {
956 print_trace($OUT, 1); # skip DB
958 $cmd =~ /^W\s*$/ && do {
960 @to_watch = @old_watch = ();
962 $cmd =~ /^W\b\s*(.*)/s && do {
966 $val = (defined $val) ? "'$val'" : 'undef' ;
967 push @old_watch, $val;
970 $cmd =~ /^\/(.*)$/ && do {
972 $inpat =~ s:([^\\])/$:$1:;
974 eval '$inpat =~ m'."\a$inpat\a";
986 $start = 1 if ($start > $max);
987 last if ($start == $end);
988 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
990 print $OUT "\032\032$filename:$start:0\n";
992 print $OUT "$start:\t", $dbline[$start], "\n";
997 print $OUT "/$pat/: not found\n" if ($start == $end);
999 $cmd =~ /^\?(.*)$/ && do {
1001 $inpat =~ s:([^\\])\?$:$1:;
1003 eval '$inpat =~ m'."\a$inpat\a";
1015 $start = $max if ($start <= 0);
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 =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1029 pop(@hist) if length($cmd) > 1;
1030 $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
1031 $cmd = $hist[$i] . "\n";
1034 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1037 $cmd =~ /^$rc([^$rc].*)$/ && do {
1039 pop(@hist) if length($cmd) > 1;
1040 for ($i = $#hist; $i; --$i) {
1041 last if $hist[$i] =~ /$pat/;
1044 print $OUT "No such command!\n\n";
1047 $cmd = $hist[$i] . "\n";
1050 $cmd =~ /^$sh$/ && do {
1051 &system($ENV{SHELL}||"/bin/sh");
1053 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1054 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1056 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1057 $end = $2?($#hist-$2):0;
1058 $hist = 0 if $hist < 0;
1059 for ($i=$#hist; $i>$end; $i--) {
1060 print $OUT "$i: ",$hist[$i],"\n"
1061 unless $hist[$i] =~ /^.?$/;
1064 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1065 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1066 $cmd =~ /^=/ && do {
1067 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1068 $alias{$k}="s~$k~$v~";
1069 print $OUT "$k = $v\n";
1070 } elsif ($cmd =~ /^=\s*$/) {
1071 foreach $k (sort keys(%alias)) {
1072 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1073 print $OUT "$k = $v\n";
1075 print $OUT "$k\t$alias{$k}\n";
1080 $cmd =~ /^\|\|?\s*[^|]/ && do {
1081 if ($pager =~ /^\|/) {
1082 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1083 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1085 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1087 unless ($piped=open(OUT,$pager)) {
1088 &warn("Can't pipe output to `$pager'");
1089 if ($pager =~ /^\|/) {
1090 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1091 open(STDOUT,">&SAVEOUT")
1092 || &warn("Can't restore STDOUT");
1095 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1099 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1100 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1101 $selected= select(OUT);
1103 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1104 $cmd =~ s/^\|+\s*//;
1106 # XXX Local variants do not work!
1107 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1108 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1109 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1111 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1113 $onetimeDump = undef;
1114 } elsif ($term_pid == $$) {
1119 if ($pager =~ /^\|/) {
1120 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1121 &warn( "Pager `$pager' failed: ",
1122 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1123 ( $? & 128 ) ? " (core dumped)" : "",
1124 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1125 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1126 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1127 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1128 # Will stop ignoring SIGPIPE if done like nohup(1)
1129 # does SIGINT but Perl doesn't give us a choice.
1131 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1134 select($selected), $selected= "" unless $selected eq "";
1138 $exiting = 1 unless defined $cmd;
1139 foreach $evalarg (@$post) {
1142 } # if ($single || $signal)
1143 ($@, $!, $,, $/, $\, $^W) = @saved;
1147 # The following code may be executed now:
1151 my ($al, $ret, @ret) = "";
1152 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1155 push(@stack, $single);
1157 $single |= 4 if $#stack == $deep;
1159 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1160 # Why -1? But it works! :-(
1161 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1162 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
1165 $single |= pop(@stack);
1167 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1168 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1169 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1170 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1171 "list context return from $sub:\n"), dumpit( \@ret ),
1172 $doret = -2 if $doret eq $#stack or $frame & 16;
1175 if (defined wantarray) {
1180 $single |= pop(@stack);
1182 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1183 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1184 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
1185 print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
1186 "scalar context return from $sub: "), dumpit( $ret ),
1187 $doret = -2 if $doret eq $#stack or $frame & 16;
1193 @saved = ($@, $!, $,, $/, $\, $^W);
1194 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1197 # The following takes its argument via $evalarg to preserve current @_
1202 local (@stack) = @stack; # guard against recursive debugging
1203 my $otrace = $trace;
1204 my $osingle = $single;
1206 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1212 local $saved[0]; # Preserve the old value of $@
1216 } elsif ($onetimeDump eq 'dump') {
1218 } elsif ($onetimeDump eq 'methods') {
1225 my $subname = shift;
1226 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1227 my $offset = $1 || 0;
1228 # Filename below can contain ':'
1229 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1232 local *dbline = $main::{'_<' . $file};
1233 local $^W = 0; # != 0 is magical below
1234 $had_breakpoints{$file}++;
1236 ++$i until $dbline[$i] != 0 or $i >= $max;
1237 $dbline{$i} = delete $postponed{$subname};
1239 print $OUT "Subroutine $subname not found.\n";
1243 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1244 #print $OUT "In postponed_sub for `$subname'.\n";
1248 return &postponed_sub
1249 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1250 # Cannot be done before the file is compiled
1251 local *dbline = shift;
1252 my $filename = $dbline;
1253 $filename =~ s/^_<//;
1254 $signal = 1, print $OUT "'$filename' loaded...\n"
1255 if $break_on_load{$filename};
1256 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
1257 return unless $postponed_file{$filename};
1258 $had_breakpoints{$filename}++;
1259 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1261 for $key (keys %{$postponed_file{$filename}}) {
1262 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
1264 delete $postponed_file{$filename};
1268 local ($savout) = select($OUT);
1269 my $osingle = $single;
1270 my $otrace = $trace;
1271 $single = $trace = 0;
1274 unless (defined &main::dumpValue) {
1277 if (defined &main::dumpValue) {
1278 &main::dumpValue(shift);
1280 print $OUT "dumpvar.pl not available.\n";
1287 # Tied method do not create a context, so may get wrong message:
1291 my @sub = dump_trace($_[0] + 1, $_[1]);
1292 my $short = $_[2]; # Print short report, next one for sub name
1294 for ($i=0; $i <= $#sub; $i++) {
1297 my $args = defined $sub[$i]{args}
1298 ? "(@{ $sub[$i]{args} })"
1300 $args = (substr $args, 0, $maxtrace - 3) . '...'
1301 if length $args > $maxtrace;
1302 my $file = $sub[$i]{file};
1303 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1305 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1307 my $sub = @_ >= 4 ? $_[3] : $s;
1308 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1310 print $fh "$sub[$i]{context} = $s$args" .
1311 " called from $file" .
1312 " line $sub[$i]{line}\n";
1319 my $count = shift || 1e9;
1322 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1323 my $nothard = not $frame & 8;
1324 local $frame = 0; # Do not want to trace this.
1325 my $otrace = $trace;
1328 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1333 if (not defined $arg) {
1335 } elsif ($nothard and tied $arg) {
1337 } elsif ($nothard and $type = ref $arg) {
1338 push @a, "ref($type)";
1340 local $_ = "$arg"; # Safe to stringify now - should not call f().
1343 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1344 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1345 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1349 $context = $context ? '@' : "\$";
1350 $args = $h ? [@a] : undef;
1351 $e =~ s/\n\s*\;\s*\Z// if $e;
1352 $e =~ s/([\\\'])/\\$1/g if $e;
1354 $sub = "require '$e'";
1355 } elsif (defined $r) {
1357 } elsif ($sub eq '(eval)') {
1358 $sub = "eval {...}";
1360 push(@sub, {context => $context, sub => $sub, args => $args,
1361 file => $file, line => $line});
1370 while ($action =~ s/\\$//) {
1381 &readline("cont: ");
1385 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1386 # many non-Unix systems can do system() but have problems with fork().
1387 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1388 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1389 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1390 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1392 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1393 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1394 close(SAVEIN); close(SAVEOUT);
1395 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1396 ( $? & 128 ) ? " (core dumped)" : "",
1397 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1404 local @stack = @stack; # Prevent growth by failing `use'.
1405 eval { require Term::ReadLine } or die $@;
1408 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1409 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1412 my $sel = select($OUT);
1416 eval "require Term::Rendezvous;" or die $@;
1417 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1418 my $term_rv = new Term::Rendezvous $rv;
1420 $OUT = $term_rv->OUT;
1424 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1426 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1428 $rl_attribs = $term->Attribs;
1429 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1430 if defined $rl_attribs->{basic_word_break_characters}
1431 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1432 $rl_attribs->{special_prefixes} = '$@&%';
1433 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1434 $rl_attribs->{completion_function} = \&db_complete;
1436 $LINEINFO = $OUT unless defined $LINEINFO;
1437 $lineinfo = $console unless defined $lineinfo;
1439 if ($term->Features->{setHistory} and "@hist" ne "?") {
1440 $term->SetHistory(@hist);
1442 ornaments($ornaments) if defined $ornaments;
1446 sub resetterm { # We forked, so we need a different TTY
1448 if (defined &get_fork_TTY) {
1450 } elsif (not defined $fork_TTY
1451 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1452 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1453 # Possibly _inside_ XTERM
1454 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1459 if (defined $fork_TTY) {
1463 print $OUT "Forked, but do not know how to change a TTY.\n",
1464 "Define \$DB::fork_TTY or get_fork_TTY().\n";
1470 my $left = @typeahead;
1471 my $got = shift @typeahead;
1472 print $OUT "auto(-$left)", shift, $got, "\n";
1473 $term->AddHistory($got)
1474 if length($got) > 1 and defined $term->Features->{addHistory};
1479 $term->readline(@_);
1483 my ($opt, $val)= @_;
1484 $val = option_val($opt,'N/A');
1485 $val =~ s/([\\\'])/\\$1/g;
1486 printf $OUT "%20s = '%s'\n", $opt, $val;
1490 my ($opt, $default)= @_;
1492 if (defined $optionVars{$opt}
1493 and defined $ {$optionVars{$opt}}) {
1494 $val = $ {$optionVars{$opt}};
1495 } elsif (defined $optionAction{$opt}
1496 and defined &{$optionAction{$opt}}) {
1497 $val = &{$optionAction{$opt}}();
1498 } elsif (defined $optionAction{$opt}
1499 and not defined $option{$opt}
1500 or defined $optionVars{$opt}
1501 and not defined $ {$optionVars{$opt}}) {
1504 $val = $option{$opt};
1512 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1513 my ($opt,$sep) = ($1,$2);
1516 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1518 #&dump_option($opt);
1519 } elsif ($sep !~ /\S/) {
1521 } elsif ($sep eq "=") {
1524 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1525 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1526 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1527 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1529 $val =~ s/\\([\\$end])/$1/g;
1533 grep( /^\Q$opt/ && ($option = $_), @options );
1534 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1536 print $OUT "Unknown option `$opt'\n" unless $matches;
1537 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1538 $option{$option} = $val if $matches == 1 and defined $val;
1539 eval "local \$frame = 0; local \$doret = -2;
1540 require '$optionRequire{$option}'"
1541 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1542 $ {$optionVars{$option}} = $val
1544 and defined $optionVars{$option} and defined $val;
1545 & {$optionAction{$option}} ($val)
1547 and defined $optionAction{$option}
1548 and defined &{$optionAction{$option}} and defined $val;
1549 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1555 my ($stem,@list) = @_;
1557 $ENV{"$ {stem}_n"} = @list;
1558 for $i (0 .. $#list) {
1560 $val =~ s/\\/\\\\/g;
1561 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1562 $ENV{"$ {stem}_$i"} = $val;
1569 my $n = delete $ENV{"$ {stem}_n"};
1571 for $i (0 .. $n - 1) {
1572 $val = delete $ENV{"$ {stem}_$i"};
1573 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1581 return; # Put nothing on the stack - malloc/free land!
1585 my($msg)= join("",@_);
1586 $msg .= ": $!\n" unless $msg =~ /\n$/;
1591 if (@_ and $term and $term->Features->{newTTY}) {
1592 my ($in, $out) = shift;
1594 ($in, $out) = split /,/, $in, 2;
1598 open IN, $in or die "cannot open `$in' for read: $!";
1599 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1600 $term->newTTY(\*IN, \*OUT);
1604 } elsif ($term and @_) {
1605 &warn("Too late to set TTY, enabled on next `R'!\n");
1613 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1615 $notty = shift if @_;
1621 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
1628 if ($ {$term->Features}{tkRunning}) {
1629 return $term->tkRunning(@_);
1631 print $OUT "tkRunning not supported by current ReadLine package.\n";
1638 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
1640 $runnonstop = shift if @_;
1647 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1654 $sh = quotemeta shift;
1655 $sh .= "\\b" if $sh =~ /\w$/;
1659 $psh =~ s/\\(.)/$1/g;
1665 if (defined $term) {
1666 local ($warnLevel,$dieLevel) = (0, 1);
1667 return '' unless $term->Features->{ornaments};
1668 eval { $term->ornaments(@_) } || '';
1676 $rc = quotemeta shift;
1677 $rc .= "\\b" if $rc =~ /\w$/;
1681 $prc =~ s/\\(.)/$1/g;
1687 return $lineinfo unless @_;
1689 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1690 $emacs = ($stream =~ /^\|/);
1691 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1692 $LINEINFO = \*LINEINFO;
1693 my $save = select($LINEINFO);
1707 s/^Term::ReadLine::readline$/readline/;
1708 if (defined $ { $_ . '::VERSION' }) {
1709 $version{$file} = "$ { $_ . '::VERSION' } from ";
1711 $version{$file} .= $INC{$file};
1713 do 'dumpvar.pl' unless defined &main::dumpValue;
1714 if (defined &main::dumpValue) {
1716 &main::dumpValue(\%version);
1718 print $OUT "dumpvar.pl not available.\n";
1725 B<s> [I<expr>] Single step [in I<expr>].
1726 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1727 <B<CR>> Repeat last B<n> or B<s> command.
1728 B<r> Return from current subroutine.
1729 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
1730 at the specified position.
1731 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1732 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1733 B<l> I<line> List single I<line>.
1734 B<l> I<subname> List first window of lines from subroutine.
1735 B<l> List next window of lines.
1736 B<-> List previous window of lines.
1737 B<w> [I<line>] List window around I<line>.
1738 B<.> Return to the executed line.
1739 B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
1740 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1741 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1742 B<L> List all breakpoints and actions.
1743 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1744 B<t> Toggle trace mode.
1745 B<t> I<expr> Trace through execution of I<expr>.
1746 B<b> [I<line>] [I<condition>]
1747 Set breakpoint; I<line> defaults to the current execution line;
1748 I<condition> breaks if it evaluates to true, defaults to '1'.
1749 B<b> I<subname> [I<condition>]
1750 Set breakpoint at first line of subroutine.
1751 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1752 B<b> B<postpone> I<subname> [I<condition>]
1753 Set breakpoint at first line of subroutine after
1755 B<b> B<compile> I<subname>
1756 Stop after the subroutine is compiled.
1757 B<d> [I<line>] Delete the breakpoint for I<line>.
1758 B<D> Delete all breakpoints.
1759 B<a> [I<line>] I<command>
1760 Set an action to be done before the I<line> is executed.
1761 Sequence is: check for breakpoint/watchpoint, print line
1762 if necessary, do action, prompt user if necessary,
1764 B<A> Delete all actions.
1765 B<W> I<expr> Add a global watch-expression.
1766 B<W> Delete all watch-expressions.
1767 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1768 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1769 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1770 B<x> I<expr> Evals expression in array context, dumps the result.
1771 B<m> I<expr> Evals expression in array context, prints methods callable
1772 on the first element of the result.
1773 B<m> I<class> Prints methods callable via the given class.
1774 B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1775 Set or query values of options. I<val> defaults to 1. I<opt> can
1776 be abbreviated. Several options can be listed.
1777 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1778 I<pager>: program for output of \"|cmd\";
1779 I<tkRunning>: run Tk while prompting (with ReadLine);
1780 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1781 I<inhibit_exit> Allows stepping off the end of the script.
1782 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1783 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1784 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1785 I<globPrint>: whether to print contents of globs;
1786 I<DumpDBFiles>: dump arrays holding debugged files;
1787 I<DumpPackages>: dump symbol tables of packages;
1788 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
1789 Option I<PrintRet> affects printing of return value after B<r> command,
1790 I<frame> affects printing messages on entry and exit from subroutines.
1791 I<AutoTrace> affects printing messages on every possible breaking point.
1792 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1793 I<ornaments> affects screen appearance of the command line.
1794 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1795 You can put additional initialization options I<TTY>, I<noTTY>,
1796 I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
1797 B<<> I<expr> Define Perl command to run before each prompt.
1798 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1799 B<>> I<expr> Define Perl command to run after each prompt.
1800 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
1801 B<{> I<db_command> Define debugger command to run before each prompt.
1802 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1803 B<$prc> I<number> Redo a previous command (default previous command).
1804 B<$prc> I<-number> Redo number'th-to-last command.
1805 B<$prc> I<pattern> Redo last command that started with I<pattern>.
1806 See 'B<O> I<recallCommand>' too.
1807 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1808 . ( $rc eq $sh ? "" : "
1809 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1810 See 'B<O> I<shellBang>' too.
1811 B<H> I<-number> Display last number commands (default all).
1812 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1813 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1814 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1815 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1816 I<command> Execute as a perl statement in current package.
1817 B<v> Show versions of loaded modules.
1818 B<R> Pure-man-restart of debugger, some of debugger state
1819 and command-line options may be lost.
1820 Currently the following setting are preserved:
1821 history, breakpoints and actions, debugger B<O>ptions
1822 and the following command-line options: I<-w>, I<-I>, I<-e>.
1823 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
1824 B<h h> Summary of debugger commands.
1825 B<q> or B<^D> Quit. Set \$DB::finished to 0 to debug global destruction.
1828 $summary = <<"END_SUM";
1829 I<List/search source lines:> I<Control script execution:>
1830 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1831 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1832 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
1833 B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s>
1834 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1835 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1836 I<Debugger controls:> B<L> List break/watch/actions
1837 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
1838 B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint
1839 B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub
1840 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1841 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1842 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1843 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
1844 B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
1845 B<q> or B<^D> Quit B<R> Attempt a restart
1846 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1847 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1848 B<p> I<expr> Print expression (uses script's current package).
1849 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1850 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1851 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
1853 # ')}}; # Fix balance of Emacs parsing
1857 my $message = shift;
1858 if (@Term::ReadLine::TermCap::rl_term_set) {
1859 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1860 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1862 print $OUT $message;
1868 $SIG{'ABRT'} = 'DEFAULT';
1869 kill 'ABRT', $$ if $panic++;
1870 if (defined &Carp::longmess) {
1871 local $SIG{__WARN__} = '';
1872 local $Carp::CarpLevel = 2; # mydie + confess
1873 &warn(Carp::longmess("Signal @_"));
1876 print $DB::OUT "Got signal @_\n";
1884 local $SIG{__WARN__} = '';
1885 local $SIG{__DIE__} = '';
1886 eval { require Carp } if defined $^S; # If error/warning during compilation,
1887 # require may be broken.
1888 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
1889 return unless defined &Carp::longmess;
1890 my ($mysingle,$mytrace) = ($single,$trace);
1891 $single = 0; $trace = 0;
1892 my $mess = Carp::longmess(@_);
1893 ($single,$trace) = ($mysingle,$mytrace);
1900 local $SIG{__DIE__} = '';
1901 local $SIG{__WARN__} = '';
1902 my $i = 0; my $ineval = 0; my $sub;
1903 if ($dieLevel > 2) {
1904 local $SIG{__WARN__} = \&dbwarn;
1905 &warn(@_); # Yell no matter what
1908 if ($dieLevel < 2) {
1909 die @_ if $^S; # in eval propagate
1911 eval { require Carp } if defined $^S; # If error/warning during compilation,
1912 # require may be broken.
1913 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
1914 unless defined &Carp::longmess;
1915 # We do not want to debug this chunk (automatic disabling works
1916 # inside DB::DB, but not in Carp).
1917 my ($mysingle,$mytrace) = ($single,$trace);
1918 $single = 0; $trace = 0;
1919 my $mess = Carp::longmess(@_);
1920 ($single,$trace) = ($mysingle,$mytrace);
1926 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1929 $SIG{__WARN__} = \&DB::dbwarn;
1931 $SIG{__WARN__} = $prevwarn;
1939 $prevdie = $SIG{__DIE__} unless $dieLevel;
1942 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1943 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
1944 print $OUT "Stack dump during die enabled",
1945 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
1947 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1949 $SIG{__DIE__} = $prevdie;
1950 print $OUT "Default die handler restored.\n";
1958 $prevsegv = $SIG{SEGV} unless $signalLevel;
1959 $prevbus = $SIG{BUS} unless $signalLevel;
1960 $signalLevel = shift;
1962 $SIG{SEGV} = \&DB::diesignal;
1963 $SIG{BUS} = \&DB::diesignal;
1965 $SIG{SEGV} = $prevsegv;
1966 $SIG{BUS} = $prevbus;
1974 return unless defined &$subr;
1976 $subr = \&$subr; # Hard reference
1979 $s = $_, last if $subr eq \&$_;
1987 $class = ref $class if ref $class;
1990 methods_via($class, '', 1);
1991 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
1996 return if $packs{$class}++;
1998 my $prepend = $prefix ? "via $prefix: " : '';
2000 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2001 sort keys %{"$ {class}::"}) {
2002 next if $seen{ $name }++;
2003 print $DB::OUT "$prepend$name\n";
2005 return unless shift; # Recurse?
2006 for $name (@{"$ {class}::ISA"}) {
2007 $prepend = $prefix ? $prefix . " -> $name" : $name;
2008 methods_via($name, $prepend, 1);
2012 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2014 BEGIN { # This does not compile, alas.
2015 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2016 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2020 $deep = 100; # warning if stack gets this deep
2024 $SIG{INT} = \&DB::catch;
2025 # This may be enabled to debug debugger:
2026 #$warnLevel = 1 unless defined $warnLevel;
2027 #$dieLevel = 1 unless defined $dieLevel;
2028 #$signalLevel = 1 unless defined $signalLevel;
2030 $db_stop = 0; # Compiler warning
2032 $level = 0; # Level of recursive debugging
2033 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2034 # Triggers bug (?) in perl is we postpone this until runtime:
2035 @postponed = @stack = (0);
2040 BEGIN {$^W = $ini_warn;} # Switch warnings back
2042 #use Carp; # This did break, left for debuggin
2045 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2046 my($text, $line, $start) = @_;
2047 my ($itext, $search, $prefix, $pack) =
2048 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
2050 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2051 (map { /$search/ ? ($1) : () } keys %sub)
2052 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2053 return sort grep /^\Q$text/, values %INC # files
2054 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2055 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2056 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2057 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2058 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2060 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2062 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2063 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2064 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2065 # We may want to complete to (eval 9), so $text may be wrong
2066 $prefix = length($1) - length($text);
2069 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2071 if ((substr $text, 0, 1) eq '&') { # subroutines
2072 $text = substr $text, 1;
2074 return sort map "$prefix$_",
2077 (map { /$search/ ? ($1) : () }
2080 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2081 $pack = ($1 eq 'main' ? '' : $1) . '::';
2082 $prefix = (substr $text, 0, 1) . $1 . '::';
2085 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2086 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2087 return db_complete($out[0], $line, $start);
2091 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2092 $pack = ($package eq 'main' ? '' : $package) . '::';
2093 $prefix = substr $text, 0, 1;
2094 $text = substr $text, 1;
2095 my @out = map "$prefix$_", grep /^\Q$text/,
2096 (grep /^_?[a-zA-Z]/, keys %$pack),
2097 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2098 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2099 return db_complete($out[0], $line, $start);
2103 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2104 my @out = grep /^\Q$text/, @options;
2105 my $val = option_val($out[0], undef);
2107 if (not defined $val or $val =~ /[\n\r]/) {
2108 # Can do nothing better
2109 } elsif ($val =~ /\s/) {
2111 foreach $l (split //, qq/\"\'\#\|/) {
2112 $out = "$l$val$l ", last if (index $val, $l) == -1;
2117 # Default to value if one completion, to question if many
2118 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2121 return $term->filename_list($text); # filenames
2125 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2129 $finished = $inhibit_exit; # So that some keys may be disabled.
2130 # Do not stop in at_exit() and destructors on exit:
2131 $DB::single = !$exiting && !$runnonstop;
2132 DB::fake::at_exit() unless $exiting or $runnonstop;
2138 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2141 package DB; # Do not trace this 1; below!