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)
320 ####################################################################
322 # Needed for the statement after exec():
324 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
325 local($^W) = 0; # Switch run-time warnings off during init.
328 $dumpvar::arrayDepth,
329 $dumpvar::dumpDBFiles,
330 $dumpvar::dumpPackages,
331 $dumpvar::quoteHighBit,
332 $dumpvar::printUndef,
341 # Command-line + PERLLIB:
344 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
346 $trace = $signal = $single = 0; # Uninitialized warning suppression
347 # (local $^W cannot help - other packages!).
348 $inhibit_exit = $option{PrintRet} = 1;
350 @options = qw(hashDepth arrayDepth CommandSet dumpDepth
351 DumpDBFiles DumpPackages DumpReused
352 compactDump veryCompact quote HighBit undefPrint
353 globPrint PrintRet UsageOnly frame AutoTrace
354 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
355 recallCommand ShellBang pager tkRunning ornaments
356 signalLevel warnLevel dieLevel inhibit_exit
357 ImmediateStop bareStringify CreateTTY
358 RemotePort windowSize);
361 hashDepth => \$dumpvar::hashDepth,
362 arrayDepth => \$dumpvar::arrayDepth,
363 CommandSet => \$CommandSet,
364 DumpDBFiles => \$dumpvar::dumpDBFiles,
365 DumpPackages => \$dumpvar::dumpPackages,
366 DumpReused => \$dumpvar::dumpReused,
367 HighBit => \$dumpvar::quoteHighBit,
368 undefPrint => \$dumpvar::printUndef,
369 globPrint => \$dumpvar::globPrint,
370 UsageOnly => \$dumpvar::usageOnly,
371 CreateTTY => \$CreateTTY,
372 bareStringify => \$dumpvar::bareStringify,
374 AutoTrace => \$trace,
375 inhibit_exit => \$inhibit_exit,
376 maxTraceLen => \$maxtrace,
377 ImmediateStop => \$ImmediateStop,
378 RemotePort => \$remoteport,
379 windowSize => \$window,
383 compactDump => \&dumpvar::compactDump,
384 veryCompact => \&dumpvar::veryCompact,
385 quote => \&dumpvar::quote,
388 ReadLine => \&ReadLine,
389 NonStop => \&NonStop,
390 LineInfo => \&LineInfo,
391 recallCommand => \&recallCommand,
392 ShellBang => \&shellBang,
394 signalLevel => \&signalLevel,
395 warnLevel => \&warnLevel,
396 dieLevel => \&dieLevel,
397 tkRunning => \&tkRunning,
398 ornaments => \&ornaments,
399 RemotePort => \&RemotePort,
403 compactDump => 'dumpvar.pl',
404 veryCompact => 'dumpvar.pl',
405 quote => 'dumpvar.pl',
408 # These guys may be defined in $ENV{PERL5DB} :
409 $rl = 1 unless defined $rl;
410 $warnLevel = 1 unless defined $warnLevel;
411 $dieLevel = 1 unless defined $dieLevel;
412 $signalLevel = 1 unless defined $signalLevel;
413 $pre = [] unless defined $pre;
414 $post = [] unless defined $post;
415 $pretype = [] unless defined $pretype;
416 $CreateTTY = 3 unless defined $CreateTTY;
417 $CommandSet = '580' unless defined $CommandSet;
419 warnLevel($warnLevel);
421 signalLevel($signalLevel);
424 defined $ENV{PAGER} ? $ENV{PAGER} :
425 eval { require Config } &&
426 defined $Config::Config{pager} ? $Config::Config{pager}
428 ) unless defined $pager;
430 &recallCommand("!") unless defined $prc;
431 &shellBang("!") unless defined $psh;
433 $maxtrace = 400 unless defined $maxtrace;
434 $ini_pids = $ENV{PERLDB_PIDS};
435 if (defined $ENV{PERLDB_PIDS}) {
436 $pids = "[$ENV{PERLDB_PIDS}]";
437 $ENV{PERLDB_PIDS} .= "->$$";
440 $ENV{PERLDB_PIDS} = "$$";
445 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
447 if (-e "/dev/tty") { # this is the wrong metric!
450 $rcfile="perldb.ini";
453 # This isn't really safe, because there's a race
454 # between checking and opening. The solution is to
455 # open and fstat the handle, but then you have to read and
456 # eval the contents. But then the silly thing gets
457 # your lexical scope, which is unfortunately at best.
461 # Just exactly what part of the word "CORE::" don't you understand?
462 local $SIG{__WARN__};
465 unless (is_safe_file($file)) {
466 CORE::warn <<EO_GRIPE;
467 perldb: Must not source insecure rcfile $file.
468 You or the superuser must be the owner, and it must not
469 be writable by anyone but its owner.
475 CORE::warn("perldb: couldn't parse $file: $@") if $@;
479 # Verifies that owner is either real user or superuser and that no
480 # one but owner may write to it. This function is of limited use
481 # when called on a path instead of upon a handle, because there are
482 # no guarantees that filename (by dirent) whose file (by ino) is
483 # eventually accessed is the same as the one tested.
484 # Assumes that the file's existence is not in doubt.
487 stat($path) || return; # mysteriously vaporized
488 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
490 return 0 if $uid != 0 && $uid != $<;
491 return 0 if $mode & 022;
496 safe_do("./$rcfile");
498 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
499 safe_do("$ENV{HOME}/$rcfile");
501 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
502 safe_do("$ENV{LOGDIR}/$rcfile");
505 if (defined $ENV{PERLDB_OPTS}) {
506 parse_options($ENV{PERLDB_OPTS});
509 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
510 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
511 *get_fork_TTY = \&xterm_get_fork_TTY;
512 } elsif ($^O eq 'os2') {
513 *get_fork_TTY = \&os2_get_fork_TTY;
516 # Here begin the unreadable code. It needs fixing.
518 if (exists $ENV{PERLDB_RESTART}) {
519 delete $ENV{PERLDB_RESTART};
521 @hist = get_list('PERLDB_HIST');
522 %break_on_load = get_list("PERLDB_ON_LOAD");
523 %postponed = get_list("PERLDB_POSTPONE");
524 my @had_breakpoints= get_list("PERLDB_VISITED");
525 for (0 .. $#had_breakpoints) {
526 my %pf = get_list("PERLDB_FILE_$_");
527 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
529 my %opt = get_list("PERLDB_OPT");
531 while (($opt,$val) = each %opt) {
532 $val =~ s/[\\\']/\\$1/g;
533 parse_options("$opt'$val'");
535 @INC = get_list("PERLDB_INC");
537 $pretype = [get_list("PERLDB_PRETYPE")];
538 $pre = [get_list("PERLDB_PRE")];
539 $post = [get_list("PERLDB_POST")];
540 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
546 # Is Perl being run from a slave editor or graphical debugger?
547 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
548 $rl = 0, shift(@main::ARGV) if $slave_editor;
550 #require Term::ReadLine;
552 if ($^O eq 'cygwin') {
553 # /dev/tty is binary. use stdin for textmode
555 } elsif (-e "/dev/tty") {
556 $console = "/dev/tty";
557 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
559 } elsif ($^O eq 'MacOS') {
560 if ($MacPerl::Version !~ /MPW/) {
561 $console = "Dev:Console:Perl Debug"; # Separate window for application
563 $console = "Dev:Console";
566 $console = "sys\$command";
569 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
573 if ($^O eq 'NetWare') {
578 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
586 $console = $tty if defined $tty;
588 if (defined $remoteport) {
590 $OUT = new IO::Socket::INET( Timeout => '10',
591 PeerAddr => $remoteport,
594 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
597 create_IN_OUT(4) if $CreateTTY & 4;
599 my ($i, $o) = split /,/, $console;
600 $o = $i unless defined $o;
601 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
602 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
603 || open(OUT,">&STDOUT"); # so we don't dongle stdout
604 } elsif (not defined $console) {
606 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
607 $console = 'STDIN/OUT';
609 # so open("|more") can read from STDOUT and so we don't dingle stdin
610 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
612 my $previous = select($OUT);
613 $| = 1; # for DB::OUT
616 $LINEINFO = $OUT unless defined $LINEINFO;
617 $lineinfo = $console unless defined $lineinfo;
619 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
620 unless ($runnonstop) {
623 if ($term_pid eq '-1') {
624 print $OUT "\nDaughter DB session started...\n";
626 print $OUT "\nLoading DB routines from $header\n";
627 print $OUT ("Editor support ",
628 $slave_editor ? "enabled" : "available",
630 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
638 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
641 if (defined &afterinit) { # May be defined in $rcfile
647 ############################################################ Subroutines
650 # _After_ the perl program is compiled, $single is set to 1:
651 if ($single and not $second_time++) {
652 if ($runnonstop) { # Disable until signal
653 for ($i=0; $i <= $stack_depth; ) {
657 # return; # Would not print trace!
658 } elsif ($ImmediateStop) {
663 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
665 ($package, $filename, $line) = caller;
666 $filename_ini = $filename;
667 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
668 "package $package;"; # this won't let them modify, alas
669 local(*dbline) = $main::{'_<' . $filename};
671 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
675 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
676 $dbline{$line} =~ s/;9($|\0)/$1/;
679 my $was_signal = $signal;
681 for (my $n = 0; $n <= $#to_watch; $n++) {
682 $evalarg = $to_watch[$n];
683 local $onetimeDump; # Do not output results
684 my ($val) = &eval; # Fix context (&eval is doing array)?
685 $val = ( (defined $val) ? "'$val'" : 'undef' );
686 if ($val ne $old_watch[$n]) {
689 Watchpoint $n:\t$to_watch[$n] changed:
690 old value:\t$old_watch[$n]
693 $old_watch[$n] = $val;
697 if ($trace & 4) { # User-installed watch
698 return if watchfunction($package, $filename, $line)
699 and not $single and not $was_signal and not ($trace & ~4);
701 $was_signal = $signal;
703 if ($single || ($trace & 1) || $was_signal) {
705 $position = "\032\032$filename:$line:0\n";
706 print_lineinfo($position);
707 } elsif ($package eq 'DB::fake') {
710 Debugged program terminated. Use B<q> to quit or B<R> to restart,
711 use B<O> I<inhibit_exit> to avoid stopping after program termination,
712 B<h q>, B<h R> or B<h O> to get additional info.
715 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
716 "package $package;"; # this won't let them modify, alas
719 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
720 $prefix .= "$sub($filename:";
721 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
722 if (length($prefix) > 30) {
723 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
728 $position = "$prefix$line$infix$dbline[$line]$after";
731 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
733 print_lineinfo($position);
735 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
736 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
738 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
739 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
740 $position .= $incr_pos;
742 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
744 print_lineinfo($incr_pos);
749 $evalarg = $action, &eval if $action;
750 if ($single || $was_signal) {
751 local $level = $level + 1;
752 foreach $evalarg (@$pre) {
755 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
758 $incr = -1; # for backward motion.
759 @typeahead = (@$pretype, @typeahead);
761 while (($term || &setterm),
762 ($term_pid == $$ or resetterm(1)),
763 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
764 ($#hist+1) . ('>' x $level) . " ")))
768 $cmd =~ s/\\$/\n/ && do {
769 $cmd .= &readline(" cont: ");
772 $cmd =~ /^$/ && ($cmd = $laststep);
773 push(@hist,$cmd) if length($cmd) > 1;
775 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
776 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
777 ($i) = split(/\s+/,$cmd);
779 # squelch the sigmangler
781 local $SIG{__WARN__};
782 eval "\$cmd =~ $alias{$i}";
785 print $OUT "Couldn't evaluate `$i' alias: $@";
789 $cmd =~ /^q$/ && ($fall_off_end = 1) && clean_ENV() && exit $?;
790 $cmd =~ /^t$/ && do {
793 print $OUT "Trace = " .
794 (($trace & 1) ? "on" : "off" ) . "\n";
796 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
797 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
800 foreach $subname (sort(keys %sub)) {
801 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
802 print $OUT $subname,"\n";
806 $cmd =~ s/^X\b/V $package/;
807 $cmd =~ /^V$/ && do {
808 $cmd = "V $package"; };
809 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
810 local ($savout) = select($OUT);
812 @vars = split(' ',$2);
813 do 'dumpvar.pl' unless defined &main::dumpvar;
814 if (defined &main::dumpvar) {
817 # must detect sigpipe failures
818 eval { &main::dumpvar($packname,@vars) };
820 die unless $@ =~ /dumpvar print failed/;
823 print $OUT "dumpvar.pl not available.\n";
827 $cmd =~ s/^x\b/ / && do { # So that will be evaled
828 $onetimeDump = 'dump';
829 # handle special "x 3 blah" syntax
830 if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
831 $onetimedumpDepth = $1;
834 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
835 methods($1); next CMD};
836 $cmd =~ s/^m\b/ / && do { # So this will be evaled
837 $onetimeDump = 'methods'; };
838 $cmd =~ /^f\b\s*(.*)/ && do {
842 print $OUT "The old f command is now the r command.\n"; # hint
843 print $OUT "The new f command switches filenames.\n";
846 if (!defined $main::{'_<' . $file}) {
847 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
848 $try = substr($try,2);
849 print $OUT "Choosing $try matching `$file':\n";
853 if (!defined $main::{'_<' . $file}) {
854 print $OUT "No file matching `$file' is loaded.\n";
856 } elsif ($file ne $filename) {
857 *dbline = $main::{'_<' . $file};
863 print $OUT "Already in $file.\n";
867 $cmd =~ /^\.$/ && do {
868 $incr = -1; # for backward motion.
870 $filename = $filename_ini;
871 *dbline = $main::{'_<' . $filename};
873 print_lineinfo($position);
875 $cmd =~ /^-$/ && do {
876 $start -= $incr + $window + 1;
877 $start = 1 if $start <= 0;
879 $cmd = 'l ' . ($start) . '+'; };
881 $cmd =~ /^([aAbBDhlLMoOvwW])\b\s*(.*)/s && do {
882 &cmd_wrapper($1, $2, $line);
886 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
887 push @$pre, action($1);
889 $cmd =~ /^>>\s*(.*)/ && do {
890 push @$post, action($1);
892 $cmd =~ /^<\s*(.*)/ && do {
894 print $OUT "All < actions cleared.\n";
900 print $OUT "No pre-prompt Perl actions.\n";
903 print $OUT "Perl commands run before each prompt:\n";
904 for my $action ( @$pre ) {
905 print $OUT "\t< -- $action\n";
911 $cmd =~ /^>\s*(.*)/ && do {
913 print $OUT "All > actions cleared.\n";
919 print $OUT "No post-prompt Perl actions.\n";
922 print $OUT "Perl commands run after each prompt:\n";
923 for my $action ( @$post ) {
924 print $OUT "\t> -- $action\n";
928 $post = [action($1)];
930 $cmd =~ /^\{\{\s*(.*)/ && do {
931 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
932 print $OUT "{{ is now a debugger command\n",
933 "use `;{{' if you mean Perl code\n";
939 $cmd =~ /^\{\s*(.*)/ && do {
941 print $OUT "All { actions cleared.\n";
947 print $OUT "No pre-prompt debugger actions.\n";
950 print $OUT "Debugger commands run before each prompt:\n";
951 for my $action ( @$pretype ) {
952 print $OUT "\t{ -- $action\n";
956 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
957 print $OUT "{ is now a debugger command\n",
958 "use `;{' if you mean Perl code\n";
964 $cmd =~ /^n$/ && do {
965 end_report(), next CMD if $finished and $level <= 1;
969 $cmd =~ /^s$/ && do {
970 end_report(), next CMD if $finished and $level <= 1;
974 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
975 end_report(), next CMD if $finished and $level <= 1;
977 # Probably not needed, since we finish an interactive
978 # sub-session anyway...
979 # local $filename = $filename;
980 # local *dbline = *dbline; # XXX Would this work?!
981 if ($subname =~ /\D/) { # subroutine name
982 $subname = $package."::".$subname
983 unless $subname =~ /::/;
984 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
988 *dbline = $main::{'_<' . $filename};
989 $had_breakpoints{$filename} |= 1;
991 ++$i while $dbline[$i] == 0 && $i < $max;
993 print $OUT "Subroutine $subname not found.\n";
998 if ($dbline[$i] == 0) {
999 print $OUT "Line $i not breakable.\n";
1002 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1004 for ($i=0; $i <= $stack_depth; ) {
1008 $cmd =~ /^r$/ && do {
1009 end_report(), next CMD if $finished and $level <= 1;
1010 $stack[$stack_depth] |= 1;
1011 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1013 $cmd =~ /^R$/ && do {
1014 print $OUT "Warning: some settings and command-line options may be lost!\n";
1015 my (@script, @flags, $cl);
1016 push @flags, '-w' if $ini_warn;
1017 # Put all the old includes at the start to get
1018 # the same debugger.
1020 push @flags, '-I', $_;
1022 push @flags, '-T' if ${^TAINT};
1023 # Arrange for setting the old INC:
1024 set_list("PERLDB_INC", @ini_INC);
1026 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1027 chomp ($cl = ${'::_<-e'}[$_]);
1028 push @script, '-e', $cl;
1033 set_list("PERLDB_HIST",
1034 $term->Features->{getHistory}
1035 ? $term->GetHistory : @hist);
1036 my @had_breakpoints = keys %had_breakpoints;
1037 set_list("PERLDB_VISITED", @had_breakpoints);
1038 set_list("PERLDB_OPT", %option);
1039 set_list("PERLDB_ON_LOAD", %break_on_load);
1041 for (0 .. $#had_breakpoints) {
1042 my $file = $had_breakpoints[$_];
1043 *dbline = $main::{'_<' . $file};
1044 next unless %dbline or $postponed_file{$file};
1045 (push @hard, $file), next
1046 if $file =~ /^\(\w*eval/;
1048 @add = %{$postponed_file{$file}}
1049 if $postponed_file{$file};
1050 set_list("PERLDB_FILE_$_", %dbline, @add);
1052 for (@hard) { # Yes, really-really...
1053 # Find the subroutines in this eval
1054 *dbline = $main::{'_<' . $_};
1055 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1056 for $sub (keys %sub) {
1057 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1058 $subs{$sub} = [$1, $2];
1062 "No subroutines in $_, ignoring breakpoints.\n";
1065 LINES: for $line (keys %dbline) {
1066 # One breakpoint per sub only:
1067 my ($offset, $sub, $found);
1068 SUBS: for $sub (keys %subs) {
1069 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1070 and (not defined $offset # Not caught
1071 or $offset < 0 )) { # or badly caught
1073 $offset = $line - $subs{$sub}->[0];
1074 $offset = "+$offset", last SUBS if $offset >= 0;
1077 if (defined $offset) {
1078 $postponed{$found} =
1079 "break $offset if $dbline{$line}";
1081 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1085 set_list("PERLDB_POSTPONE", %postponed);
1086 set_list("PERLDB_PRETYPE", @$pretype);
1087 set_list("PERLDB_PRE", @$pre);
1088 set_list("PERLDB_POST", @$post);
1089 set_list("PERLDB_TYPEAHEAD", @typeahead);
1090 $ENV{PERLDB_RESTART} = 1;
1091 delete $ENV{PERLDB_PIDS}; # Restore ini state
1092 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1093 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1094 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1095 print $OUT "exec failed: $!\n";
1097 $cmd =~ /^T$/ && do {
1098 print_trace($OUT, 1); # skip DB
1100 $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w($1); next CMD; };
1101 $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W($1); next CMD; };
1102 $cmd =~ /^\/(.*)$/ && do {
1104 $inpat =~ s:([^\\])/$:$1:;
1106 # squelch the sigmangler
1107 local $SIG{__DIE__};
1108 local $SIG{__WARN__};
1109 eval '$inpat =~ m'."\a$inpat\a";
1121 $start = 1 if ($start > $max);
1122 last if ($start == $end);
1123 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1124 if ($slave_editor) {
1125 print $OUT "\032\032$filename:$start:0\n";
1127 print $OUT "$start:\t", $dbline[$start], "\n";
1132 print $OUT "/$pat/: not found\n" if ($start == $end);
1134 $cmd =~ /^\?(.*)$/ && do {
1136 $inpat =~ s:([^\\])\?$:$1:;
1138 # squelch the sigmangler
1139 local $SIG{__DIE__};
1140 local $SIG{__WARN__};
1141 eval '$inpat =~ m'."\a$inpat\a";
1153 $start = $max if ($start <= 0);
1154 last if ($start == $end);
1155 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1156 if ($slave_editor) {
1157 print $OUT "\032\032$filename:$start:0\n";
1159 print $OUT "$start:\t", $dbline[$start], "\n";
1164 print $OUT "?$pat?: not found\n" if ($start == $end);
1166 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1167 pop(@hist) if length($cmd) > 1;
1168 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1170 print $OUT $cmd, "\n";
1172 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1175 $cmd =~ /^$rc([^$rc].*)$/ && do {
1177 pop(@hist) if length($cmd) > 1;
1178 for ($i = $#hist; $i; --$i) {
1179 last if $hist[$i] =~ /$pat/;
1182 print $OUT "No such command!\n\n";
1186 print $OUT $cmd, "\n";
1188 $cmd =~ /^$sh$/ && do {
1189 &system($ENV{SHELL}||"/bin/sh");
1191 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1192 # XXX: using csh or tcsh destroys sigint retvals!
1193 #&system($1); # use this instead
1194 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1196 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1197 $end = $2 ? ($#hist-$2) : 0;
1198 $hist = 0 if $hist < 0;
1199 for ($i=$#hist; $i>$end; $i--) {
1200 print $OUT "$i: ",$hist[$i],"\n"
1201 unless $hist[$i] =~ /^.?$/;
1204 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1207 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1208 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1209 $cmd =~ s/^=\s*// && do {
1211 if (length $cmd == 0) {
1212 @keys = sort keys %alias;
1213 } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1214 # can't use $_ or kill //g state
1215 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1216 $alias{$k} = "s\a$k\a$v\a";
1217 # squelch the sigmangler
1218 local $SIG{__DIE__};
1219 local $SIG{__WARN__};
1220 unless (eval "sub { s\a$k\a$v\a }; 1") {
1221 print $OUT "Can't alias $k to $v: $@\n";
1230 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1231 print $OUT "$k\t= $1\n";
1233 elsif (defined $alias{$k}) {
1234 print $OUT "$k\t$alias{$k}\n";
1237 print "No alias for $k\n";
1241 $cmd =~ /^\@\s*(.*\S)/ && do {
1242 if (open my $fh, $1) {
1245 &warn("Can't execute `$1': $!\n");
1248 $cmd =~ /^\|\|?\s*[^|]/ && do {
1249 if ($pager =~ /^\|/) {
1250 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1251 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1253 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1256 unless ($piped=open(OUT,$pager)) {
1257 &warn("Can't pipe output to `$pager'");
1258 if ($pager =~ /^\|/) {
1259 open(OUT,">&STDOUT") # XXX: lost message
1260 || &warn("Can't restore DB::OUT");
1261 open(STDOUT,">&SAVEOUT")
1262 || &warn("Can't restore STDOUT");
1265 open(OUT,">&STDOUT") # XXX: lost message
1266 || &warn("Can't restore DB::OUT");
1270 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1271 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1272 $selected= select(OUT);
1274 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1275 $cmd =~ s/^\|+\s*//;
1278 # XXX Local variants do not work!
1279 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1280 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1281 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1283 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1285 $onetimeDump = undef;
1286 $onetimedumpDepth = undef;
1287 } elsif ($term_pid == $$) {
1292 if ($pager =~ /^\|/) {
1294 # we cannot warn here: the handle is missing --tchrist
1295 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1297 # most of the $? crud was coping with broken cshisms
1299 print SAVEOUT "Pager `$pager' failed: ";
1301 print SAVEOUT "shell returned -1\n";
1304 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1305 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1307 print SAVEOUT "status ", ($? >> 8), "\n";
1311 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1312 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1313 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1314 # Will stop ignoring SIGPIPE if done like nohup(1)
1315 # does SIGINT but Perl doesn't give us a choice.
1317 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1320 select($selected), $selected= "" unless $selected eq "";
1324 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1325 foreach $evalarg (@$post) {
1328 } # if ($single || $signal)
1329 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1333 # The following code may be executed now:
1337 my ($al, $ret, @ret) = "";
1338 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1341 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1342 $#stack = $stack_depth;
1343 $stack[-1] = $single;
1345 $single |= 4 if $stack_depth == $deep;
1347 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1348 # Why -1? But it works! :-(
1349 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1350 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1353 $single |= $stack[$stack_depth--];
1355 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1356 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1357 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1358 if ($doret eq $stack_depth or $frame & 16) {
1360 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1361 print $fh ' ' x $stack_depth if $frame & 16;
1362 print $fh "list context return from $sub:\n";
1363 dumpit($fh, \@ret );
1368 if (defined wantarray) {
1373 $single |= $stack[$stack_depth--];
1375 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1376 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1377 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1378 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1380 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1381 print $fh (' ' x $stack_depth) if $frame & 16;
1382 print $fh (defined wantarray
1383 ? "scalar context return from $sub: "
1384 : "void context return from $sub\n");
1385 dumpit( $fh, $ret ) if defined wantarray;
1394 ### Functions with multiple modes of failure die on error, the rest
1395 ### returns FALSE on error.
1396 ### User-interface functions cmd_* output error message.
1398 ### Note all cmd_[a-zA-Z]'s require $line, $dblineno as first arguments
1403 'A' => 'pre580_null',
1405 'B' => 'pre580_null',
1406 'd' => 'pre580_null',
1409 'M' => 'pre580_null',
1411 'o' => 'pre580_null',
1421 my $dblineno = shift;
1423 # with this level of indirection we can wrap
1424 # to old (pre580) or other command sets easily
1427 $set{$CommandSet}{$cmd} || $cmd
1429 # print "rjsf: cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
1431 return &$call($line, $dblineno);
1435 my $line = shift || ''; # [.|line] expr
1436 my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
1437 if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
1438 my ($lineno, $expr) = ($1, $2);
1440 if ($dbline[$lineno] == 0) {
1441 print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
1443 $had_breakpoints{$filename} |= 2;
1444 $dbline{$lineno} =~ s/\0[^\0]*//;
1445 $dbline{$lineno} .= "\0" . action($expr);
1449 print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
1454 my $line = shift || '';
1455 my $dbline = shift; $line =~ s/^\./$dbline/;
1457 eval { &delete_action(); 1 } or print $OUT $@ and return;
1458 } elsif ($line =~ /^(\S.*)/) {
1459 eval { &delete_action($1); 1 } or print $OUT $@ and return;
1461 print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
1468 die "Line $i has no action .\n" if $dbline[$i] == 0;
1469 $dbline{$i} =~ s/\0[^\0]*//; # \^a
1470 delete $dbline{$i} if $dbline{$i} eq '';
1472 print $OUT "Deleting all actions...\n";
1473 for my $file (keys %had_breakpoints) {
1474 local *dbline = $main::{'_<' . $file};
1477 for ($i = 1; $i <= $max ; $i++) {
1478 if (defined $dbline{$i}) {
1479 $dbline{$i} =~ s/\0[^\0]*//;
1480 delete $dbline{$i} if $dbline{$i} eq '';
1482 unless ($had_breakpoints{$file} &= ~2) {
1483 delete $had_breakpoints{$file};
1491 my $line = shift; # [.|line] [cond]
1492 my $dbline = shift; $line =~ s/^\./$dbline/;
1493 if ($line =~ /^\s*$/) {
1494 &cmd_b_line($dbline, 1);
1495 } elsif ($line =~ /^load\b\s*(.*)/) {
1496 my $file = $1; $file =~ s/\s+$//;
1498 } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
1499 my $cond = length $3 ? $3 : '1';
1500 my ($subname, $break) = ($2, $1 eq 'postpone');
1501 $subname =~ s/\'/::/g;
1502 $subname = "${'package'}::" . $subname unless $subname =~ /::/;
1503 $subname = "main".$subname if substr($subname,0,2) eq "::";
1504 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
1505 } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
1507 $cond = length $2 ? $2 : '1';
1508 &cmd_b_sub($subname, $cond);
1509 } elsif ($line =~ /^(\d*)\s*(.*)/) {
1510 $line = $1 || $dbline;
1511 $cond = length $2 ? $2 : '1';
1512 &cmd_b_line($line, $cond);
1514 print "confused by line($line)?\n";
1520 $break_on_load{$file} = 1;
1521 $had_breakpoints{$file} |= 1;
1524 sub report_break_on_load {
1525 sort keys %break_on_load;
1533 push @files, $::INC{$file} if $::INC{$file};
1534 $file .= '.pm', redo unless $file =~ /\./;
1536 break_on_load($_) for @files;
1537 @files = report_break_on_load;
1540 print $OUT "Will stop on load of `@files'.\n";
1543 $filename_error = '';
1545 sub breakable_line {
1546 my ($from, $to) = @_;
1549 my $delta = $from < $to ? +1 : -1;
1550 my $limit = $delta > 0 ? $#dbline : 1;
1551 $limit = $to if ($limit - $to) * $delta > 0;
1552 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1554 return $i unless $dbline[$i] == 0;
1555 my ($pl, $upto) = ('', '');
1556 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1557 die "Line$pl $from$upto$filename_error not breakable\n";
1560 sub breakable_line_in_filename {
1562 local *dbline = $main::{'_<' . $f};
1563 local $filename_error = " of `$f'";
1568 my ($i, $cond) = @_;
1569 $cond = 1 unless @_ >= 2;
1573 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1574 $had_breakpoints{$filename} |= 1;
1575 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1576 else { $dbline{$i} = $cond; }
1580 eval { break_on_line(@_); 1 } or do {
1582 print $OUT $@ and return;
1586 sub break_on_filename_line {
1587 my ($f, $i, $cond) = @_;
1588 $cond = 1 unless @_ >= 3;
1589 local *dbline = $main::{'_<' . $f};
1590 local $filename_error = " of `$f'";
1591 local $filename = $f;
1592 break_on_line($i, $cond);
1595 sub break_on_filename_line_range {
1596 my ($f, $from, $to, $cond) = @_;
1597 my $i = breakable_line_in_filename($f, $from, $to);
1598 $cond = 1 unless @_ >= 3;
1599 break_on_filename_line($f,$i,$cond);
1602 sub subroutine_filename_lines {
1603 my ($subname,$cond) = @_;
1604 # Filename below can contain ':'
1605 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1608 sub break_subroutine {
1609 my $subname = shift;
1610 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1611 die "Subroutine $subname not found.\n";
1612 $cond = 1 unless @_ >= 2;
1613 break_on_filename_line_range($file,$s,$e,@_);
1617 my ($subname,$cond) = @_;
1618 $cond = 1 unless @_ >= 2;
1619 unless (ref $subname eq 'CODE') {
1620 $subname =~ s/\'/::/g;
1622 $subname = "${'package'}::" . $subname
1623 unless $subname =~ /::/;
1624 $subname = "CORE::GLOBAL::$s"
1625 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1626 $subname = "main".$subname if substr($subname,0,2) eq "::";
1628 eval { break_subroutine($subname,$cond); 1 } or do {
1630 print $OUT $@ and return;
1635 my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
1636 my $dbline = shift; $line =~ s/^\./$dbline/;
1638 eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
1639 } elsif ($line =~ /^(\S.*)/) {
1640 eval { &delete_breakpoint($line || $dbline); 1 } or do {
1642 print $OUT $@ and return;
1645 print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
1649 sub delete_breakpoint {
1652 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1653 $dbline{$i} =~ s/^[^\0]*//;
1654 delete $dbline{$i} if $dbline{$i} eq '';
1656 print $OUT "Deleting all breakpoints...\n";
1657 for my $file (keys %had_breakpoints) {
1658 local *dbline = $main::{'_<' . $file};
1661 for ($i = 1; $i <= $max ; $i++) {
1662 if (defined $dbline{$i}) {
1663 $dbline{$i} =~ s/^[^\0]+//;
1664 if ($dbline{$i} =~ s/^\0?$//) {
1669 if (not $had_breakpoints{$file} &= ~1) {
1670 delete $had_breakpoints{$file};
1674 undef %postponed_file;
1675 undef %break_on_load;
1679 sub cmd_stop { # As on ^C, but not signal-safy.
1684 my $line = shift || '';
1685 if ($line =~ /^h\s*/) {
1687 } elsif ($line =~ /^(\S.*)$/) {
1688 # support long commands; otherwise bogus errors
1689 # happen when you ask for h on <CR> for example
1690 my $asked = $1; # for proper errmsg
1691 my $qasked = quotemeta($asked); # for searching
1692 # XXX: finds CR but not <CR>
1693 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
1694 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
1698 print_help("B<$asked> is not a debugger command.\n");
1701 print_help($summary);
1707 $line =~ s/^-\s*$/-/;
1708 if ($line =~ /^(\$.*)/s) {
1711 print($OUT "Error: $@\n"), next CMD if $@;
1713 print($OUT "Interpreted as: $1 $s\n");
1716 } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
1717 my $s = $subname = $1;
1718 $subname =~ s/\'/::/;
1719 $subname = $package."::".$subname
1720 unless $subname =~ /::/;
1721 $subname = "CORE::GLOBAL::$s"
1722 if not defined &$subname and $s !~ /::/
1723 and defined &{"CORE::GLOBAL::$s"};
1724 $subname = "main".$subname if substr($subname,0,2) eq "::";
1725 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
1726 $subrange = pop @pieces;
1727 $file = join(':', @pieces);
1728 if ($file ne $filename) {
1729 print $OUT "Switching to file '$file'.\n"
1730 unless $slave_editor;
1731 *dbline = $main::{'_<' . $file};
1736 if (eval($subrange) < -$window) {
1737 $subrange =~ s/-.*/+/;
1742 print $OUT "Subroutine $subname not found.\n";
1744 } elsif ($line =~ /^\s*$/) {
1745 $incr = $window - 1;
1746 $line = $start . '-' . ($start + $incr);
1748 } elsif ($line =~ /^(\d*)\+(\d*)$/) {
1751 $incr = $window - 1 unless $incr;
1752 $line = $start . '-' . ($start + $incr);
1754 } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
1755 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
1756 $end = $max if $end > $max;
1758 $i = $line if $i eq '.';
1761 if ($slave_editor) {
1762 print $OUT "\032\032$filename:$i:0\n";
1765 for (; $i <= $end; $i++) {
1767 ($stop,$action) = split(/\0/, $dbline{$i}) if
1770 and $filename eq $filename_ini)
1772 : ($dbline[$i]+0 ? ':' : ' ') ;
1773 $arrow .= 'b' if $stop;
1774 $arrow .= 'a' if $action;
1775 print $OUT "$i$arrow\t", $dbline[$i];
1776 $i++, last if $signal;
1778 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
1780 $start = $i; # remember in case they want more
1781 $start = $max if $start > $max;
1786 my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
1787 my $action_wanted = ($arg =~ /a/) ? 1 : 0;
1788 my $break_wanted = ($arg =~ /b/) ? 1 : 0;
1789 my $watch_wanted = ($arg =~ /w/) ? 1 : 0;
1791 if ($break_wanted or $action_wanted) {
1792 for my $file (keys %had_breakpoints) {
1793 local *dbline = $main::{'_<' . $file};
1796 for ($i = 1; $i <= $max; $i++) {
1797 if (defined $dbline{$i}) {
1798 print $OUT "$file:\n" unless $was++;
1799 print $OUT " $i:\t", $dbline[$i];
1800 ($stop,$action) = split(/\0/, $dbline{$i});
1801 print $OUT " break if (", $stop, ")\n"
1802 if $stop and $break_wanted;
1803 print $OUT " action: ", $action, "\n"
1804 if $action and $action_wanted;
1810 if (%postponed and $break_wanted) {
1811 print $OUT "Postponed breakpoints in subroutines:\n";
1813 for $subname (keys %postponed) {
1814 print $OUT " $subname\t$postponed{$subname}\n";
1818 my @have = map { # Combined keys
1819 keys %{$postponed_file{$_}}
1820 } keys %postponed_file;
1821 if (@have and ($break_wanted or $action_wanted)) {
1822 print $OUT "Postponed breakpoints in files:\n";
1824 for $file (keys %postponed_file) {
1825 my $db = $postponed_file{$file};
1826 print $OUT " $file:\n";
1827 for $line (sort {$a <=> $b} keys %$db) {
1828 print $OUT " $line:\n";
1829 my ($stop,$action) = split(/\0/, $$db{$line});
1830 print $OUT " break if (", $stop, ")\n"
1831 if $stop and $break_wanted;
1832 print $OUT " action: ", $action, "\n"
1833 if $action and $action_wanted;
1839 if (%break_on_load and $break_wanted) {
1840 print $OUT "Breakpoints on load:\n";
1842 for $file (keys %break_on_load) {
1843 print $OUT " $file\n";
1847 if ($watch_wanted) {
1849 print $OUT "Watch-expressions:\n" if @to_watch;
1850 for my $expr (@to_watch) {
1851 print $OUT " $expr\n";
1863 my $opt = shift || ''; # opt[=val]
1864 if ($opt =~ /^(\S.*)/) {
1876 if ($line =~ /^(\d*)$/) {
1877 $incr = $window - 1;
1880 $line = $start . '-' . ($start + $incr);
1886 my $expr = shift || '';
1887 if ($expr =~ /^(\S.*)/) {
1888 push @to_watch, $expr;
1891 $val = (defined $val) ? "'$val'" : 'undef' ;
1892 push @old_watch, $val;
1895 print $OUT "Adding a watch-expression requires an expression\n"; # hint
1900 my $expr = shift || '';
1903 print $OUT "Deleting all watch expressions ...\n";
1904 @to_watch = @old_watch = ();
1905 } elsif ($expr =~ /^(\S.*)/) {
1907 foreach (@to_watch) {
1908 my $val = $to_watch[$i_cnt];
1909 if ($val eq $expr) { # =~ m/^\Q$i$/) {
1910 splice(@to_watch, $i_cnt, 1);
1915 print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
1919 ### END of the API section
1922 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1923 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1926 sub print_lineinfo {
1927 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1933 # The following takes its argument via $evalarg to preserve current @_
1936 my $subname = shift;
1937 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1938 my $offset = $1 || 0;
1939 # Filename below can contain ':'
1940 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1943 local *dbline = $main::{'_<' . $file};
1944 local $^W = 0; # != 0 is magical below
1945 $had_breakpoints{$file} |= 1;
1947 ++$i until $dbline[$i] != 0 or $i >= $max;
1948 $dbline{$i} = delete $postponed{$subname};
1951 print $OUT "Subroutine $subname not found.\n";
1955 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1956 #print $OUT "In postponed_sub for `$subname'.\n";
1960 if ($ImmediateStop) {
1964 return &postponed_sub
1965 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1966 # Cannot be done before the file is compiled
1967 local *dbline = shift;
1968 my $filename = $dbline;
1969 $filename =~ s/^_<//;
1971 $signal = 1, print $OUT "'$filename' loaded...\n"
1972 if $break_on_load{$filename};
1973 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1974 return unless $postponed_file{$filename};
1975 $had_breakpoints{$filename} |= 1;
1976 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1978 for $key (keys %{$postponed_file{$filename}}) {
1979 $dbline{$key} = ${$postponed_file{$filename}}{$key};
1981 delete $postponed_file{$filename};
1985 local ($savout) = select(shift);
1986 my $osingle = $single;
1987 my $otrace = $trace;
1988 $single = $trace = 0;
1991 unless (defined &main::dumpValue) {
1994 if (defined &main::dumpValue) {
1999 my $maxdepth = shift || $option{dumpDepth};
2000 $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
2001 &main::dumpValue($v, $maxdepth);
2004 print $OUT "dumpvar.pl not available.\n";
2011 # Tied method do not create a context, so may get wrong message:
2016 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
2017 my @sub = dump_trace($_[0] + 1, $_[1]);
2018 my $short = $_[2]; # Print short report, next one for sub name
2020 for ($i=0; $i <= $#sub; $i++) {
2023 my $args = defined $sub[$i]{args}
2024 ? "(@{ $sub[$i]{args} })"
2026 $args = (substr $args, 0, $maxtrace - 3) . '...'
2027 if length $args > $maxtrace;
2028 my $file = $sub[$i]{file};
2029 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
2031 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
2033 my $sub = @_ >= 4 ? $_[3] : $s;
2034 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
2036 print $fh "$sub[$i]{context} = $s$args" .
2037 " called from $file" .
2038 " line $sub[$i]{line}\n";
2045 my $count = shift || 1e9;
2048 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
2049 my $nothard = not $frame & 8;
2050 local $frame = 0; # Do not want to trace this.
2051 my $otrace = $trace;
2054 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
2059 if (not defined $arg) {
2061 } elsif ($nothard and tied $arg) {
2063 } elsif ($nothard and $type = ref $arg) {
2064 push @a, "ref($type)";
2066 local $_ = "$arg"; # Safe to stringify now - should not call f().
2069 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
2070 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
2071 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
2075 $context = $context ? '@' : (defined $context ? "\$" : '.');
2076 $args = $h ? [@a] : undef;
2077 $e =~ s/\n\s*\;\s*\Z// if $e;
2078 $e =~ s/([\\\'])/\\$1/g if $e;
2080 $sub = "require '$e'";
2081 } elsif (defined $r) {
2083 } elsif ($sub eq '(eval)') {
2084 $sub = "eval {...}";
2086 push(@sub, {context => $context, sub => $sub, args => $args,
2087 file => $file, line => $line});
2096 while ($action =~ s/\\$//) {
2105 # i hate using globals!
2106 $balanced_brace_re ||= qr{
2109 (?> [^{}] + ) # Non-parens without backtracking
2111 (??{ $balanced_brace_re }) # Group with matching parens
2115 return $_[0] !~ m/$balanced_brace_re/;
2119 &readline("cont: ");
2123 # We save, change, then restore STDIN and STDOUT to avoid fork() since
2124 # some non-Unix systems can do system() but have problems with fork().
2125 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
2126 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
2127 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
2128 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
2130 # XXX: using csh or tcsh destroys sigint retvals!
2132 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
2133 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
2138 # most of the $? crud was coping with broken cshisms
2140 &warn("(Command exited ", ($? >> 8), ")\n");
2142 &warn( "(Command died of SIG#", ($? & 127),
2143 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
2153 eval { require Term::ReadLine } or die $@;
2156 my ($i, $o) = split $tty, /,/;
2157 $o = $i unless defined $o;
2158 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
2159 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
2162 my $sel = select($OUT);
2166 eval "require Term::Rendezvous;" or die;
2167 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
2168 my $term_rv = new Term::Rendezvous $rv;
2170 $OUT = $term_rv->OUT;
2173 if ($term_pid eq '-1') { # In a TTY with another debugger
2177 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2179 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2181 $rl_attribs = $term->Attribs;
2182 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2183 if defined $rl_attribs->{basic_word_break_characters}
2184 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2185 $rl_attribs->{special_prefixes} = '$@&%';
2186 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2187 $rl_attribs->{completion_function} = \&db_complete;
2189 $LINEINFO = $OUT unless defined $LINEINFO;
2190 $lineinfo = $console unless defined $lineinfo;
2192 if ($term->Features->{setHistory} and "@hist" ne "?") {
2193 $term->SetHistory(@hist);
2195 ornaments($ornaments) if defined $ornaments;
2199 # Example get_fork_TTY functions
2200 sub xterm_get_fork_TTY {
2201 (my $name = $0) =~ s,^.*[/\\],,s;
2202 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2206 $pidprompt = ''; # Shown anyway in titlebar
2210 # This example function resets $IN, $OUT itself
2211 sub os2_get_fork_TTY {
2212 local $^F = 40; # XXXX Fixme!
2214 my ($in1, $out1, $in2, $out2);
2215 # Having -d in PERL5OPT would lead to a disaster...
2216 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2217 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2218 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2219 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2220 (my $name = $0) =~ s,^.*[/\\],,s;
2222 if ( pipe $in1, $out1 and pipe $in2, $out2
2223 # system P_SESSION will fail if there is another process
2224 # in the same session with a "dependent" asynchronous child session.
2225 and @args = ($rl, fileno $in1, fileno $out2,
2226 "Daughter Perl debugger $pids $name") and
2227 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2230 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2232 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2233 open IN, '<&=$in' or die "open <&=$in: \$!";
2234 \$| = 1; print while sysread IN, \$_, 1<<16;
2238 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2240 require Term::ReadKey if $rl;
2241 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2242 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2244 or warn "system P_SESSION: $!, $^E" and 0)
2245 and close $in1 and close $out2 ) {
2246 $pidprompt = ''; # Shown anyway in titlebar
2247 reset_IN_OUT($in2, $out1);
2249 return ''; # Indicate that reset_IN_OUT is called
2254 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2255 my $in = &get_fork_TTY if defined &get_fork_TTY;
2256 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2257 if (not defined $in) {
2259 print_help(<<EOP) if $why == 1;
2260 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2262 print_help(<<EOP) if $why == 2;
2263 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2264 This may be an asynchronous session, so the parent debugger may be active.
2266 print_help(<<EOP) if $why != 4;
2267 Since two debuggers fight for the same TTY, input is severely entangled.
2271 I know how to switch the output to a different window in xterms
2272 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2273 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2275 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2276 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2279 } elsif ($in ne '') {
2282 $console = ''; # Indicate no need to open-from-the-console
2287 sub resetterm { # We forked, so we need a different TTY
2289 my $systemed = $in > 1 ? '-' : '';
2291 $pids =~ s/\]/$systemed->$$]/;
2293 $pids = "[$term_pid->$$]";
2297 return unless $CreateTTY & $in;
2304 my $left = @typeahead;
2305 my $got = shift @typeahead;
2307 print $OUT "auto(-$left)", shift, $got, "\n";
2308 $term->AddHistory($got)
2309 if length($got) > 1 and defined $term->Features->{addHistory};
2315 my $line = CORE::readline($cmdfhs[-1]);
2316 defined $line ? (print $OUT ">> $line" and return $line)
2317 : close pop @cmdfhs;
2319 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2320 $OUT->write(join('', @_));
2322 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2326 $term->readline(@_);
2331 my ($opt, $val)= @_;
2332 $val = option_val($opt,'N/A');
2333 $val =~ s/([\\\'])/\\$1/g;
2334 printf $OUT "%20s = '%s'\n", $opt, $val;
2338 my ($opt, $default)= @_;
2340 if (defined $optionVars{$opt}
2341 and defined ${$optionVars{$opt}}) {
2342 $val = ${$optionVars{$opt}};
2343 } elsif (defined $optionAction{$opt}
2344 and defined &{$optionAction{$opt}}) {
2345 $val = &{$optionAction{$opt}}();
2346 } elsif (defined $optionAction{$opt}
2347 and not defined $option{$opt}
2348 or defined $optionVars{$opt}
2349 and not defined ${$optionVars{$opt}}) {
2352 $val = $option{$opt};
2354 $val = $default unless defined $val;
2361 # too dangerous to let intuitive usage overwrite important things
2362 # defaultion should never be the default
2363 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2364 dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2365 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2370 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2371 my ($opt,$sep) = ($1,$2);
2374 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2376 #&dump_option($opt);
2377 } elsif ($sep !~ /\S/) {
2379 $val = "1"; # this is an evil default; make 'em set it!
2380 } elsif ($sep eq "=") {
2381 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2383 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2387 print OUT qq(Option better cleared using $opt=""\n)
2391 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2392 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2393 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2394 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2395 ($val = $1) =~ s/\\([\\$end])/$1/g;
2399 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2400 || grep( /^\Q$opt/i && ($option = $_), @options );
2402 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2403 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2405 if ($opt_needs_val{$option} && $val_defaulted) {
2406 my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
2407 print $OUT "Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
2411 $option{$option} = $val if defined $val;
2416 require '$optionRequire{$option}';
2418 } || die # XXX: shouldn't happen
2419 if defined $optionRequire{$option} &&
2422 ${$optionVars{$option}} = $val
2423 if defined $optionVars{$option} &&
2426 &{$optionAction{$option}} ($val)
2427 if defined $optionAction{$option} &&
2428 defined &{$optionAction{$option}} &&
2432 dump_option($option) unless $OUT eq \*STDERR;
2437 my ($stem,@list) = @_;
2439 $ENV{"${stem}_n"} = @list;
2440 for $i (0 .. $#list) {
2442 $val =~ s/\\/\\\\/g;
2443 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2444 $ENV{"${stem}_$i"} = $val;
2451 my $n = delete $ENV{"${stem}_n"};
2453 for $i (0 .. $n - 1) {
2454 $val = delete $ENV{"${stem}_$i"};
2455 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2463 return; # Put nothing on the stack - malloc/free land!
2467 my($msg)= join("",@_);
2468 $msg .= ": $!\n" unless $msg =~ /\n$/;
2474 my $switch_li = $LINEINFO eq $OUT;
2475 if ($term and $term->Features->{newTTY}) {
2476 ($IN, $OUT) = (shift, shift);
2477 $term->newTTY($IN, $OUT);
2479 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2481 ($IN, $OUT) = (shift, shift);
2483 my $o = select $OUT;
2486 $LINEINFO = $OUT if $switch_li;
2490 if (@_ and $term and $term->Features->{newTTY}) {
2491 my ($in, $out) = shift;
2493 ($in, $out) = split /,/, $in, 2;
2497 open IN, $in or die "cannot open `$in' for read: $!";
2498 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2499 reset_IN_OUT(\*IN,\*OUT);
2502 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2503 # Useful if done through PERLDB_OPTS:
2504 $console = $tty = shift if @_;
2510 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2512 $notty = shift if @_;
2518 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2526 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2528 $remoteport = shift if @_;
2533 if (${$term->Features}{tkRunning}) {
2534 return $term->tkRunning(@_);
2537 print $OUT "tkRunning not supported by current ReadLine package.\n";
2544 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2546 $runnonstop = shift if @_;
2553 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2560 $sh = quotemeta shift;
2561 $sh .= "\\b" if $sh =~ /\w$/;
2565 $psh =~ s/\\(.)/$1/g;
2570 if (defined $term) {
2571 local ($warnLevel,$dieLevel) = (0, 1);
2572 return '' unless $term->Features->{ornaments};
2573 eval { $term->ornaments(@_) } || '';
2581 $rc = quotemeta shift;
2582 $rc .= "\\b" if $rc =~ /\w$/;
2586 $prc =~ s/\\(.)/$1/g;
2591 return $lineinfo unless @_;
2593 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2594 $slave_editor = ($stream =~ /^\|/);
2595 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2596 $LINEINFO = \*LINEINFO;
2597 my $save = select($LINEINFO);
2603 sub list_modules { # versions
2611 s/^Term::ReadLine::readline$/readline/;
2612 if (defined ${ $_ . '::VERSION' }) {
2613 $version{$file} = "${ $_ . '::VERSION' } from ";
2615 $version{$file} .= $INC{$file};
2617 dumpit($OUT,\%version);
2621 # XXX: make sure there are tabs between the command and explanation,
2622 # or print_help will screw up your formatting if you have
2623 # eeevil ornaments enabled. This is an insane mess.
2626 Help is currently only available for the new 580 CommandSet,
2627 if you really want old behaviour, presumably you know what
2631 B<s> [I<expr>] Single step [in I<expr>].
2632 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2633 <B<CR>> Repeat last B<n> or B<s> command.
2634 B<r> Return from current subroutine.
2635 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2636 at the specified position.
2637 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2638 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2639 B<l> I<line> List single I<line>.
2640 B<l> I<subname> List first window of lines from subroutine.
2641 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2642 B<l> List next window of lines.
2643 B<-> List previous window of lines.
2644 B<v> [I<line>] View window around I<line>.
2645 B<.> Return to the executed line.
2646 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2647 I<filename> may be either the full name of the file, or a regular
2648 expression matching the full file name:
2649 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2650 Evals (with saved bodies) are considered to be filenames:
2651 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2652 (in the order of execution).
2653 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2654 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2655 B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions.
2656 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2657 B<t> Toggle trace mode.
2658 B<t> I<expr> Trace through execution of I<expr>.
2659 B<b> Sets breakpoint on current line)
2660 B<b> [I<line>] [I<condition>]
2661 Set breakpoint; I<line> defaults to the current execution line;
2662 I<condition> breaks if it evaluates to true, defaults to '1'.
2663 B<b> I<subname> [I<condition>]
2664 Set breakpoint at first line of subroutine.
2665 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2666 B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
2667 B<b> B<postpone> I<subname> [I<condition>]
2668 Set breakpoint at first line of subroutine after
2670 B<b> B<compile> I<subname>
2671 Stop after the subroutine is compiled.
2672 B<B> [I<line>] Delete the breakpoint for I<line>.
2673 B<B> I<*> Delete all breakpoints.
2674 B<a> [I<line>] I<command>
2675 Set an action to be done before the I<line> is executed;
2676 I<line> defaults to the current execution line.
2677 Sequence is: check for breakpoint/watchpoint, print line
2678 if necessary, do action, prompt user if necessary,
2681 B<A> [I<line>] Delete the action for I<line>.
2682 B<A> I<*> Delete all actions.
2683 B<w> I<expr> Add a global watch-expression.
2685 B<W> I<expr> Delete a global watch-expression.
2686 B<W> I<*> Delete all watch-expressions.
2687 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2688 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2689 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2690 B<x> I<expr> Evals expression in list context, dumps the result.
2691 B<m> I<expr> Evals expression in list context, prints methods callable
2692 on the first element of the result.
2693 B<m> I<class> Prints methods callable via the given class.
2694 B<M> Show versions of loaded modules.
2696 B<<> ? List Perl commands to run before each prompt.
2697 B<<> I<expr> Define Perl command to run before each prompt.
2698 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2699 B<>> ? List Perl commands to run after each prompt.
2700 B<>> I<expr> Define Perl command to run after each prompt.
2701 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2702 B<{> I<db_command> Define debugger command to run before each prompt.
2703 B<{> ? List debugger commands to run before each prompt.
2704 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2705 B<$prc> I<number> Redo a previous command (default previous command).
2706 B<$prc> I<-number> Redo number'th-to-last command.
2707 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2708 See 'B<O> I<recallCommand>' too.
2709 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2710 . ( $rc eq $sh ? "" : "
2711 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2712 See 'B<O> I<shellBang>' too.
2713 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2714 B<H> I<-number> Display last number commands (default all).
2715 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2716 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2717 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2718 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2719 I<command> Execute as a perl statement in current package.
2720 B<R> Pure-man-restart of debugger, some of debugger state
2721 and command-line options may be lost.
2722 Currently the following settings are preserved:
2723 history, breakpoints and actions, debugger B<O>ptions
2724 and the following command-line options: I<-w>, I<-I>, I<-e>.
2726 B<o> [I<opt>] ... Set boolean option to true
2727 B<o> [I<opt>B<?>] Query options
2728 B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2729 Set options. Use quotes in spaces in value.
2730 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2731 I<pager> program for output of \"|cmd\";
2732 I<tkRunning> run Tk while prompting (with ReadLine);
2733 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2734 I<inhibit_exit> Allows stepping off the end of the script.
2735 I<ImmediateStop> Debugger should stop as early as possible.
2736 I<RemotePort> Remote hostname:port for remote debugging
2737 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2738 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2739 I<compactDump>, I<veryCompact> change style of array and hash dump;
2740 I<globPrint> whether to print contents of globs;
2741 I<DumpDBFiles> dump arrays holding debugged files;
2742 I<DumpPackages> dump symbol tables of packages;
2743 I<DumpReused> dump contents of \"reused\" addresses;
2744 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2745 I<bareStringify> Do not print the overload-stringified value;
2746 Other options include:
2747 I<PrintRet> affects printing of return value after B<r> command,
2748 I<frame> affects printing messages on subroutine entry/exit.
2749 I<AutoTrace> affects printing messages on possible breaking points.
2750 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2751 I<ornaments> affects screen appearance of the command line.
2752 I<CreateTTY> bits control attempts to create a new TTY on events:
2753 1: on fork() 2: debugger is started inside debugger
2755 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2756 You can put additional initialization options I<TTY>, I<noTTY>,
2757 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2758 `B<R>' after you set them).
2760 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2761 B<h> Summary of debugger commands.
2762 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2763 B<h h> Long help for debugger commands
2764 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2765 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2766 Set B<\$DB::doccmd> to change viewer.
2768 Type `|h h' for a paged display if this was too hard to read.
2770 "; # Fix balance of vi % matching: }}}}
2772 # note: tabs in the following section are not-so-helpful
2773 $summary = <<"END_SUM";
2774 I<List/search source lines:> I<Control script execution:>
2775 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2776 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2777 B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs
2778 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2779 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2780 B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position
2781 I<Debugger controls:> B<L> List break/watch/actions
2782 B<o> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2783 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2784 B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints
2785 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2786 B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions
2787 B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression
2788 B<h h> Complete help page B<W> I<expr|*> Delete a/all watch expressions
2789 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2790 B<q> or B<^D> Quit B<R> Attempt a restart
2791 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2792 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2793 B<p> I<expr> Print expression (uses script's current package).
2794 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2795 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2796 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2797 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2799 # ')}}; # Fix balance of vi % matching
2801 # and this is really numb...
2804 B<s> [I<expr>] Single step [in I<expr>].
2805 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2806 <B<CR>> Repeat last B<n> or B<s> command.
2807 B<r> Return from current subroutine.
2808 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2809 at the specified position.
2810 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2811 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2812 B<l> I<line> List single I<line>.
2813 B<l> I<subname> List first window of lines from subroutine.
2814 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2815 B<l> List next window of lines.
2816 B<-> List previous window of lines.
2817 B<w> [I<line>] List window around I<line>.
2818 B<.> Return to the executed line.
2819 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2820 I<filename> may be either the full name of the file, or a regular
2821 expression matching the full file name:
2822 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2823 Evals (with saved bodies) are considered to be filenames:
2824 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2825 (in the order of execution).
2826 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2827 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2828 B<L> List all breakpoints and actions.
2829 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2830 B<t> Toggle trace mode.
2831 B<t> I<expr> Trace through execution of I<expr>.
2832 B<b> [I<line>] [I<condition>]
2833 Set breakpoint; I<line> defaults to the current execution line;
2834 I<condition> breaks if it evaluates to true, defaults to '1'.
2835 B<b> I<subname> [I<condition>]
2836 Set breakpoint at first line of subroutine.
2837 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2838 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2839 B<b> B<postpone> I<subname> [I<condition>]
2840 Set breakpoint at first line of subroutine after
2842 B<b> B<compile> I<subname>
2843 Stop after the subroutine is compiled.
2844 B<d> [I<line>] Delete the breakpoint for I<line>.
2845 B<D> Delete all breakpoints.
2846 B<a> [I<line>] I<command>
2847 Set an action to be done before the I<line> is executed;
2848 I<line> defaults to the current execution line.
2849 Sequence is: check for breakpoint/watchpoint, print line
2850 if necessary, do action, prompt user if necessary,
2852 B<a> [I<line>] Delete the action for I<line>.
2853 B<A> Delete all actions.
2854 B<W> I<expr> Add a global watch-expression.
2855 B<W> Delete all watch-expressions.
2856 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2857 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2858 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2859 B<x> I<expr> Evals expression in list context, dumps the result.
2860 B<m> I<expr> Evals expression in list context, prints methods callable
2861 on the first element of the result.
2862 B<m> I<class> Prints methods callable via the given class.
2864 B<<> ? List Perl commands to run before each prompt.
2865 B<<> I<expr> Define Perl command to run before each prompt.
2866 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2867 B<>> ? List Perl commands to run after each prompt.
2868 B<>> I<expr> Define Perl command to run after each prompt.
2869 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2870 B<{> I<db_command> Define debugger command to run before each prompt.
2871 B<{> ? List debugger commands to run before each prompt.
2872 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2873 B<$prc> I<number> Redo a previous command (default previous command).
2874 B<$prc> I<-number> Redo number'th-to-last command.
2875 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2876 See 'B<O> I<recallCommand>' too.
2877 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2878 . ( $rc eq $sh ? "" : "
2879 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2880 See 'B<O> I<shellBang>' too.
2881 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2882 B<H> I<-number> Display last number commands (default all).
2883 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2884 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2885 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2886 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2887 I<command> Execute as a perl statement in current package.
2888 B<v> Show versions of loaded modules.
2889 B<R> Pure-man-restart of debugger, some of debugger state
2890 and command-line options may be lost.
2891 Currently the following settings are preserved:
2892 history, breakpoints and actions, debugger B<O>ptions
2893 and the following command-line options: I<-w>, I<-I>, I<-e>.
2895 B<O> [I<opt>] ... Set boolean option to true
2896 B<O> [I<opt>B<?>] Query options
2897 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2898 Set options. Use quotes in spaces in value.
2899 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2900 I<pager> program for output of \"|cmd\";
2901 I<tkRunning> run Tk while prompting (with ReadLine);
2902 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2903 I<inhibit_exit> Allows stepping off the end of the script.
2904 I<ImmediateStop> Debugger should stop as early as possible.
2905 I<RemotePort> Remote hostname:port for remote debugging
2906 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2907 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2908 I<compactDump>, I<veryCompact> change style of array and hash dump;
2909 I<globPrint> whether to print contents of globs;
2910 I<DumpDBFiles> dump arrays holding debugged files;
2911 I<DumpPackages> dump symbol tables of packages;
2912 I<DumpReused> dump contents of \"reused\" addresses;
2913 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2914 I<bareStringify> Do not print the overload-stringified value;
2915 Other options include:
2916 I<PrintRet> affects printing of return value after B<r> command,
2917 I<frame> affects printing messages on subroutine entry/exit.
2918 I<AutoTrace> affects printing messages on possible breaking points.
2919 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2920 I<ornaments> affects screen appearance of the command line.
2921 I<CreateTTY> bits control attempts to create a new TTY on events:
2922 1: on fork() 2: debugger is started inside debugger
2924 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2925 You can put additional initialization options I<TTY>, I<noTTY>,
2926 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2927 `B<R>' after you set them).
2929 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2930 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2931 B<h h> Summary of debugger commands.
2932 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2933 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2934 Set B<\$DB::doccmd> to change viewer.
2936 Type `|h' for a paged display if this was too hard to read.
2938 "; # Fix balance of vi % matching: }}}}
2940 # note: tabs in the following section are not-so-helpful
2941 $pre580_summary = <<"END_SUM";
2942 I<List/search source lines:> I<Control script execution:>
2943 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2944 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2945 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2946 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2947 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2948 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2949 I<Debugger controls:> B<L> List break/watch/actions
2950 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2951 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2952 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2953 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2954 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2955 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2956 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2957 B<q> or B<^D> Quit B<R> Attempt a restart
2958 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2959 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2960 B<p> I<expr> Print expression (uses script's current package).
2961 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2962 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2963 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2964 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2966 # ')}}; # Fix balance of vi % matching
2973 # Restore proper alignment destroyed by eeevil I<> and B<>
2974 # ornaments: A pox on both their houses!
2976 # A help command will have everything up to and including
2977 # the first tab sequence padded into a field 16 (or if indented 20)
2978 # wide. If it's wider than that, an extra space will be added.
2980 ^ # only matters at start of line
2981 ( \040{4} | \t )* # some subcommands are indented
2982 ( < ? # so <CR> works
2983 [BI] < [^\t\n] + ) # find an eeevil ornament
2984 ( \t+ ) # original separation, discarded
2985 ( .* ) # this will now start (no earlier) than
2988 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2989 my $clean = $command;
2990 $clean =~ s/[BI]<([^>]*)>/$1/g;
2991 # replace with this whole string:
2992 ($leadwhite ? " " x 4 : "")
2994 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
2999 s{ # handle bold ornaments
3000 B < ( [^>] + | > ) >
3002 $Term::ReadLine::TermCap::rl_term_set[2]
3004 . $Term::ReadLine::TermCap::rl_term_set[3]
3007 s{ # handle italic ornaments
3008 I < ( [^>] + | > ) >
3010 $Term::ReadLine::TermCap::rl_term_set[0]
3012 . $Term::ReadLine::TermCap::rl_term_set[1]
3020 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
3021 my $is_less = $pager =~ /\bless\b/;
3022 if ($pager =~ /\bmore\b/) {
3023 my @st_more = stat('/usr/bin/more');
3024 my @st_less = stat('/usr/bin/less');
3025 $is_less = @st_more && @st_less
3026 && $st_more[0] == $st_less[0]
3027 && $st_more[1] == $st_less[1];
3029 # changes environment!
3030 $ENV{LESS} .= 'r' if $is_less;
3036 $SIG{'ABRT'} = 'DEFAULT';
3037 kill 'ABRT', $$ if $panic++;
3038 if (defined &Carp::longmess) {
3039 local $SIG{__WARN__} = '';
3040 local $Carp::CarpLevel = 2; # mydie + confess
3041 &warn(Carp::longmess("Signal @_"));
3045 print $DB::OUT "Got signal @_\n";
3053 local $SIG{__WARN__} = '';
3054 local $SIG{__DIE__} = '';
3055 eval { require Carp } if defined $^S; # If error/warning during compilation,
3056 # require may be broken.
3057 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
3058 return unless defined &Carp::longmess;
3059 my ($mysingle,$mytrace) = ($single,$trace);
3060 $single = 0; $trace = 0;
3061 my $mess = Carp::longmess(@_);
3062 ($single,$trace) = ($mysingle,$mytrace);
3069 local $SIG{__DIE__} = '';
3070 local $SIG{__WARN__} = '';
3071 my $i = 0; my $ineval = 0; my $sub;
3072 if ($dieLevel > 2) {
3073 local $SIG{__WARN__} = \&dbwarn;
3074 &warn(@_); # Yell no matter what
3077 if ($dieLevel < 2) {
3078 die @_ if $^S; # in eval propagate
3080 # No need to check $^S, eval is much more robust nowadays
3081 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
3082 # require may be broken.
3084 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
3085 unless defined &Carp::longmess;
3087 # We do not want to debug this chunk (automatic disabling works
3088 # inside DB::DB, but not in Carp).
3089 my ($mysingle,$mytrace) = ($single,$trace);
3090 $single = 0; $trace = 0;
3093 package Carp; # Do not include us in the list
3095 $mess = Carp::longmess(@_);
3098 ($single,$trace) = ($mysingle,$mytrace);
3104 $prevwarn = $SIG{__WARN__} unless $warnLevel;
3107 $SIG{__WARN__} = \&DB::dbwarn;
3108 } elsif ($prevwarn) {
3109 $SIG{__WARN__} = $prevwarn;
3118 $prevdie = $SIG{__DIE__} unless $dieLevel;
3121 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
3122 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
3123 print $OUT "Stack dump during die enabled",
3124 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
3126 print $OUT "Dump printed too.\n" if $dieLevel > 2;
3127 } elsif ($prevdie) {
3128 $SIG{__DIE__} = $prevdie;
3129 print $OUT "Default die handler restored.\n";
3137 $prevsegv = $SIG{SEGV} unless $signalLevel;
3138 $prevbus = $SIG{BUS} unless $signalLevel;
3139 $signalLevel = shift;
3141 $SIG{SEGV} = \&DB::diesignal;
3142 $SIG{BUS} = \&DB::diesignal;
3144 $SIG{SEGV} = $prevsegv;
3145 $SIG{BUS} = $prevbus;
3153 my $name = CvGV_name_or_bust($in);
3154 defined $name ? $name : $in;
3157 sub CvGV_name_or_bust {
3159 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
3160 return unless ref $in;
3161 $in = \&$in; # Hard reference...
3162 eval {require Devel::Peek; 1} or return;
3163 my $gv = Devel::Peek::CvGV($in) or return;
3164 *$gv{PACKAGE} . '::' . *$gv{NAME};
3170 return unless defined &$subr;
3171 my $name = CvGV_name_or_bust($subr);
3173 $data = $sub{$name} if defined $name;
3174 return $data if defined $data;
3177 $subr = \&$subr; # Hard reference
3180 $s = $_, last if $subr eq \&$_;
3188 $class = ref $class if ref $class;
3191 methods_via($class, '', 1);
3192 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
3197 return if $packs{$class}++;
3199 my $prepend = $prefix ? "via $prefix: " : '';
3201 for $name (grep {defined &{${"${class}::"}{$_}}}
3202 sort keys %{"${class}::"}) {
3203 next if $seen{ $name }++;
3206 print $DB::OUT "$prepend$name\n";
3208 return unless shift; # Recurse?
3209 for $name (@{"${class}::ISA"}) {
3210 $prepend = $prefix ? $prefix . " -> $name" : $name;
3211 methods_via($name, $prepend, 1);
3216 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
3217 ? "man" # O Happy Day!
3218 : "perldoc"; # Alas, poor unfortunates
3224 &system("$doccmd $doccmd");
3227 # this way user can override, like with $doccmd="man -Mwhatever"
3228 # or even just "man " to disable the path check.
3229 unless ($doccmd eq 'man') {
3230 &system("$doccmd $page");
3234 $page = 'perl' if lc($page) eq 'help';
3237 my $man1dir = $Config::Config{'man1dir'};
3238 my $man3dir = $Config::Config{'man3dir'};
3239 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
3241 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
3242 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
3243 chop $manpath if $manpath;
3244 # harmless if missing, I figure
3245 my $oldpath = $ENV{MANPATH};
3246 $ENV{MANPATH} = $manpath if $manpath;
3247 my $nopathopt = $^O =~ /dunno what goes here/;
3248 if (CORE::system($doccmd,
3249 # I just *know* there are men without -M
3250 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3253 unless ($page =~ /^perl\w/) {
3254 if (grep { $page eq $_ } qw{
3255 5004delta 5005delta amiga api apio book boot bot call compile
3256 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
3257 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
3258 form func guts hack hist hpux intern ipc lexwarn locale lol mod
3259 modinstall modlib number obj op opentut os2 os390 pod port
3260 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
3261 trap unicode var vms win32 xs xstut
3265 CORE::system($doccmd,
3266 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3271 if (defined $oldpath) {
3272 $ENV{MANPATH} = $manpath;
3274 delete $ENV{MANPATH};
3278 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
3280 BEGIN { # This does not compile, alas.
3281 $IN = \*STDIN; # For bugs before DB::OUT has been opened
3282 $OUT = \*STDERR; # For errors before DB::OUT has been opened
3286 $deep = 100; # warning if stack gets this deep
3290 $SIG{INT} = \&DB::catch;
3291 # This may be enabled to debug debugger:
3292 #$warnLevel = 1 unless defined $warnLevel;
3293 #$dieLevel = 1 unless defined $dieLevel;
3294 #$signalLevel = 1 unless defined $signalLevel;
3296 $db_stop = 0; # Compiler warning
3298 $level = 0; # Level of recursive debugging
3299 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
3300 # Triggers bug (?) in perl is we postpone this until runtime:
3301 @postponed = @stack = (0);
3302 $stack_depth = 0; # Localized $#stack
3307 BEGIN {$^W = $ini_warn;} # Switch warnings back
3309 #use Carp; # This did break, left for debugging
3312 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
3313 my($text, $line, $start) = @_;
3314 my ($itext, $search, $prefix, $pack) =
3315 ($text, "^\Q${'package'}::\E([^:]+)\$");
3317 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
3318 (map { /$search/ ? ($1) : () } keys %sub)
3319 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
3320 return sort grep /^\Q$text/, values %INC # files
3321 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
3322 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3323 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
3324 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
3325 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3327 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
3329 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
3330 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
3331 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
3332 # We may want to complete to (eval 9), so $text may be wrong
3333 $prefix = length($1) - length($text);
3336 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
3338 if ((substr $text, 0, 1) eq '&') { # subroutines
3339 $text = substr $text, 1;
3341 return sort map "$prefix$_",
3344 (map { /$search/ ? ($1) : () }
3347 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
3348 $pack = ($1 eq 'main' ? '' : $1) . '::';
3349 $prefix = (substr $text, 0, 1) . $1 . '::';
3352 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
3353 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3354 return db_complete($out[0], $line, $start);
3358 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3359 $pack = ($package eq 'main' ? '' : $package) . '::';
3360 $prefix = substr $text, 0, 1;
3361 $text = substr $text, 1;
3362 my @out = map "$prefix$_", grep /^\Q$text/,
3363 (grep /^_?[a-zA-Z]/, keys %$pack),
3364 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3365 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3366 return db_complete($out[0], $line, $start);
3370 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3371 my @out = grep /^\Q$text/, @options;
3372 my $val = option_val($out[0], undef);
3374 if (not defined $val or $val =~ /[\n\r]/) {
3375 # Can do nothing better
3376 } elsif ($val =~ /\s/) {
3378 foreach $l (split //, qq/\"\'\#\|/) {
3379 $out = "$l$val$l ", last if (index $val, $l) == -1;
3384 # Default to value if one completion, to question if many
3385 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3388 return $term->filename_list($text); # filenames
3393 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3397 if (defined($ini_pids)) {
3398 $ENV{PERLDB_PIDS} = $ini_pids;
3400 delete($ENV{PERLDB_PIDS});
3405 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3406 $fall_off_end = 1 unless $inhibit_exit;
3407 # Do not stop in at_exit() and destructors on exit:
3408 $DB::single = !$fall_off_end && !$runnonstop;
3409 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3413 # ===================================== pre580 ================================
3414 # this is very sad below here...
3417 sub cmd_pre580_null {
3423 if ($cmd =~ /^(\d*)\s*(.*)/) {
3424 $i = $1 || $line; $j = $2;
3426 if ($dbline[$i] == 0) {
3427 print $OUT "Line $i may not have an action.\n";
3429 $had_breakpoints{$filename} |= 2;
3430 $dbline{$i} =~ s/\0[^\0]*//;
3431 $dbline{$i} .= "\0" . action($j);
3434 $dbline{$i} =~ s/\0[^\0]*//;
3435 delete $dbline{$i} if $dbline{$i} eq '';
3443 if ($cmd =~ /^load\b\s*(.*)/) {
3444 my $file = $1; $file =~ s/\s+$//;
3446 } elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
3447 my $cond = length $3 ? $3 : '1';
3448 my ($subname, $break) = ($2, $1 eq 'postpone');
3449 $subname =~ s/\'/::/g;
3450 $subname = "${'package'}::" . $subname
3451 unless $subname =~ /::/;
3452 $subname = "main".$subname if substr($subname,0,2) eq "::";
3453 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
3454 } elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
3456 my $cond = length $2 ? $2 : '1';
3457 &cmd_b_sub($subname, $cond);
3458 } elsif ($cmd =~ /^(\d*)\s*(.*)/) {
3459 my $i = $1 || $dbline;
3460 my $cond = length $2 ? $2 : '1';
3461 &cmd_b_line($i, $cond);
3467 if ($cmd =~ /^\s*$/) {
3468 print $OUT "Deleting all breakpoints...\n";
3470 for $file (keys %had_breakpoints) {
3471 local *dbline = $main::{'_<' . $file};
3475 for ($i = 1; $i <= $max ; $i++) {
3476 if (defined $dbline{$i}) {
3477 $dbline{$i} =~ s/^[^\0]+//;
3478 if ($dbline{$i} =~ s/^\0?$//) {
3484 if (not $had_breakpoints{$file} &= ~1) {
3485 delete $had_breakpoints{$file};
3489 undef %postponed_file;
3490 undef %break_on_load;
3496 if ($cmd =~ /^\s*$/) {
3497 print_help($pre580_help);
3498 } elsif ($cmd =~ /^h\s*/) {
3499 print_help($pre580_summary);
3500 } elsif ($cmd =~ /^h\s+(\S.*)$/) {
3501 my $asked = $1; # for proper errmsg
3502 my $qasked = quotemeta($asked); # for searching
3503 # XXX: finds CR but not <CR>
3504 if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) {
3505 while ($pre580_help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
3509 print_help("B<$asked> is not a debugger command.\n");
3518 @to_watch = @old_watch = ();
3519 } elsif ($cmd =~ /^(.*)/s) {
3523 $val = (defined $val) ? "'$val'" : 'undef' ;
3524 push @old_watch, $val;
3532 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3535 package DB; # Do not trace this 1; below!