3 # Debugger for Perl 5.00x; perl5db.pl patch level:
6 $header = "perl5db.pl version $VERSION";
9 # This file is automatically included if you do perl -d.
10 # It's probably not useful to include this yourself.
12 # Perl supplies the values for %sub. It effectively inserts
13 # a &DB'DB(); in front of every place that can have a
14 # breakpoint. Instead of a subroutine call it calls &DB::sub with
15 # $DB::sub being the called subroutine. It also inserts a BEGIN
16 # {require 'perl5db.pl'} before the first line.
18 # After each `require'd file is compiled, but before it is executed, a
19 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
20 # $filename is the expanded name of the `require'd file (as found as
23 # Additional services from Perl interpreter:
25 # if caller() is called from the package DB, it provides some
28 # The array @{$main::{'_<'.$filename} is the line-by-line contents of
31 # The hash %{'_<'.$filename} contains breakpoints and action (it is
32 # keyed by line number), and individual entries are settable (as
33 # opposed to the whole hash). Only true/false is important to the
34 # interpreter, though the values used by perl5db.pl have the form
35 # "$break_condition\0$action". Values are magical in numeric context.
37 # The scalar ${'_<'.$filename} contains $filename.
39 # Note that no subroutine call is possible until &DB::sub is defined
40 # (for subroutines defined outside of the package DB). In fact the same is
41 # true if $deep is not defined.
46 # At start reads $rcfile that may set important options. This file
47 # may define a subroutine &afterinit that will be executed after the
48 # debugger is initialized.
50 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
51 # it as a rest of `O ...' line in debugger prompt.
53 # The options that can be specified only at startup:
54 # [To set in $rcfile, call &parse_options("optionName=new_value").]
56 # TTY - the TTY to use for debugging i/o.
58 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
59 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
60 # Term::Rendezvous. Current variant is to have the name of TTY in this
63 # ReadLine - If false, dummy ReadLine is used, so you can debug
64 # ReadLine applications.
66 # NonStop - if true, no i/o is performed until interrupt.
68 # LineInfo - file or pipe to print line number info to. If it is a
69 # pipe, a short "emacs like" message is used.
71 # RemotePort - host:port to connect to on remote host for remote debugging.
73 # Example $rcfile: (delete leading hashes!)
75 # &parse_options("NonStop=1 LineInfo=db.out");
76 # sub afterinit { $trace = 1; }
78 # The script will run without human intervention, putting trace
79 # information into db.out. (If you interrupt it, you would better
80 # reset LineInfo to something "interactive"!)
82 ##################################################################
84 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
85 # Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
87 # modified Perl debugger, to be run from Emacs in perldb-mode
88 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
89 # Johan Vromans -- upgrade to 4.0 pl 10
90 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
94 # A lot of things changed after 0.94. First of all, core now informs
95 # debugger about entry into XSUBs, overloaded operators, tied operations,
96 # BEGIN and END. Handy with `O f=2'.
98 # This can make debugger a little bit too verbose, please be patient
99 # and report your problems promptly.
101 # Now the option frame has 3 values: 0,1,2.
103 # Note that if DESTROY returns a reference to the object (or object),
104 # the deletion of data may be postponed until the next function call,
105 # due to the need to examine the return value.
107 # Changes: 0.95: `v' command shows versions.
108 # Changes: 0.96: `v' command shows version of readline.
109 # primitive completion works (dynamic variables, subs for `b' and `l',
110 # options). Can `p %var'
111 # Better help (`h <' now works). New commands <<, >>, {, {{.
112 # {dump|print}_trace() coded (to be able to do it from <<cmd).
113 # `c sub' documented.
114 # At last enough magic combined to stop after the end of debuggee.
115 # !! should work now (thanks to Emacs bracket matching an extra
116 # `]' in a regexp is caught).
117 # `L', `D' and `A' span files now (as documented).
118 # Breakpoints in `require'd code are possible (used in `R').
119 # Some additional words on internal work of debugger.
120 # `b load filename' implemented.
121 # `b postpone subr' implemented.
122 # now only `q' exits debugger (overwriteable on $inhibit_exit).
123 # When restarting debugger breakpoints/actions persist.
124 # Buglet: When restarting debugger only one breakpoint/action per
125 # autoloaded function persists.
126 # Changes: 0.97: NonStop will not stop in at_exit().
127 # Option AutoTrace implemented.
128 # Trace printed differently if frames are printed too.
129 # new `inhibitExit' option.
130 # printing of a very long statement interruptible.
131 # Changes: 0.98: New command `m' for printing possible methods
132 # 'l -' is a synonim for `-'.
133 # Cosmetic bugs in printing stack trace.
134 # `frame' & 8 to print "expanded args" in stack trace.
135 # Can list/break in imported subs.
136 # new `maxTraceLen' option.
137 # frame & 4 and frame & 8 granted.
139 # nonstoppable lines do not have `:' near the line number.
140 # `b compile subname' implemented.
141 # Will not use $` any more.
142 # `-' behaves sane now.
143 # Changes: 0.99: Completion for `f', `m'.
144 # `m' will remove duplicate names instead of duplicate functions.
145 # `b load' strips trailing whitespace.
146 # completion ignores leading `|'; takes into account current package
147 # when completing a subroutine name (same for `l').
148 # Changes: 1.07: Many fixed by tchrist 13-March-2000
150 # + Added bare mimimal security checks on perldb rc files, plus
151 # comments on what else is needed.
152 # + Fixed the ornaments that made "|h" completely unusable.
153 # They are not used in print_help if they will hurt. Strip pod
154 # if we're paging to less.
155 # + Fixed mis-formatting of help messages caused by ornaments
156 # to restore Larry's original formatting.
157 # + Fixed many other formatting errors. The code is still suboptimal,
158 # and needs a lot of work at restructuing. It's also misindented
160 # + Fixed bug where trying to look at an option like your pager
162 # + Fixed some $? processing. Note: if you use csh or tcsh, you will
163 # lose. You should consider shell escapes not using their shell,
164 # or else not caring about detailed status. This should really be
165 # unified into one place, too.
166 # + Fixed bug where invisible trailing whitespace on commands hoses you,
167 # tricking Perl into thinking you wern't calling a debugger command!
168 # + Fixed bug where leading whitespace on commands hoses you. (One
169 # suggests a leading semicolon or any other irrelevant non-whitespace
170 # to indicate literal Perl code.)
171 # + Fixed bugs that ate warnings due to wrong selected handle.
172 # + Fixed a precedence bug on signal stuff.
173 # + Fixed some unseemly wording.
174 # + Fixed bug in help command trying to call perl method code.
175 # + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
177 # + Added some comments. This code is still nasty spaghetti.
178 # + Added message if you clear your pre/post command stacks which was
179 # very easy to do if you just typed a bare >, <, or {. (A command
180 # without an argument should *never* be a destructive action; this
181 # API is fundamentally screwed up; likewise option setting, which
182 # is equally buggered.)
183 # + Added command stack dump on argument of "?" for >, <, or {.
184 # + Added a semi-built-in doc viewer command that calls man with the
185 # proper %Config::Config path (and thus gets caching, man -k, etc),
186 # or else perldoc on obstreperous platforms.
187 # + Added to and rearranged the help information.
188 # + Detected apparent misuse of { ... } to declare a block; this used
189 # to work but now is a command, and mysteriously gave no complaint.
191 ####################################################################
193 # Needed for the statement after exec():
195 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
196 local($^W) = 0; # Switch run-time warnings off during init.
199 $dumpvar::arrayDepth,
200 $dumpvar::dumpDBFiles,
201 $dumpvar::dumpPackages,
202 $dumpvar::quoteHighBit,
203 $dumpvar::printUndef,
212 # Command-line + PERLLIB:
215 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
217 $trace = $signal = $single = 0; # Uninitialized warning suppression
218 # (local $^W cannot help - other packages!).
219 $inhibit_exit = $option{PrintRet} = 1;
221 @options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
222 compactDump veryCompact quote HighBit undefPrint
223 globPrint PrintRet UsageOnly frame AutoTrace
224 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
225 recallCommand ShellBang pager tkRunning ornaments
226 signalLevel warnLevel dieLevel inhibit_exit
227 ImmediateStop bareStringify
231 hashDepth => \$dumpvar::hashDepth,
232 arrayDepth => \$dumpvar::arrayDepth,
233 DumpDBFiles => \$dumpvar::dumpDBFiles,
234 DumpPackages => \$dumpvar::dumpPackages,
235 DumpReused => \$dumpvar::dumpReused,
236 HighBit => \$dumpvar::quoteHighBit,
237 undefPrint => \$dumpvar::printUndef,
238 globPrint => \$dumpvar::globPrint,
239 UsageOnly => \$dumpvar::usageOnly,
240 bareStringify => \$dumpvar::bareStringify,
242 AutoTrace => \$trace,
243 inhibit_exit => \$inhibit_exit,
244 maxTraceLen => \$maxtrace,
245 ImmediateStop => \$ImmediateStop,
246 RemotePort => \$remoteport,
250 compactDump => \&dumpvar::compactDump,
251 veryCompact => \&dumpvar::veryCompact,
252 quote => \&dumpvar::quote,
255 ReadLine => \&ReadLine,
256 NonStop => \&NonStop,
257 LineInfo => \&LineInfo,
258 recallCommand => \&recallCommand,
259 ShellBang => \&shellBang,
261 signalLevel => \&signalLevel,
262 warnLevel => \&warnLevel,
263 dieLevel => \&dieLevel,
264 tkRunning => \&tkRunning,
265 ornaments => \&ornaments,
266 RemotePort => \&RemotePort,
270 compactDump => 'dumpvar.pl',
271 veryCompact => 'dumpvar.pl',
272 quote => 'dumpvar.pl',
275 # These guys may be defined in $ENV{PERL5DB} :
276 $rl = 1 unless defined $rl;
277 $warnLevel = 0 unless defined $warnLevel;
278 $dieLevel = 0 unless defined $dieLevel;
279 $signalLevel = 1 unless defined $signalLevel;
280 $pre = [] unless defined $pre;
281 $post = [] unless defined $post;
282 $pretype = [] unless defined $pretype;
284 warnLevel($warnLevel);
286 signalLevel($signalLevel);
289 (defined($ENV{PAGER})
293 : 'more'))) unless defined $pager;
295 &recallCommand("!") unless defined $prc;
296 &shellBang("!") unless defined $psh;
297 $maxtrace = 400 unless defined $maxtrace;
299 if (-e "/dev/tty") { # this is the wrong metric!
302 $rcfile="perldb.ini";
305 # This isn't really safe, because there's a race
306 # between checking and opening. The solution is to
307 # open and fstat the handle, but then you have to read and
308 # eval the contents. But then the silly thing gets
309 # your lexical scope, which is unfortunately at best.
313 # Just exactly what part of the word "CORE::" don't you understand?
314 local $SIG{__WARN__};
317 unless (is_safe_file($file)) {
318 CORE::warn <<EO_GRIPE;
319 perldb: Must not source insecure rcfile $file.
320 You or the superuser must be the owner, and it must not
321 be writable by anyone but its owner.
327 CORE::warn("perldb: couldn't parse $file: $@") if $@;
331 # Verifies that owner is either real user or superuser and that no
332 # one but owner may write to it. This function is of limited use
333 # when called on a path instead of upon a handle, because there are
334 # no guarantees that filename (by dirent) whose file (by ino) is
335 # eventually accessed is the same as the one tested.
336 # Assumes that the file's existence is not in doubt.
339 stat($path) || return; # mysteriously vaporized
340 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
342 return 0 if $uid != 0 && $uid != $<;
343 return 0 if $mode & 022;
348 safe_do("./$rcfile");
350 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
351 safe_do("$ENV{HOME}/$rcfile");
353 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
354 safe_do("$ENV{LOGDIR}/$rcfile");
357 if (defined $ENV{PERLDB_OPTS}) {
358 parse_options($ENV{PERLDB_OPTS});
361 # Here begin the unreadable code. It needs fixing.
363 if (exists $ENV{PERLDB_RESTART}) {
364 delete $ENV{PERLDB_RESTART};
366 @hist = get_list('PERLDB_HIST');
367 %break_on_load = get_list("PERLDB_ON_LOAD");
368 %postponed = get_list("PERLDB_POSTPONE");
369 my @had_breakpoints= get_list("PERLDB_VISITED");
370 for (0 .. $#had_breakpoints) {
371 my %pf = get_list("PERLDB_FILE_$_");
372 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
374 my %opt = get_list("PERLDB_OPT");
376 while (($opt,$val) = each %opt) {
377 $val =~ s/[\\\']/\\$1/g;
378 parse_options("$opt'$val'");
380 @INC = get_list("PERLDB_INC");
382 $pretype = [get_list("PERLDB_PRETYPE")];
383 $pre = [get_list("PERLDB_PRE")];
384 $post = [get_list("PERLDB_POST")];
385 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
391 # Is Perl being run from a slave editor or graphical debugger?
392 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
393 $rl = 0, shift(@main::ARGV) if $slave_editor;
395 #require Term::ReadLine;
397 if ($^O eq 'cygwin') {
398 # /dev/tty is binary. use stdin for textmode
400 } elsif (-e "/dev/tty") {
401 $console = "/dev/tty";
402 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
405 $console = "sys\$command";
408 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
413 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
421 $console = $tty if defined $tty;
423 if (defined $remoteport) {
425 $OUT = new IO::Socket::INET( Timeout => '10',
426 PeerAddr => $remoteport,
429 if (!$OUT) { die "Could not create socket to connect to remote host."; }
433 if (defined $console) {
434 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
435 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
436 || open(OUT,">&STDOUT"); # so we don't dongle stdout
439 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
440 $console = 'STDIN/OUT';
442 # so open("|more") can read from STDOUT and so we don't dingle stdin
448 $| = 1; # for DB::OUT
451 $LINEINFO = $OUT unless defined $LINEINFO;
452 $lineinfo = $console unless defined $lineinfo;
454 $| = 1; # for real STDOUT
456 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
457 unless ($runnonstop) {
458 print $OUT "\nLoading DB routines from $header\n";
459 print $OUT ("Editor support ",
460 $slave_editor ? "enabled" : "available",
462 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
469 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
472 if (defined &afterinit) { # May be defined in $rcfile
478 ############################################################ Subroutines
481 # _After_ the perl program is compiled, $single is set to 1:
482 if ($single and not $second_time++) {
483 if ($runnonstop) { # Disable until signal
484 for ($i=0; $i <= $stack_depth; ) {
488 # return; # Would not print trace!
489 } elsif ($ImmediateStop) {
494 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
496 ($package, $filename, $line) = caller;
497 $filename_ini = $filename;
498 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
499 "package $package;"; # this won't let them modify, alas
500 local(*dbline) = $main::{'_<' . $filename};
502 if (($stop,$action) = split(/\0/,$dbline{$line})) {
506 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
507 $dbline{$line} =~ s/;9($|\0)/$1/;
510 my $was_signal = $signal;
512 for (my $n = 0; $n <= $#to_watch; $n++) {
513 $evalarg = $to_watch[$n];
514 local $onetimeDump; # Do not output results
515 my ($val) = &eval; # Fix context (&eval is doing array)?
516 $val = ( (defined $val) ? "'$val'" : 'undef' );
517 if ($val ne $old_watch[$n]) {
520 Watchpoint $n:\t$to_watch[$n] changed:
521 old value:\t$old_watch[$n]
524 $old_watch[$n] = $val;
528 if ($trace & 4) { # User-installed watch
529 return if watchfunction($package, $filename, $line)
530 and not $single and not $was_signal and not ($trace & ~4);
532 $was_signal = $signal;
534 if ($single || ($trace & 1) || $was_signal) {
536 $position = "\032\032$filename:$line:0\n";
537 print $LINEINFO $position;
538 } elsif ($package eq 'DB::fake') {
541 Debugged program terminated. Use B<q> to quit or B<R> to restart,
542 use B<O> I<inhibit_exit> to avoid stopping after program termination,
543 B<h q>, B<h R> or B<h O> to get additional info.
546 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
547 "package $package;"; # this won't let them modify, alas
550 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
551 $prefix .= "$sub($filename:";
552 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
553 if (length($prefix) > 30) {
554 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
559 $position = "$prefix$line$infix$dbline[$line]$after";
562 print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
564 print $LINEINFO $position;
566 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
567 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
569 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
570 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
571 $position .= $incr_pos;
573 print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
575 print $LINEINFO $incr_pos;
580 $evalarg = $action, &eval if $action;
581 if ($single || $was_signal) {
582 local $level = $level + 1;
583 foreach $evalarg (@$pre) {
586 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
589 $incr = -1; # for backward motion.
590 @typeahead = (@$pretype, @typeahead);
592 while (($term || &setterm),
593 ($term_pid == $$ or &resetterm),
594 defined ($cmd=&readline(" DB" . ('<' x $level) .
595 ($#hist+1) . ('>' x $level) .
600 $cmd =~ s/\\$/\n/ && do {
601 $cmd .= &readline(" cont: ");
604 $cmd =~ /^$/ && ($cmd = $laststep);
605 push(@hist,$cmd) if length($cmd) > 1;
607 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
608 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
609 ($i) = split(/\s+/,$cmd);
611 # squelch the sigmangler
613 local $SIG{__WARN__};
614 eval "\$cmd =~ $alias{$i}";
616 print $OUT "Couldn't evaluate `$i' alias: $@";
620 $cmd =~ /^q$/ && ($exiting = 1) && exit $?;
621 $cmd =~ /^h$/ && do {
624 $cmd =~ /^h\s+h$/ && do {
625 print_help($summary);
627 # support long commands; otherwise bogus errors
628 # happen when you ask for h on <CR> for example
629 $cmd =~ /^h\s+(\S.*)$/ && do {
630 my $asked = $1; # for proper errmsg
631 my $qasked = quotemeta($asked); # for searching
632 # XXX: finds CR but not <CR>
633 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
634 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
638 print_help("B<$asked> is not a debugger command.\n");
641 $cmd =~ /^t$/ && do {
643 print $OUT "Trace = " .
644 (($trace & 1) ? "on" : "off" ) . "\n";
646 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
647 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
648 foreach $subname (sort(keys %sub)) {
649 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
650 print $OUT $subname,"\n";
654 $cmd =~ /^v$/ && do {
655 list_versions(); next CMD};
656 $cmd =~ s/^X\b/V $package/;
657 $cmd =~ /^V$/ && do {
658 $cmd = "V $package"; };
659 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
660 local ($savout) = select($OUT);
662 @vars = split(' ',$2);
663 do 'dumpvar.pl' unless defined &main::dumpvar;
664 if (defined &main::dumpvar) {
667 # must detect sigpipe failures
668 eval { &main::dumpvar($packname,@vars) };
670 die unless $@ =~ /dumpvar print failed/;
673 print $OUT "dumpvar.pl not available.\n";
677 $cmd =~ s/^x\b/ / && do { # So that will be evaled
678 $onetimeDump = 'dump'; };
679 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
680 methods($1); next CMD};
681 $cmd =~ s/^m\b/ / && do { # So this will be evaled
682 $onetimeDump = 'methods'; };
683 $cmd =~ /^f\b\s*(.*)/ && do {
687 print $OUT "The old f command is now the r command.\n";
688 print $OUT "The new f command switches filenames.\n";
691 if (!defined $main::{'_<' . $file}) {
692 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
693 $try = substr($try,2);
694 print $OUT "Choosing $try matching `$file':\n";
698 if (!defined $main::{'_<' . $file}) {
699 print $OUT "No file matching `$file' is loaded.\n";
701 } elsif ($file ne $filename) {
702 *dbline = $main::{'_<' . $file};
708 print $OUT "Already in $file.\n";
712 $cmd =~ s/^l\s+-\s*$/-/;
713 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
716 print($OUT "Error: $@\n"), next CMD if $@;
718 print($OUT "Interpreted as: $1 $s\n");
721 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
723 $subname =~ s/\'/::/;
724 $subname = $package."::".$subname
725 unless $subname =~ /::/;
726 $subname = "main".$subname if substr($subname,0,2) eq "::";
727 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
728 $subrange = pop @pieces;
729 $file = join(':', @pieces);
730 if ($file ne $filename) {
731 print $OUT "Switching to file '$file'.\n"
732 unless $slave_editor;
733 *dbline = $main::{'_<' . $file};
738 if (eval($subrange) < -$window) {
739 $subrange =~ s/-.*/+/;
741 $cmd = "l $subrange";
743 print $OUT "Subroutine $subname not found.\n";
746 $cmd =~ /^\.$/ && do {
747 $incr = -1; # for backward motion.
749 $filename = $filename_ini;
750 *dbline = $main::{'_<' . $filename};
752 print $LINEINFO $position;
754 $cmd =~ /^w\b\s*(\d*)$/ && do {
758 #print $OUT 'l ' . $start . '-' . ($start + $incr);
759 $cmd = 'l ' . $start . '-' . ($start + $incr); };
760 $cmd =~ /^-$/ && do {
761 $start -= $incr + $window + 1;
762 $start = 1 if $start <= 0;
764 $cmd = 'l ' . ($start) . '+'; };
765 $cmd =~ /^l$/ && do {
767 $cmd = 'l ' . $start . '-' . ($start + $incr); };
768 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
771 $incr = $window - 1 unless $incr;
772 $cmd = 'l ' . $start . '-' . ($start + $incr); };
773 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
774 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
775 $end = $max if $end > $max;
777 $i = $line if $i eq '.';
781 print $OUT "\032\032$filename:$i:0\n";
784 for (; $i <= $end; $i++) {
785 ($stop,$action) = split(/\0/, $dbline{$i});
787 and $filename eq $filename_ini)
789 : ($dbline[$i]+0 ? ':' : ' ') ;
790 $arrow .= 'b' if $stop;
791 $arrow .= 'a' if $action;
792 print $OUT "$i$arrow\t", $dbline[$i];
793 $i++, last if $signal;
795 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
797 $start = $i; # remember in case they want more
798 $start = $max if $start > $max;
800 $cmd =~ /^D$/ && do {
801 print $OUT "Deleting all breakpoints...\n";
803 for $file (keys %had_breakpoints) {
804 local *dbline = $main::{'_<' . $file};
808 for ($i = 1; $i <= $max ; $i++) {
809 if (defined $dbline{$i}) {
810 $dbline{$i} =~ s/^[^\0]+//;
811 if ($dbline{$i} =~ s/^\0?$//) {
817 if (not $had_breakpoints{$file} &= ~1) {
818 delete $had_breakpoints{$file};
822 undef %postponed_file;
823 undef %break_on_load;
825 $cmd =~ /^L$/ && do {
827 for $file (keys %had_breakpoints) {
828 local *dbline = $main::{'_<' . $file};
832 for ($i = 1; $i <= $max; $i++) {
833 if (defined $dbline{$i}) {
834 print $OUT "$file:\n" unless $was++;
835 print $OUT " $i:\t", $dbline[$i];
836 ($stop,$action) = split(/\0/, $dbline{$i});
837 print $OUT " break if (", $stop, ")\n"
839 print $OUT " action: ", $action, "\n"
846 print $OUT "Postponed breakpoints in subroutines:\n";
848 for $subname (keys %postponed) {
849 print $OUT " $subname\t$postponed{$subname}\n";
853 my @have = map { # Combined keys
854 keys %{$postponed_file{$_}}
855 } keys %postponed_file;
857 print $OUT "Postponed breakpoints in files:\n";
859 for $file (keys %postponed_file) {
860 my $db = $postponed_file{$file};
861 print $OUT " $file:\n";
862 for $line (sort {$a <=> $b} keys %$db) {
863 print $OUT " $line:\n";
864 my ($stop,$action) = split(/\0/, $$db{$line});
865 print $OUT " break if (", $stop, ")\n"
867 print $OUT " action: ", $action, "\n"
874 if (%break_on_load) {
875 print $OUT "Breakpoints on load:\n";
877 for $file (keys %break_on_load) {
878 print $OUT " $file\n";
883 print $OUT "Watch-expressions:\n";
885 for $expr (@to_watch) {
886 print $OUT " $expr\n";
891 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
892 my $file = $1; $file =~ s/\s+$//;
894 $break_on_load{$file} = 1;
895 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
896 $file .= '.pm', redo unless $file =~ /\./;
898 $had_breakpoints{$file} |= 1;
899 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
901 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
902 my $cond = length $3 ? $3 : '1';
903 my ($subname, $break) = ($2, $1 eq 'postpone');
904 $subname =~ s/\'/::/g;
905 $subname = "${'package'}::" . $subname
906 unless $subname =~ /::/;
907 $subname = "main".$subname if substr($subname,0,2) eq "::";
908 $postponed{$subname} = $break
909 ? "break +0 if $cond" : "compile";
911 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
913 $cond = length $2 ? $2 : '1';
914 $subname =~ s/\'/::/g;
915 $subname = "${'package'}::" . $subname
916 unless $subname =~ /::/;
917 $subname = "main".$subname if substr($subname,0,2) eq "::";
918 # Filename below can contain ':'
919 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
922 local $filename = $file;
923 local *dbline = $main::{'_<' . $filename};
924 $had_breakpoints{$filename} |= 1;
926 ++$i while $dbline[$i] == 0 && $i < $max;
927 $dbline{$i} =~ s/^[^\0]*/$cond/;
929 print $OUT "Subroutine $subname not found.\n";
932 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
934 $cond = length $2 ? $2 : '1';
935 if ($dbline[$i] == 0) {
936 print $OUT "Line $i not breakable.\n";
938 $had_breakpoints{$filename} |= 1;
939 $dbline{$i} =~ s/^[^\0]*/$cond/;
942 $cmd =~ /^d\b\s*(\d*)/ && do {
944 if ($dbline[$i] == 0) {
945 print $OUT "Line $i not breakable.\n";
947 $dbline{$i} =~ s/^[^\0]*//;
948 delete $dbline{$i} if $dbline{$i} eq '';
951 $cmd =~ /^A$/ && do {
952 print $OUT "Deleting all actions...\n";
954 for $file (keys %had_breakpoints) {
955 local *dbline = $main::{'_<' . $file};
959 for ($i = 1; $i <= $max ; $i++) {
960 if (defined $dbline{$i}) {
961 $dbline{$i} =~ s/\0[^\0]*//;
962 delete $dbline{$i} if $dbline{$i} eq '';
966 unless ($had_breakpoints{$file} &= ~2) {
967 delete $had_breakpoints{$file};
971 $cmd =~ /^O\s*$/ && do {
976 $cmd =~ /^O\s*(\S.*)/ && do {
979 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
980 push @$pre, action($1);
982 $cmd =~ /^>>\s*(.*)/ && do {
983 push @$post, action($1);
985 $cmd =~ /^<\s*(.*)/ && do {
987 print $OUT "All < actions cleared.\n";
993 print $OUT "No pre-prompt Perl actions.\n";
996 print $OUT "Perl commands run before each prompt:\n";
997 for my $action ( @$pre ) {
998 print $OUT "\t< -- $action\n";
1002 $pre = [action($1)];
1004 $cmd =~ /^>\s*(.*)/ && do {
1006 print $OUT "All > actions cleared.\n";
1012 print $OUT "No post-prompt Perl actions.\n";
1015 print $OUT "Perl commands run after each prompt:\n";
1016 for my $action ( @$post ) {
1017 print $OUT "\t> -- $action\n";
1021 $post = [action($1)];
1023 $cmd =~ /^\{\{\s*(.*)/ && do {
1024 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
1025 print $OUT "{{ is now a debugger command\n",
1026 "use `;{{' if you mean Perl code\n";
1032 $cmd =~ /^\{\s*(.*)/ && do {
1034 print $OUT "All { actions cleared.\n";
1039 unless (@$pretype) {
1040 print $OUT "No pre-prompt debugger actions.\n";
1043 print $OUT "Debugger commands run before each prompt:\n";
1044 for my $action ( @$pretype ) {
1045 print $OUT "\t{ -- $action\n";
1049 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
1050 print $OUT "{ is now a debugger command\n",
1051 "use `;{' if you mean Perl code\n";
1057 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1058 $i = $1 || $line; $j = $2;
1060 if ($dbline[$i] == 0) {
1061 print $OUT "Line $i may not have an action.\n";
1063 $had_breakpoints{$filename} |= 2;
1064 $dbline{$i} =~ s/\0[^\0]*//;
1065 $dbline{$i} .= "\0" . action($j);
1068 $dbline{$i} =~ s/\0[^\0]*//;
1069 delete $dbline{$i} if $dbline{$i} eq '';
1072 $cmd =~ /^n$/ && do {
1073 end_report(), next CMD if $finished and $level <= 1;
1077 $cmd =~ /^s$/ && do {
1078 end_report(), next CMD if $finished and $level <= 1;
1082 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
1083 end_report(), next CMD if $finished and $level <= 1;
1085 # Probably not needed, since we finish an interactive
1086 # sub-session anyway...
1087 # local $filename = $filename;
1088 # local *dbline = *dbline; # XXX Would this work?!
1089 if ($i =~ /\D/) { # subroutine name
1090 $subname = $package."::".$subname
1091 unless $subname =~ /::/;
1092 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1096 *dbline = $main::{'_<' . $filename};
1097 $had_breakpoints{$filename} |= 1;
1099 ++$i while $dbline[$i] == 0 && $i < $max;
1101 print $OUT "Subroutine $subname not found.\n";
1106 if ($dbline[$i] == 0) {
1107 print $OUT "Line $i not breakable.\n";
1110 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1112 for ($i=0; $i <= $stack_depth; ) {
1116 $cmd =~ /^r$/ && do {
1117 end_report(), next CMD if $finished and $level <= 1;
1118 $stack[$stack_depth] |= 1;
1119 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1121 $cmd =~ /^R$/ && do {
1122 print $OUT "Warning: some settings and command-line options may be lost!\n";
1123 my (@script, @flags, $cl);
1124 push @flags, '-w' if $ini_warn;
1125 # Put all the old includes at the start to get
1126 # the same debugger.
1128 push @flags, '-I', $_;
1130 # Arrange for setting the old INC:
1131 set_list("PERLDB_INC", @ini_INC);
1133 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1134 chomp ($cl = ${'::_<-e'}[$_]);
1135 push @script, '-e', $cl;
1140 set_list("PERLDB_HIST",
1141 $term->Features->{getHistory}
1142 ? $term->GetHistory : @hist);
1143 my @had_breakpoints = keys %had_breakpoints;
1144 set_list("PERLDB_VISITED", @had_breakpoints);
1145 set_list("PERLDB_OPT", %option);
1146 set_list("PERLDB_ON_LOAD", %break_on_load);
1148 for (0 .. $#had_breakpoints) {
1149 my $file = $had_breakpoints[$_];
1150 *dbline = $main::{'_<' . $file};
1151 next unless %dbline or $postponed_file{$file};
1152 (push @hard, $file), next
1153 if $file =~ /^\(eval \d+\)$/;
1155 @add = %{$postponed_file{$file}}
1156 if $postponed_file{$file};
1157 set_list("PERLDB_FILE_$_", %dbline, @add);
1159 for (@hard) { # Yes, really-really...
1160 # Find the subroutines in this eval
1161 *dbline = $main::{'_<' . $_};
1162 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1163 for $sub (keys %sub) {
1164 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1165 $subs{$sub} = [$1, $2];
1169 "No subroutines in $_, ignoring breakpoints.\n";
1172 LINES: for $line (keys %dbline) {
1173 # One breakpoint per sub only:
1174 my ($offset, $sub, $found);
1175 SUBS: for $sub (keys %subs) {
1176 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1177 and (not defined $offset # Not caught
1178 or $offset < 0 )) { # or badly caught
1180 $offset = $line - $subs{$sub}->[0];
1181 $offset = "+$offset", last SUBS if $offset >= 0;
1184 if (defined $offset) {
1185 $postponed{$found} =
1186 "break $offset if $dbline{$line}";
1188 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1192 set_list("PERLDB_POSTPONE", %postponed);
1193 set_list("PERLDB_PRETYPE", @$pretype);
1194 set_list("PERLDB_PRE", @$pre);
1195 set_list("PERLDB_POST", @$post);
1196 set_list("PERLDB_TYPEAHEAD", @typeahead);
1197 $ENV{PERLDB_RESTART} = 1;
1198 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1199 exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS;
1200 print $OUT "exec failed: $!\n";
1202 $cmd =~ /^T$/ && do {
1203 print_trace($OUT, 1); # skip DB
1205 $cmd =~ /^W\s*$/ && do {
1207 @to_watch = @old_watch = ();
1209 $cmd =~ /^W\b\s*(.*)/s && do {
1213 $val = (defined $val) ? "'$val'" : 'undef' ;
1214 push @old_watch, $val;
1217 $cmd =~ /^\/(.*)$/ && do {
1219 $inpat =~ s:([^\\])/$:$1:;
1221 # squelch the sigmangler
1222 local $SIG{__DIE__};
1223 local $SIG{__WARN__};
1224 eval '$inpat =~ m'."\a$inpat\a";
1236 $start = 1 if ($start > $max);
1237 last if ($start == $end);
1238 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1239 if ($slave_editor) {
1240 print $OUT "\032\032$filename:$start:0\n";
1242 print $OUT "$start:\t", $dbline[$start], "\n";
1247 print $OUT "/$pat/: not found\n" if ($start == $end);
1249 $cmd =~ /^\?(.*)$/ && do {
1251 $inpat =~ s:([^\\])\?$:$1:;
1253 # squelch the sigmangler
1254 local $SIG{__DIE__};
1255 local $SIG{__WARN__};
1256 eval '$inpat =~ m'."\a$inpat\a";
1268 $start = $max if ($start <= 0);
1269 last if ($start == $end);
1270 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1271 if ($slave_editor) {
1272 print $OUT "\032\032$filename:$start:0\n";
1274 print $OUT "$start:\t", $dbline[$start], "\n";
1279 print $OUT "?$pat?: not found\n" if ($start == $end);
1281 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1282 pop(@hist) if length($cmd) > 1;
1283 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1285 print $OUT $cmd, "\n";
1287 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1290 $cmd =~ /^$rc([^$rc].*)$/ && do {
1292 pop(@hist) if length($cmd) > 1;
1293 for ($i = $#hist; $i; --$i) {
1294 last if $hist[$i] =~ /$pat/;
1297 print $OUT "No such command!\n\n";
1301 print $OUT $cmd, "\n";
1303 $cmd =~ /^$sh$/ && do {
1304 &system($ENV{SHELL}||"/bin/sh");
1306 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1307 # XXX: using csh or tcsh destroys sigint retvals!
1308 #&system($1); # use this instead
1309 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1311 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1312 $end = $2 ? ($#hist-$2) : 0;
1313 $hist = 0 if $hist < 0;
1314 for ($i=$#hist; $i>$end; $i--) {
1315 print $OUT "$i: ",$hist[$i],"\n"
1316 unless $hist[$i] =~ /^.?$/;
1319 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1322 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1323 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1324 $cmd =~ s/^=\s*// && do {
1326 if (length $cmd == 0) {
1327 @keys = sort keys %alias;
1329 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1330 # can't use $_ or kill //g state
1331 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1332 $alias{$k} = "s\a$k\a$v\a";
1333 # squelch the sigmangler
1334 local $SIG{__DIE__};
1335 local $SIG{__WARN__};
1336 unless (eval "sub { s\a$k\a$v\a }; 1") {
1337 print $OUT "Can't alias $k to $v: $@\n";
1347 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1348 print $OUT "$k\t= $1\n";
1350 elsif (defined $alias{$k}) {
1351 print $OUT "$k\t$alias{$k}\n";
1354 print "No alias for $k\n";
1358 $cmd =~ /^\|\|?\s*[^|]/ && do {
1359 if ($pager =~ /^\|/) {
1360 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1361 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1363 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1366 unless ($piped=open(OUT,$pager)) {
1367 &warn("Can't pipe output to `$pager'");
1368 if ($pager =~ /^\|/) {
1369 open(OUT,">&STDOUT") # XXX: lost message
1370 || &warn("Can't restore DB::OUT");
1371 open(STDOUT,">&SAVEOUT")
1372 || &warn("Can't restore STDOUT");
1375 open(OUT,">&STDOUT") # XXX: lost message
1376 || &warn("Can't restore DB::OUT");
1380 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1381 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1382 $selected= select(OUT);
1384 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1385 $cmd =~ s/^\|+\s*//;
1388 # XXX Local variants do not work!
1389 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1390 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1391 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1393 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1395 $onetimeDump = undef;
1396 } elsif ($term_pid == $$) {
1401 if ($pager =~ /^\|/) {
1403 # we cannot warn here: the handle is missing --tchrist
1404 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1406 # most of the $? crud was coping with broken cshisms
1408 print SAVEOUT "Pager `$pager' failed: ";
1410 print SAVEOUT "shell returned -1\n";
1413 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1414 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1416 print SAVEOUT "status ", ($? >> 8), "\n";
1420 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1421 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1422 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1423 # Will stop ignoring SIGPIPE if done like nohup(1)
1424 # does SIGINT but Perl doesn't give us a choice.
1426 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1429 select($selected), $selected= "" unless $selected eq "";
1433 $exiting = 1 unless defined $cmd;
1434 foreach $evalarg (@$post) {
1437 } # if ($single || $signal)
1438 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1442 # The following code may be executed now:
1446 my ($al, $ret, @ret) = "";
1447 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1450 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1451 $#stack = $stack_depth;
1452 $stack[-1] = $single;
1454 $single |= 4 if $stack_depth == $deep;
1456 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
1457 # Why -1? But it works! :-(
1458 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1459 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
1462 $single |= $stack[$stack_depth--];
1464 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1465 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1466 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1467 if ($doret eq $stack_depth or $frame & 16) {
1468 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1469 print $fh ' ' x $stack_depth if $frame & 16;
1470 print $fh "list context return from $sub:\n";
1471 dumpit($fh, \@ret );
1476 if (defined wantarray) {
1481 $single |= $stack[$stack_depth--];
1483 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
1484 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1485 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1486 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1487 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1488 print $fh (' ' x $stack_depth) if $frame & 16;
1489 print $fh (defined wantarray
1490 ? "scalar context return from $sub: "
1491 : "void context return from $sub\n");
1492 dumpit( $fh, $ret ) if defined wantarray;
1500 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1501 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1504 # The following takes its argument via $evalarg to preserve current @_
1507 # 'my' would make it visible from user code
1508 # but so does local! --tchrist
1511 local $otrace = $trace;
1512 local $osingle = $single;
1514 { ($evalarg) = $evalarg =~ /(.*)/s; }
1515 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1521 local $saved[0]; # Preserve the old value of $@
1525 } elsif ($onetimeDump eq 'dump') {
1526 dumpit($OUT, \@res);
1527 } elsif ($onetimeDump eq 'methods') {
1534 my $subname = shift;
1535 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1536 my $offset = $1 || 0;
1537 # Filename below can contain ':'
1538 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1541 local *dbline = $main::{'_<' . $file};
1542 local $^W = 0; # != 0 is magical below
1543 $had_breakpoints{$file} |= 1;
1545 ++$i until $dbline[$i] != 0 or $i >= $max;
1546 $dbline{$i} = delete $postponed{$subname};
1548 print $OUT "Subroutine $subname not found.\n";
1552 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1553 #print $OUT "In postponed_sub for `$subname'.\n";
1557 if ($ImmediateStop) {
1561 return &postponed_sub
1562 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1563 # Cannot be done before the file is compiled
1564 local *dbline = shift;
1565 my $filename = $dbline;
1566 $filename =~ s/^_<//;
1567 $signal = 1, print $OUT "'$filename' loaded...\n"
1568 if $break_on_load{$filename};
1569 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
1570 return unless $postponed_file{$filename};
1571 $had_breakpoints{$filename} |= 1;
1572 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1574 for $key (keys %{$postponed_file{$filename}}) {
1575 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1577 delete $postponed_file{$filename};
1581 local ($savout) = select(shift);
1582 my $osingle = $single;
1583 my $otrace = $trace;
1584 $single = $trace = 0;
1587 unless (defined &main::dumpValue) {
1590 if (defined &main::dumpValue) {
1591 &main::dumpValue(shift);
1593 print $OUT "dumpvar.pl not available.\n";
1600 # Tied method do not create a context, so may get wrong message:
1604 my @sub = dump_trace($_[0] + 1, $_[1]);
1605 my $short = $_[2]; # Print short report, next one for sub name
1607 for ($i=0; $i <= $#sub; $i++) {
1610 my $args = defined $sub[$i]{args}
1611 ? "(@{ $sub[$i]{args} })"
1613 $args = (substr $args, 0, $maxtrace - 3) . '...'
1614 if length $args > $maxtrace;
1615 my $file = $sub[$i]{file};
1616 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1618 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
1620 my $sub = @_ >= 4 ? $_[3] : $s;
1621 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1623 print $fh "$sub[$i]{context} = $s$args" .
1624 " called from $file" .
1625 " line $sub[$i]{line}\n";
1632 my $count = shift || 1e9;
1635 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
1636 my $nothard = not $frame & 8;
1637 local $frame = 0; # Do not want to trace this.
1638 my $otrace = $trace;
1641 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
1646 if (not defined $arg) {
1648 } elsif ($nothard and tied $arg) {
1650 } elsif ($nothard and $type = ref $arg) {
1651 push @a, "ref($type)";
1653 local $_ = "$arg"; # Safe to stringify now - should not call f().
1656 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1657 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1658 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1662 $context = $context ? '@' : (defined $context ? "\$" : '.');
1663 $args = $h ? [@a] : undef;
1664 $e =~ s/\n\s*\;\s*\Z// if $e;
1665 $e =~ s/([\\\'])/\\$1/g if $e;
1667 $sub = "require '$e'";
1668 } elsif (defined $r) {
1670 } elsif ($sub eq '(eval)') {
1671 $sub = "eval {...}";
1673 push(@sub, {context => $context, sub => $sub, args => $args,
1674 file => $file, line => $line});
1683 while ($action =~ s/\\$//) {
1692 # i hate using globals!
1693 $balanced_brace_re ||= qr{
1696 (?> [^{}] + ) # Non-parens without backtracking
1698 (??{ $balanced_brace_re }) # Group with matching parens
1702 return $_[0] !~ m/$balanced_brace_re/;
1706 &readline("cont: ");
1710 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1711 # some non-Unix systems can do system() but have problems with fork().
1712 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1713 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1714 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1715 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1717 # XXX: using csh or tcsh destroys sigint retvals!
1719 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1720 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1725 # most of the $? crud was coping with broken cshisms
1727 &warn("(Command exited ", ($? >> 8), ")\n");
1729 &warn( "(Command died of SIG#", ($? & 127),
1730 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1740 eval { require Term::ReadLine } or die $@;
1743 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1744 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1747 my $sel = select($OUT);
1751 eval "require Term::Rendezvous;" or die;
1752 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1753 my $term_rv = new Term::Rendezvous $rv;
1755 $OUT = $term_rv->OUT;
1759 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1761 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1763 $rl_attribs = $term->Attribs;
1764 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1765 if defined $rl_attribs->{basic_word_break_characters}
1766 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1767 $rl_attribs->{special_prefixes} = '$@&%';
1768 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1769 $rl_attribs->{completion_function} = \&db_complete;
1771 $LINEINFO = $OUT unless defined $LINEINFO;
1772 $lineinfo = $console unless defined $lineinfo;
1774 if ($term->Features->{setHistory} and "@hist" ne "?") {
1775 $term->SetHistory(@hist);
1777 ornaments($ornaments) if defined $ornaments;
1781 sub resetterm { # We forked, so we need a different TTY
1783 if (defined &get_fork_TTY) {
1785 } elsif (not defined $fork_TTY
1786 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1787 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1788 # Possibly _inside_ XTERM
1789 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1794 if (defined $fork_TTY) {
1799 I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1800 Define B<\$DB::fork_TTY>
1801 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1802 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1803 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1804 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1812 my $left = @typeahead;
1813 my $got = shift @typeahead;
1814 print $OUT "auto(-$left)", shift, $got, "\n";
1815 $term->AddHistory($got)
1816 if length($got) > 1 and defined $term->Features->{addHistory};
1821 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1822 $OUT->write(join('', @_));
1824 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
1828 $term->readline(@_);
1833 my ($opt, $val)= @_;
1834 $val = option_val($opt,'N/A');
1835 $val =~ s/([\\\'])/\\$1/g;
1836 printf $OUT "%20s = '%s'\n", $opt, $val;
1840 my ($opt, $default)= @_;
1842 if (defined $optionVars{$opt}
1843 and defined ${$optionVars{$opt}}) {
1844 $val = ${$optionVars{$opt}};
1845 } elsif (defined $optionAction{$opt}
1846 and defined &{$optionAction{$opt}}) {
1847 $val = &{$optionAction{$opt}}();
1848 } elsif (defined $optionAction{$opt}
1849 and not defined $option{$opt}
1850 or defined $optionVars{$opt}
1851 and not defined ${$optionVars{$opt}}) {
1854 $val = $option{$opt};
1861 # too dangerous to let intuitive usage overwrite important things
1862 # defaultion should never be the default
1863 my %opt_needs_val = map { ( $_ => 1 ) } qw{
1864 arrayDepth hashDepth LineInfo maxTraceLen ornaments
1865 pager quote ReadLine recallCommand RemotePort ShellBang TTY
1870 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
1871 my ($opt,$sep) = ($1,$2);
1874 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1876 #&dump_option($opt);
1877 } elsif ($sep !~ /\S/) {
1879 $val = "1"; # this is an evil default; make 'em set it!
1880 } elsif ($sep eq "=") {
1882 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
1884 ($val = $2) =~ s/\\([$quote\\])/$1/g;
1888 print OUT qq(Option better cleared using $opt=""\n)
1892 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1893 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1894 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1895 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1896 ($val = $1) =~ s/\\([\\$end])/$1/g;
1900 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
1901 || grep( /^\Q$opt/i && ($option = $_), @options );
1903 print($OUT "Unknown option `$opt'\n"), next unless $matches;
1904 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
1906 if ($opt_needs_val{$option} && $val_defaulted) {
1907 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
1911 $option{$option} = $val if defined $val;
1916 require '$optionRequire{$option}';
1918 } || die # XXX: shouldn't happen
1919 if defined $optionRequire{$option} &&
1922 ${$optionVars{$option}} = $val
1923 if defined $optionVars{$option} &&
1926 &{$optionAction{$option}} ($val)
1927 if defined $optionAction{$option} &&
1928 defined &{$optionAction{$option}} &&
1932 dump_option($option) unless $OUT eq \*STDERR;
1937 my ($stem,@list) = @_;
1939 $ENV{"${stem}_n"} = @list;
1940 for $i (0 .. $#list) {
1942 $val =~ s/\\/\\\\/g;
1943 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
1944 $ENV{"${stem}_$i"} = $val;
1951 my $n = delete $ENV{"${stem}_n"};
1953 for $i (0 .. $n - 1) {
1954 $val = delete $ENV{"${stem}_$i"};
1955 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1963 return; # Put nothing on the stack - malloc/free land!
1967 my($msg)= join("",@_);
1968 $msg .= ": $!\n" unless $msg =~ /\n$/;
1973 if (@_ and $term and $term->Features->{newTTY}) {
1974 my ($in, $out) = shift;
1976 ($in, $out) = split /,/, $in, 2;
1980 open IN, $in or die "cannot open `$in' for read: $!";
1981 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1982 $term->newTTY(\*IN, \*OUT);
1986 } elsif ($term and @_) {
1987 &warn("Too late to set TTY, enabled on next `R'!\n");
1995 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
1997 $notty = shift if @_;
2003 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2011 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2013 $remoteport = shift if @_;
2018 if (${$term->Features}{tkRunning}) {
2019 return $term->tkRunning(@_);
2021 print $OUT "tkRunning not supported by current ReadLine package.\n";
2028 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2030 $runnonstop = shift if @_;
2037 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2044 $sh = quotemeta shift;
2045 $sh .= "\\b" if $sh =~ /\w$/;
2049 $psh =~ s/\\(.)/$1/g;
2055 if (defined $term) {
2056 local ($warnLevel,$dieLevel) = (0, 1);
2057 return '' unless $term->Features->{ornaments};
2058 eval { $term->ornaments(@_) } || '';
2066 $rc = quotemeta shift;
2067 $rc .= "\\b" if $rc =~ /\w$/;
2071 $prc =~ s/\\(.)/$1/g;
2077 return $lineinfo unless @_;
2079 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2080 $slave_editor = ($stream =~ /^\|/);
2081 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2082 $LINEINFO = \*LINEINFO;
2083 my $save = select($LINEINFO);
2097 s/^Term::ReadLine::readline$/readline/;
2098 if (defined ${ $_ . '::VERSION' }) {
2099 $version{$file} = "${ $_ . '::VERSION' } from ";
2101 $version{$file} .= $INC{$file};
2103 dumpit($OUT,\%version);
2107 # XXX: make sure these are tabs between the command and explantion,
2108 # or print_help will screw up your formatting if you have
2109 # eeevil ornaments enabled. This is an insane mess.
2113 B<s> [I<expr>] Single step [in I<expr>].
2114 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2115 <B<CR>> Repeat last B<n> or B<s> command.
2116 B<r> Return from current subroutine.
2117 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2118 at the specified position.
2119 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2120 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2121 B<l> I<line> List single I<line>.
2122 B<l> I<subname> List first window of lines from subroutine.
2123 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2124 B<l> List next window of lines.
2125 B<-> List previous window of lines.
2126 B<w> [I<line>] List window around I<line>.
2127 B<.> Return to the executed line.
2128 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2129 I<filename> may be either the full name of the file, or a regular
2130 expression matching the full file name:
2131 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2132 Evals (with saved bodies) are considered to be filenames:
2133 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2134 (in the order of execution).
2135 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2136 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2137 B<L> List all breakpoints and actions.
2138 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2139 B<t> Toggle trace mode.
2140 B<t> I<expr> Trace through execution of I<expr>.
2141 B<b> [I<line>] [I<condition>]
2142 Set breakpoint; I<line> defaults to the current execution line;
2143 I<condition> breaks if it evaluates to true, defaults to '1'.
2144 B<b> I<subname> [I<condition>]
2145 Set breakpoint at first line of subroutine.
2146 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2147 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2148 B<b> B<postpone> I<subname> [I<condition>]
2149 Set breakpoint at first line of subroutine after
2151 B<b> B<compile> I<subname>
2152 Stop after the subroutine is compiled.
2153 B<d> [I<line>] Delete the breakpoint for I<line>.
2154 B<D> Delete all breakpoints.
2155 B<a> [I<line>] I<command>
2156 Set an action to be done before the I<line> is executed;
2157 I<line> defaults to the current execution line.
2158 Sequence is: check for breakpoint/watchpoint, print line
2159 if necessary, do action, prompt user if necessary,
2161 B<a> [I<line>] Delete the action for I<line>.
2162 B<A> Delete all actions.
2163 B<W> I<expr> Add a global watch-expression.
2164 B<W> Delete all watch-expressions.
2165 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2166 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2167 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2168 B<x> I<expr> Evals expression in list context, dumps the result.
2169 B<m> I<expr> Evals expression in list context, prints methods callable
2170 on the first element of the result.
2171 B<m> I<class> Prints methods callable via the given class.
2173 B<<> ? List Perl commands to run before each prompt.
2174 B<<> I<expr> Define Perl command to run before each prompt.
2175 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2176 B<>> ? List Perl commands to run after each prompt.
2177 B<>> I<expr> Define Perl command to run after each prompt.
2178 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2179 B<{> I<db_command> Define debugger command to run before each prompt.
2180 B<{> ? List debugger commands to run before each prompt.
2181 B<<> I<expr> Define Perl command to run before each prompt.
2182 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2183 B<$prc> I<number> Redo a previous command (default previous command).
2184 B<$prc> I<-number> Redo number'th-to-last command.
2185 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2186 See 'B<O> I<recallCommand>' too.
2187 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2188 . ( $rc eq $sh ? "" : "
2189 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2190 See 'B<O> I<shellBang>' too.
2191 B<H> I<-number> Display last number commands (default all).
2192 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2193 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2194 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2195 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2196 I<command> Execute as a perl statement in current package.
2197 B<v> Show versions of loaded modules.
2198 B<R> Pure-man-restart of debugger, some of debugger state
2199 and command-line options may be lost.
2200 Currently the following setting are preserved:
2201 history, breakpoints and actions, debugger B<O>ptions
2202 and the following command-line options: I<-w>, I<-I>, I<-e>.
2204 B<O> [I<opt>] ... Set boolean option to true
2205 B<O> [I<opt>B<?>] Query options
2206 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2207 Set options. Use quotes in spaces in value.
2208 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2209 I<pager> program for output of \"|cmd\";
2210 I<tkRunning> run Tk while prompting (with ReadLine);
2211 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2212 I<inhibit_exit> Allows stepping off the end of the script.
2213 I<ImmediateStop> Debugger should stop as early as possible.
2214 I<RemotePort> Remote hostname:port for remote debugging
2215 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2216 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2217 I<compactDump>, I<veryCompact> change style of array and hash dump;
2218 I<globPrint> whether to print contents of globs;
2219 I<DumpDBFiles> dump arrays holding debugged files;
2220 I<DumpPackages> dump symbol tables of packages;
2221 I<DumpReused> dump contents of \"reused\" addresses;
2222 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2223 I<bareStringify> Do not print the overload-stringified value;
2224 Other options include:
2225 I<PrintRet> affects printing of return value after B<r> command,
2226 I<frame> affects printing messages on entry and exit from subroutines.
2227 I<AutoTrace> affects printing messages on every possible breaking point.
2228 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
2229 I<ornaments> affects screen appearance of the command line.
2230 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2231 You can put additional initialization options I<TTY>, I<noTTY>,
2232 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2233 `B<R>' after you set them).
2235 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2236 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2237 B<h h> Summary of debugger commands.
2238 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2239 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2240 Set B<\$DB::doccmd> to change viewer.
2242 Type `|h' for a paged display if this was too hard to read.
2244 "; # Fix balance of vi % matching: } }}
2246 $summary = <<"END_SUM";
2247 I<List/search source lines:> I<Control script execution:>
2248 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2249 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2250 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2251 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2252 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2253 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2254 I<Debugger controls:> B<L> List break/watch/actions
2255 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2256 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2257 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2258 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2259 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2260 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2261 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2262 B<q> or B<^D> Quit B<R> Attempt a restart
2263 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2264 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2265 B<p> I<expr> Print expression (uses script's current package).
2266 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2267 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2268 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2269 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2271 # ')}}; # Fix balance of vi % matching
2277 # Restore proper alignment destroyed by eeevil I<> and B<>
2278 # ornaments: A pox on both their houses!
2280 # A help command will have everything up to and including
2281 # the first tab sequence paddeed into a field 16 (or if indented 20)
2282 # wide. If it's wide than that, an extra space will be added.
2284 ^ # only matters at start of line
2285 ( \040{4} | \t )* # some subcommands are indented
2286 ( < ? # so <CR> works
2287 [BI] < [^\t\n] + ) # find an eeevil ornament
2288 ( \t+ ) # original separation, discarded
2289 ( .* ) # this will now start (no earlier) than
2292 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2293 my $clean = $command;
2294 $clean =~ s/[BI]<([^>]*)>/$1/g;
2295 # replace with this whole string:
2296 (length($leadwhite) ? " " x 4 : "")
2298 . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ")
2303 s{ # handle bold ornaments
2304 B < ( [^>] + | > ) >
2306 $Term::ReadLine::TermCap::rl_term_set[2]
2308 . $Term::ReadLine::TermCap::rl_term_set[3]
2311 s{ # handle italic ornaments
2312 I < ( [^>] + | > ) >
2314 $Term::ReadLine::TermCap::rl_term_set[0]
2316 . $Term::ReadLine::TermCap::rl_term_set[1]
2323 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2324 my $is_less = $pager =~ /\bless\b/;
2325 if ($pager =~ /\bmore\b/) {
2326 my @st_more = stat('/usr/bin/more');
2327 my @st_less = stat('/usr/bin/less');
2328 $is_less = @st_more && @st_less
2329 && $st_more[0] == $st_less[0]
2330 && $st_more[1] == $st_less[1];
2332 # changes environment!
2333 $ENV{LESS} .= 'r' if $is_less;
2339 $SIG{'ABRT'} = 'DEFAULT';
2340 kill 'ABRT', $$ if $panic++;
2341 if (defined &Carp::longmess) {
2342 local $SIG{__WARN__} = '';
2343 local $Carp::CarpLevel = 2; # mydie + confess
2344 &warn(Carp::longmess("Signal @_"));
2347 print $DB::OUT "Got signal @_\n";
2355 local $SIG{__WARN__} = '';
2356 local $SIG{__DIE__} = '';
2357 eval { require Carp } if defined $^S; # If error/warning during compilation,
2358 # require may be broken.
2359 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2360 return unless defined &Carp::longmess;
2361 my ($mysingle,$mytrace) = ($single,$trace);
2362 $single = 0; $trace = 0;
2363 my $mess = Carp::longmess(@_);
2364 ($single,$trace) = ($mysingle,$mytrace);
2371 local $SIG{__DIE__} = '';
2372 local $SIG{__WARN__} = '';
2373 my $i = 0; my $ineval = 0; my $sub;
2374 if ($dieLevel > 2) {
2375 local $SIG{__WARN__} = \&dbwarn;
2376 &warn(@_); # Yell no matter what
2379 if ($dieLevel < 2) {
2380 die @_ if $^S; # in eval propagate
2382 eval { require Carp } if defined $^S; # If error/warning during compilation,
2383 # require may be broken.
2385 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2386 unless defined &Carp::longmess;
2388 # We do not want to debug this chunk (automatic disabling works
2389 # inside DB::DB, but not in Carp).
2390 my ($mysingle,$mytrace) = ($single,$trace);
2391 $single = 0; $trace = 0;
2392 my $mess = Carp::longmess(@_);
2393 ($single,$trace) = ($mysingle,$mytrace);
2399 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2402 $SIG{__WARN__} = \&DB::dbwarn;
2404 $SIG{__WARN__} = $prevwarn;
2412 $prevdie = $SIG{__DIE__} unless $dieLevel;
2415 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2416 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
2417 print $OUT "Stack dump during die enabled",
2418 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2420 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2422 $SIG{__DIE__} = $prevdie;
2423 print $OUT "Default die handler restored.\n";
2431 $prevsegv = $SIG{SEGV} unless $signalLevel;
2432 $prevbus = $SIG{BUS} unless $signalLevel;
2433 $signalLevel = shift;
2435 $SIG{SEGV} = \&DB::diesignal;
2436 $SIG{BUS} = \&DB::diesignal;
2438 $SIG{SEGV} = $prevsegv;
2439 $SIG{BUS} = $prevbus;
2447 my $name = CvGV_name_or_bust($in);
2448 defined $name ? $name : $in;
2451 sub CvGV_name_or_bust {
2453 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2454 $in = \&$in; # Hard reference...
2455 eval {require Devel::Peek; 1} or return;
2456 my $gv = Devel::Peek::CvGV($in) or return;
2457 *$gv{PACKAGE} . '::' . *$gv{NAME};
2463 return unless defined &$subr;
2464 my $name = CvGV_name_or_bust($subr);
2466 $data = $sub{$name} if defined $name;
2467 return $data if defined $data;
2470 $subr = \&$subr; # Hard reference
2473 $s = $_, last if $subr eq \&$_;
2481 $class = ref $class if ref $class;
2484 methods_via($class, '', 1);
2485 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2490 return if $packs{$class}++;
2492 my $prepend = $prefix ? "via $prefix: " : '';
2494 for $name (grep {defined &{${"${class}::"}{$_}}}
2495 sort keys %{"${class}::"}) {
2496 next if $seen{ $name }++;
2497 print $DB::OUT "$prepend$name\n";
2499 return unless shift; # Recurse?
2500 for $name (@{"${class}::ISA"}) {
2501 $prepend = $prefix ? $prefix . " -> $name" : $name;
2502 methods_via($name, $prepend, 1);
2507 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
2508 ? "man" # O Happy Day!
2509 : "perldoc"; # Alas, poor unfortunates
2515 &system("$doccmd $doccmd");
2518 # this way user can override, like with $doccmd="man -Mwhatever"
2519 # or even just "man " to disable the path check.
2520 unless ($doccmd eq 'man') {
2521 &system("$doccmd $page");
2525 $page = 'perl' if lc($page) eq 'help';
2528 my $man1dir = $Config::Config{'man1dir'};
2529 my $man3dir = $Config::Config{'man3dir'};
2530 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2532 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2533 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2534 chop $manpath if $manpath;
2535 # harmless if missing, I figure
2536 my $oldpath = $ENV{MANPATH};
2537 $ENV{MANPATH} = $manpath if $manpath;
2538 my $nopathopt = $^O =~ /dunno what goes here/;
2540 # I just *know* there are men without -M
2541 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2544 unless ($page =~ /^perl\w/) {
2545 if (grep { $page eq $_ } qw{
2546 5004delta 5005delta amiga api apio book boot bot call compile
2547 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2548 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2549 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2550 modinstall modlib number obj op opentut os2 os390 pod port
2551 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2552 trap unicode var vms win32 xs xstut
2557 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2562 if (defined $oldpath) {
2563 $ENV{MANPATH} = $manpath;
2565 delete $ENV{MANPATH};
2569 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2571 BEGIN { # This does not compile, alas.
2572 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2573 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2577 $deep = 100; # warning if stack gets this deep
2581 $SIG{INT} = \&DB::catch;
2582 # This may be enabled to debug debugger:
2583 #$warnLevel = 1 unless defined $warnLevel;
2584 #$dieLevel = 1 unless defined $dieLevel;
2585 #$signalLevel = 1 unless defined $signalLevel;
2587 $db_stop = 0; # Compiler warning
2589 $level = 0; # Level of recursive debugging
2590 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2591 # Triggers bug (?) in perl is we postpone this until runtime:
2592 @postponed = @stack = (0);
2593 $stack_depth = 0; # Localized $#stack
2598 BEGIN {$^W = $ini_warn;} # Switch warnings back
2600 #use Carp; # This did break, left for debuggin
2603 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
2604 my($text, $line, $start) = @_;
2605 my ($itext, $search, $prefix, $pack) =
2606 ($text, "^\Q${'package'}::\E([^:]+)\$");
2608 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2609 (map { /$search/ ? ($1) : () } keys %sub)
2610 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2611 return sort grep /^\Q$text/, values %INC # files
2612 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
2613 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2614 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2615 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2616 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2618 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2620 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2621 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
2622 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2623 # We may want to complete to (eval 9), so $text may be wrong
2624 $prefix = length($1) - length($text);
2627 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
2629 if ((substr $text, 0, 1) eq '&') { # subroutines
2630 $text = substr $text, 1;
2632 return sort map "$prefix$_",
2635 (map { /$search/ ? ($1) : () }
2638 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2639 $pack = ($1 eq 'main' ? '' : $1) . '::';
2640 $prefix = (substr $text, 0, 1) . $1 . '::';
2643 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2644 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2645 return db_complete($out[0], $line, $start);
2649 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2650 $pack = ($package eq 'main' ? '' : $package) . '::';
2651 $prefix = substr $text, 0, 1;
2652 $text = substr $text, 1;
2653 my @out = map "$prefix$_", grep /^\Q$text/,
2654 (grep /^_?[a-zA-Z]/, keys %$pack),
2655 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2656 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2657 return db_complete($out[0], $line, $start);
2661 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
2662 my @out = grep /^\Q$text/, @options;
2663 my $val = option_val($out[0], undef);
2665 if (not defined $val or $val =~ /[\n\r]/) {
2666 # Can do nothing better
2667 } elsif ($val =~ /\s/) {
2669 foreach $l (split //, qq/\"\'\#\|/) {
2670 $out = "$l$val$l ", last if (index $val, $l) == -1;
2675 # Default to value if one completion, to question if many
2676 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
2679 return $term->filename_list($text); # filenames
2683 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2687 $finished = $inhibit_exit; # So that some keys may be disabled.
2688 # Do not stop in at_exit() and destructors on exit:
2689 $DB::single = !$exiting && !$runnonstop;
2690 DB::fake::at_exit() unless $exiting or $runnonstop;
2696 "Debugged program terminated. Use `q' to quit or `R' to restart.";
2699 package DB; # Do not trace this 1; below!