3 # Debugger for Perl 5.00x; perl5db.pl patch level:
5 $header = "perl5db.pl version $VERSION";
7 # It is crucial that there is no lexicals in scope of `eval ""' down below
9 # 'my' would make it visible from user code
10 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
13 local $otrace = $trace;
14 local $osingle = $single;
16 { ($evalarg) = $evalarg =~ /(.*)/s; }
17 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
23 local $saved[0]; # Preserve the old value of $@
28 } elsif ($onetimeDump) {
29 if ($onetimeDump eq 'dump') {
30 local $option{dumpDepth} = $onetimedumpDepth
31 if defined $onetimedumpDepth;
33 } elsif ($onetimeDump eq 'methods') {
40 # After this point it is safe to introduce lexicals
41 # However, one should not overdo it: leave as much control from outside as possible
43 # This file is automatically included if you do perl -d.
44 # It's probably not useful to include this yourself.
46 # Before venturing further into these twisty passages, it is
47 # wise to read the perldebguts man page or risk the ire of dragons.
49 # Perl supplies the values for %sub. It effectively inserts
50 # a &DB::DB(); in front of every place that can have a
51 # breakpoint. Instead of a subroutine call it calls &DB::sub with
52 # $DB::sub being the called subroutine. It also inserts a BEGIN
53 # {require 'perl5db.pl'} before the first line.
55 # After each `require'd file is compiled, but before it is executed, a
56 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
57 # $filename is the expanded name of the `require'd file (as found as
60 # Additional services from Perl interpreter:
62 # if caller() is called from the package DB, it provides some
65 # The array @{$main::{'_<'.$filename}} (herein called @dbline) is the
66 # line-by-line contents of $filename.
68 # The hash %{'_<'.$filename} (herein called %dbline) contains
69 # breakpoints and action (it is keyed by line number), and individual
70 # entries are settable (as opposed to the whole hash). Only true/false
71 # is important to the interpreter, though the values used by
72 # perl5db.pl have the form "$break_condition\0$action". Values are
73 # magical in numeric context.
75 # The scalar ${'_<'.$filename} contains $filename.
77 # Note that no subroutine call is possible until &DB::sub is defined
78 # (for subroutines defined outside of the package DB). In fact the same is
79 # true if $deep is not defined.
84 # At start reads $rcfile that may set important options. This file
85 # may define a subroutine &afterinit that will be executed after the
86 # debugger is initialized.
88 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
89 # it as a rest of `O ...' line in debugger prompt.
91 # The options that can be specified only at startup:
92 # [To set in $rcfile, call &parse_options("optionName=new_value").]
94 # TTY - the TTY to use for debugging i/o.
96 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
97 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
98 # Term::Rendezvous. Current variant is to have the name of TTY in this
101 # ReadLine - If false, dummy ReadLine is used, so you can debug
102 # ReadLine applications.
104 # NonStop - if true, no i/o is performed until interrupt.
106 # LineInfo - file or pipe to print line number info to. If it is a
107 # pipe, a short "emacs like" message is used.
109 # RemotePort - host:port to connect to on remote host for remote debugging.
111 # Example $rcfile: (delete leading hashes!)
113 # &parse_options("NonStop=1 LineInfo=db.out");
114 # sub afterinit { $trace = 1; }
116 # The script will run without human intervention, putting trace
117 # information into db.out. (If you interrupt it, you would better
118 # reset LineInfo to something "interactive"!)
120 ##################################################################
122 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
124 # modified Perl debugger, to be run from Emacs in perldb-mode
125 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
126 # Johan Vromans -- upgrade to 4.0 pl 10
127 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
131 # A lot of things changed after 0.94. First of all, core now informs
132 # debugger about entry into XSUBs, overloaded operators, tied operations,
133 # BEGIN and END. Handy with `O f=2'.
135 # This can make debugger a little bit too verbose, please be patient
136 # and report your problems promptly.
138 # Now the option frame has 3 values: 0,1,2.
140 # Note that if DESTROY returns a reference to the object (or object),
141 # the deletion of data may be postponed until the next function call,
142 # due to the need to examine the return value.
144 # Changes: 0.95: `v' command shows versions.
145 # Changes: 0.96: `v' command shows version of readline.
146 # primitive completion works (dynamic variables, subs for `b' and `l',
147 # options). Can `p %var'
148 # Better help (`h <' now works). New commands <<, >>, {, {{.
149 # {dump|print}_trace() coded (to be able to do it from <<cmd).
150 # `c sub' documented.
151 # At last enough magic combined to stop after the end of debuggee.
152 # !! should work now (thanks to Emacs bracket matching an extra
153 # `]' in a regexp is caught).
154 # `L', `D' and `A' span files now (as documented).
155 # Breakpoints in `require'd code are possible (used in `R').
156 # Some additional words on internal work of debugger.
157 # `b load filename' implemented.
158 # `b postpone subr' implemented.
159 # now only `q' exits debugger (overwritable on $inhibit_exit).
160 # When restarting debugger breakpoints/actions persist.
161 # Buglet: When restarting debugger only one breakpoint/action per
162 # autoloaded function persists.
163 # Changes: 0.97: NonStop will not stop in at_exit().
164 # Option AutoTrace implemented.
165 # Trace printed differently if frames are printed too.
166 # new `inhibitExit' option.
167 # printing of a very long statement interruptible.
168 # Changes: 0.98: New command `m' for printing possible methods
169 # 'l -' is a synonym for `-'.
170 # Cosmetic bugs in printing stack trace.
171 # `frame' & 8 to print "expanded args" in stack trace.
172 # Can list/break in imported subs.
173 # new `maxTraceLen' option.
174 # frame & 4 and frame & 8 granted.
176 # nonstoppable lines do not have `:' near the line number.
177 # `b compile subname' implemented.
178 # Will not use $` any more.
179 # `-' behaves sane now.
180 # Changes: 0.99: Completion for `f', `m'.
181 # `m' will remove duplicate names instead of duplicate functions.
182 # `b load' strips trailing whitespace.
183 # completion ignores leading `|'; takes into account current package
184 # when completing a subroutine name (same for `l').
185 # Changes: 1.07: Many fixed by tchrist 13-March-2000
187 # + Added bare minimal security checks on perldb rc files, plus
188 # comments on what else is needed.
189 # + Fixed the ornaments that made "|h" completely unusable.
190 # They are not used in print_help if they will hurt. Strip pod
191 # if we're paging to less.
192 # + Fixed mis-formatting of help messages caused by ornaments
193 # to restore Larry's original formatting.
194 # + Fixed many other formatting errors. The code is still suboptimal,
195 # and needs a lot of work at restructuring. It's also misindented
197 # + Fixed bug where trying to look at an option like your pager
199 # + Fixed some $? processing. Note: if you use csh or tcsh, you will
200 # lose. You should consider shell escapes not using their shell,
201 # or else not caring about detailed status. This should really be
202 # unified into one place, too.
203 # + Fixed bug where invisible trailing whitespace on commands hoses you,
204 # tricking Perl into thinking you weren't calling a debugger command!
205 # + Fixed bug where leading whitespace on commands hoses you. (One
206 # suggests a leading semicolon or any other irrelevant non-whitespace
207 # to indicate literal Perl code.)
208 # + Fixed bugs that ate warnings due to wrong selected handle.
209 # + Fixed a precedence bug on signal stuff.
210 # + Fixed some unseemly wording.
211 # + Fixed bug in help command trying to call perl method code.
212 # + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
214 # + Added some comments. This code is still nasty spaghetti.
215 # + Added message if you clear your pre/post command stacks which was
216 # very easy to do if you just typed a bare >, <, or {. (A command
217 # without an argument should *never* be a destructive action; this
218 # API is fundamentally screwed up; likewise option setting, which
219 # is equally buggered.)
220 # + Added command stack dump on argument of "?" for >, <, or {.
221 # + Added a semi-built-in doc viewer command that calls man with the
222 # proper %Config::Config path (and thus gets caching, man -k, etc),
223 # or else perldoc on obstreperous platforms.
224 # + Added to and rearranged the help information.
225 # + Detected apparent misuse of { ... } to declare a block; this used
226 # to work but now is a command, and mysteriously gave no complaint.
228 # Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
230 # + This patch to perl5db.pl cleans up formatting issues on the help
231 # summary (h h) screen in the debugger. Mostly columnar alignment
232 # issues, plus converted the printed text to use all spaces, since
233 # tabs don't seem to help much here.
235 # Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
236 # 0) Minor bugs corrected;
237 # a) Support for auto-creation of new TTY window on startup, either
238 # unconditionally, or if started as a kid of another debugger session;
239 # b) New `O'ption CreateTTY
240 # I<CreateTTY> bits control attempts to create a new TTY on events:
241 # 1: on fork() 2: debugger is started inside debugger
243 # c) Code to auto-create a new TTY window on OS/2 (currently one
244 # extra window per session - need named pipes to have more...);
245 # d) Simplified interface for custom createTTY functions (with a backward
246 # compatibility hack); now returns the TTY name to use; return of ''
247 # means that the function reset the I/O handles itself;
248 # d') Better message on the semantic of custom createTTY function;
249 # e) Convert the existing code to create a TTY into a custom createTTY
251 # f) Consistent support for TTY names of the form "TTYin,TTYout";
252 # g) Switch line-tracing output too to the created TTY window;
253 # h) make `b fork' DWIM with CORE::GLOBAL::fork;
254 # i) High-level debugger API cmd_*():
255 # cmd_b_load($filenamepart) # b load filenamepart
256 # cmd_b_line($lineno [, $cond]) # b lineno [cond]
257 # cmd_b_sub($sub [, $cond]) # b sub [cond]
258 # cmd_stop() # Control-C
259 # cmd_d($lineno) # d lineno (B)
260 # The cmd_*() API returns FALSE on failure; in this case it outputs
261 # the error message to the debugging output.
262 # j) Low-level debugger API
263 # break_on_load($filename) # b load filename
264 # @files = report_break_on_load() # List files with load-breakpoints
265 # breakable_line_in_filename($name, $from [, $to])
266 # # First breakable line in the
267 # # range $from .. $to. $to defaults
268 # # to $from, and may be less than $to
269 # breakable_line($from [, $to]) # Same for the current file
270 # break_on_filename_line($name, $lineno [, $cond])
271 # # Set breakpoint,$cond defaults to 1
272 # break_on_filename_line_range($name, $from, $to [, $cond])
273 # # As above, on the first
274 # # breakable line in range
275 # break_on_line($lineno [, $cond]) # As above, in the current file
276 # break_subroutine($sub [, $cond]) # break on the first breakable line
277 # ($name, $from, $to) = subroutine_filename_lines($sub)
278 # # The range of lines of the text
279 # The low-level API returns TRUE on success, and die()s on failure.
281 # Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
283 # + Fixed warnings generated by "perl -dWe 42"
284 # + Corrected spelling errors
285 # + Squeezed Help (h) output into 80 columns
287 # Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
288 # + Made "x @INC" work like it used to
290 # Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
291 # + Fixed warnings generated by "O" (Show debugger options)
292 # + Fixed warnings generated by "p 42" (Print expression)
293 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
294 # + Added windowSize option
295 # Changes: 1.14: Oct 9, 2001 multiple
296 # + Clean up after itself on VMS (Charles Lane in 12385)
297 # + Adding "@ file" syntax (Peter Scott in 12014)
298 # + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
299 # + $^S and other debugger fixes (Ilya Zakharevich in 11120)
300 # + Forgot a my() declaration (Ilya Zakharevich in 11085)
301 # Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern@pobox.com>
302 # + Updated 1.14 change log
303 # + Added *dbline explainatory comments
304 # + Mentioning perldebguts man page
305 # Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com>
306 # + $onetimeDump improvements
307 # Changes: 1.17: Feb 20, 2002 Richard Foley <richard.foley@rfi.net>
308 # Moved some code to cmd_[.]()'s for clarity and ease of handling,
309 # rationalised the following commands and added cmd_wrapper() to
310 # enable switching between old and frighteningly consistent new
311 # behaviours for diehards: 'o CommandSet=pre580' (sigh...)
312 # a(add), A(del) # action expr (added del by line)
313 # + b(add), B(del) # break [line] (was b,D)
314 # + w(add), W(del) # watch expr (was W,W) added del by expr
315 # + h(summary), h h(long) # help (hh) (was h h,h)
316 # + m(methods), M(modules) # ... (was m,v)
317 # + o(option) # lc (was O)
318 # + v(view code), V(view Variables) # ... (was w,V)
319 # Changes: 1.18: Mar 17, 2002 Richard Foley <richard.foley@rfi.net>
320 # + fixed missing cmd_O bug
322 ####################################################################
324 # Needed for the statement after exec():
326 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
327 local($^W) = 0; # Switch run-time warnings off during init.
330 $dumpvar::arrayDepth,
331 $dumpvar::dumpDBFiles,
332 $dumpvar::dumpPackages,
333 $dumpvar::quoteHighBit,
334 $dumpvar::printUndef,
343 # Command-line + PERLLIB:
346 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
348 $trace = $signal = $single = 0; # Uninitialized warning suppression
349 # (local $^W cannot help - other packages!).
350 $inhibit_exit = $option{PrintRet} = 1;
352 @options = qw(hashDepth arrayDepth CommandSet dumpDepth
353 DumpDBFiles DumpPackages DumpReused
354 compactDump veryCompact quote HighBit undefPrint
355 globPrint PrintRet UsageOnly frame AutoTrace
356 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
357 recallCommand ShellBang pager tkRunning ornaments
358 signalLevel warnLevel dieLevel inhibit_exit
359 ImmediateStop bareStringify CreateTTY
360 RemotePort windowSize);
363 hashDepth => \$dumpvar::hashDepth,
364 arrayDepth => \$dumpvar::arrayDepth,
365 CommandSet => \$CommandSet,
366 DumpDBFiles => \$dumpvar::dumpDBFiles,
367 DumpPackages => \$dumpvar::dumpPackages,
368 DumpReused => \$dumpvar::dumpReused,
369 HighBit => \$dumpvar::quoteHighBit,
370 undefPrint => \$dumpvar::printUndef,
371 globPrint => \$dumpvar::globPrint,
372 UsageOnly => \$dumpvar::usageOnly,
373 CreateTTY => \$CreateTTY,
374 bareStringify => \$dumpvar::bareStringify,
376 AutoTrace => \$trace,
377 inhibit_exit => \$inhibit_exit,
378 maxTraceLen => \$maxtrace,
379 ImmediateStop => \$ImmediateStop,
380 RemotePort => \$remoteport,
381 windowSize => \$window,
385 compactDump => \&dumpvar::compactDump,
386 veryCompact => \&dumpvar::veryCompact,
387 quote => \&dumpvar::quote,
390 ReadLine => \&ReadLine,
391 NonStop => \&NonStop,
392 LineInfo => \&LineInfo,
393 recallCommand => \&recallCommand,
394 ShellBang => \&shellBang,
396 signalLevel => \&signalLevel,
397 warnLevel => \&warnLevel,
398 dieLevel => \&dieLevel,
399 tkRunning => \&tkRunning,
400 ornaments => \&ornaments,
401 RemotePort => \&RemotePort,
405 compactDump => 'dumpvar.pl',
406 veryCompact => 'dumpvar.pl',
407 quote => 'dumpvar.pl',
410 # These guys may be defined in $ENV{PERL5DB} :
411 $rl = 1 unless defined $rl;
412 $warnLevel = 1 unless defined $warnLevel;
413 $dieLevel = 1 unless defined $dieLevel;
414 $signalLevel = 1 unless defined $signalLevel;
415 $pre = [] unless defined $pre;
416 $post = [] unless defined $post;
417 $pretype = [] unless defined $pretype;
418 $CreateTTY = 3 unless defined $CreateTTY;
419 $CommandSet = '580' unless defined $CommandSet;
421 warnLevel($warnLevel);
423 signalLevel($signalLevel);
426 defined $ENV{PAGER} ? $ENV{PAGER} :
427 eval { require Config } &&
428 defined $Config::Config{pager} ? $Config::Config{pager}
430 ) unless defined $pager;
432 &recallCommand("!") unless defined $prc;
433 &shellBang("!") unless defined $psh;
435 $maxtrace = 400 unless defined $maxtrace;
436 $ini_pids = $ENV{PERLDB_PIDS};
437 if (defined $ENV{PERLDB_PIDS}) {
438 $pids = "[$ENV{PERLDB_PIDS}]";
439 $ENV{PERLDB_PIDS} .= "->$$";
442 $ENV{PERLDB_PIDS} = "$$";
447 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
449 if (-e "/dev/tty") { # this is the wrong metric!
452 $rcfile="perldb.ini";
455 # This isn't really safe, because there's a race
456 # between checking and opening. The solution is to
457 # open and fstat the handle, but then you have to read and
458 # eval the contents. But then the silly thing gets
459 # your lexical scope, which is unfortunately at best.
463 # Just exactly what part of the word "CORE::" don't you understand?
464 local $SIG{__WARN__};
467 unless (is_safe_file($file)) {
468 CORE::warn <<EO_GRIPE;
469 perldb: Must not source insecure rcfile $file.
470 You or the superuser must be the owner, and it must not
471 be writable by anyone but its owner.
477 CORE::warn("perldb: couldn't parse $file: $@") if $@;
481 # Verifies that owner is either real user or superuser and that no
482 # one but owner may write to it. This function is of limited use
483 # when called on a path instead of upon a handle, because there are
484 # no guarantees that filename (by dirent) whose file (by ino) is
485 # eventually accessed is the same as the one tested.
486 # Assumes that the file's existence is not in doubt.
489 stat($path) || return; # mysteriously vaporized
490 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
492 return 0 if $uid != 0 && $uid != $<;
493 return 0 if $mode & 022;
498 safe_do("./$rcfile");
500 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
501 safe_do("$ENV{HOME}/$rcfile");
503 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
504 safe_do("$ENV{LOGDIR}/$rcfile");
507 if (defined $ENV{PERLDB_OPTS}) {
508 parse_options($ENV{PERLDB_OPTS});
511 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
512 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
513 *get_fork_TTY = \&xterm_get_fork_TTY;
514 } elsif ($^O eq 'os2') {
515 *get_fork_TTY = \&os2_get_fork_TTY;
518 # Here begin the unreadable code. It needs fixing.
520 if (exists $ENV{PERLDB_RESTART}) {
521 delete $ENV{PERLDB_RESTART};
523 @hist = get_list('PERLDB_HIST');
524 %break_on_load = get_list("PERLDB_ON_LOAD");
525 %postponed = get_list("PERLDB_POSTPONE");
526 my @had_breakpoints= get_list("PERLDB_VISITED");
527 for (0 .. $#had_breakpoints) {
528 my %pf = get_list("PERLDB_FILE_$_");
529 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
531 my %opt = get_list("PERLDB_OPT");
533 while (($opt,$val) = each %opt) {
534 $val =~ s/[\\\']/\\$1/g;
535 parse_options("$opt'$val'");
537 @INC = get_list("PERLDB_INC");
539 $pretype = [get_list("PERLDB_PRETYPE")];
540 $pre = [get_list("PERLDB_PRE")];
541 $post = [get_list("PERLDB_POST")];
542 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
548 # Is Perl being run from a slave editor or graphical debugger?
549 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
550 $rl = 0, shift(@main::ARGV) if $slave_editor;
552 #require Term::ReadLine;
554 if ($^O eq 'cygwin') {
555 # /dev/tty is binary. use stdin for textmode
557 } elsif (-e "/dev/tty") {
558 $console = "/dev/tty";
559 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
561 } elsif ($^O eq 'MacOS') {
562 if ($MacPerl::Version !~ /MPW/) {
563 $console = "Dev:Console:Perl Debug"; # Separate window for application
565 $console = "Dev:Console";
568 $console = "sys\$command";
571 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
575 if ($^O eq 'NetWare') {
580 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
588 $console = $tty if defined $tty;
590 if (defined $remoteport) {
592 $OUT = new IO::Socket::INET( Timeout => '10',
593 PeerAddr => $remoteport,
596 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
599 create_IN_OUT(4) if $CreateTTY & 4;
601 my ($i, $o) = split /,/, $console;
602 $o = $i unless defined $o;
603 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
604 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
605 || open(OUT,">&STDOUT"); # so we don't dongle stdout
606 } elsif (not defined $console) {
608 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
609 $console = 'STDIN/OUT';
611 # so open("|more") can read from STDOUT and so we don't dingle stdin
612 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
614 my $previous = select($OUT);
615 $| = 1; # for DB::OUT
618 $LINEINFO = $OUT unless defined $LINEINFO;
619 $lineinfo = $console unless defined $lineinfo;
621 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
622 unless ($runnonstop) {
625 if ($term_pid eq '-1') {
626 print $OUT "\nDaughter DB session started...\n";
628 print $OUT "\nLoading DB routines from $header\n";
629 print $OUT ("Editor support ",
630 $slave_editor ? "enabled" : "available",
632 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
640 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
643 if (defined &afterinit) { # May be defined in $rcfile
649 ############################################################ Subroutines
652 # _After_ the perl program is compiled, $single is set to 1:
653 if ($single and not $second_time++) {
654 if ($runnonstop) { # Disable until signal
655 for ($i=0; $i <= $stack_depth; ) {
659 # return; # Would not print trace!
660 } elsif ($ImmediateStop) {
665 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
667 ($package, $filename, $line) = caller;
668 $filename_ini = $filename;
669 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
670 "package $package;"; # this won't let them modify, alas
671 local(*dbline) = $main::{'_<' . $filename};
673 # we need to check for pseudofiles on Mac OS (these are files
674 # not attached to a filename, but instead stored in Dev:Pseudo)
675 if ($^O eq 'MacOS' && $#dbline < 0) {
676 $filename_ini = $filename = 'Dev:Pseudo';
677 *dbline = $main::{'_<' . $filename};
681 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
685 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
686 $dbline{$line} =~ s/;9($|\0)/$1/;
689 my $was_signal = $signal;
691 for (my $n = 0; $n <= $#to_watch; $n++) {
692 $evalarg = $to_watch[$n];
693 local $onetimeDump; # Do not output results
694 my ($val) = &eval; # Fix context (&eval is doing array)?
695 $val = ( (defined $val) ? "'$val'" : 'undef' );
696 if ($val ne $old_watch[$n]) {
699 Watchpoint $n:\t$to_watch[$n] changed:
700 old value:\t$old_watch[$n]
703 $old_watch[$n] = $val;
707 if ($trace & 4) { # User-installed watch
708 return if watchfunction($package, $filename, $line)
709 and not $single and not $was_signal and not ($trace & ~4);
711 $was_signal = $signal;
713 if ($single || ($trace & 1) || $was_signal) {
715 $position = "\032\032$filename:$line:0\n";
716 print_lineinfo($position);
717 } elsif ($package eq 'DB::fake') {
720 Debugged program terminated. Use B<q> to quit or B<R> to restart,
721 use B<O> I<inhibit_exit> to avoid stopping after program termination,
722 B<h q>, B<h R> or B<h O> to get additional info.
725 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
726 "package $package;"; # this won't let them modify, alas
729 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
730 $prefix .= "$sub($filename:";
731 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
732 if (length($prefix) > 30) {
733 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
738 $position = "$prefix$line$infix$dbline[$line]$after";
741 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
743 print_lineinfo($position);
745 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
746 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
748 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
749 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
750 $position .= $incr_pos;
752 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
754 print_lineinfo($incr_pos);
759 $evalarg = $action, &eval if $action;
760 if ($single || $was_signal) {
761 local $level = $level + 1;
762 foreach $evalarg (@$pre) {
765 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
768 $incr = -1; # for backward motion.
769 @typeahead = (@$pretype, @typeahead);
771 while (($term || &setterm),
772 ($term_pid == $$ or resetterm(1)),
773 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
774 ($#hist+1) . ('>' x $level) . " ")))
778 $cmd =~ s/\\$/\n/ && do {
779 $cmd .= &readline(" cont: ");
782 $cmd =~ /^$/ && ($cmd = $laststep);
783 push(@hist,$cmd) if length($cmd) > 1;
785 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
786 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
787 ($i) = split(/\s+/,$cmd);
789 # squelch the sigmangler
791 local $SIG{__WARN__};
792 eval "\$cmd =~ $alias{$i}";
795 print $OUT "Couldn't evaluate `$i' alias: $@";
799 $cmd =~ /^q$/ && do {
804 $cmd =~ /^t$/ && do {
807 print $OUT "Trace = " .
808 (($trace & 1) ? "on" : "off" ) . "\n";
810 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
811 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
814 foreach $subname (sort(keys %sub)) {
815 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
816 print $OUT $subname,"\n";
820 $cmd =~ s/^X\b/V $package/;
821 $cmd =~ /^V$/ && do {
822 $cmd = "V $package"; };
823 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
824 local ($savout) = select($OUT);
826 @vars = split(' ',$2);
827 do 'dumpvar.pl' unless defined &main::dumpvar;
828 if (defined &main::dumpvar) {
831 # must detect sigpipe failures
832 eval { &main::dumpvar($packname,
833 defined $option{dumpDepth}
834 ? $option{dumpDepth} : -1,
837 die unless $@ =~ /dumpvar print failed/;
840 print $OUT "dumpvar.pl not available.\n";
844 $cmd =~ s/^x\b/ / && do { # So that will be evaled
845 $onetimeDump = 'dump';
846 # handle special "x 3 blah" syntax
847 if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
848 $onetimedumpDepth = $1;
851 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
852 methods($1); next CMD};
853 $cmd =~ s/^m\b/ / && do { # So this will be evaled
854 $onetimeDump = 'methods'; };
855 $cmd =~ /^f\b\s*(.*)/ && do {
859 print $OUT "The old f command is now the r command.\n"; # hint
860 print $OUT "The new f command switches filenames.\n";
863 if (!defined $main::{'_<' . $file}) {
864 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
865 $try = substr($try,2);
866 print $OUT "Choosing $try matching `$file':\n";
870 if (!defined $main::{'_<' . $file}) {
871 print $OUT "No file matching `$file' is loaded.\n";
873 } elsif ($file ne $filename) {
874 *dbline = $main::{'_<' . $file};
880 print $OUT "Already in $file.\n";
884 $cmd =~ /^\.$/ && do {
885 $incr = -1; # for backward motion.
887 $filename = $filename_ini;
888 *dbline = $main::{'_<' . $filename};
890 print_lineinfo($position);
892 $cmd =~ /^-$/ && do {
893 $start -= $incr + $window + 1;
894 $start = 1 if $start <= 0;
896 $cmd = 'l ' . ($start) . '+'; };
898 $cmd =~ /^([aAbBDhlLMoOvwW])\b\s*(.*)/s && do {
899 &cmd_wrapper($1, $2, $line);
903 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
904 push @$pre, action($1);
906 $cmd =~ /^>>\s*(.*)/ && do {
907 push @$post, action($1);
909 $cmd =~ /^<\s*(.*)/ && do {
911 print $OUT "All < actions cleared.\n";
917 print $OUT "No pre-prompt Perl actions.\n";
920 print $OUT "Perl commands run before each prompt:\n";
921 for my $action ( @$pre ) {
922 print $OUT "\t< -- $action\n";
928 $cmd =~ /^>\s*(.*)/ && do {
930 print $OUT "All > actions cleared.\n";
936 print $OUT "No post-prompt Perl actions.\n";
939 print $OUT "Perl commands run after each prompt:\n";
940 for my $action ( @$post ) {
941 print $OUT "\t> -- $action\n";
945 $post = [action($1)];
947 $cmd =~ /^\{\{\s*(.*)/ && do {
948 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
949 print $OUT "{{ is now a debugger command\n",
950 "use `;{{' if you mean Perl code\n";
956 $cmd =~ /^\{\s*(.*)/ && do {
958 print $OUT "All { actions cleared.\n";
964 print $OUT "No pre-prompt debugger actions.\n";
967 print $OUT "Debugger commands run before each prompt:\n";
968 for my $action ( @$pretype ) {
969 print $OUT "\t{ -- $action\n";
973 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
974 print $OUT "{ is now a debugger command\n",
975 "use `;{' if you mean Perl code\n";
981 $cmd =~ /^n$/ && do {
982 end_report(), next CMD if $finished and $level <= 1;
986 $cmd =~ /^s$/ && do {
987 end_report(), next CMD if $finished and $level <= 1;
991 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
992 end_report(), next CMD if $finished and $level <= 1;
994 # Probably not needed, since we finish an interactive
995 # sub-session anyway...
996 # local $filename = $filename;
997 # local *dbline = *dbline; # XXX Would this work?!
998 if ($subname =~ /\D/) { # subroutine name
999 $subname = $package."::".$subname
1000 unless $subname =~ /::/;
1001 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1005 *dbline = $main::{'_<' . $filename};
1006 $had_breakpoints{$filename} |= 1;
1008 ++$i while $dbline[$i] == 0 && $i < $max;
1010 print $OUT "Subroutine $subname not found.\n";
1015 if ($dbline[$i] == 0) {
1016 print $OUT "Line $i not breakable.\n";
1019 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1021 for ($i=0; $i <= $stack_depth; ) {
1025 $cmd =~ /^r$/ && do {
1026 end_report(), next CMD if $finished and $level <= 1;
1027 $stack[$stack_depth] |= 1;
1028 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1030 $cmd =~ /^R$/ && do {
1031 print $OUT "Warning: some settings and command-line options may be lost!\n";
1032 my (@script, @flags, $cl);
1033 push @flags, '-w' if $ini_warn;
1034 # Put all the old includes at the start to get
1035 # the same debugger.
1037 push @flags, '-I', $_;
1039 push @flags, '-T' if ${^TAINT};
1040 # Arrange for setting the old INC:
1041 set_list("PERLDB_INC", @ini_INC);
1043 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1044 chomp ($cl = ${'::_<-e'}[$_]);
1045 push @script, '-e', $cl;
1050 set_list("PERLDB_HIST",
1051 $term->Features->{getHistory}
1052 ? $term->GetHistory : @hist);
1053 my @had_breakpoints = keys %had_breakpoints;
1054 set_list("PERLDB_VISITED", @had_breakpoints);
1055 set_list("PERLDB_OPT", %option);
1056 set_list("PERLDB_ON_LOAD", %break_on_load);
1058 for (0 .. $#had_breakpoints) {
1059 my $file = $had_breakpoints[$_];
1060 *dbline = $main::{'_<' . $file};
1061 next unless %dbline or $postponed_file{$file};
1062 (push @hard, $file), next
1063 if $file =~ /^\(\w*eval/;
1065 @add = %{$postponed_file{$file}}
1066 if $postponed_file{$file};
1067 set_list("PERLDB_FILE_$_", %dbline, @add);
1069 for (@hard) { # Yes, really-really...
1070 # Find the subroutines in this eval
1071 *dbline = $main::{'_<' . $_};
1072 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1073 for $sub (keys %sub) {
1074 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1075 $subs{$sub} = [$1, $2];
1079 "No subroutines in $_, ignoring breakpoints.\n";
1082 LINES: for $line (keys %dbline) {
1083 # One breakpoint per sub only:
1084 my ($offset, $sub, $found);
1085 SUBS: for $sub (keys %subs) {
1086 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1087 and (not defined $offset # Not caught
1088 or $offset < 0 )) { # or badly caught
1090 $offset = $line - $subs{$sub}->[0];
1091 $offset = "+$offset", last SUBS if $offset >= 0;
1094 if (defined $offset) {
1095 $postponed{$found} =
1096 "break $offset if $dbline{$line}";
1098 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1102 set_list("PERLDB_POSTPONE", %postponed);
1103 set_list("PERLDB_PRETYPE", @$pretype);
1104 set_list("PERLDB_PRE", @$pre);
1105 set_list("PERLDB_POST", @$post);
1106 set_list("PERLDB_TYPEAHEAD", @typeahead);
1107 $ENV{PERLDB_RESTART} = 1;
1108 delete $ENV{PERLDB_PIDS}; # Restore ini state
1109 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1110 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1111 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1112 print $OUT "exec failed: $!\n";
1114 $cmd =~ /^T$/ && do {
1115 print_trace($OUT, 1); # skip DB
1117 $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w($1); next CMD; };
1118 $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W($1); next CMD; };
1119 $cmd =~ /^\/(.*)$/ && do {
1121 $inpat =~ s:([^\\])/$:$1:;
1123 # squelch the sigmangler
1124 local $SIG{__DIE__};
1125 local $SIG{__WARN__};
1126 eval '$inpat =~ m'."\a$inpat\a";
1138 $start = 1 if ($start > $max);
1139 last if ($start == $end);
1140 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1141 if ($slave_editor) {
1142 print $OUT "\032\032$filename:$start:0\n";
1144 print $OUT "$start:\t", $dbline[$start], "\n";
1149 print $OUT "/$pat/: not found\n" if ($start == $end);
1151 $cmd =~ /^\?(.*)$/ && do {
1153 $inpat =~ s:([^\\])\?$:$1:;
1155 # squelch the sigmangler
1156 local $SIG{__DIE__};
1157 local $SIG{__WARN__};
1158 eval '$inpat =~ m'."\a$inpat\a";
1170 $start = $max if ($start <= 0);
1171 last if ($start == $end);
1172 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1173 if ($slave_editor) {
1174 print $OUT "\032\032$filename:$start:0\n";
1176 print $OUT "$start:\t", $dbline[$start], "\n";
1181 print $OUT "?$pat?: not found\n" if ($start == $end);
1183 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1184 pop(@hist) if length($cmd) > 1;
1185 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1187 print $OUT $cmd, "\n";
1189 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1192 $cmd =~ /^$rc([^$rc].*)$/ && do {
1194 pop(@hist) if length($cmd) > 1;
1195 for ($i = $#hist; $i; --$i) {
1196 last if $hist[$i] =~ /$pat/;
1199 print $OUT "No such command!\n\n";
1203 print $OUT $cmd, "\n";
1205 $cmd =~ /^$sh$/ && do {
1206 &system($ENV{SHELL}||"/bin/sh");
1208 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1209 # XXX: using csh or tcsh destroys sigint retvals!
1210 #&system($1); # use this instead
1211 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1213 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1214 $end = $2 ? ($#hist-$2) : 0;
1215 $hist = 0 if $hist < 0;
1216 for ($i=$#hist; $i>$end; $i--) {
1217 print $OUT "$i: ",$hist[$i],"\n"
1218 unless $hist[$i] =~ /^.?$/;
1221 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1224 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1225 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1226 $cmd =~ s/^=\s*// && do {
1228 if (length $cmd == 0) {
1229 @keys = sort keys %alias;
1230 } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1231 # can't use $_ or kill //g state
1232 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1233 $alias{$k} = "s\a$k\a$v\a";
1234 # squelch the sigmangler
1235 local $SIG{__DIE__};
1236 local $SIG{__WARN__};
1237 unless (eval "sub { s\a$k\a$v\a }; 1") {
1238 print $OUT "Can't alias $k to $v: $@\n";
1247 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1248 print $OUT "$k\t= $1\n";
1250 elsif (defined $alias{$k}) {
1251 print $OUT "$k\t$alias{$k}\n";
1254 print "No alias for $k\n";
1258 $cmd =~ /^\@\s*(.*\S)/ && do {
1259 if (open my $fh, $1) {
1262 &warn("Can't execute `$1': $!\n");
1265 $cmd =~ /^\|\|?\s*[^|]/ && do {
1266 if ($pager =~ /^\|/) {
1267 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1268 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1270 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1273 unless ($piped=open(OUT,$pager)) {
1274 &warn("Can't pipe output to `$pager'");
1275 if ($pager =~ /^\|/) {
1276 open(OUT,">&STDOUT") # XXX: lost message
1277 || &warn("Can't restore DB::OUT");
1278 open(STDOUT,">&SAVEOUT")
1279 || &warn("Can't restore STDOUT");
1282 open(OUT,">&STDOUT") # XXX: lost message
1283 || &warn("Can't restore DB::OUT");
1287 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1288 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1289 $selected= select(OUT);
1291 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1292 $cmd =~ s/^\|+\s*//;
1295 # XXX Local variants do not work!
1296 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1297 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1298 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1300 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1302 $onetimeDump = undef;
1303 $onetimedumpDepth = undef;
1304 } elsif ($term_pid == $$) {
1309 if ($pager =~ /^\|/) {
1311 # we cannot warn here: the handle is missing --tchrist
1312 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1314 # most of the $? crud was coping with broken cshisms
1316 print SAVEOUT "Pager `$pager' failed: ";
1318 print SAVEOUT "shell returned -1\n";
1321 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1322 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1324 print SAVEOUT "status ", ($? >> 8), "\n";
1328 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1329 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1330 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1331 # Will stop ignoring SIGPIPE if done like nohup(1)
1332 # does SIGINT but Perl doesn't give us a choice.
1334 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1337 select($selected), $selected= "" unless $selected eq "";
1341 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1342 foreach $evalarg (@$post) {
1345 } # if ($single || $signal)
1346 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1350 # The following code may be executed now:
1354 my ($al, $ret, @ret) = "";
1355 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1358 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1359 $#stack = $stack_depth;
1360 $stack[-1] = $single;
1362 $single |= 4 if $stack_depth == $deep;
1364 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1365 # Why -1? But it works! :-(
1366 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1367 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1370 $single |= $stack[$stack_depth--];
1372 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1373 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1374 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1375 if ($doret eq $stack_depth or $frame & 16) {
1377 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1378 print $fh ' ' x $stack_depth if $frame & 16;
1379 print $fh "list context return from $sub:\n";
1380 dumpit($fh, \@ret );
1385 if (defined wantarray) {
1390 $single |= $stack[$stack_depth--];
1392 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1393 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1394 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1395 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1397 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1398 print $fh (' ' x $stack_depth) if $frame & 16;
1399 print $fh (defined wantarray
1400 ? "scalar context return from $sub: "
1401 : "void context return from $sub\n");
1402 dumpit( $fh, $ret ) if defined wantarray;
1411 ### Functions with multiple modes of failure die on error, the rest
1412 ### returns FALSE on error.
1413 ### User-interface functions cmd_* output error message.
1415 ### Note all cmd_[a-zA-Z]'s require $line, $dblineno as first arguments
1420 'A' => 'pre580_null',
1422 'B' => 'pre580_null',
1423 'd' => 'pre580_null',
1426 'M' => 'pre580_null',
1428 'o' => 'pre580_null',
1438 my $dblineno = shift;
1440 # with this level of indirection we can wrap
1441 # to old (pre580) or other command sets easily
1444 $set{$CommandSet}{$cmd} || $cmd
1446 # print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
1448 return &$call($line, $dblineno);
1452 my $line = shift || ''; # [.|line] expr
1453 my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
1454 if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
1455 my ($lineno, $expr) = ($1, $2);
1457 if ($dbline[$lineno] == 0) {
1458 print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
1460 $had_breakpoints{$filename} |= 2;
1461 $dbline{$lineno} =~ s/\0[^\0]*//;
1462 $dbline{$lineno} .= "\0" . action($expr);
1466 print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
1471 my $line = shift || '';
1472 my $dbline = shift; $line =~ s/^\./$dbline/;
1474 eval { &delete_action(); 1 } or print $OUT $@ and return;
1475 } elsif ($line =~ /^(\S.*)/) {
1476 eval { &delete_action($1); 1 } or print $OUT $@ and return;
1478 print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
1485 die "Line $i has no action .\n" if $dbline[$i] == 0;
1486 $dbline{$i} =~ s/\0[^\0]*//; # \^a
1487 delete $dbline{$i} if $dbline{$i} eq '';
1489 print $OUT "Deleting all actions...\n";
1490 for my $file (keys %had_breakpoints) {
1491 local *dbline = $main::{'_<' . $file};
1494 for ($i = 1; $i <= $max ; $i++) {
1495 if (defined $dbline{$i}) {
1496 $dbline{$i} =~ s/\0[^\0]*//;
1497 delete $dbline{$i} if $dbline{$i} eq '';
1499 unless ($had_breakpoints{$file} &= ~2) {
1500 delete $had_breakpoints{$file};
1508 my $line = shift; # [.|line] [cond]
1509 my $dbline = shift; $line =~ s/^\./$dbline/;
1510 if ($line =~ /^\s*$/) {
1511 &cmd_b_line($dbline, 1);
1512 } elsif ($line =~ /^load\b\s*(.*)/) {
1513 my $file = $1; $file =~ s/\s+$//;
1515 } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
1516 my $cond = length $3 ? $3 : '1';
1517 my ($subname, $break) = ($2, $1 eq 'postpone');
1518 $subname =~ s/\'/::/g;
1519 $subname = "${'package'}::" . $subname unless $subname =~ /::/;
1520 $subname = "main".$subname if substr($subname,0,2) eq "::";
1521 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
1522 } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
1524 $cond = length $2 ? $2 : '1';
1525 &cmd_b_sub($subname, $cond);
1526 } elsif ($line =~ /^(\d*)\s*(.*)/) {
1527 $line = $1 || $dbline;
1528 $cond = length $2 ? $2 : '1';
1529 &cmd_b_line($line, $cond);
1531 print "confused by line($line)?\n";
1537 $break_on_load{$file} = 1;
1538 $had_breakpoints{$file} |= 1;
1541 sub report_break_on_load {
1542 sort keys %break_on_load;
1550 push @files, $::INC{$file} if $::INC{$file};
1551 $file .= '.pm', redo unless $file =~ /\./;
1553 break_on_load($_) for @files;
1554 @files = report_break_on_load;
1557 print $OUT "Will stop on load of `@files'.\n";
1560 $filename_error = '';
1562 sub breakable_line {
1563 my ($from, $to) = @_;
1566 my $delta = $from < $to ? +1 : -1;
1567 my $limit = $delta > 0 ? $#dbline : 1;
1568 $limit = $to if ($limit - $to) * $delta > 0;
1569 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1571 return $i unless $dbline[$i] == 0;
1572 my ($pl, $upto) = ('', '');
1573 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1574 die "Line$pl $from$upto$filename_error not breakable\n";
1577 sub breakable_line_in_filename {
1579 local *dbline = $main::{'_<' . $f};
1580 local $filename_error = " of `$f'";
1585 my ($i, $cond) = @_;
1586 $cond = 1 unless @_ >= 2;
1590 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1591 $had_breakpoints{$filename} |= 1;
1592 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1593 else { $dbline{$i} = $cond; }
1597 eval { break_on_line(@_); 1 } or do {
1599 print $OUT $@ and return;
1603 sub break_on_filename_line {
1604 my ($f, $i, $cond) = @_;
1605 $cond = 1 unless @_ >= 3;
1606 local *dbline = $main::{'_<' . $f};
1607 local $filename_error = " of `$f'";
1608 local $filename = $f;
1609 break_on_line($i, $cond);
1612 sub break_on_filename_line_range {
1613 my ($f, $from, $to, $cond) = @_;
1614 my $i = breakable_line_in_filename($f, $from, $to);
1615 $cond = 1 unless @_ >= 3;
1616 break_on_filename_line($f,$i,$cond);
1619 sub subroutine_filename_lines {
1620 my ($subname,$cond) = @_;
1621 # Filename below can contain ':'
1622 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1625 sub break_subroutine {
1626 my $subname = shift;
1627 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1628 die "Subroutine $subname not found.\n";
1629 $cond = 1 unless @_ >= 2;
1630 break_on_filename_line_range($file,$s,$e,@_);
1634 my ($subname,$cond) = @_;
1635 $cond = 1 unless @_ >= 2;
1636 unless (ref $subname eq 'CODE') {
1637 $subname =~ s/\'/::/g;
1639 $subname = "${'package'}::" . $subname
1640 unless $subname =~ /::/;
1641 $subname = "CORE::GLOBAL::$s"
1642 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1643 $subname = "main".$subname if substr($subname,0,2) eq "::";
1645 eval { break_subroutine($subname,$cond); 1 } or do {
1647 print $OUT $@ and return;
1652 my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
1653 my $dbline = shift; $line =~ s/^\./$dbline/;
1655 eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
1656 } elsif ($line =~ /^(\S.*)/) {
1657 eval { &delete_breakpoint($line || $dbline); 1 } or do {
1659 print $OUT $@ and return;
1662 print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
1666 sub delete_breakpoint {
1669 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1670 $dbline{$i} =~ s/^[^\0]*//;
1671 delete $dbline{$i} if $dbline{$i} eq '';
1673 print $OUT "Deleting all breakpoints...\n";
1674 for my $file (keys %had_breakpoints) {
1675 local *dbline = $main::{'_<' . $file};
1678 for ($i = 1; $i <= $max ; $i++) {
1679 if (defined $dbline{$i}) {
1680 $dbline{$i} =~ s/^[^\0]+//;
1681 if ($dbline{$i} =~ s/^\0?$//) {
1686 if (not $had_breakpoints{$file} &= ~1) {
1687 delete $had_breakpoints{$file};
1691 undef %postponed_file;
1692 undef %break_on_load;
1696 sub cmd_stop { # As on ^C, but not signal-safy.
1701 my $line = shift || '';
1702 if ($line =~ /^h\s*/) {
1704 } elsif ($line =~ /^(\S.*)$/) {
1705 # support long commands; otherwise bogus errors
1706 # happen when you ask for h on <CR> for example
1707 my $asked = $1; # for proper errmsg
1708 my $qasked = quotemeta($asked); # for searching
1709 # XXX: finds CR but not <CR>
1710 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
1711 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
1715 print_help("B<$asked> is not a debugger command.\n");
1718 print_help($summary);
1724 $line =~ s/^-\s*$/-/;
1725 if ($line =~ /^(\$.*)/s) {
1728 print($OUT "Error: $@\n"), next CMD if $@;
1730 print($OUT "Interpreted as: $1 $s\n");
1733 } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
1734 my $s = $subname = $1;
1735 $subname =~ s/\'/::/;
1736 $subname = $package."::".$subname
1737 unless $subname =~ /::/;
1738 $subname = "CORE::GLOBAL::$s"
1739 if not defined &$subname and $s !~ /::/
1740 and defined &{"CORE::GLOBAL::$s"};
1741 $subname = "main".$subname if substr($subname,0,2) eq "::";
1742 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
1743 $subrange = pop @pieces;
1744 $file = join(':', @pieces);
1745 if ($file ne $filename) {
1746 print $OUT "Switching to file '$file'.\n"
1747 unless $slave_editor;
1748 *dbline = $main::{'_<' . $file};
1753 if (eval($subrange) < -$window) {
1754 $subrange =~ s/-.*/+/;
1759 print $OUT "Subroutine $subname not found.\n";
1761 } elsif ($line =~ /^\s*$/) {
1762 $incr = $window - 1;
1763 $line = $start . '-' . ($start + $incr);
1765 } elsif ($line =~ /^(\d*)\+(\d*)$/) {
1768 $incr = $window - 1 unless $incr;
1769 $line = $start . '-' . ($start + $incr);
1771 } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
1772 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
1773 $end = $max if $end > $max;
1775 $i = $line if $i eq '.';
1778 if ($slave_editor) {
1779 print $OUT "\032\032$filename:$i:0\n";
1782 for (; $i <= $end; $i++) {
1784 ($stop,$action) = split(/\0/, $dbline{$i}) if
1787 and $filename eq $filename_ini)
1789 : ($dbline[$i]+0 ? ':' : ' ') ;
1790 $arrow .= 'b' if $stop;
1791 $arrow .= 'a' if $action;
1792 print $OUT "$i$arrow\t", $dbline[$i];
1793 $i++, last if $signal;
1795 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
1797 $start = $i; # remember in case they want more
1798 $start = $max if $start > $max;
1803 my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
1804 my $action_wanted = ($arg =~ /a/) ? 1 : 0;
1805 my $break_wanted = ($arg =~ /b/) ? 1 : 0;
1806 my $watch_wanted = ($arg =~ /w/) ? 1 : 0;
1808 if ($break_wanted or $action_wanted) {
1809 for my $file (keys %had_breakpoints) {
1810 local *dbline = $main::{'_<' . $file};
1813 for ($i = 1; $i <= $max; $i++) {
1814 if (defined $dbline{$i}) {
1815 print $OUT "$file:\n" unless $was++;
1816 print $OUT " $i:\t", $dbline[$i];
1817 ($stop,$action) = split(/\0/, $dbline{$i});
1818 print $OUT " break if (", $stop, ")\n"
1819 if $stop and $break_wanted;
1820 print $OUT " action: ", $action, "\n"
1821 if $action and $action_wanted;
1827 if (%postponed and $break_wanted) {
1828 print $OUT "Postponed breakpoints in subroutines:\n";
1830 for $subname (keys %postponed) {
1831 print $OUT " $subname\t$postponed{$subname}\n";
1835 my @have = map { # Combined keys
1836 keys %{$postponed_file{$_}}
1837 } keys %postponed_file;
1838 if (@have and ($break_wanted or $action_wanted)) {
1839 print $OUT "Postponed breakpoints in files:\n";
1841 for $file (keys %postponed_file) {
1842 my $db = $postponed_file{$file};
1843 print $OUT " $file:\n";
1844 for $line (sort {$a <=> $b} keys %$db) {
1845 print $OUT " $line:\n";
1846 my ($stop,$action) = split(/\0/, $$db{$line});
1847 print $OUT " break if (", $stop, ")\n"
1848 if $stop and $break_wanted;
1849 print $OUT " action: ", $action, "\n"
1850 if $action and $action_wanted;
1856 if (%break_on_load and $break_wanted) {
1857 print $OUT "Breakpoints on load:\n";
1859 for $file (keys %break_on_load) {
1860 print $OUT " $file\n";
1864 if ($watch_wanted) {
1866 print $OUT "Watch-expressions:\n" if @to_watch;
1867 for my $expr (@to_watch) {
1868 print $OUT " $expr\n";
1880 my $opt = shift || ''; # opt[=val]
1881 if ($opt =~ /^(\S.*)/) {
1891 print $OUT "The old O command is now the o command.\n"; # hint
1892 print $OUT "Use 'h' to get current command help synopsis or\n"; #
1893 print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; #
1899 if ($line =~ /^(\d*)$/) {
1900 $incr = $window - 1;
1903 $line = $start . '-' . ($start + $incr);
1909 my $expr = shift || '';
1910 if ($expr =~ /^(\S.*)/) {
1911 push @to_watch, $expr;
1914 $val = (defined $val) ? "'$val'" : 'undef' ;
1915 push @old_watch, $val;
1918 print $OUT "Adding a watch-expression requires an expression\n"; # hint
1923 my $expr = shift || '';
1926 print $OUT "Deleting all watch expressions ...\n";
1927 @to_watch = @old_watch = ();
1928 } elsif ($expr =~ /^(\S.*)/) {
1930 foreach (@to_watch) {
1931 my $val = $to_watch[$i_cnt];
1932 if ($val eq $expr) { # =~ m/^\Q$i$/) {
1933 splice(@to_watch, $i_cnt, 1);
1938 print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
1942 ### END of the API section
1945 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1946 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1949 sub print_lineinfo {
1950 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1956 # The following takes its argument via $evalarg to preserve current @_
1959 my $subname = shift;
1960 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1961 my $offset = $1 || 0;
1962 # Filename below can contain ':'
1963 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1966 local *dbline = $main::{'_<' . $file};
1967 local $^W = 0; # != 0 is magical below
1968 $had_breakpoints{$file} |= 1;
1970 ++$i until $dbline[$i] != 0 or $i >= $max;
1971 $dbline{$i} = delete $postponed{$subname};
1974 print $OUT "Subroutine $subname not found.\n";
1978 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1979 #print $OUT "In postponed_sub for `$subname'.\n";
1983 if ($ImmediateStop) {
1987 return &postponed_sub
1988 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1989 # Cannot be done before the file is compiled
1990 local *dbline = shift;
1991 my $filename = $dbline;
1992 $filename =~ s/^_<//;
1994 $signal = 1, print $OUT "'$filename' loaded...\n"
1995 if $break_on_load{$filename};
1996 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1997 return unless $postponed_file{$filename};
1998 $had_breakpoints{$filename} |= 1;
1999 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
2001 for $key (keys %{$postponed_file{$filename}}) {
2002 $dbline{$key} = ${$postponed_file{$filename}}{$key};
2004 delete $postponed_file{$filename};
2008 local ($savout) = select(shift);
2009 my $osingle = $single;
2010 my $otrace = $trace;
2011 $single = $trace = 0;
2014 unless (defined &main::dumpValue) {
2017 if (defined &main::dumpValue) {
2022 my $maxdepth = shift || $option{dumpDepth};
2023 $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
2024 &main::dumpValue($v, $maxdepth);
2027 print $OUT "dumpvar.pl not available.\n";
2034 # Tied method do not create a context, so may get wrong message:
2039 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
2040 my @sub = dump_trace($_[0] + 1, $_[1]);
2041 my $short = $_[2]; # Print short report, next one for sub name
2043 for ($i=0; $i <= $#sub; $i++) {
2046 my $args = defined $sub[$i]{args}
2047 ? "(@{ $sub[$i]{args} })"
2049 $args = (substr $args, 0, $maxtrace - 3) . '...'
2050 if length $args > $maxtrace;
2051 my $file = $sub[$i]{file};
2052 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
2054 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
2056 my $sub = @_ >= 4 ? $_[3] : $s;
2057 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
2059 print $fh "$sub[$i]{context} = $s$args" .
2060 " called from $file" .
2061 " line $sub[$i]{line}\n";
2068 my $count = shift || 1e9;
2071 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
2072 my $nothard = not $frame & 8;
2073 local $frame = 0; # Do not want to trace this.
2074 my $otrace = $trace;
2077 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
2082 if (not defined $arg) {
2084 } elsif ($nothard and tied $arg) {
2086 } elsif ($nothard and $type = ref $arg) {
2087 push @a, "ref($type)";
2089 local $_ = "$arg"; # Safe to stringify now - should not call f().
2092 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
2093 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
2094 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
2098 $context = $context ? '@' : (defined $context ? "\$" : '.');
2099 $args = $h ? [@a] : undef;
2100 $e =~ s/\n\s*\;\s*\Z// if $e;
2101 $e =~ s/([\\\'])/\\$1/g if $e;
2103 $sub = "require '$e'";
2104 } elsif (defined $r) {
2106 } elsif ($sub eq '(eval)') {
2107 $sub = "eval {...}";
2109 push(@sub, {context => $context, sub => $sub, args => $args,
2110 file => $file, line => $line});
2119 while ($action =~ s/\\$//) {
2128 # i hate using globals!
2129 $balanced_brace_re ||= qr{
2132 (?> [^{}] + ) # Non-parens without backtracking
2134 (??{ $balanced_brace_re }) # Group with matching parens
2138 return $_[0] !~ m/$balanced_brace_re/;
2142 &readline("cont: ");
2146 # We save, change, then restore STDIN and STDOUT to avoid fork() since
2147 # some non-Unix systems can do system() but have problems with fork().
2148 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
2149 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
2150 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
2151 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
2153 # XXX: using csh or tcsh destroys sigint retvals!
2155 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
2156 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
2161 # most of the $? crud was coping with broken cshisms
2163 &warn("(Command exited ", ($? >> 8), ")\n");
2165 &warn( "(Command died of SIG#", ($? & 127),
2166 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
2176 eval { require Term::ReadLine } or die $@;
2179 my ($i, $o) = split $tty, /,/;
2180 $o = $i unless defined $o;
2181 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
2182 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
2185 my $sel = select($OUT);
2189 eval "require Term::Rendezvous;" or die;
2190 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
2191 my $term_rv = new Term::Rendezvous $rv;
2193 $OUT = $term_rv->OUT;
2196 if ($term_pid eq '-1') { # In a TTY with another debugger
2200 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2202 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2204 $rl_attribs = $term->Attribs;
2205 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2206 if defined $rl_attribs->{basic_word_break_characters}
2207 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2208 $rl_attribs->{special_prefixes} = '$@&%';
2209 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2210 $rl_attribs->{completion_function} = \&db_complete;
2212 $LINEINFO = $OUT unless defined $LINEINFO;
2213 $lineinfo = $console unless defined $lineinfo;
2215 if ($term->Features->{setHistory} and "@hist" ne "?") {
2216 $term->SetHistory(@hist);
2218 ornaments($ornaments) if defined $ornaments;
2222 # Example get_fork_TTY functions
2223 sub xterm_get_fork_TTY {
2224 (my $name = $0) =~ s,^.*[/\\],,s;
2225 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2229 $pidprompt = ''; # Shown anyway in titlebar
2233 # This example function resets $IN, $OUT itself
2234 sub os2_get_fork_TTY {
2235 local $^F = 40; # XXXX Fixme!
2237 my ($in1, $out1, $in2, $out2);
2238 # Having -d in PERL5OPT would lead to a disaster...
2239 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2240 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2241 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2242 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2243 (my $name = $0) =~ s,^.*[/\\],,s;
2245 if ( pipe $in1, $out1 and pipe $in2, $out2
2246 # system P_SESSION will fail if there is another process
2247 # in the same session with a "dependent" asynchronous child session.
2248 and @args = ($rl, fileno $in1, fileno $out2,
2249 "Daughter Perl debugger $pids $name") and
2250 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2253 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2255 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2256 open IN, '<&=$in' or die "open <&=$in: \$!";
2257 \$| = 1; print while sysread IN, \$_, 1<<16;
2261 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2263 require Term::ReadKey if $rl;
2264 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2265 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2267 or warn "system P_SESSION: $!, $^E" and 0)
2268 and close $in1 and close $out2 ) {
2269 $pidprompt = ''; # Shown anyway in titlebar
2270 reset_IN_OUT($in2, $out1);
2272 return ''; # Indicate that reset_IN_OUT is called
2277 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2278 my $in = &get_fork_TTY if defined &get_fork_TTY;
2279 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2280 if (not defined $in) {
2282 print_help(<<EOP) if $why == 1;
2283 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2285 print_help(<<EOP) if $why == 2;
2286 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2287 This may be an asynchronous session, so the parent debugger may be active.
2289 print_help(<<EOP) if $why != 4;
2290 Since two debuggers fight for the same TTY, input is severely entangled.
2294 I know how to switch the output to a different window in xterms
2295 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2296 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2298 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2299 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2302 } elsif ($in ne '') {
2305 $console = ''; # Indicate no need to open-from-the-console
2310 sub resetterm { # We forked, so we need a different TTY
2312 my $systemed = $in > 1 ? '-' : '';
2314 $pids =~ s/\]/$systemed->$$]/;
2316 $pids = "[$term_pid->$$]";
2320 return unless $CreateTTY & $in;
2327 my $left = @typeahead;
2328 my $got = shift @typeahead;
2330 print $OUT "auto(-$left)", shift, $got, "\n";
2331 $term->AddHistory($got)
2332 if length($got) > 1 and defined $term->Features->{addHistory};
2338 my $line = CORE::readline($cmdfhs[-1]);
2339 defined $line ? (print $OUT ">> $line" and return $line)
2340 : close pop @cmdfhs;
2342 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2343 $OUT->write(join('', @_));
2345 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2349 $term->readline(@_);
2354 my ($opt, $val)= @_;
2355 $val = option_val($opt,'N/A');
2356 $val =~ s/([\\\'])/\\$1/g;
2357 printf $OUT "%20s = '%s'\n", $opt, $val;
2361 my ($opt, $default)= @_;
2363 if (defined $optionVars{$opt}
2364 and defined ${$optionVars{$opt}}) {
2365 $val = ${$optionVars{$opt}};
2366 } elsif (defined $optionAction{$opt}
2367 and defined &{$optionAction{$opt}}) {
2368 $val = &{$optionAction{$opt}}();
2369 } elsif (defined $optionAction{$opt}
2370 and not defined $option{$opt}
2371 or defined $optionVars{$opt}
2372 and not defined ${$optionVars{$opt}}) {
2375 $val = $option{$opt};
2377 $val = $default unless defined $val;
2384 # too dangerous to let intuitive usage overwrite important things
2385 # defaultion should never be the default
2386 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2387 dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2388 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2393 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2394 my ($opt,$sep) = ($1,$2);
2397 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2399 #&dump_option($opt);
2400 } elsif ($sep !~ /\S/) {
2402 $val = "1"; # this is an evil default; make 'em set it!
2403 } elsif ($sep eq "=") {
2404 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2406 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2410 print OUT qq(Option better cleared using $opt=""\n)
2414 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2415 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2416 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2417 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2418 ($val = $1) =~ s/\\([\\$end])/$1/g;
2422 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2423 || grep( /^\Q$opt/i && ($option = $_), @options );
2425 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2426 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2428 if ($opt_needs_val{$option} && $val_defaulted) {
2429 my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
2430 print $OUT "Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
2434 $option{$option} = $val if defined $val;
2439 require '$optionRequire{$option}';
2441 } || die # XXX: shouldn't happen
2442 if defined $optionRequire{$option} &&
2445 ${$optionVars{$option}} = $val
2446 if defined $optionVars{$option} &&
2449 &{$optionAction{$option}} ($val)
2450 if defined $optionAction{$option} &&
2451 defined &{$optionAction{$option}} &&
2455 dump_option($option) unless $OUT eq \*STDERR;
2460 my ($stem,@list) = @_;
2462 $ENV{"${stem}_n"} = @list;
2463 for $i (0 .. $#list) {
2465 $val =~ s/\\/\\\\/g;
2466 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2467 $ENV{"${stem}_$i"} = $val;
2474 my $n = delete $ENV{"${stem}_n"};
2476 for $i (0 .. $n - 1) {
2477 $val = delete $ENV{"${stem}_$i"};
2478 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2486 return; # Put nothing on the stack - malloc/free land!
2490 my($msg)= join("",@_);
2491 $msg .= ": $!\n" unless $msg =~ /\n$/;
2497 my $switch_li = $LINEINFO eq $OUT;
2498 if ($term and $term->Features->{newTTY}) {
2499 ($IN, $OUT) = (shift, shift);
2500 $term->newTTY($IN, $OUT);
2502 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2504 ($IN, $OUT) = (shift, shift);
2506 my $o = select $OUT;
2509 $LINEINFO = $OUT if $switch_li;
2513 if (@_ and $term and $term->Features->{newTTY}) {
2514 my ($in, $out) = shift;
2516 ($in, $out) = split /,/, $in, 2;
2520 open IN, $in or die "cannot open `$in' for read: $!";
2521 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2522 reset_IN_OUT(\*IN,\*OUT);
2525 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2526 # Useful if done through PERLDB_OPTS:
2527 $console = $tty = shift if @_;
2533 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2535 $notty = shift if @_;
2541 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2549 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2551 $remoteport = shift if @_;
2556 if (${$term->Features}{tkRunning}) {
2557 return $term->tkRunning(@_);
2560 print $OUT "tkRunning not supported by current ReadLine package.\n";
2567 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2569 $runnonstop = shift if @_;
2576 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2583 $sh = quotemeta shift;
2584 $sh .= "\\b" if $sh =~ /\w$/;
2588 $psh =~ s/\\(.)/$1/g;
2593 if (defined $term) {
2594 local ($warnLevel,$dieLevel) = (0, 1);
2595 return '' unless $term->Features->{ornaments};
2596 eval { $term->ornaments(@_) } || '';
2604 $rc = quotemeta shift;
2605 $rc .= "\\b" if $rc =~ /\w$/;
2609 $prc =~ s/\\(.)/$1/g;
2614 return $lineinfo unless @_;
2616 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2617 $slave_editor = ($stream =~ /^\|/);
2618 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2619 $LINEINFO = \*LINEINFO;
2620 my $save = select($LINEINFO);
2626 sub list_modules { # versions
2634 s/^Term::ReadLine::readline$/readline/;
2635 if (defined ${ $_ . '::VERSION' }) {
2636 $version{$file} = "${ $_ . '::VERSION' } from ";
2638 $version{$file} .= $INC{$file};
2640 dumpit($OUT,\%version);
2644 # XXX: make sure there are tabs between the command and explanation,
2645 # or print_help will screw up your formatting if you have
2646 # eeevil ornaments enabled. This is an insane mess.
2649 Help is currently only available for the new 580 CommandSet,
2650 if you really want old behaviour, presumably you know what
2654 B<s> [I<expr>] Single step [in I<expr>].
2655 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2656 <B<CR>> Repeat last B<n> or B<s> command.
2657 B<r> Return from current subroutine.
2658 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2659 at the specified position.
2660 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2661 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2662 B<l> I<line> List single I<line>.
2663 B<l> I<subname> List first window of lines from subroutine.
2664 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2665 B<l> List next window of lines.
2666 B<-> List previous window of lines.
2667 B<v> [I<line>] View window around I<line>.
2668 B<.> Return to the executed line.
2669 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2670 I<filename> may be either the full name of the file, or a regular
2671 expression matching the full file name:
2672 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2673 Evals (with saved bodies) are considered to be filenames:
2674 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2675 (in the order of execution).
2676 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2677 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2678 B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions.
2679 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2680 B<t> Toggle trace mode.
2681 B<t> I<expr> Trace through execution of I<expr>.
2682 B<b> Sets breakpoint on current line)
2683 B<b> [I<line>] [I<condition>]
2684 Set breakpoint; I<line> defaults to the current execution line;
2685 I<condition> breaks if it evaluates to true, defaults to '1'.
2686 B<b> I<subname> [I<condition>]
2687 Set breakpoint at first line of subroutine.
2688 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2689 B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
2690 B<b> B<postpone> I<subname> [I<condition>]
2691 Set breakpoint at first line of subroutine after
2693 B<b> B<compile> I<subname>
2694 Stop after the subroutine is compiled.
2695 B<B> [I<line>] Delete the breakpoint for I<line>.
2696 B<B> I<*> Delete all breakpoints.
2697 B<a> [I<line>] I<command>
2698 Set an action to be done before the I<line> is executed;
2699 I<line> defaults to the current execution line.
2700 Sequence is: check for breakpoint/watchpoint, print line
2701 if necessary, do action, prompt user if necessary,
2704 B<A> [I<line>] Delete the action for I<line>.
2705 B<A> I<*> Delete all actions.
2706 B<w> I<expr> Add a global watch-expression.
2708 B<W> I<expr> Delete a global watch-expression.
2709 B<W> I<*> Delete all watch-expressions.
2710 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2711 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2712 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2713 B<x> I<expr> Evals expression in list context, dumps the result.
2714 B<m> I<expr> Evals expression in list context, prints methods callable
2715 on the first element of the result.
2716 B<m> I<class> Prints methods callable via the given class.
2717 B<M> Show versions of loaded modules.
2719 B<<> ? List Perl commands to run before each prompt.
2720 B<<> I<expr> Define Perl command to run before each prompt.
2721 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2722 B<>> ? List Perl commands to run after each prompt.
2723 B<>> I<expr> Define Perl command to run after each prompt.
2724 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2725 B<{> I<db_command> Define debugger command to run before each prompt.
2726 B<{> ? List debugger commands to run before each prompt.
2727 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2728 B<$prc> I<number> Redo a previous command (default previous command).
2729 B<$prc> I<-number> Redo number'th-to-last command.
2730 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2731 See 'B<O> I<recallCommand>' too.
2732 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2733 . ( $rc eq $sh ? "" : "
2734 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2735 See 'B<O> I<shellBang>' too.
2736 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2737 B<H> I<-number> Display last number commands (default all).
2738 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2739 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2740 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2741 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2742 I<command> Execute as a perl statement in current package.
2743 B<R> Pure-man-restart of debugger, some of debugger state
2744 and command-line options may be lost.
2745 Currently the following settings are preserved:
2746 history, breakpoints and actions, debugger B<O>ptions
2747 and the following command-line options: I<-w>, I<-I>, I<-e>.
2749 B<o> [I<opt>] ... Set boolean option to true
2750 B<o> [I<opt>B<?>] Query options
2751 B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2752 Set options. Use quotes in spaces in value.
2753 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2754 I<pager> program for output of \"|cmd\";
2755 I<tkRunning> run Tk while prompting (with ReadLine);
2756 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2757 I<inhibit_exit> Allows stepping off the end of the script.
2758 I<ImmediateStop> Debugger should stop as early as possible.
2759 I<RemotePort> Remote hostname:port for remote debugging
2760 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2761 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2762 I<compactDump>, I<veryCompact> change style of array and hash dump;
2763 I<globPrint> whether to print contents of globs;
2764 I<DumpDBFiles> dump arrays holding debugged files;
2765 I<DumpPackages> dump symbol tables of packages;
2766 I<DumpReused> dump contents of \"reused\" addresses;
2767 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2768 I<bareStringify> Do not print the overload-stringified value;
2769 Other options include:
2770 I<PrintRet> affects printing of return value after B<r> command,
2771 I<frame> affects printing messages on subroutine entry/exit.
2772 I<AutoTrace> affects printing messages on possible breaking points.
2773 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2774 I<ornaments> affects screen appearance of the command line.
2775 I<CreateTTY> bits control attempts to create a new TTY on events:
2776 1: on fork() 2: debugger is started inside debugger
2778 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2779 You can put additional initialization options I<TTY>, I<noTTY>,
2780 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2781 `B<R>' after you set them).
2783 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2784 B<h> Summary of debugger commands.
2785 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2786 B<h h> Long help for debugger commands
2787 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2788 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2789 Set B<\$DB::doccmd> to change viewer.
2791 Type `|h h' for a paged display if this was too hard to read.
2793 "; # Fix balance of vi % matching: }}}}
2795 # note: tabs in the following section are not-so-helpful
2796 $summary = <<"END_SUM";
2797 I<List/search source lines:> I<Control script execution:>
2798 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2799 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2800 B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs
2801 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2802 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2803 B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position
2804 I<Debugger controls:> B<L> List break/watch/actions
2805 B<o> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2806 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2807 B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints
2808 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2809 B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions
2810 B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression
2811 B<h h> Complete help page B<W> I<expr|*> Delete a/all watch expressions
2812 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2813 B<q> or B<^D> Quit B<R> Attempt a restart
2814 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2815 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2816 B<p> I<expr> Print expression (uses script's current package).
2817 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2818 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2819 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2820 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2821 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2823 # ')}}; # Fix balance of vi % matching
2825 # and this is really numb...
2828 B<s> [I<expr>] Single step [in I<expr>].
2829 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2830 <B<CR>> Repeat last B<n> or B<s> command.
2831 B<r> Return from current subroutine.
2832 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2833 at the specified position.
2834 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2835 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2836 B<l> I<line> List single I<line>.
2837 B<l> I<subname> List first window of lines from subroutine.
2838 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2839 B<l> List next window of lines.
2840 B<-> List previous window of lines.
2841 B<w> [I<line>] List window around I<line>.
2842 B<.> Return to the executed line.
2843 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2844 I<filename> may be either the full name of the file, or a regular
2845 expression matching the full file name:
2846 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2847 Evals (with saved bodies) are considered to be filenames:
2848 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2849 (in the order of execution).
2850 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2851 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2852 B<L> List all breakpoints and actions.
2853 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2854 B<t> Toggle trace mode.
2855 B<t> I<expr> Trace through execution of I<expr>.
2856 B<b> [I<line>] [I<condition>]
2857 Set breakpoint; I<line> defaults to the current execution line;
2858 I<condition> breaks if it evaluates to true, defaults to '1'.
2859 B<b> I<subname> [I<condition>]
2860 Set breakpoint at first line of subroutine.
2861 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2862 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2863 B<b> B<postpone> I<subname> [I<condition>]
2864 Set breakpoint at first line of subroutine after
2866 B<b> B<compile> I<subname>
2867 Stop after the subroutine is compiled.
2868 B<d> [I<line>] Delete the breakpoint for I<line>.
2869 B<D> Delete all breakpoints.
2870 B<a> [I<line>] I<command>
2871 Set an action to be done before the I<line> is executed;
2872 I<line> defaults to the current execution line.
2873 Sequence is: check for breakpoint/watchpoint, print line
2874 if necessary, do action, prompt user if necessary,
2876 B<a> [I<line>] Delete the action for I<line>.
2877 B<A> Delete all actions.
2878 B<W> I<expr> Add a global watch-expression.
2879 B<W> Delete all watch-expressions.
2880 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2881 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2882 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2883 B<x> I<expr> Evals expression in list context, dumps the result.
2884 B<m> I<expr> Evals expression in list context, prints methods callable
2885 on the first element of the result.
2886 B<m> I<class> Prints methods callable via the given class.
2888 B<<> ? List Perl commands to run before each prompt.
2889 B<<> I<expr> Define Perl command to run before each prompt.
2890 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2891 B<>> ? List Perl commands to run after each prompt.
2892 B<>> I<expr> Define Perl command to run after each prompt.
2893 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2894 B<{> I<db_command> Define debugger command to run before each prompt.
2895 B<{> ? List debugger commands to run before each prompt.
2896 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2897 B<$prc> I<number> Redo a previous command (default previous command).
2898 B<$prc> I<-number> Redo number'th-to-last command.
2899 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2900 See 'B<O> I<recallCommand>' too.
2901 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2902 . ( $rc eq $sh ? "" : "
2903 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2904 See 'B<O> I<shellBang>' too.
2905 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2906 B<H> I<-number> Display last number commands (default all).
2907 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2908 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2909 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2910 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2911 I<command> Execute as a perl statement in current package.
2912 B<v> Show versions of loaded modules.
2913 B<R> Pure-man-restart of debugger, some of debugger state
2914 and command-line options may be lost.
2915 Currently the following settings are preserved:
2916 history, breakpoints and actions, debugger B<O>ptions
2917 and the following command-line options: I<-w>, I<-I>, I<-e>.
2919 B<O> [I<opt>] ... Set boolean option to true
2920 B<O> [I<opt>B<?>] Query options
2921 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2922 Set options. Use quotes in spaces in value.
2923 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2924 I<pager> program for output of \"|cmd\";
2925 I<tkRunning> run Tk while prompting (with ReadLine);
2926 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2927 I<inhibit_exit> Allows stepping off the end of the script.
2928 I<ImmediateStop> Debugger should stop as early as possible.
2929 I<RemotePort> Remote hostname:port for remote debugging
2930 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2931 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2932 I<compactDump>, I<veryCompact> change style of array and hash dump;
2933 I<globPrint> whether to print contents of globs;
2934 I<DumpDBFiles> dump arrays holding debugged files;
2935 I<DumpPackages> dump symbol tables of packages;
2936 I<DumpReused> dump contents of \"reused\" addresses;
2937 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2938 I<bareStringify> Do not print the overload-stringified value;
2939 Other options include:
2940 I<PrintRet> affects printing of return value after B<r> command,
2941 I<frame> affects printing messages on subroutine entry/exit.
2942 I<AutoTrace> affects printing messages on possible breaking points.
2943 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2944 I<ornaments> affects screen appearance of the command line.
2945 I<CreateTTY> bits control attempts to create a new TTY on events:
2946 1: on fork() 2: debugger is started inside debugger
2948 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2949 You can put additional initialization options I<TTY>, I<noTTY>,
2950 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2951 `B<R>' after you set them).
2953 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2954 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2955 B<h h> Summary of debugger commands.
2956 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2957 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2958 Set B<\$DB::doccmd> to change viewer.
2960 Type `|h' for a paged display if this was too hard to read.
2962 "; # Fix balance of vi % matching: }}}}
2964 # note: tabs in the following section are not-so-helpful
2965 $pre580_summary = <<"END_SUM";
2966 I<List/search source lines:> I<Control script execution:>
2967 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2968 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2969 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2970 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2971 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2972 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2973 I<Debugger controls:> B<L> List break/watch/actions
2974 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2975 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2976 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2977 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2978 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2979 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2980 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2981 B<q> or B<^D> Quit B<R> Attempt a restart
2982 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2983 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2984 B<p> I<expr> Print expression (uses script's current package).
2985 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2986 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2987 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2988 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2989 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2991 # ')}}; # Fix balance of vi % matching
2998 # Restore proper alignment destroyed by eeevil I<> and B<>
2999 # ornaments: A pox on both their houses!
3001 # A help command will have everything up to and including
3002 # the first tab sequence padded into a field 16 (or if indented 20)
3003 # wide. If it's wider than that, an extra space will be added.
3005 ^ # only matters at start of line
3006 ( \040{4} | \t )* # some subcommands are indented
3007 ( < ? # so <CR> works
3008 [BI] < [^\t\n] + ) # find an eeevil ornament
3009 ( \t+ ) # original separation, discarded
3010 ( .* ) # this will now start (no earlier) than
3013 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
3014 my $clean = $command;
3015 $clean =~ s/[BI]<([^>]*)>/$1/g;
3016 # replace with this whole string:
3017 ($leadwhite ? " " x 4 : "")
3019 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
3024 s{ # handle bold ornaments
3025 B < ( [^>] + | > ) >
3027 $Term::ReadLine::TermCap::rl_term_set[2]
3029 . $Term::ReadLine::TermCap::rl_term_set[3]
3032 s{ # handle italic ornaments
3033 I < ( [^>] + | > ) >
3035 $Term::ReadLine::TermCap::rl_term_set[0]
3037 . $Term::ReadLine::TermCap::rl_term_set[1]
3045 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
3046 my $is_less = $pager =~ /\bless\b/;
3047 if ($pager =~ /\bmore\b/) {
3048 my @st_more = stat('/usr/bin/more');
3049 my @st_less = stat('/usr/bin/less');
3050 $is_less = @st_more && @st_less
3051 && $st_more[0] == $st_less[0]
3052 && $st_more[1] == $st_less[1];
3054 # changes environment!
3055 $ENV{LESS} .= 'r' if $is_less;
3061 $SIG{'ABRT'} = 'DEFAULT';
3062 kill 'ABRT', $$ if $panic++;
3063 if (defined &Carp::longmess) {
3064 local $SIG{__WARN__} = '';
3065 local $Carp::CarpLevel = 2; # mydie + confess
3066 &warn(Carp::longmess("Signal @_"));
3070 print $DB::OUT "Got signal @_\n";
3078 local $SIG{__WARN__} = '';
3079 local $SIG{__DIE__} = '';
3080 eval { require Carp } if defined $^S; # If error/warning during compilation,
3081 # require may be broken.
3082 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
3083 return unless defined &Carp::longmess;
3084 my ($mysingle,$mytrace) = ($single,$trace);
3085 $single = 0; $trace = 0;
3086 my $mess = Carp::longmess(@_);
3087 ($single,$trace) = ($mysingle,$mytrace);
3094 local $SIG{__DIE__} = '';
3095 local $SIG{__WARN__} = '';
3096 my $i = 0; my $ineval = 0; my $sub;
3097 if ($dieLevel > 2) {
3098 local $SIG{__WARN__} = \&dbwarn;
3099 &warn(@_); # Yell no matter what
3102 if ($dieLevel < 2) {
3103 die @_ if $^S; # in eval propagate
3105 # No need to check $^S, eval is much more robust nowadays
3106 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
3107 # require may be broken.
3109 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
3110 unless defined &Carp::longmess;
3112 # We do not want to debug this chunk (automatic disabling works
3113 # inside DB::DB, but not in Carp).
3114 my ($mysingle,$mytrace) = ($single,$trace);
3115 $single = 0; $trace = 0;
3118 package Carp; # Do not include us in the list
3120 $mess = Carp::longmess(@_);
3123 ($single,$trace) = ($mysingle,$mytrace);
3129 $prevwarn = $SIG{__WARN__} unless $warnLevel;
3132 $SIG{__WARN__} = \&DB::dbwarn;
3133 } elsif ($prevwarn) {
3134 $SIG{__WARN__} = $prevwarn;
3143 $prevdie = $SIG{__DIE__} unless $dieLevel;
3146 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
3147 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
3148 print $OUT "Stack dump during die enabled",
3149 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
3151 print $OUT "Dump printed too.\n" if $dieLevel > 2;
3152 } elsif ($prevdie) {
3153 $SIG{__DIE__} = $prevdie;
3154 print $OUT "Default die handler restored.\n";
3162 $prevsegv = $SIG{SEGV} unless $signalLevel;
3163 $prevbus = $SIG{BUS} unless $signalLevel;
3164 $signalLevel = shift;
3166 $SIG{SEGV} = \&DB::diesignal;
3167 $SIG{BUS} = \&DB::diesignal;
3169 $SIG{SEGV} = $prevsegv;
3170 $SIG{BUS} = $prevbus;
3178 my $name = CvGV_name_or_bust($in);
3179 defined $name ? $name : $in;
3182 sub CvGV_name_or_bust {
3184 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
3185 return unless ref $in;
3186 $in = \&$in; # Hard reference...
3187 eval {require Devel::Peek; 1} or return;
3188 my $gv = Devel::Peek::CvGV($in) or return;
3189 *$gv{PACKAGE} . '::' . *$gv{NAME};
3195 return unless defined &$subr;
3196 my $name = CvGV_name_or_bust($subr);
3198 $data = $sub{$name} if defined $name;
3199 return $data if defined $data;
3202 $subr = \&$subr; # Hard reference
3205 $s = $_, last if $subr eq \&$_;
3213 $class = ref $class if ref $class;
3216 methods_via($class, '', 1);
3217 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
3222 return if $packs{$class}++;
3224 my $prepend = $prefix ? "via $prefix: " : '';
3226 for $name (grep {defined &{${"${class}::"}{$_}}}
3227 sort keys %{"${class}::"}) {
3228 next if $seen{ $name }++;
3231 print $DB::OUT "$prepend$name\n";
3233 return unless shift; # Recurse?
3234 for $name (@{"${class}::ISA"}) {
3235 $prepend = $prefix ? $prefix . " -> $name" : $name;
3236 methods_via($name, $prepend, 1);
3241 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
3242 ? "man" # O Happy Day!
3243 : "perldoc"; # Alas, poor unfortunates
3249 &system("$doccmd $doccmd");
3252 # this way user can override, like with $doccmd="man -Mwhatever"
3253 # or even just "man " to disable the path check.
3254 unless ($doccmd eq 'man') {
3255 &system("$doccmd $page");
3259 $page = 'perl' if lc($page) eq 'help';
3262 my $man1dir = $Config::Config{'man1dir'};
3263 my $man3dir = $Config::Config{'man3dir'};
3264 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
3266 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
3267 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
3268 chop $manpath if $manpath;
3269 # harmless if missing, I figure
3270 my $oldpath = $ENV{MANPATH};
3271 $ENV{MANPATH} = $manpath if $manpath;
3272 my $nopathopt = $^O =~ /dunno what goes here/;
3273 if (CORE::system($doccmd,
3274 # I just *know* there are men without -M
3275 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3278 unless ($page =~ /^perl\w/) {
3279 if (grep { $page eq $_ } qw{
3280 5004delta 5005delta amiga api apio book boot bot call compile
3281 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
3282 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
3283 form func guts hack hist hpux intern ipc lexwarn locale lol mod
3284 modinstall modlib number obj op opentut os2 os390 pod port
3285 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
3286 trap unicode var vms win32 xs xstut
3290 CORE::system($doccmd,
3291 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3296 if (defined $oldpath) {
3297 $ENV{MANPATH} = $manpath;
3299 delete $ENV{MANPATH};
3303 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
3305 BEGIN { # This does not compile, alas.
3306 $IN = \*STDIN; # For bugs before DB::OUT has been opened
3307 $OUT = \*STDERR; # For errors before DB::OUT has been opened
3311 $deep = 100; # warning if stack gets this deep
3315 $SIG{INT} = \&DB::catch;
3316 # This may be enabled to debug debugger:
3317 #$warnLevel = 1 unless defined $warnLevel;
3318 #$dieLevel = 1 unless defined $dieLevel;
3319 #$signalLevel = 1 unless defined $signalLevel;
3321 $db_stop = 0; # Compiler warning
3323 $level = 0; # Level of recursive debugging
3324 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
3325 # Triggers bug (?) in perl is we postpone this until runtime:
3326 @postponed = @stack = (0);
3327 $stack_depth = 0; # Localized $#stack
3332 BEGIN {$^W = $ini_warn;} # Switch warnings back
3334 #use Carp; # This did break, left for debugging
3337 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
3338 my($text, $line, $start) = @_;
3339 my ($itext, $search, $prefix, $pack) =
3340 ($text, "^\Q${'package'}::\E([^:]+)\$");
3342 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
3343 (map { /$search/ ? ($1) : () } keys %sub)
3344 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
3345 return sort grep /^\Q$text/, values %INC # files
3346 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
3347 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3348 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
3349 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
3350 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3352 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
3354 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
3355 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
3356 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
3357 # We may want to complete to (eval 9), so $text may be wrong
3358 $prefix = length($1) - length($text);
3361 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
3363 if ((substr $text, 0, 1) eq '&') { # subroutines
3364 $text = substr $text, 1;
3366 return sort map "$prefix$_",
3369 (map { /$search/ ? ($1) : () }
3372 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
3373 $pack = ($1 eq 'main' ? '' : $1) . '::';
3374 $prefix = (substr $text, 0, 1) . $1 . '::';
3377 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
3378 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3379 return db_complete($out[0], $line, $start);
3383 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3384 $pack = ($package eq 'main' ? '' : $package) . '::';
3385 $prefix = substr $text, 0, 1;
3386 $text = substr $text, 1;
3387 my @out = map "$prefix$_", grep /^\Q$text/,
3388 (grep /^_?[a-zA-Z]/, keys %$pack),
3389 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3390 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3391 return db_complete($out[0], $line, $start);
3395 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3396 my @out = grep /^\Q$text/, @options;
3397 my $val = option_val($out[0], undef);
3399 if (not defined $val or $val =~ /[\n\r]/) {
3400 # Can do nothing better
3401 } elsif ($val =~ /\s/) {
3403 foreach $l (split //, qq/\"\'\#\|/) {
3404 $out = "$l$val$l ", last if (index $val, $l) == -1;
3409 # Default to value if one completion, to question if many
3410 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3413 return $term->filename_list($text); # filenames
3418 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3422 if (defined($ini_pids)) {
3423 $ENV{PERLDB_PIDS} = $ini_pids;
3425 delete($ENV{PERLDB_PIDS});
3430 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3431 $fall_off_end = 1 unless $inhibit_exit;
3432 # Do not stop in at_exit() and destructors on exit:
3433 $DB::single = !$fall_off_end && !$runnonstop;
3434 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3438 # ===================================== pre580 ================================
3439 # this is very sad below here...
3442 sub cmd_pre580_null {
3448 if ($cmd =~ /^(\d*)\s*(.*)/) {
3449 $i = $1 || $line; $j = $2;
3451 if ($dbline[$i] == 0) {
3452 print $OUT "Line $i may not have an action.\n";
3454 $had_breakpoints{$filename} |= 2;
3455 $dbline{$i} =~ s/\0[^\0]*//;
3456 $dbline{$i} .= "\0" . action($j);
3459 $dbline{$i} =~ s/\0[^\0]*//;
3460 delete $dbline{$i} if $dbline{$i} eq '';
3468 if ($cmd =~ /^load\b\s*(.*)/) {
3469 my $file = $1; $file =~ s/\s+$//;
3471 } elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
3472 my $cond = length $3 ? $3 : '1';
3473 my ($subname, $break) = ($2, $1 eq 'postpone');
3474 $subname =~ s/\'/::/g;
3475 $subname = "${'package'}::" . $subname
3476 unless $subname =~ /::/;
3477 $subname = "main".$subname if substr($subname,0,2) eq "::";
3478 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
3479 } elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
3481 my $cond = length $2 ? $2 : '1';
3482 &cmd_b_sub($subname, $cond);
3483 } elsif ($cmd =~ /^(\d*)\s*(.*)/) {
3484 my $i = $1 || $dbline;
3485 my $cond = length $2 ? $2 : '1';
3486 &cmd_b_line($i, $cond);
3492 if ($cmd =~ /^\s*$/) {
3493 print $OUT "Deleting all breakpoints...\n";
3495 for $file (keys %had_breakpoints) {
3496 local *dbline = $main::{'_<' . $file};
3500 for ($i = 1; $i <= $max ; $i++) {
3501 if (defined $dbline{$i}) {
3502 $dbline{$i} =~ s/^[^\0]+//;
3503 if ($dbline{$i} =~ s/^\0?$//) {
3509 if (not $had_breakpoints{$file} &= ~1) {
3510 delete $had_breakpoints{$file};
3514 undef %postponed_file;
3515 undef %break_on_load;
3521 if ($cmd =~ /^\s*$/) {
3522 print_help($pre580_help);
3523 } elsif ($cmd =~ /^h\s*/) {
3524 print_help($pre580_summary);
3525 } elsif ($cmd =~ /^h\s+(\S.*)$/) {
3526 my $asked = $1; # for proper errmsg
3527 my $qasked = quotemeta($asked); # for searching
3528 # XXX: finds CR but not <CR>
3529 if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) {
3530 while ($pre580_help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
3534 print_help("B<$asked> is not a debugger command.\n");
3543 @to_watch = @old_watch = ();
3544 } elsif ($cmd =~ /^(.*)/s) {
3548 $val = (defined $val) ? "'$val'" : 'undef' ;
3549 push @old_watch, $val;
3557 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3560 package DB; # Do not trace this 1; below!