5 # Debugger for Perl 5.00x; perl5db.pl patch level:
7 $header = "perl5db.pl version $VERSION";
9 # It is crucial that there is no lexicals in scope of `eval ""' down below
11 # 'my' would make it visible from user code
12 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
15 local $otrace = $trace;
16 local $osingle = $single;
18 { ($evalarg) = $evalarg =~ /(.*)/s; }
19 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
25 local $saved[0]; # Preserve the old value of $@
30 } elsif ($onetimeDump) {
31 if ($onetimeDump eq 'dump') {
32 local $option{dumpDepth} = $onetimedumpDepth
33 if defined $onetimedumpDepth;
35 } elsif ($onetimeDump eq 'methods') {
42 # After this point it is safe to introduce lexicals
43 # However, one should not overdo it: leave as much control from outside as possible
45 # This file is automatically included if you do perl -d.
46 # It's probably not useful to include this yourself.
48 # Before venturing further into these twisty passages, it is
49 # wise to read the perldebguts man page or risk the ire of dragons.
51 # Perl supplies the values for %sub. It effectively inserts
52 # a &DB::DB(); in front of every place that can have a
53 # breakpoint. Instead of a subroutine call it calls &DB::sub with
54 # $DB::sub being the called subroutine. It also inserts a BEGIN
55 # {require 'perl5db.pl'} before the first line.
57 # After each `require'd file is compiled, but before it is executed, a
58 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
59 # $filename is the expanded name of the `require'd file (as found as
62 # Additional services from Perl interpreter:
64 # if caller() is called from the package DB, it provides some
67 # The array @{$main::{'_<'.$filename}} (herein called @dbline) is the
68 # line-by-line contents of $filename.
70 # The hash %{'_<'.$filename} (herein called %dbline) contains
71 # breakpoints and action (it is keyed by line number), and individual
72 # entries are settable (as opposed to the whole hash). Only true/false
73 # is important to the interpreter, though the values used by
74 # perl5db.pl have the form "$break_condition\0$action". Values are
75 # magical in numeric context.
77 # The scalar ${'_<'.$filename} contains $filename.
79 # Note that no subroutine call is possible until &DB::sub is defined
80 # (for subroutines defined outside of the package DB). In fact the same is
81 # true if $deep is not defined.
85 # At start reads $rcfile that may set important options. This file
86 # may define a subroutine &afterinit that will be executed after the
87 # debugger is initialized.
89 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
90 # it as a rest of `O ...' line in debugger prompt.
92 # The options that can be specified only at startup:
93 # [To set in $rcfile, call &parse_options("optionName=new_value").]
95 # TTY - the TTY to use for debugging i/o.
97 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
98 # uses the value of noTTY or ".perldbtty$$" to find TTY using
99 # Term::Rendezvous. Current variant is to have the name of TTY in this
102 # ReadLine - If false, dummy ReadLine is used, so you can debug
103 # ReadLine applications.
105 # NonStop - if true, no i/o is performed until interrupt.
107 # LineInfo - file or pipe to print line number info to. If it is a
108 # pipe, a short "emacs like" message is used.
110 # RemotePort - host:port to connect to on remote host for remote debugging.
112 # Example $rcfile: (delete leading hashes!)
114 # &parse_options("NonStop=1 LineInfo=db.out");
115 # sub afterinit { $trace = 1; }
117 # The script will run without human intervention, putting trace
118 # information into db.out. (If you interrupt it, you would better
119 # reset LineInfo to something "interactive"!)
121 ##################################################################
123 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
125 # modified Perl debugger, to be run from Emacs in perldb-mode
126 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
127 # Johan Vromans -- upgrade to 4.0 pl 10
128 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
132 # A lot of things changed after 0.94. First of all, core now informs
133 # debugger about entry into XSUBs, overloaded operators, tied operations,
134 # BEGIN and END. Handy with `O f=2'.
136 # This can make debugger a little bit too verbose, please be patient
137 # and report your problems promptly.
139 # Now the option frame has 3 values: 0,1,2.
141 # Note that if DESTROY returns a reference to the object (or object),
142 # the deletion of data may be postponed until the next function call,
143 # due to the need to examine the return value.
145 # Changes: 0.95: `v' command shows versions.
146 # Changes: 0.96: `v' command shows version of readline.
147 # primitive completion works (dynamic variables, subs for `b' and `l',
148 # options). Can `p %var'
149 # Better help (`h <' now works). New commands <<, >>, {, {{.
150 # {dump|print}_trace() coded (to be able to do it from <<cmd).
151 # `c sub' documented.
152 # At last enough magic combined to stop after the end of debuggee.
153 # !! should work now (thanks to Emacs bracket matching an extra
154 # `]' in a regexp is caught).
155 # `L', `D' and `A' span files now (as documented).
156 # Breakpoints in `require'd code are possible (used in `R').
157 # Some additional words on internal work of debugger.
158 # `b load filename' implemented.
159 # `b postpone subr' implemented.
160 # now only `q' exits debugger (overwritable on $inhibit_exit).
161 # When restarting debugger breakpoints/actions persist.
162 # Buglet: When restarting debugger only one breakpoint/action per
163 # autoloaded function persists.
164 # Changes: 0.97: NonStop will not stop in at_exit().
165 # Option AutoTrace implemented.
166 # Trace printed differently if frames are printed too.
167 # new `inhibitExit' option.
168 # printing of a very long statement interruptible.
169 # Changes: 0.98: New command `m' for printing possible methods
170 # 'l -' is a synonym for `-'.
171 # Cosmetic bugs in printing stack trace.
172 # `frame' & 8 to print "expanded args" in stack trace.
173 # Can list/break in imported subs.
174 # new `maxTraceLen' option.
175 # frame & 4 and frame & 8 granted.
177 # nonstoppable lines do not have `:' near the line number.
178 # `b compile subname' implemented.
179 # Will not use $` any more.
180 # `-' behaves sane now.
181 # Changes: 0.99: Completion for `f', `m'.
182 # `m' will remove duplicate names instead of duplicate functions.
183 # `b load' strips trailing whitespace.
184 # completion ignores leading `|'; takes into account current package
185 # when completing a subroutine name (same for `l').
186 # Changes: 1.07: Many fixed by tchrist 13-March-2000
188 # + Added bare minimal security checks on perldb rc files, plus
189 # comments on what else is needed.
190 # + Fixed the ornaments that made "|h" completely unusable.
191 # They are not used in print_help if they will hurt. Strip pod
192 # if we're paging to less.
193 # + Fixed mis-formatting of help messages caused by ornaments
194 # to restore Larry's original formatting.
195 # + Fixed many other formatting errors. The code is still suboptimal,
196 # and needs a lot of work at restructuring. It's also misindented
198 # + Fixed bug where trying to look at an option like your pager
200 # + Fixed some $? processing. Note: if you use csh or tcsh, you will
201 # lose. You should consider shell escapes not using their shell,
202 # or else not caring about detailed status. This should really be
203 # unified into one place, too.
204 # + Fixed bug where invisible trailing whitespace on commands hoses you,
205 # tricking Perl into thinking you weren't calling a debugger command!
206 # + Fixed bug where leading whitespace on commands hoses you. (One
207 # suggests a leading semicolon or any other irrelevant non-whitespace
208 # to indicate literal Perl code.)
209 # + Fixed bugs that ate warnings due to wrong selected handle.
210 # + Fixed a precedence bug on signal stuff.
211 # + Fixed some unseemly wording.
212 # + Fixed bug in help command trying to call perl method code.
213 # + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
215 # + Added some comments. This code is still nasty spaghetti.
216 # + Added message if you clear your pre/post command stacks which was
217 # very easy to do if you just typed a bare >, <, or {. (A command
218 # without an argument should *never* be a destructive action; this
219 # API is fundamentally screwed up; likewise option setting, which
220 # is equally buggered.)
221 # + Added command stack dump on argument of "?" for >, <, or {.
222 # + Added a semi-built-in doc viewer command that calls man with the
223 # proper %Config::Config path (and thus gets caching, man -k, etc),
224 # or else perldoc on obstreperous platforms.
225 # + Added to and rearranged the help information.
226 # + Detected apparent misuse of { ... } to declare a block; this used
227 # to work but now is a command, and mysteriously gave no complaint.
229 # Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
231 # + This patch to perl5db.pl cleans up formatting issues on the help
232 # summary (h h) screen in the debugger. Mostly columnar alignment
233 # issues, plus converted the printed text to use all spaces, since
234 # tabs don't seem to help much here.
236 # Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
237 # 0) Minor bugs corrected;
238 # a) Support for auto-creation of new TTY window on startup, either
239 # unconditionally, or if started as a kid of another debugger session;
240 # b) New `O'ption CreateTTY
241 # I<CreateTTY> bits control attempts to create a new TTY on events:
242 # 1: on fork() 2: debugger is started inside debugger
244 # c) Code to auto-create a new TTY window on OS/2 (currently one
245 # extra window per session - need named pipes to have more...);
246 # d) Simplified interface for custom createTTY functions (with a backward
247 # compatibility hack); now returns the TTY name to use; return of ''
248 # means that the function reset the I/O handles itself;
249 # d') Better message on the semantic of custom createTTY function;
250 # e) Convert the existing code to create a TTY into a custom createTTY
252 # f) Consistent support for TTY names of the form "TTYin,TTYout";
253 # g) Switch line-tracing output too to the created TTY window;
254 # h) make `b fork' DWIM with CORE::GLOBAL::fork;
255 # i) High-level debugger API cmd_*():
256 # cmd_b_load($filenamepart) # b load filenamepart
257 # cmd_b_line($lineno [, $cond]) # b lineno [cond]
258 # cmd_b_sub($sub [, $cond]) # b sub [cond]
259 # cmd_stop() # Control-C
260 # cmd_d($lineno) # d lineno (B)
261 # The cmd_*() API returns FALSE on failure; in this case it outputs
262 # the error message to the debugging output.
263 # j) Low-level debugger API
264 # break_on_load($filename) # b load filename
265 # @files = report_break_on_load() # List files with load-breakpoints
266 # breakable_line_in_filename($name, $from [, $to])
267 # # First breakable line in the
268 # # range $from .. $to. $to defaults
269 # # to $from, and may be less than $to
270 # breakable_line($from [, $to]) # Same for the current file
271 # break_on_filename_line($name, $lineno [, $cond])
272 # # Set breakpoint,$cond defaults to 1
273 # break_on_filename_line_range($name, $from, $to [, $cond])
274 # # As above, on the first
275 # # breakable line in range
276 # break_on_line($lineno [, $cond]) # As above, in the current file
277 # break_subroutine($sub [, $cond]) # break on the first breakable line
278 # ($name, $from, $to) = subroutine_filename_lines($sub)
279 # # The range of lines of the text
280 # The low-level API returns TRUE on success, and die()s on failure.
282 # Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
284 # + Fixed warnings generated by "perl -dWe 42"
285 # + Corrected spelling errors
286 # + Squeezed Help (h) output into 80 columns
288 # Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
289 # + Made "x @INC" work like it used to
291 # Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
292 # + Fixed warnings generated by "O" (Show debugger options)
293 # + Fixed warnings generated by "p 42" (Print expression)
294 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
295 # + Added windowSize option
296 # Changes: 1.14: Oct 9, 2001 multiple
297 # + Clean up after itself on VMS (Charles Lane in 12385)
298 # + Adding "@ file" syntax (Peter Scott in 12014)
299 # + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
300 # + $^S and other debugger fixes (Ilya Zakharevich in 11120)
301 # + Forgot a my() declaration (Ilya Zakharevich in 11085)
302 # Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern@pobox.com>
303 # + Updated 1.14 change log
304 # + Added *dbline explainatory comments
305 # + Mentioning perldebguts man page
306 # Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com>
307 # + $onetimeDump improvements
308 # Changes: 1.17: Feb 20, 2002 Richard Foley <richard.foley@rfi.net>
309 # Moved some code to cmd_[.]()'s for clarity and ease of handling,
310 # rationalised the following commands and added cmd_wrapper() to
311 # enable switching between old and frighteningly consistent new
312 # behaviours for diehards: 'o CommandSet=pre580' (sigh...)
313 # a(add), A(del) # action expr (added del by line)
314 # + b(add), B(del) # break [line] (was b,D)
315 # + w(add), W(del) # watch expr (was W,W) added del by expr
316 # + h(summary), h h(long) # help (hh) (was h h,h)
317 # + m(methods), M(modules) # ... (was m,v)
318 # + o(option) # lc (was O)
319 # + v(view code), V(view Variables) # ... (was w,V)
320 # Changes: 1.18: Mar 17, 2002 Richard Foley <richard.foley@rfi.net>
321 # + fixed missing cmd_O bug
322 # Changes: 1.19: Mar 29, 2002 Spider Boardman
323 # + Added missing local()s -- DB::DB is called recursively.
324 # Changes: 1.20: Feb 17, 2003 Richard Foley <richard.foley@rfi.net>
325 # + pre'n'post commands no longer trashed with no args
326 # + watch val joined out of eval()
327 # Changes: 1.21: Dec 21, 2003 Dominique Quatravaux
328 # + Fix a side-effect of bug #24674 in the perl debugger ("odd taint bug")
329 # Changes: 1.24: Mar 03, 2004 Richard Foley <richard.foley@rfi.net>
330 # + Added command to save all debugger commands for sourcing later.
331 # + Added command to display parent inheritence tree of given class.
332 # + Fixed minor newline in history bug.
333 ####################################################################
335 # Needed for the statement after exec():
337 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
339 # test if assertions are supported and actived:
342 eval "sub asserting_test : assertion {1}; 1";
343 # $ini_assertion = undef => assertions unsupported,
344 # " = 1 => assertions suported
345 # print "\$ini_assertion=$ini_assertion\n";
348 local($^W) = 0; # Switch run-time warnings off during init.
351 $dumpvar::arrayDepth,
352 $dumpvar::dumpDBFiles,
353 $dumpvar::dumpPackages,
354 $dumpvar::quoteHighBit,
355 $dumpvar::printUndef,
364 # Command-line + PERLLIB:
367 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
369 $trace = $signal = $single = 0; # Uninitialized warning suppression
370 # (local $^W cannot help - other packages!).
371 $inhibit_exit = $option{PrintRet} = 1;
373 @options = qw(hashDepth arrayDepth CommandSet dumpDepth
374 DumpDBFiles DumpPackages DumpReused
375 compactDump veryCompact quote HighBit undefPrint
376 globPrint PrintRet UsageOnly frame AutoTrace
377 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
378 recallCommand ShellBang pager tkRunning ornaments
379 signalLevel warnLevel dieLevel inhibit_exit
380 ImmediateStop bareStringify CreateTTY
381 RemotePort windowSize DollarCaretP OnlyAssertions
384 @RememberOnROptions = qw(DollarCaretP OnlyAssertions);
387 hashDepth => \$dumpvar::hashDepth,
388 arrayDepth => \$dumpvar::arrayDepth,
389 CommandSet => \$CommandSet,
390 DumpDBFiles => \$dumpvar::dumpDBFiles,
391 DumpPackages => \$dumpvar::dumpPackages,
392 DumpReused => \$dumpvar::dumpReused,
393 HighBit => \$dumpvar::quoteHighBit,
394 undefPrint => \$dumpvar::printUndef,
395 globPrint => \$dumpvar::globPrint,
396 UsageOnly => \$dumpvar::usageOnly,
397 CreateTTY => \$CreateTTY,
398 bareStringify => \$dumpvar::bareStringify,
400 AutoTrace => \$trace,
401 inhibit_exit => \$inhibit_exit,
402 maxTraceLen => \$maxtrace,
403 ImmediateStop => \$ImmediateStop,
404 RemotePort => \$remoteport,
405 windowSize => \$window,
406 WarnAssertions => \$warnassertions,
410 compactDump => \&dumpvar::compactDump,
411 veryCompact => \&dumpvar::veryCompact,
412 quote => \&dumpvar::quote,
415 ReadLine => \&ReadLine,
416 NonStop => \&NonStop,
417 LineInfo => \&LineInfo,
418 recallCommand => \&recallCommand,
419 ShellBang => \&shellBang,
421 signalLevel => \&signalLevel,
422 warnLevel => \&warnLevel,
423 dieLevel => \&dieLevel,
424 tkRunning => \&tkRunning,
425 ornaments => \&ornaments,
426 RemotePort => \&RemotePort,
427 DollarCaretP => \&DollarCaretP,
428 OnlyAssertions=> \&OnlyAssertions,
432 compactDump => 'dumpvar.pl',
433 veryCompact => 'dumpvar.pl',
434 quote => 'dumpvar.pl',
437 # These guys may be defined in $ENV{PERL5DB} :
438 $rl = 1 unless defined $rl;
439 $warnLevel = 1 unless defined $warnLevel;
440 $dieLevel = 1 unless defined $dieLevel;
441 $signalLevel = 1 unless defined $signalLevel;
442 $pre = [] unless defined $pre;
443 $post = [] unless defined $post;
444 $pretype = [] unless defined $pretype;
445 $CreateTTY = 3 unless defined $CreateTTY;
446 $CommandSet = '580' unless defined $CommandSet;
448 warnLevel($warnLevel);
450 signalLevel($signalLevel);
453 defined $ENV{PAGER} ? $ENV{PAGER} :
454 eval { require Config } &&
455 defined $Config::Config{pager} ? $Config::Config{pager}
457 ) unless defined $pager;
459 &recallCommand("!") unless defined $prc;
460 &shellBang("!") unless defined $psh;
462 $maxtrace = 400 unless defined $maxtrace;
463 $ini_pids = $ENV{PERLDB_PIDS};
464 if (defined $ENV{PERLDB_PIDS}) {
465 $pids = "[$ENV{PERLDB_PIDS}]";
466 $ENV{PERLDB_PIDS} .= "->$$";
469 $ENV{PERLDB_PIDS} = "$$";
474 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
476 if (-e "/dev/tty") { # this is the wrong metric!
479 $rcfile="perldb.ini";
482 # This isn't really safe, because there's a race
483 # between checking and opening. The solution is to
484 # open and fstat the handle, but then you have to read and
485 # eval the contents. But then the silly thing gets
486 # your lexical scope, which is unfortunately at best.
490 # Just exactly what part of the word "CORE::" don't you understand?
491 local $SIG{__WARN__};
494 unless (is_safe_file($file)) {
495 CORE::warn <<EO_GRIPE;
496 perldb: Must not source insecure rcfile $file.
497 You or the superuser must be the owner, and it must not
498 be writable by anyone but its owner.
504 CORE::warn("perldb: couldn't parse $file: $@") if $@;
508 # Verifies that owner is either real user or superuser and that no
509 # one but owner may write to it. This function is of limited use
510 # when called on a path instead of upon a handle, because there are
511 # no guarantees that filename (by dirent) whose file (by ino) is
512 # eventually accessed is the same as the one tested.
513 # Assumes that the file's existence is not in doubt.
516 stat($path) || return; # mysteriously vaporized
517 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
519 return 0 if $uid != 0 && $uid != $<;
520 return 0 if $mode & 022;
525 safe_do("./$rcfile");
527 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
528 safe_do("$ENV{HOME}/$rcfile");
530 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
531 safe_do("$ENV{LOGDIR}/$rcfile");
534 if (defined $ENV{PERLDB_OPTS}) {
535 parse_options($ENV{PERLDB_OPTS});
538 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
539 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
540 *get_fork_TTY = \&xterm_get_fork_TTY;
541 } elsif ($^O eq 'os2') {
542 *get_fork_TTY = \&os2_get_fork_TTY;
544 # untaint $^O, which may have been tainted by the last statement.
545 # see bug [perl #24674]
546 $^O =~ m/^(.*)\z/; $^O = $1;
548 # Here begin the unreadable code. It needs fixing.
550 if (exists $ENV{PERLDB_RESTART}) {
551 delete $ENV{PERLDB_RESTART};
553 @hist = get_list('PERLDB_HIST');
554 %break_on_load = get_list("PERLDB_ON_LOAD");
555 %postponed = get_list("PERLDB_POSTPONE");
556 my @had_breakpoints= get_list("PERLDB_VISITED");
557 for (0 .. $#had_breakpoints) {
558 my %pf = get_list("PERLDB_FILE_$_");
559 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
561 my %opt = get_list("PERLDB_OPT");
563 while (($opt,$val) = each %opt) {
564 $val =~ s/[\\\']/\\$1/g;
565 parse_options("$opt'$val'");
567 @INC = get_list("PERLDB_INC");
569 $pretype = [get_list("PERLDB_PRETYPE")];
570 $pre = [get_list("PERLDB_PRE")];
571 $post = [get_list("PERLDB_POST")];
572 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
578 # Is Perl being run from a slave editor or graphical debugger?
579 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
580 $rl = 0, shift(@main::ARGV) if $slave_editor;
582 #require Term::ReadLine;
584 if ($^O eq 'cygwin') {
585 # /dev/tty is binary. use stdin for textmode
587 } elsif (-e "/dev/tty") {
588 $console = "/dev/tty";
589 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
591 } elsif ($^O eq 'MacOS') {
592 if ($MacPerl::Version !~ /MPW/) {
593 $console = "Dev:Console:Perl Debug"; # Separate window for application
595 $console = "Dev:Console";
598 $console = "sys\$command";
601 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
605 if ($^O eq 'NetWare') {
610 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
618 $console = $tty if defined $tty;
620 if (defined $remoteport) {
622 $OUT = new IO::Socket::INET( Timeout => '10',
623 PeerAddr => $remoteport,
626 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
629 create_IN_OUT(4) if $CreateTTY & 4;
631 my ($i, $o) = split /,/, $console;
632 $o = $i unless defined $o;
633 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
634 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
635 || open(OUT,">&STDOUT"); # so we don't dongle stdout
636 } elsif (not defined $console) {
638 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
639 $console = 'STDIN/OUT';
641 # so open("|more") can read from STDOUT and so we don't dingle stdin
642 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
644 my $previous = select($OUT);
645 $| = 1; # for DB::OUT
648 $LINEINFO = $OUT unless defined $LINEINFO;
649 $lineinfo = $console unless defined $lineinfo;
651 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
652 unless ($runnonstop) {
655 if ($term_pid eq '-1') {
656 print $OUT "\nDaughter DB session started...\n";
658 print $OUT "\nLoading DB routines from $header\n";
659 print $OUT ("Editor support ",
660 $slave_editor ? "enabled" : "available",
662 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
670 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
673 if (defined &afterinit) { # May be defined in $rcfile
679 ############################################################ Subroutines
682 # _After_ the perl program is compiled, $single is set to 1:
683 if ($single and not $second_time++) {
684 if ($runnonstop) { # Disable until signal
685 for ($i=0; $i <= $stack_depth; ) {
689 # return; # Would not print trace!
690 } elsif ($ImmediateStop) {
695 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
697 local($package, $filename, $line) = caller;
698 local $filename_ini = $filename;
699 local $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
700 "package $package;"; # this won't let them modify, alas
701 local(*dbline) = $main::{'_<' . $filename};
703 # we need to check for pseudofiles on Mac OS (these are files
704 # not attached to a filename, but instead stored in Dev:Pseudo)
705 if ($^O eq 'MacOS' && $#dbline < 0) {
706 $filename_ini = $filename = 'Dev:Pseudo';
707 *dbline = $main::{'_<' . $filename};
710 local $max = $#dbline;
711 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
715 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
716 $dbline{$line} =~ s/;9($|\0)/$1/;
719 my $was_signal = $signal;
721 for (my $n = 0; $n <= $#to_watch; $n++) {
722 $evalarg = $to_watch[$n];
723 local $onetimeDump; # Do not output results
724 my ($val) = join("', '", &eval); # Fix context (&eval is doing array)
725 $val = ( (defined $val) ? "'$val'" : 'undef' );
726 if ($val ne $old_watch[$n]) {
729 Watchpoint $n:\t$to_watch[$n] changed:
730 old value:\t$old_watch[$n]
733 $old_watch[$n] = $val;
737 if ($trace & 4) { # User-installed watch
738 return if watchfunction($package, $filename, $line)
739 and not $single and not $was_signal and not ($trace & ~4);
741 $was_signal = $signal;
743 if ($single || ($trace & 1) || $was_signal) {
745 $position = "\032\032$filename:$line:0\n";
746 print_lineinfo($position);
747 } elsif ($package eq 'DB::fake') {
750 Debugged program terminated. Use B<q> to quit or B<R> to restart,
751 use B<O> I<inhibit_exit> to avoid stopping after program termination,
752 B<h q>, B<h R> or B<h O> to get additional info.
755 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
756 "package $package;"; # this won't let them modify, alas
759 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
760 $prefix .= "$sub($filename:";
761 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
762 if (length($prefix) > 30) {
763 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
768 $position = "$prefix$line$infix$dbline[$line]$after";
771 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
773 print_lineinfo($position);
775 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
776 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
778 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
779 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
780 $position .= $incr_pos;
782 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
784 print_lineinfo($incr_pos);
789 $evalarg = $action, &eval if $action;
790 if ($single || $was_signal) {
791 local $level = $level + 1;
792 foreach $evalarg (@$pre) {
795 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
798 $incr = -1; # for backward motion.
799 @typeahead = (@$pretype, @typeahead);
801 while (($term || &setterm),
802 ($term_pid == $$ or resetterm(1)),
803 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
804 ($#hist+1) . ('>' x $level) . " ")))
808 $cmd =~ s/\\$/\n/ && do {
809 $cmd .= &readline(" cont: ");
812 $cmd =~ /^$/ && ($cmd = $laststep);
813 chomp($cmd); # get rid of the annoying extra newline
814 push(@hist,$cmd) if length($cmd) > 1;
815 push (@truehist, $cmd);
817 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
818 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
819 ($i) = split(/\s+/,$cmd);
821 # squelch the sigmangler
823 local $SIG{__WARN__};
824 eval "\$cmd =~ $alias{$i}";
827 print $OUT "Couldn't evaluate `$i' alias: $@";
831 $cmd =~ /^q$/ && do {
836 $cmd =~ /^t$/ && do {
839 print $OUT "Trace = " .
840 (($trace & 1) ? "on" : "off" ) . "\n";
842 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
843 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
846 foreach $subname (sort(keys %sub)) {
847 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
848 print $OUT $subname,"\n";
852 $cmd =~ s/^X\b/V $package/;
853 $cmd =~ /^V$/ && do {
854 $cmd = "V $package"; };
855 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
856 local ($savout) = select($OUT);
858 @vars = split(' ',$2);
859 do 'dumpvar.pl' unless defined &main::dumpvar;
860 if (defined &main::dumpvar) {
863 # must detect sigpipe failures
864 eval { &main::dumpvar($packname,
865 defined $option{dumpDepth}
866 ? $option{dumpDepth} : -1,
869 die unless $@ =~ /dumpvar print failed/;
872 print $OUT "dumpvar.pl not available.\n";
876 $cmd =~ s/^x\b/ / && do { # So that will be evaled
877 $onetimeDump = 'dump';
878 # handle special "x 3 blah" syntax
879 if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
880 $onetimedumpDepth = $1;
883 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
884 methods($1); next CMD};
885 $cmd =~ s/^m\b/ / && do { # So this will be evaled
886 $onetimeDump = 'methods'; };
887 $cmd =~ /^f\b\s*(.*)/ && do {
891 print $OUT "The old f command is now the r command.\n"; # hint
892 print $OUT "The new f command switches filenames.\n";
895 if (!defined $main::{'_<' . $file}) {
896 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
897 $try = substr($try,2);
898 print $OUT "Choosing $try matching `$file':\n";
902 if (!defined $main::{'_<' . $file}) {
903 print $OUT "No file matching `$file' is loaded.\n";
905 } elsif ($file ne $filename) {
906 *dbline = $main::{'_<' . $file};
912 print $OUT "Already in $file.\n";
916 $cmd =~ /^\.$/ && do {
917 $incr = -1; # for backward motion.
919 $filename = $filename_ini;
920 *dbline = $main::{'_<' . $filename};
922 print_lineinfo($position);
924 $cmd =~ /^-$/ && do {
925 $start -= $incr + $window + 1;
926 $start = 1 if $start <= 0;
928 $cmd = 'l ' . ($start) . '+'; };
929 $cmd =~ /^([aAbBhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
930 &cmd_wrapper($1, $2, $line);
933 $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
934 eval { require PadWalker; PadWalker->VERSION(0.08) }
935 or &warn($@ =~ /locate/
936 ? "PadWalker module not found - please install\n"
939 do 'dumpvar.pl' unless defined &main::dumpvar;
940 defined &main::dumpvar
941 or print $OUT "dumpvar.pl not available.\n"
943 my @vars = split(' ', $2 || '');
944 my $h = eval { PadWalker::peek_my(($1 || 0) + 1) };
945 $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
946 my $savout = select($OUT);
947 dumpvar::dumplex($_, $h->{$_},
948 defined $option{dumpDepth}
949 ? $option{dumpDepth} : -1,
954 $cmd =~ /^n$/ && do {
955 end_report(), next CMD if $finished and $level <= 1;
959 $cmd =~ /^s$/ && do {
960 end_report(), next CMD if $finished and $level <= 1;
964 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
965 end_report(), next CMD if $finished and $level <= 1;
967 # Probably not needed, since we finish an interactive
968 # sub-session anyway...
969 # local $filename = $filename;
970 # local *dbline = *dbline; # XXX Would this work?!
971 if ($subname =~ /\D/) { # subroutine name
972 $subname = $package."::".$subname
973 unless $subname =~ /::/;
974 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
978 *dbline = $main::{'_<' . $filename};
979 $had_breakpoints{$filename} |= 1;
981 ++$i while $dbline[$i] == 0 && $i < $max;
983 print $OUT "Subroutine $subname not found.\n";
988 if ($dbline[$i] == 0) {
989 print $OUT "Line $i not breakable.\n";
992 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
994 for ($i=0; $i <= $stack_depth; ) {
998 $cmd =~ /^r$/ && do {
999 end_report(), next CMD if $finished and $level <= 1;
1000 $stack[$stack_depth] |= 1;
1001 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1003 $cmd =~ /^R$/ && do {
1004 print $OUT "Warning: some settings and command-line options may be lost!\n";
1005 my (@script, @flags, $cl);
1006 push @flags, '-w' if $ini_warn;
1007 if ($ini_assertion and @{^ASSERTING}) {
1008 push @flags, (map { /\:\^\(\?\:(.*)\)\$\)/ ?
1009 "-A$1" : "-A$_" } @{^ASSERTING});
1011 # Put all the old includes at the start to get
1012 # the same debugger.
1014 push @flags, '-I', $_;
1016 push @flags, '-T' if ${^TAINT};
1017 # Arrange for setting the old INC:
1018 set_list("PERLDB_INC", @ini_INC);
1020 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1021 chomp ($cl = ${'::_<-e'}[$_]);
1022 push @script, '-e', $cl;
1027 set_list("PERLDB_HIST",
1028 $term->Features->{getHistory}
1029 ? $term->GetHistory : @hist);
1030 my @had_breakpoints = keys %had_breakpoints;
1031 set_list("PERLDB_VISITED", @had_breakpoints);
1032 set_list("PERLDB_OPT", options2remember());
1033 set_list("PERLDB_ON_LOAD", %break_on_load);
1035 for (0 .. $#had_breakpoints) {
1036 my $file = $had_breakpoints[$_];
1037 *dbline = $main::{'_<' . $file};
1038 next unless %dbline or $postponed_file{$file};
1039 (push @hard, $file), next
1040 if $file =~ /^\(\w*eval/;
1042 @add = %{$postponed_file{$file}}
1043 if $postponed_file{$file};
1044 set_list("PERLDB_FILE_$_", %dbline, @add);
1046 for (@hard) { # Yes, really-really...
1047 # Find the subroutines in this eval
1048 *dbline = $main::{'_<' . $_};
1049 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1050 for $sub (keys %sub) {
1051 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1052 $subs{$sub} = [$1, $2];
1056 "No subroutines in $_, ignoring breakpoints.\n";
1059 LINES: for $line (keys %dbline) {
1060 # One breakpoint per sub only:
1061 my ($offset, $sub, $found);
1062 SUBS: for $sub (keys %subs) {
1063 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1064 and (not defined $offset # Not caught
1065 or $offset < 0 )) { # or badly caught
1067 $offset = $line - $subs{$sub}->[0];
1068 $offset = "+$offset", last SUBS if $offset >= 0;
1071 if (defined $offset) {
1072 $postponed{$found} =
1073 "break $offset if $dbline{$line}";
1075 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1079 set_list("PERLDB_POSTPONE", %postponed);
1080 set_list("PERLDB_PRETYPE", @$pretype);
1081 set_list("PERLDB_PRE", @$pre);
1082 set_list("PERLDB_POST", @$post);
1083 set_list("PERLDB_TYPEAHEAD", @typeahead);
1084 $ENV{PERLDB_RESTART} = 1;
1085 delete $ENV{PERLDB_PIDS}; # Restore ini state
1086 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1087 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1088 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1089 print $OUT "exec failed: $!\n";
1091 $cmd =~ /^T$/ && do {
1092 print_trace($OUT, 1); # skip DB
1094 $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; };
1095 $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W('W', $1); next CMD; };
1096 $cmd =~ /^\/(.*)$/ && do {
1098 $inpat =~ s:([^\\])/$:$1:;
1100 # squelch the sigmangler
1101 local $SIG{__DIE__};
1102 local $SIG{__WARN__};
1103 eval '$inpat =~ m'."\a$inpat\a";
1115 $start = 1 if ($start > $max);
1116 last if ($start == $end);
1117 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1118 if ($slave_editor) {
1119 print $OUT "\032\032$filename:$start:0\n";
1121 print $OUT "$start:\t", $dbline[$start], "\n";
1126 print $OUT "/$pat/: not found\n" if ($start == $end);
1128 $cmd =~ /^\?(.*)$/ && do {
1130 $inpat =~ s:([^\\])\?$:$1:;
1132 # squelch the sigmangler
1133 local $SIG{__DIE__};
1134 local $SIG{__WARN__};
1135 eval '$inpat =~ m'."\a$inpat\a";
1147 $start = $max if ($start <= 0);
1148 last if ($start == $end);
1149 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1150 if ($slave_editor) {
1151 print $OUT "\032\032$filename:$start:0\n";
1153 print $OUT "$start:\t", $dbline[$start], "\n";
1158 print $OUT "?$pat?: not found\n" if ($start == $end);
1160 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1161 pop(@hist) if length($cmd) > 1;
1162 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1164 print $OUT $cmd, "\n";
1166 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1169 $cmd =~ /^$rc([^$rc].*)$/ && do {
1171 pop(@hist) if length($cmd) > 1;
1172 for ($i = $#hist; $i; --$i) {
1173 last if $hist[$i] =~ /$pat/;
1176 print $OUT "No such command!\n\n";
1180 print $OUT $cmd, "\n";
1182 $cmd =~ /^$sh$/ && do {
1183 &system($ENV{SHELL}||"/bin/sh");
1185 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1186 # XXX: using csh or tcsh destroys sigint retvals!
1187 #&system($1); # use this instead
1188 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1190 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1191 $end = $2 ? ($#hist-$2) : 0;
1192 $hist = 0 if $hist < 0;
1193 for ($i=$#hist; $i>$end; $i--) {
1194 print $OUT "$i: ",$hist[$i],"\n"
1195 unless $hist[$i] =~ /^.?$/;
1198 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1201 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1202 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1203 $cmd =~ s/^=\s*// && do {
1205 if (length $cmd == 0) {
1206 @keys = sort keys %alias;
1207 } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1208 # can't use $_ or kill //g state
1209 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1210 $alias{$k} = "s\a$k\a$v\a";
1211 # squelch the sigmangler
1212 local $SIG{__DIE__};
1213 local $SIG{__WARN__};
1214 unless (eval "sub { s\a$k\a$v\a }; 1") {
1215 print $OUT "Can't alias $k to $v: $@\n";
1224 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1225 print $OUT "$k\t= $1\n";
1227 elsif (defined $alias{$k}) {
1228 print $OUT "$k\t$alias{$k}\n";
1231 print "No alias for $k\n";
1235 $cmd =~ /^source\s+(.*\S)/ && do {
1236 if (open my $fh, $1) {
1239 &warn("Can't execute `$1': $!\n");
1243 =head4 C<save> - send current history to a file
1245 Takes the complete history, (not the shrunken version you see with C<H>),
1246 and saves it to the given filename, so it can be replayed using C<source>.
1248 Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
1252 # save source - write commands to a file for later use
1253 $cmd =~ /^save\s*(.*)$/ && do {
1254 my $file = $1 || '.perl5dbrc'; # default?
1255 if (open my $fh, "> $file") {
1256 # chomp to remove extraneous newlines from source'd files
1257 chomp(my @truelist = map { m/^\s*(save|source)/ ? "#$_": $_ } @truehist);
1258 print $fh join("\n", @truelist);
1259 print "commands saved in $file\n";
1261 &warn("Can't save debugger commands in '$1': $!\n");
1266 $cmd =~ /^\|\|?\s*[^|]/ && do {
1267 if ($pager =~ /^\|/) {
1268 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1269 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1271 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1274 unless ($piped=open(OUT,$pager)) {
1275 &warn("Can't pipe output to `$pager'");
1276 if ($pager =~ /^\|/) {
1277 open(OUT,">&STDOUT") # XXX: lost message
1278 || &warn("Can't restore DB::OUT");
1279 open(STDOUT,">&SAVEOUT")
1280 || &warn("Can't restore STDOUT");
1283 open(OUT,">&STDOUT") # XXX: lost message
1284 || &warn("Can't restore DB::OUT");
1288 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1289 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1290 $selected= select(OUT);
1292 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1293 $cmd =~ s/^\|+\s*//;
1296 # XXX Local variants do not work!
1297 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1298 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1299 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1301 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1303 $onetimeDump = undef;
1304 $onetimedumpDepth = undef;
1305 } elsif ($term_pid == $$) {
1312 if ($pager =~ /^\|/) {
1314 # we cannot warn here: the handle is missing --tchrist
1315 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1317 # most of the $? crud was coping with broken cshisms
1319 print SAVEOUT "Pager `$pager' failed: ";
1321 print SAVEOUT "shell returned -1\n";
1324 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1325 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1327 print SAVEOUT "status ", ($? >> 8), "\n";
1331 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1332 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1333 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1334 # Will stop ignoring SIGPIPE if done like nohup(1)
1335 # does SIGINT but Perl doesn't give us a choice.
1337 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1340 select($selected), $selected= "" unless $selected eq "";
1344 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1345 foreach $evalarg (@$post) {
1348 } # if ($single || $signal)
1349 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1353 # The following code may be executed now:
1357 my ($al, $ret, @ret) = "";
1358 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1361 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1362 $#stack = $stack_depth;
1363 $stack[-1] = $single;
1365 $single |= 4 if $stack_depth == $deep;
1367 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1368 # Why -1? But it works! :-(
1369 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1370 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1379 $signal=1 unless $warnassertions;
1385 $single |= $stack[$stack_depth--];
1387 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1388 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1389 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1390 if ($doret eq $stack_depth or $frame & 16) {
1392 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1393 print $fh ' ' x $stack_depth if $frame & 16;
1394 print $fh "list context return from $sub:\n";
1395 dumpit($fh, \@ret );
1407 $signal=1 unless $warnassertions;
1409 $ret=undef unless defined wantarray;
1412 if (defined wantarray) {
1418 $single |= $stack[$stack_depth--];
1420 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1421 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1422 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1423 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1425 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1426 print $fh (' ' x $stack_depth) if $frame & 16;
1427 print $fh (defined wantarray
1428 ? "scalar context return from $sub: "
1429 : "void context return from $sub\n");
1430 dumpit( $fh, $ret ) if defined wantarray;
1439 ### Functions with multiple modes of failure die on error, the rest
1440 ### returns FALSE on error.
1441 ### User-interface functions cmd_* output error message.
1443 ### Note all cmd_[a-zA-Z]'s require $cmd, $line, $dblineno as first arguments
1448 'A' => 'pre580_null',
1450 'B' => 'pre580_null',
1451 'd' => 'pre580_null',
1454 'M' => 'pre580_null',
1456 'o' => 'pre580_null',
1462 '<' => 'pre590_prepost',
1463 '<<' => 'pre590_prepost',
1464 '>' => 'pre590_prepost',
1465 '>>' => 'pre590_prepost',
1466 '{' => 'pre590_prepost',
1467 '{{' => 'pre590_prepost',
1474 my $dblineno = shift;
1476 # with this level of indirection we can wrap
1477 # to old (pre580) or other command sets easily
1480 $set{$CommandSet}{$cmd} || ($cmd =~ /^[<>{]+/o ? 'prepost' : $cmd)
1482 # print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
1484 return &$call($cmd, $line, $dblineno);
1488 my $cmd = shift; # a
1489 my $line = shift || ''; # [.|line] expr
1490 my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
1491 if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
1492 my ($lineno, $expr) = ($1, $2);
1494 if ($dbline[$lineno] == 0) {
1495 print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
1497 $had_breakpoints{$filename} |= 2;
1498 $dbline{$lineno} =~ s/\0[^\0]*//;
1499 $dbline{$lineno} .= "\0" . action($expr);
1503 print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
1508 my $cmd = shift; # A
1509 my $line = shift || '';
1510 my $dbline = shift; $line =~ s/^\./$dbline/;
1512 eval { &delete_action(); 1 } or print $OUT $@ and return;
1513 } elsif ($line =~ /^(\S.*)/) {
1514 eval { &delete_action($1); 1 } or print $OUT $@ and return;
1516 print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
1523 die "Line $i has no action .\n" if $dbline[$i] == 0;
1524 $dbline{$i} =~ s/\0[^\0]*//; # \^a
1525 delete $dbline{$i} if $dbline{$i} eq '';
1527 print $OUT "Deleting all actions...\n";
1528 for my $file (keys %had_breakpoints) {
1529 local *dbline = $main::{'_<' . $file};
1532 for ($i = 1; $i <= $max ; $i++) {
1533 if (defined $dbline{$i}) {
1534 $dbline{$i} =~ s/\0[^\0]*//;
1535 delete $dbline{$i} if $dbline{$i} eq '';
1537 unless ($had_breakpoints{$file} &= ~2) {
1538 delete $had_breakpoints{$file};
1546 my $cmd = shift; # b
1547 my $line = shift; # [.|line] [cond]
1548 my $dbline = shift; $line =~ s/^\./$dbline/;
1549 if ($line =~ /^\s*$/) {
1550 &cmd_b_line($dbline, 1);
1551 } elsif ($line =~ /^load\b\s*(.*)/) {
1552 my $file = $1; $file =~ s/\s+$//;
1554 } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
1555 my $cond = length $3 ? $3 : '1';
1556 my ($subname, $break) = ($2, $1 eq 'postpone');
1557 $subname =~ s/\'/::/g;
1558 $subname = "${'package'}::" . $subname unless $subname =~ /::/;
1559 $subname = "main".$subname if substr($subname,0,2) eq "::";
1560 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
1561 } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
1563 $cond = length $2 ? $2 : '1';
1564 &cmd_b_sub($subname, $cond);
1565 } elsif ($line =~ /^(\d*)\s*(.*)/) {
1566 $line = $1 || $dbline;
1567 $cond = length $2 ? $2 : '1';
1568 &cmd_b_line($line, $cond);
1570 print "confused by line($line)?\n";
1576 $break_on_load{$file} = 1;
1577 $had_breakpoints{$file} |= 1;
1580 sub report_break_on_load {
1581 sort keys %break_on_load;
1589 push @files, $::INC{$file} if $::INC{$file};
1590 $file .= '.pm', redo unless $file =~ /\./;
1592 break_on_load($_) for @files;
1593 @files = report_break_on_load;
1596 print $OUT "Will stop on load of `@files'.\n";
1599 $filename_error = '';
1601 sub breakable_line {
1602 my ($from, $to) = @_;
1605 my $delta = $from < $to ? +1 : -1;
1606 my $limit = $delta > 0 ? $#dbline : 1;
1607 $limit = $to if ($limit - $to) * $delta > 0;
1608 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1610 return $i unless $dbline[$i] == 0;
1611 my ($pl, $upto) = ('', '');
1612 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1613 die "Line$pl $from$upto$filename_error not breakable\n";
1616 sub breakable_line_in_filename {
1618 local *dbline = $main::{'_<' . $f};
1619 local $filename_error = " of `$f'";
1624 my ($i, $cond) = @_;
1625 $cond = 1 unless @_ >= 2;
1629 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1630 $had_breakpoints{$filename} |= 1;
1631 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1632 else { $dbline{$i} = $cond; }
1636 eval { break_on_line(@_); 1 } or do {
1638 print $OUT $@ and return;
1642 sub break_on_filename_line {
1643 my ($f, $i, $cond) = @_;
1644 $cond = 1 unless @_ >= 3;
1645 local *dbline = $main::{'_<' . $f};
1646 local $filename_error = " of `$f'";
1647 local $filename = $f;
1648 break_on_line($i, $cond);
1651 sub break_on_filename_line_range {
1652 my ($f, $from, $to, $cond) = @_;
1653 my $i = breakable_line_in_filename($f, $from, $to);
1654 $cond = 1 unless @_ >= 3;
1655 break_on_filename_line($f,$i,$cond);
1658 sub subroutine_filename_lines {
1659 my ($subname,$cond) = @_;
1660 # Filename below can contain ':'
1661 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1664 sub break_subroutine {
1665 my $subname = shift;
1666 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1667 die "Subroutine $subname not found.\n";
1668 $cond = 1 unless @_ >= 2;
1669 break_on_filename_line_range($file,$s,$e,@_);
1673 my ($subname,$cond) = @_;
1674 $cond = 1 unless @_ >= 2;
1675 unless (ref $subname eq 'CODE') {
1676 $subname =~ s/\'/::/g;
1678 $subname = "${'package'}::" . $subname
1679 unless $subname =~ /::/;
1680 $subname = "CORE::GLOBAL::$s"
1681 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1682 $subname = "main".$subname if substr($subname,0,2) eq "::";
1684 eval { break_subroutine($subname,$cond); 1 } or do {
1686 print $OUT $@ and return;
1691 my $cmd = shift; # B
1692 my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
1693 my $dbline = shift; $line =~ s/^\./$dbline/;
1695 eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
1696 } elsif ($line =~ /^(\S.*)/) {
1697 eval { &delete_breakpoint($line || $dbline); 1 } or do {
1699 print $OUT $@ and return;
1702 print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
1706 sub delete_breakpoint {
1709 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1710 $dbline{$i} =~ s/^[^\0]*//;
1711 delete $dbline{$i} if $dbline{$i} eq '';
1713 print $OUT "Deleting all breakpoints...\n";
1714 for my $file (keys %had_breakpoints) {
1715 local *dbline = $main::{'_<' . $file};
1718 for ($i = 1; $i <= $max ; $i++) {
1719 if (defined $dbline{$i}) {
1720 $dbline{$i} =~ s/^[^\0]+//;
1721 if ($dbline{$i} =~ s/^\0?$//) {
1726 if (not $had_breakpoints{$file} &= ~1) {
1727 delete $had_breakpoints{$file};
1731 undef %postponed_file;
1732 undef %break_on_load;
1736 sub cmd_stop { # As on ^C, but not signal-safy.
1741 my $cmd = shift; # h
1742 my $line = shift || '';
1743 if ($line =~ /^h\s*/) {
1745 } elsif ($line =~ /^(\S.*)$/) {
1746 # support long commands; otherwise bogus errors
1747 # happen when you ask for h on <CR> for example
1748 my $asked = $1; # for proper errmsg
1749 my $qasked = quotemeta($asked); # for searching
1750 # XXX: finds CR but not <CR>
1751 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
1752 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
1756 print_help("B<$asked> is not a debugger command.\n");
1759 print_help($summary);
1763 =head3 C<cmd_i> - inheritance display
1765 Display the (nested) parentage of the module or object given.
1772 eval { require Class::ISA };
1774 &warn($@ =~ /locate/ ? "Class::ISA module not found - please install\n" : $@);
1777 foreach my $isa (split(/\s+/, $line)) {
1779 print join(', ', map { # snaffled unceremoniously from Class::ISA
1780 "$_".(defined(${"$_\::VERSION"}) ? ' '.${"$_\::VERSION"} : undef)
1781 } Class::ISA::self_and_super_path($isa));
1788 my $current_line = $line;
1789 my $cmd = shift; # l
1791 $line =~ s/^-\s*$/-/;
1792 if ($line =~ /^(\$.*)/s) {
1795 print($OUT "Error: $@\n"), next CMD if $@;
1797 print($OUT "Interpreted as: $1 $s\n");
1800 } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
1801 my $s = $subname = $1;
1802 $subname =~ s/\'/::/;
1803 $subname = $package."::".$subname
1804 unless $subname =~ /::/;
1805 $subname = "CORE::GLOBAL::$s"
1806 if not defined &$subname and $s !~ /::/
1807 and defined &{"CORE::GLOBAL::$s"};
1808 $subname = "main".$subname if substr($subname,0,2) eq "::";
1809 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
1810 $subrange = pop @pieces;
1811 $file = join(':', @pieces);
1812 if ($file ne $filename) {
1813 print $OUT "Switching to file '$file'.\n"
1814 unless $slave_editor;
1815 *dbline = $main::{'_<' . $file};
1820 if (eval($subrange) < -$window) {
1821 $subrange =~ s/-.*/+/;
1824 &cmd_l('l', $subrange);
1826 print $OUT "Subroutine $subname not found.\n";
1828 } elsif ($line =~ /^\s*$/) {
1829 $incr = $window - 1;
1830 $line = $start . '-' . ($start + $incr);
1832 } elsif ($line =~ /^(\d*)\+(\d*)$/) {
1835 $incr = $window - 1 unless $incr;
1836 $line = $start . '-' . ($start + $incr);
1838 } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
1839 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
1840 $end = $max if $end > $max;
1842 $i = $line if $i eq '.';
1845 if ($slave_editor) {
1846 print $OUT "\032\032$filename:$i:0\n";
1849 for (; $i <= $end; $i++) {
1851 ($stop,$action) = split(/\0/, $dbline{$i}) if
1853 $arrow = ($i==$current_line
1854 and $filename eq $filename_ini)
1856 : ($dbline[$i]+0 ? ':' : ' ') ;
1857 $arrow .= 'b' if $stop;
1858 $arrow .= 'a' if $action;
1859 print $OUT "$i$arrow\t", $dbline[$i];
1860 $i++, last if $signal;
1862 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
1864 $start = $i; # remember in case they want more
1865 $start = $max if $start > $max;
1870 my $cmd = shift; # L
1871 my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
1872 my $action_wanted = ($arg =~ /a/) ? 1 : 0;
1873 my $break_wanted = ($arg =~ /b/) ? 1 : 0;
1874 my $watch_wanted = ($arg =~ /w/) ? 1 : 0;
1876 if ($break_wanted or $action_wanted) {
1877 for my $file (keys %had_breakpoints) {
1878 local *dbline = $main::{'_<' . $file};
1881 for ($i = 1; $i <= $max; $i++) {
1882 if (defined $dbline{$i}) {
1883 print $OUT "$file:\n" unless $was++;
1884 print $OUT " $i:\t", $dbline[$i];
1885 ($stop,$action) = split(/\0/, $dbline{$i});
1886 print $OUT " break if (", $stop, ")\n"
1887 if $stop and $break_wanted;
1888 print $OUT " action: ", $action, "\n"
1889 if $action and $action_wanted;
1895 if (%postponed and $break_wanted) {
1896 print $OUT "Postponed breakpoints in subroutines:\n";
1898 for $subname (keys %postponed) {
1899 print $OUT " $subname\t$postponed{$subname}\n";
1903 my @have = map { # Combined keys
1904 keys %{$postponed_file{$_}}
1905 } keys %postponed_file;
1906 if (@have and ($break_wanted or $action_wanted)) {
1907 print $OUT "Postponed breakpoints in files:\n";
1909 for $file (keys %postponed_file) {
1910 my $db = $postponed_file{$file};
1911 print $OUT " $file:\n";
1912 for $line (sort {$a <=> $b} keys %$db) {
1913 print $OUT " $line:\n";
1914 my ($stop,$action) = split(/\0/, $$db{$line});
1915 print $OUT " break if (", $stop, ")\n"
1916 if $stop and $break_wanted;
1917 print $OUT " action: ", $action, "\n"
1918 if $action and $action_wanted;
1924 if (%break_on_load and $break_wanted) {
1925 print $OUT "Breakpoints on load:\n";
1927 for $file (keys %break_on_load) {
1928 print $OUT " $file\n";
1932 if ($watch_wanted) {
1934 print $OUT "Watch-expressions:\n" if @to_watch;
1935 for my $expr (@to_watch) {
1936 print $OUT " $expr\n";
1948 my $cmd = shift; # o
1949 my $opt = shift || ''; # opt[=val]
1950 if ($opt =~ /^(\S.*)/) {
1960 print $OUT "The old O command is now the o command.\n"; # hint
1961 print $OUT "Use 'h' to get current command help synopsis or\n"; #
1962 print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; #
1966 my $cmd = shift; # v
1969 if ($line =~ /^(\d*)$/) {
1970 $incr = $window - 1;
1973 $line = $start . '-' . ($start + $incr);
1979 my $cmd = shift; # w
1980 my $expr = shift || '';
1981 if ($expr =~ /^(\S.*)/) {
1982 push @to_watch, $expr;
1984 my ($val) = join(' ', &eval);
1985 $val = (defined $val) ? "'$val'" : 'undef' ;
1986 push @old_watch, $val;
1989 print $OUT "Adding a watch-expression requires an expression\n"; # hint
1994 my $cmd = shift; # W
1995 my $expr = shift || '';
1998 print $OUT "Deleting all watch expressions ...\n";
1999 @to_watch = @old_watch = ();
2000 } elsif ($expr =~ /^(\S.*)/) {
2002 foreach (@to_watch) {
2003 my $val = $to_watch[$i_cnt];
2004 if ($val eq $expr) { # =~ m/^\Q$i$/) {
2005 splice(@to_watch, $i_cnt, 1);
2010 print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
2017 if ($cmd =~ /^.\b\s*([+-]?)\s*(~?)\s*(\w+(\s*\|\s*\w+)*)\s*$/) {
2018 my ($how, $neg, $flags)=($1, $2, $3);
2019 my $acu=parse_DollarCaretP_flags($flags);
2021 $acu= ~$acu if $neg;
2022 if ($how eq '+') { $^P|=$acu }
2023 elsif ($how eq '-') { $^P&=~$acu }
2026 # else { print $OUT "undefined acu\n" }
2028 my $expanded=expand_DollarCaretP_flags($^P);
2029 print $OUT "Internal Perl debugger flags:\n\$^P=$expanded\n";
2033 ### END of the API section
2036 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
2037 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
2040 sub print_lineinfo {
2041 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
2047 # The following takes its argument via $evalarg to preserve current @_
2050 my $subname = shift;
2051 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
2052 my $offset = $1 || 0;
2053 # Filename below can contain ':'
2054 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
2057 local *dbline = $main::{'_<' . $file};
2058 local $^W = 0; # != 0 is magical below
2059 $had_breakpoints{$file} |= 1;
2061 ++$i until $dbline[$i] != 0 or $i >= $max;
2062 $dbline{$i} = delete $postponed{$subname};
2065 print $OUT "Subroutine $subname not found.\n";
2069 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
2070 #print $OUT "In postponed_sub for `$subname'.\n";
2074 if ($ImmediateStop) {
2078 return &postponed_sub
2079 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
2080 # Cannot be done before the file is compiled
2081 local *dbline = shift;
2082 my $filename = $dbline;
2083 $filename =~ s/^_<//;
2085 $signal = 1, print $OUT "'$filename' loaded...\n"
2086 if $break_on_load{$filename};
2087 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
2088 return unless $postponed_file{$filename};
2089 $had_breakpoints{$filename} |= 1;
2090 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
2092 for $key (keys %{$postponed_file{$filename}}) {
2093 $dbline{$key} = ${$postponed_file{$filename}}{$key};
2095 delete $postponed_file{$filename};
2099 local ($savout) = select(shift);
2100 my $osingle = $single;
2101 my $otrace = $trace;
2102 $single = $trace = 0;
2105 unless (defined &main::dumpValue) {
2108 if (defined &main::dumpValue) {
2113 my $maxdepth = shift || $option{dumpDepth};
2114 $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
2115 &main::dumpValue($v, $maxdepth);
2118 print $OUT "dumpvar.pl not available.\n";
2125 # Tied method do not create a context, so may get wrong message:
2130 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
2131 my @sub = dump_trace($_[0] + 1, $_[1]);
2132 my $short = $_[2]; # Print short report, next one for sub name
2134 for ($i=0; $i <= $#sub; $i++) {
2137 my $args = defined $sub[$i]{args}
2138 ? "(@{ $sub[$i]{args} })"
2140 $args = (substr $args, 0, $maxtrace - 3) . '...'
2141 if length $args > $maxtrace;
2142 my $file = $sub[$i]{file};
2143 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
2145 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
2147 my $sub = @_ >= 4 ? $_[3] : $s;
2148 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
2150 print $fh "$sub[$i]{context} = $s$args" .
2151 " called from $file" .
2152 " line $sub[$i]{line}\n";
2159 my $count = shift || 1e9;
2162 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
2163 my $nothard = not $frame & 8;
2164 local $frame = 0; # Do not want to trace this.
2165 my $otrace = $trace;
2168 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
2173 if (not defined $arg) {
2175 } elsif ($nothard and tied $arg) {
2177 } elsif ($nothard and $type = ref $arg) {
2178 push @a, "ref($type)";
2180 local $_ = "$arg"; # Safe to stringify now - should not call f().
2183 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
2184 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
2185 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
2189 $context = $context ? '@' : (defined $context ? "\$" : '.');
2190 $args = $h ? [@a] : undef;
2191 $e =~ s/\n\s*\;\s*\Z// if $e;
2192 $e =~ s/([\\\'])/\\$1/g if $e;
2194 $sub = "require '$e'";
2195 } elsif (defined $r) {
2197 } elsif ($sub eq '(eval)') {
2198 $sub = "eval {...}";
2200 push(@sub, {context => $context, sub => $sub, args => $args,
2201 file => $file, line => $line});
2210 while ($action =~ s/\\$//) {
2219 # i hate using globals!
2220 $balanced_brace_re ||= qr{
2223 (?> [^{}] + ) # Non-parens without backtracking
2225 (??{ $balanced_brace_re }) # Group with matching parens
2229 return $_[0] !~ m/$balanced_brace_re/;
2233 &readline("cont: ");
2237 # We save, change, then restore STDIN and STDOUT to avoid fork() since
2238 # some non-Unix systems can do system() but have problems with fork().
2239 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
2240 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
2241 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
2242 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
2244 # XXX: using csh or tcsh destroys sigint retvals!
2246 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
2247 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
2252 # most of the $? crud was coping with broken cshisms
2254 &warn("(Command exited ", ($? >> 8), ")\n");
2256 &warn( "(Command died of SIG#", ($? & 127),
2257 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
2267 eval { require Term::ReadLine } or die $@;
2270 my ($i, $o) = split $tty, /,/;
2271 $o = $i unless defined $o;
2272 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
2273 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
2276 my $sel = select($OUT);
2280 eval "require Term::Rendezvous;" or die;
2281 my $rv = $ENV{PERLDB_NOTTY} || ".perldbtty$$";
2282 my $term_rv = new Term::Rendezvous $rv;
2284 $OUT = $term_rv->OUT;
2287 if ($term_pid eq '-1') { # In a TTY with another debugger
2291 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2293 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2295 $rl_attribs = $term->Attribs;
2296 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2297 if defined $rl_attribs->{basic_word_break_characters}
2298 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2299 $rl_attribs->{special_prefixes} = '$@&%';
2300 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2301 $rl_attribs->{completion_function} = \&db_complete;
2303 $LINEINFO = $OUT unless defined $LINEINFO;
2304 $lineinfo = $console unless defined $lineinfo;
2306 if ($term->Features->{setHistory} and "@hist" ne "?") {
2307 $term->SetHistory(@hist);
2309 ornaments($ornaments) if defined $ornaments;
2313 # Example get_fork_TTY functions
2314 sub xterm_get_fork_TTY {
2315 (my $name = $0) =~ s,^.*[/\\],,s;
2316 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2320 $pidprompt = ''; # Shown anyway in titlebar
2324 # This example function resets $IN, $OUT itself
2325 sub os2_get_fork_TTY {
2326 local $^F = 40; # XXXX Fixme!
2328 my ($in1, $out1, $in2, $out2);
2329 # Having -d in PERL5OPT would lead to a disaster...
2330 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2331 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2332 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2333 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2334 local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB};
2335 $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB};
2336 $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB};
2337 (my $name = $0) =~ s,^.*[/\\],,s;
2339 if ( pipe $in1, $out1 and pipe $in2, $out2
2340 # system P_SESSION will fail if there is another process
2341 # in the same session with a "dependent" asynchronous child session.
2342 and @args = ($rl, fileno $in1, fileno $out2,
2343 "Daughter Perl debugger $pids $name") and
2344 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2345 END {sleep 5 unless $loaded}
2346 BEGIN {open STDIN, '</dev/con' or warn "reopen stdin: $!"}
2349 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2351 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2352 open IN, '<&=$in' or die "open <&=$in: \$!";
2353 \$| = 1; print while sysread IN, \$_, 1<<16;
2357 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2359 require Term::ReadKey if $rl;
2360 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2361 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2363 or warn "system P_SESSION: $!, $^E" and 0)
2364 and close $in1 and close $out2 ) {
2365 $pidprompt = ''; # Shown anyway in titlebar
2366 reset_IN_OUT($in2, $out1);
2368 return ''; # Indicate that reset_IN_OUT is called
2373 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2374 my $in = &get_fork_TTY if defined &get_fork_TTY;
2375 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2376 if (not defined $in) {
2378 print_help(<<EOP) if $why == 1;
2379 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2381 print_help(<<EOP) if $why == 2;
2382 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2383 This may be an asynchronous session, so the parent debugger may be active.
2385 print_help(<<EOP) if $why != 4;
2386 Since two debuggers fight for the same TTY, input is severely entangled.
2390 I know how to switch the output to a different window in xterms
2391 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2392 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2394 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2395 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2398 } elsif ($in ne '') {
2401 $console = ''; # Indicate no need to open-from-the-console
2406 sub resetterm { # We forked, so we need a different TTY
2408 my $systemed = $in > 1 ? '-' : '';
2410 $pids =~ s/\]/$systemed->$$]/;
2412 $pids = "[$term_pid->$$]";
2416 return unless $CreateTTY & $in;
2423 my $left = @typeahead;
2424 my $got = shift @typeahead;
2426 print $OUT "auto(-$left)", shift, $got, "\n";
2427 $term->AddHistory($got)
2428 if length($got) > 1 and defined $term->Features->{addHistory};
2434 my $line = CORE::readline($cmdfhs[-1]);
2435 defined $line ? (print $OUT ">> $line" and return $line)
2436 : close pop @cmdfhs;
2438 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2439 $OUT->write(join('', @_));
2441 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2445 $term->readline(@_);
2450 my ($opt, $val)= @_;
2451 $val = option_val($opt,'N/A');
2452 $val =~ s/([\\\'])/\\$1/g;
2453 printf $OUT "%20s = '%s'\n", $opt, $val;
2456 sub options2remember {
2457 foreach my $k (@RememberOnROptions) {
2458 $option{$k}=option_val($k, 'N/A');
2464 my ($opt, $default)= @_;
2466 if (defined $optionVars{$opt}
2467 and defined ${$optionVars{$opt}}) {
2468 $val = ${$optionVars{$opt}};
2469 } elsif (defined $optionAction{$opt}
2470 and defined &{$optionAction{$opt}}) {
2471 $val = &{$optionAction{$opt}}();
2472 } elsif (defined $optionAction{$opt}
2473 and not defined $option{$opt}
2474 or defined $optionVars{$opt}
2475 and not defined ${$optionVars{$opt}}) {
2478 $val = $option{$opt};
2480 $val = $default unless defined $val;
2487 # too dangerous to let intuitive usage overwrite important things
2488 # defaultion should never be the default
2489 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2490 dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2491 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2496 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2497 my ($opt,$sep) = ($1,$2);
2500 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2502 #&dump_option($opt);
2503 } elsif ($sep !~ /\S/) {
2505 $val = "1"; # this is an evil default; make 'em set it!
2506 } elsif ($sep eq "=") {
2507 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2509 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2513 print OUT qq(Option better cleared using $opt=""\n)
2517 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2518 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2519 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2520 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2521 ($val = $1) =~ s/\\([\\$end])/$1/g;
2525 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2526 || grep( /^\Q$opt/i && ($option = $_), @options );
2528 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2529 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2531 if ($opt_needs_val{$option} && $val_defaulted) {
2532 my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
2533 print $OUT "Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
2537 $option{$option} = $val if defined $val;
2542 require '$optionRequire{$option}';
2544 } || die # XXX: shouldn't happen
2545 if defined $optionRequire{$option} &&
2548 ${$optionVars{$option}} = $val
2549 if defined $optionVars{$option} &&
2552 &{$optionAction{$option}} ($val)
2553 if defined $optionAction{$option} &&
2554 defined &{$optionAction{$option}} &&
2558 dump_option($option) unless $OUT eq \*STDERR;
2563 my ($stem,@list) = @_;
2565 $ENV{"${stem}_n"} = @list;
2566 for $i (0 .. $#list) {
2568 $val =~ s/\\/\\\\/g;
2569 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2570 $ENV{"${stem}_$i"} = $val;
2577 my $n = delete $ENV{"${stem}_n"};
2579 for $i (0 .. $n - 1) {
2580 $val = delete $ENV{"${stem}_$i"};
2581 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2589 return; # Put nothing on the stack - malloc/free land!
2593 my($msg)= join("",@_);
2594 $msg .= ": $!\n" unless $msg =~ /\n$/;
2600 my $switch_li = $LINEINFO eq $OUT;
2601 if ($term and $term->Features->{newTTY}) {
2602 ($IN, $OUT) = (shift, shift);
2603 $term->newTTY($IN, $OUT);
2605 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2607 ($IN, $OUT) = (shift, shift);
2609 my $o = select $OUT;
2612 $LINEINFO = $OUT if $switch_li;
2616 if (@_ and $term and $term->Features->{newTTY}) {
2617 my ($in, $out) = shift;
2619 ($in, $out) = split /,/, $in, 2;
2623 open IN, $in or die "cannot open `$in' for read: $!";
2624 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2625 reset_IN_OUT(\*IN,\*OUT);
2628 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2629 # Useful if done through PERLDB_OPTS:
2630 $console = $tty = shift if @_;
2636 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2638 $notty = shift if @_;
2644 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2652 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2654 $remoteport = shift if @_;
2659 if (${$term->Features}{tkRunning}) {
2660 return $term->tkRunning(@_);
2663 print $OUT "tkRunning not supported by current ReadLine package.\n";
2670 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2672 $runnonstop = shift if @_;
2678 &warn("Some flag changes could not take effect until next 'R'!\n") if @_;
2680 $^P = parse_DollarCaretP_flags(shift) if @_;
2681 expand_DollarCaretP_flags($^P)
2684 sub OnlyAssertions {
2686 &warn("Too late to set up OnlyAssertions mode, enabled on next 'R'!\n") if @_;
2689 unless (defined $ini_assertion) {
2691 &warn("Current Perl interpreter doesn't support assertions");
2696 unless ($ini_assertion) {
2697 print "Assertions will be active on next 'R'!\n";
2700 $^P&= ~$DollarCaretP_flags{PERLDBf_SUB};
2701 $^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
2704 $^P|=$DollarCaretP_flags{PERLDBf_SUB};
2707 !($^P & $DollarCaretP_flags{PERLDBf_SUB}) || 0;
2713 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2720 $sh = quotemeta shift;
2721 $sh .= "\\b" if $sh =~ /\w$/;
2725 $psh =~ s/\\(.)/$1/g;
2730 if (defined $term) {
2731 local ($warnLevel,$dieLevel) = (0, 1);
2732 return '' unless $term->Features->{ornaments};
2733 eval { $term->ornaments(@_) } || '';
2741 $rc = quotemeta shift;
2742 $rc .= "\\b" if $rc =~ /\w$/;
2746 $prc =~ s/\\(.)/$1/g;
2751 return $lineinfo unless @_;
2753 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2754 $slave_editor = ($stream =~ /^\|/);
2755 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2756 $LINEINFO = \*LINEINFO;
2757 my $save = select($LINEINFO);
2763 sub list_modules { # versions
2771 s/^Term::ReadLine::readline$/readline/;
2772 if (defined ${ $_ . '::VERSION' }) {
2773 $version{$file} = "${ $_ . '::VERSION' } from ";
2775 $version{$file} .= $INC{$file};
2777 dumpit($OUT,\%version);
2781 # XXX: make sure there are tabs between the command and explanation,
2782 # or print_help will screw up your formatting if you have
2783 # eeevil ornaments enabled. This is an insane mess.
2786 Help is currently only available for the new 580 CommandSet,
2787 if you really want old behaviour, presumably you know what
2791 B<s> [I<expr>] Single step [in I<expr>].
2792 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2793 <B<CR>> Repeat last B<n> or B<s> command.
2794 B<r> Return from current subroutine.
2795 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2796 at the specified position.
2797 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2798 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2799 B<l> I<line> List single I<line>.
2800 B<l> I<subname> List first window of lines from subroutine.
2801 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2802 B<l> List next window of lines.
2803 B<-> List previous window of lines.
2804 B<v> [I<line>] View window around I<line>.
2805 B<.> Return to the executed line.
2806 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2807 I<filename> may be either the full name of the file, or a regular
2808 expression matching the full file name:
2809 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2810 Evals (with saved bodies) are considered to be filenames:
2811 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2812 (in the order of execution).
2813 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2814 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2815 B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions.
2816 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2817 B<t> Toggle trace mode.
2818 B<t> I<expr> Trace through execution of I<expr>.
2819 B<b> Sets breakpoint on current line)
2820 B<b> [I<line>] [I<condition>]
2821 Set breakpoint; I<line> defaults to the current execution line;
2822 I<condition> breaks if it evaluates to true, defaults to '1'.
2823 B<b> I<subname> [I<condition>]
2824 Set breakpoint at first line of subroutine.
2825 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2826 B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
2827 B<b> B<postpone> I<subname> [I<condition>]
2828 Set breakpoint at first line of subroutine after
2830 B<b> B<compile> I<subname>
2831 Stop after the subroutine is compiled.
2832 B<B> [I<line>] Delete the breakpoint for I<line>.
2833 B<B> I<*> Delete all breakpoints.
2834 B<a> [I<line>] I<command>
2835 Set an action to be done before the I<line> is executed;
2836 I<line> defaults to the current execution line.
2837 Sequence is: check for breakpoint/watchpoint, print line
2838 if necessary, do action, prompt user if necessary,
2841 B<A> [I<line>] Delete the action for I<line>.
2842 B<A> I<*> Delete all actions.
2843 B<w> I<expr> Add a global watch-expression.
2845 B<W> I<expr> Delete a global watch-expression.
2846 B<W> I<*> Delete all watch-expressions.
2847 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2848 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2849 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2850 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2851 B<x> I<expr> Evals expression in list context, dumps the result.
2852 B<m> I<expr> Evals expression in list context, prints methods callable
2853 on the first element of the result.
2854 B<m> I<class> Prints methods callable via the given class.
2855 B<M> Show versions of loaded modules.
2856 B<i> I<class> Prints nested parents of given class.
2857 B<y> [I<n> [I<vars>]] List lexical variables I<n> levels up from current sub
2859 B<<> ? List Perl commands to run before each prompt.
2860 B<<> I<expr> Define Perl command to run before each prompt.
2861 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2862 B<< *> Delete the list of perl commands to run before each prompt.
2863 B<>> ? List Perl commands to run after each prompt.
2864 B<>> I<expr> Define Perl command to run after each prompt.
2865 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2866 B<>>B< *> Delete the list of Perl commands to run after each prompt.
2867 B<{> I<db_command> Define debugger command to run before each prompt.
2868 B<{> ? List debugger commands to run before each prompt.
2869 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2870 B<{ *> Delete the list of debugger commands to run before each prompt.
2871 B<$prc> I<number> Redo a previous command (default previous command).
2872 B<$prc> I<-number> Redo number'th-to-last command.
2873 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2874 See 'B<O> I<recallCommand>' too.
2875 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2876 . ( $rc eq $sh ? "" : "
2877 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2878 See 'B<O> I<shellBang>' too.
2879 B<source> I<file> Execute I<file> containing debugger commands (may nest).
2880 B<save> I<file> Save current debugger session (actual history) to I<file>.
2881 B<H> I<-number> Display last number commands (default all).
2882 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2883 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2884 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2885 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2886 I<command> Execute as a perl statement in current package.
2887 B<R> Pure-man-restart of debugger, some of debugger state
2888 and command-line options may be lost.
2889 Currently the following settings are preserved:
2890 history, breakpoints and actions, debugger B<O>ptions
2891 and the following command-line options: I<-w>, I<-I>, I<-e>.
2893 B<o> [I<opt>] ... Set boolean option to true
2894 B<o> [I<opt>B<?>] Query options
2895 B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2896 Set options. Use quotes in spaces in value.
2897 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2898 I<pager> program for output of \"|cmd\";
2899 I<tkRunning> run Tk while prompting (with ReadLine);
2900 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2901 I<inhibit_exit> Allows stepping off the end of the script.
2902 I<ImmediateStop> Debugger should stop as early as possible.
2903 I<RemotePort> Remote hostname:port for remote debugging
2904 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2905 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2906 I<compactDump>, I<veryCompact> change style of array and hash dump;
2907 I<globPrint> whether to print contents of globs;
2908 I<DumpDBFiles> dump arrays holding debugged files;
2909 I<DumpPackages> dump symbol tables of packages;
2910 I<DumpReused> dump contents of \"reused\" addresses;
2911 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2912 I<bareStringify> Do not print the overload-stringified value;
2913 Other options include:
2914 I<PrintRet> affects printing of return value after B<r> command,
2915 I<frame> affects printing messages on subroutine entry/exit.
2916 I<AutoTrace> affects printing messages on possible breaking points.
2917 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2918 I<ornaments> affects screen appearance of the command line.
2919 I<CreateTTY> bits control attempts to create a new TTY on events:
2920 1: on fork() 2: debugger is started inside debugger
2922 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2923 You can put additional initialization options I<TTY>, I<noTTY>,
2924 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2925 `B<R>' after you set them).
2927 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2928 B<h> Summary of debugger commands.
2929 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2930 B<h h> Long help for debugger commands
2931 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2932 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2933 Set B<\$DB::doccmd> to change viewer.
2935 Type `|h h' for a paged display if this was too hard to read.
2937 "; # Fix balance of vi % matching: }}}}
2939 # note: tabs in the following section are not-so-helpful
2940 $summary = <<"END_SUM";
2941 I<List/search source lines:> I<Control script execution:>
2942 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2943 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2944 B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs
2945 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2946 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2947 B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position
2948 I<Debugger controls:> B<L> List break/watch/actions
2949 B<o> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2950 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2951 B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints
2952 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2953 B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions
2954 B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression
2955 B<h h> Complete help page B<W> I<expr|*> Delete a/all watch exprs
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>]\". B<i> I<class> inheritance tree.
2964 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2965 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2967 # ')}}; # Fix balance of vi % matching
2969 # and this is really numb...
2972 B<s> [I<expr>] Single step [in I<expr>].
2973 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2974 <B<CR>> Repeat last B<n> or B<s> command.
2975 B<r> Return from current subroutine.
2976 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2977 at the specified position.
2978 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2979 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2980 B<l> I<line> List single I<line>.
2981 B<l> I<subname> List first window of lines from subroutine.
2982 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2983 B<l> List next window of lines.
2984 B<-> List previous window of lines.
2985 B<w> [I<line>] List window around I<line>.
2986 B<.> Return to the executed line.
2987 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2988 I<filename> may be either the full name of the file, or a regular
2989 expression matching the full file name:
2990 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2991 Evals (with saved bodies) are considered to be filenames:
2992 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2993 (in the order of execution).
2994 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2995 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2996 B<L> List all breakpoints and actions.
2997 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2998 B<t> Toggle trace mode.
2999 B<t> I<expr> Trace through execution of I<expr>.
3000 B<b> [I<line>] [I<condition>]
3001 Set breakpoint; I<line> defaults to the current execution line;
3002 I<condition> breaks if it evaluates to true, defaults to '1'.
3003 B<b> I<subname> [I<condition>]
3004 Set breakpoint at first line of subroutine.
3005 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
3006 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
3007 B<b> B<postpone> I<subname> [I<condition>]
3008 Set breakpoint at first line of subroutine after
3010 B<b> B<compile> I<subname>
3011 Stop after the subroutine is compiled.
3012 B<d> [I<line>] Delete the breakpoint for I<line>.
3013 B<D> Delete all breakpoints.
3014 B<a> [I<line>] I<command>
3015 Set an action to be done before the I<line> is executed;
3016 I<line> defaults to the current execution line.
3017 Sequence is: check for breakpoint/watchpoint, print line
3018 if necessary, do action, prompt user if necessary,
3020 B<a> [I<line>] Delete the action for I<line>.
3021 B<A> Delete all actions.
3022 B<W> I<expr> Add a global watch-expression.
3023 B<W> Delete all watch-expressions.
3024 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
3025 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
3026 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
3027 B<x> I<expr> Evals expression in list context, dumps the result.
3028 B<m> I<expr> Evals expression in list context, prints methods callable
3029 on the first element of the result.
3030 B<m> I<class> Prints methods callable via the given class.
3032 B<<> ? List Perl commands to run before each prompt.
3033 B<<> I<expr> Define Perl command to run before each prompt.
3034 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
3035 B<>> ? List Perl commands to run after each prompt.
3036 B<>> I<expr> Define Perl command to run after each prompt.
3037 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
3038 B<{> I<db_command> Define debugger command to run before each prompt.
3039 B<{> ? List debugger commands to run before each prompt.
3040 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
3041 B<$prc> I<number> Redo a previous command (default previous command).
3042 B<$prc> I<-number> Redo number'th-to-last command.
3043 B<$prc> I<pattern> Redo last command that started with I<pattern>.
3044 See 'B<O> I<recallCommand>' too.
3045 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
3046 . ( $rc eq $sh ? "" : "
3047 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
3048 See 'B<O> I<shellBang>' too.
3049 B<source> I<file> Execute I<file> containing debugger commands (may nest).
3050 B<H> I<-number> Display last number commands (default all).
3051 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
3052 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
3053 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
3054 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
3055 I<command> Execute as a perl statement in current package.
3056 B<v> Show versions of loaded modules.
3057 B<R> Pure-man-restart of debugger, some of debugger state
3058 and command-line options may be lost.
3059 Currently the following settings are preserved:
3060 history, breakpoints and actions, debugger B<O>ptions
3061 and the following command-line options: I<-w>, I<-I>, I<-e>.
3063 B<O> [I<opt>] ... Set boolean option to true
3064 B<O> [I<opt>B<?>] Query options
3065 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
3066 Set options. Use quotes in spaces in value.
3067 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
3068 I<pager> program for output of \"|cmd\";
3069 I<tkRunning> run Tk while prompting (with ReadLine);
3070 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
3071 I<inhibit_exit> Allows stepping off the end of the script.
3072 I<ImmediateStop> Debugger should stop as early as possible.
3073 I<RemotePort> Remote hostname:port for remote debugging
3074 The following options affect what happens with B<V>, B<X>, and B<x> commands:
3075 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
3076 I<compactDump>, I<veryCompact> change style of array and hash dump;
3077 I<globPrint> whether to print contents of globs;
3078 I<DumpDBFiles> dump arrays holding debugged files;
3079 I<DumpPackages> dump symbol tables of packages;
3080 I<DumpReused> dump contents of \"reused\" addresses;
3081 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
3082 I<bareStringify> Do not print the overload-stringified value;
3083 Other options include:
3084 I<PrintRet> affects printing of return value after B<r> command,
3085 I<frame> affects printing messages on subroutine entry/exit.
3086 I<AutoTrace> affects printing messages on possible breaking points.
3087 I<maxTraceLen> gives max length of evals/args listed in stack trace.
3088 I<ornaments> affects screen appearance of the command line.
3089 I<CreateTTY> bits control attempts to create a new TTY on events:
3090 1: on fork() 2: debugger is started inside debugger
3092 During startup options are initialized from \$ENV{PERLDB_OPTS}.
3093 You can put additional initialization options I<TTY>, I<noTTY>,
3094 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
3095 `B<R>' after you set them).
3097 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
3098 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
3099 B<h h> Summary of debugger commands.
3100 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
3101 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
3102 Set B<\$DB::doccmd> to change viewer.
3104 Type `|h' for a paged display if this was too hard to read.
3106 "; # Fix balance of vi % matching: }}}}
3108 # note: tabs in the following section are not-so-helpful
3109 $pre580_summary = <<"END_SUM";
3110 I<List/search source lines:> I<Control script execution:>
3111 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
3112 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
3113 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
3114 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
3115 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
3116 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
3117 I<Debugger controls:> B<L> List break/watch/actions
3118 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
3119 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
3120 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
3121 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
3122 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
3123 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
3124 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
3125 B<q> or B<^D> Quit B<R> Attempt a restart
3126 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
3127 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
3128 B<p> I<expr> Print expression (uses script's current package).
3129 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
3130 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
3131 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
3132 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
3133 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
3135 # ')}}; # Fix balance of vi % matching
3142 # Restore proper alignment destroyed by eeevil I<> and B<>
3143 # ornaments: A pox on both their houses!
3145 # A help command will have everything up to and including
3146 # the first tab sequence padded into a field 16 (or if indented 20)
3147 # wide. If it's wider than that, an extra space will be added.
3149 ^ # only matters at start of line
3150 ( \040{4} | \t )* # some subcommands are indented
3151 ( < ? # so <CR> works
3152 [BI] < [^\t\n] + ) # find an eeevil ornament
3153 ( \t+ ) # original separation, discarded
3154 ( .* ) # this will now start (no earlier) than
3157 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
3158 my $clean = $command;
3159 $clean =~ s/[BI]<([^>]*)>/$1/g;
3160 # replace with this whole string:
3161 ($leadwhite ? " " x 4 : "")
3163 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
3168 s{ # handle bold ornaments
3169 B < ( [^>] + | > ) >
3171 $Term::ReadLine::TermCap::rl_term_set[2]
3173 . $Term::ReadLine::TermCap::rl_term_set[3]
3176 s{ # handle italic ornaments
3177 I < ( [^>] + | > ) >
3179 $Term::ReadLine::TermCap::rl_term_set[0]
3181 . $Term::ReadLine::TermCap::rl_term_set[1]
3189 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
3190 my $is_less = $pager =~ /\bless\b/;
3191 if ($pager =~ /\bmore\b/) {
3192 my @st_more = stat('/usr/bin/more');
3193 my @st_less = stat('/usr/bin/less');
3194 $is_less = @st_more && @st_less
3195 && $st_more[0] == $st_less[0]
3196 && $st_more[1] == $st_less[1];
3198 # changes environment!
3199 $ENV{LESS} .= 'r' if $is_less;
3205 $SIG{'ABRT'} = 'DEFAULT';
3206 kill 'ABRT', $$ if $panic++;
3207 if (defined &Carp::longmess) {
3208 local $SIG{__WARN__} = '';
3209 local $Carp::CarpLevel = 2; # mydie + confess
3210 &warn(Carp::longmess("Signal @_"));
3214 print $DB::OUT "Got signal @_\n";
3222 local $SIG{__WARN__} = '';
3223 local $SIG{__DIE__} = '';
3224 eval { require Carp } if defined $^S; # If error/warning during compilation,
3225 # require may be broken.
3226 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
3227 return unless defined &Carp::longmess;
3228 my ($mysingle,$mytrace) = ($single,$trace);
3229 $single = 0; $trace = 0;
3230 my $mess = Carp::longmess(@_);
3231 ($single,$trace) = ($mysingle,$mytrace);
3238 local $SIG{__DIE__} = '';
3239 local $SIG{__WARN__} = '';
3240 my $i = 0; my $ineval = 0; my $sub;
3241 if ($dieLevel > 2) {
3242 local $SIG{__WARN__} = \&dbwarn;
3243 &warn(@_); # Yell no matter what
3246 if ($dieLevel < 2) {
3247 die @_ if $^S; # in eval propagate
3249 # No need to check $^S, eval is much more robust nowadays
3250 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
3251 # require may be broken.
3253 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
3254 unless defined &Carp::longmess;
3256 # We do not want to debug this chunk (automatic disabling works
3257 # inside DB::DB, but not in Carp).
3258 my ($mysingle,$mytrace) = ($single,$trace);
3259 $single = 0; $trace = 0;
3262 package Carp; # Do not include us in the list
3264 $mess = Carp::longmess(@_);
3267 ($single,$trace) = ($mysingle,$mytrace);
3273 $prevwarn = $SIG{__WARN__} unless $warnLevel;
3276 $SIG{__WARN__} = \&DB::dbwarn;
3277 } elsif ($prevwarn) {
3278 $SIG{__WARN__} = $prevwarn;
3287 $prevdie = $SIG{__DIE__} unless $dieLevel;
3290 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
3291 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
3292 print $OUT "Stack dump during die enabled",
3293 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
3295 print $OUT "Dump printed too.\n" if $dieLevel > 2;
3296 } elsif ($prevdie) {
3297 $SIG{__DIE__} = $prevdie;
3298 print $OUT "Default die handler restored.\n";
3306 $prevsegv = $SIG{SEGV} unless $signalLevel;
3307 $prevbus = $SIG{BUS} unless $signalLevel;
3308 $signalLevel = shift;
3310 $SIG{SEGV} = \&DB::diesignal;
3311 $SIG{BUS} = \&DB::diesignal;
3313 $SIG{SEGV} = $prevsegv;
3314 $SIG{BUS} = $prevbus;
3322 my $name = CvGV_name_or_bust($in);
3323 defined $name ? $name : $in;
3326 sub CvGV_name_or_bust {
3328 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
3329 return unless ref $in;
3330 $in = \&$in; # Hard reference...
3331 eval {require Devel::Peek; 1} or return;
3332 my $gv = Devel::Peek::CvGV($in) or return;
3333 *$gv{PACKAGE} . '::' . *$gv{NAME};
3339 return unless defined &$subr;
3340 my $name = CvGV_name_or_bust($subr);
3342 $data = $sub{$name} if defined $name;
3343 return $data if defined $data;
3346 $subr = \&$subr; # Hard reference
3349 $s = $_, last if $subr eq \&$_;
3357 $class = ref $class if ref $class;
3360 methods_via($class, '', 1);
3361 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
3366 return if $packs{$class}++;
3368 my $prepend = $prefix ? "via $prefix: " : '';
3370 for $name (grep {defined &{${"${class}::"}{$_}}}
3371 sort keys %{"${class}::"}) {
3372 next if $seen{ $name }++;
3375 print $DB::OUT "$prepend$name\n";
3377 return unless shift; # Recurse?
3378 for $name (@{"${class}::ISA"}) {
3379 $prepend = $prefix ? $prefix . " -> $name" : $name;
3380 methods_via($name, $prepend, 1);
3385 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
3386 ? "man" # O Happy Day!
3387 : "perldoc"; # Alas, poor unfortunates
3393 &system("$doccmd $doccmd");
3396 # this way user can override, like with $doccmd="man -Mwhatever"
3397 # or even just "man " to disable the path check.
3398 unless ($doccmd eq 'man') {
3399 &system("$doccmd $page");
3403 $page = 'perl' if lc($page) eq 'help';
3406 my $man1dir = $Config::Config{'man1dir'};
3407 my $man3dir = $Config::Config{'man3dir'};
3408 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
3410 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
3411 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
3412 chop $manpath if $manpath;
3413 # harmless if missing, I figure
3414 my $oldpath = $ENV{MANPATH};
3415 $ENV{MANPATH} = $manpath if $manpath;
3416 my $nopathopt = $^O =~ /dunno what goes here/;
3417 if (CORE::system($doccmd,
3418 # I just *know* there are men without -M
3419 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3422 unless ($page =~ /^perl\w/) {
3423 if (grep { $page eq $_ } qw{
3424 5004delta 5005delta amiga api apio book boot bot call compile
3425 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
3426 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
3427 form func guts hack hist hpux intern ipc lexwarn locale lol mod
3428 modinstall modlib number obj op opentut os2 os390 pod port
3429 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
3430 trap unicode var vms win32 xs xstut
3434 CORE::system($doccmd,
3435 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3440 if (defined $oldpath) {
3441 $ENV{MANPATH} = $manpath;
3443 delete $ENV{MANPATH};
3447 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
3449 BEGIN { # This does not compile, alas.
3450 $IN = \*STDIN; # For bugs before DB::OUT has been opened
3451 $OUT = \*STDERR; # For errors before DB::OUT has been opened
3455 @truehist=(); # Can be saved for replay (per session)
3456 $deep = 100; # warning if stack gets this deep
3460 $SIG{INT} = \&DB::catch;
3461 # This may be enabled to debug debugger:
3462 #$warnLevel = 1 unless defined $warnLevel;
3463 #$dieLevel = 1 unless defined $dieLevel;
3464 #$signalLevel = 1 unless defined $signalLevel;
3466 $db_stop = 0; # Compiler warning
3468 $level = 0; # Level of recursive debugging
3469 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
3470 # Triggers bug (?) in perl is we postpone this until runtime:
3471 @postponed = @stack = (0);
3472 $stack_depth = 0; # Localized $#stack
3477 BEGIN {$^W = $ini_warn;} # Switch warnings back
3479 #use Carp; # This did break, left for debugging
3482 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
3483 my($text, $line, $start) = @_;
3484 my ($itext, $search, $prefix, $pack) =
3485 ($text, "^\Q${'package'}::\E([^:]+)\$");
3487 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
3488 (map { /$search/ ? ($1) : () } keys %sub)
3489 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
3490 return sort grep /^\Q$text/, values %INC # files
3491 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
3492 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3493 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
3494 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
3495 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3497 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
3499 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
3500 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
3501 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
3502 # We may want to complete to (eval 9), so $text may be wrong
3503 $prefix = length($1) - length($text);
3506 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
3508 if ((substr $text, 0, 1) eq '&') { # subroutines
3509 $text = substr $text, 1;
3511 return sort map "$prefix$_",
3514 (map { /$search/ ? ($1) : () }
3517 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
3518 $pack = ($1 eq 'main' ? '' : $1) . '::';
3519 $prefix = (substr $text, 0, 1) . $1 . '::';
3522 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
3523 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3524 return db_complete($out[0], $line, $start);
3528 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3529 $pack = ($package eq 'main' ? '' : $package) . '::';
3530 $prefix = substr $text, 0, 1;
3531 $text = substr $text, 1;
3532 my @out = map "$prefix$_", grep /^\Q$text/,
3533 (grep /^_?[a-zA-Z]/, keys %$pack),
3534 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3535 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3536 return db_complete($out[0], $line, $start);
3540 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3541 my @out = grep /^\Q$text/, @options;
3542 my $val = option_val($out[0], undef);
3544 if (not defined $val or $val =~ /[\n\r]/) {
3545 # Can do nothing better
3546 } elsif ($val =~ /\s/) {
3548 foreach $l (split //, qq/\"\'\#\|/) {
3549 $out = "$l$val$l ", last if (index $val, $l) == -1;
3554 # Default to value if one completion, to question if many
3555 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3558 return $term->filename_list($text); # filenames
3563 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3567 if (defined($ini_pids)) {
3568 $ENV{PERLDB_PIDS} = $ini_pids;
3570 delete($ENV{PERLDB_PIDS});
3575 # PERLDBf_... flag names from perl.h
3576 our (%DollarCaretP_flags, %DollarCaretP_flags_r);
3578 %DollarCaretP_flags =
3579 ( PERLDBf_SUB => 0x01, # Debug sub enter/exit
3580 PERLDBf_LINE => 0x02, # Keep line #
3581 PERLDBf_NOOPT => 0x04, # Switch off optimizations
3582 PERLDBf_INTER => 0x08, # Preserve more data
3583 PERLDBf_SUBLINE => 0x10, # Keep subr source lines
3584 PERLDBf_SINGLE => 0x20, # Start with single-step on
3585 PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr
3586 PERLDBf_GOTO => 0x80, # Report goto: call DB::goto
3587 PERLDBf_NAMEEVAL => 0x100, # Informative names for evals
3588 PERLDBf_NAMEANON => 0x200, # Informative names for anon subs
3589 PERLDBf_ASSERTION => 0x400, # Debug assertion subs enter/exit
3590 PERLDB_ALL => 0x33f, # No _NONAME, _GOTO, _ASSERTION
3593 %DollarCaretP_flags_r=reverse %DollarCaretP_flags;
3596 sub parse_DollarCaretP_flags {
3601 foreach my $f (split /\s*\|\s*/, $flags) {
3603 if ($f=~/^0x([[:xdigit:]]+)$/) {
3606 elsif ($f=~/^(\d+)$/) {
3609 elsif ($f=~/^DEFAULT$/i) {
3610 $value=$DollarCaretP_flags{PERLDB_ALL};
3613 $f=~/^(?:PERLDBf_)?(.*)$/i;
3614 $value=$DollarCaretP_flags{'PERLDBf_'.uc($1)};
3615 unless (defined $value) {
3616 print $OUT ("Unrecognized \$^P flag '$f'!\n",
3617 "Acceptable flags are: ".
3618 join(', ', sort keys %DollarCaretP_flags),
3619 ", and hexadecimal and decimal numbers.\n");
3628 sub expand_DollarCaretP_flags {
3629 my $DollarCaretP=shift;
3630 my @bits= ( map { my $n=(1<<$_);
3631 ($DollarCaretP & $n)
3632 ? ($DollarCaretP_flags_r{$n}
3633 || sprintf('0x%x', $n))
3635 return @bits ? join('|', @bits) : 0;
3639 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3640 $fall_off_end = 1 unless $inhibit_exit;
3641 # Do not stop in at_exit() and destructors on exit:
3642 $DB::single = !$fall_off_end && !$runnonstop;
3643 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3647 # ===================================== pre580 ================================
3648 # this is very sad below here...
3651 sub cmd_pre580_null {
3658 if ($cmd =~ /^(\d*)\s*(.*)/) {
3659 $i = $1 || $line; $j = $2;
3661 if ($dbline[$i] == 0) {
3662 print $OUT "Line $i may not have an action.\n";
3664 $had_breakpoints{$filename} |= 2;
3665 $dbline{$i} =~ s/\0[^\0]*//;
3666 $dbline{$i} .= "\0" . action($j);
3669 $dbline{$i} =~ s/\0[^\0]*//;
3670 delete $dbline{$i} if $dbline{$i} eq '';
3679 if ($cmd =~ /^load\b\s*(.*)/) {
3680 my $file = $1; $file =~ s/\s+$//;
3682 } elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
3683 my $cond = length $3 ? $3 : '1';
3684 my ($subname, $break) = ($2, $1 eq 'postpone');
3685 $subname =~ s/\'/::/g;
3686 $subname = "${'package'}::" . $subname
3687 unless $subname =~ /::/;
3688 $subname = "main".$subname if substr($subname,0,2) eq "::";
3689 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
3690 } elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
3692 my $cond = length $2 ? $2 : '1';
3693 &cmd_b_sub($subname, $cond);
3694 } elsif ($cmd =~ /^(\d*)\s*(.*)/) {
3695 my $i = $1 || $dbline;
3696 my $cond = length $2 ? $2 : '1';
3697 &cmd_b_line($i, $cond);
3704 if ($cmd =~ /^\s*$/) {
3705 print $OUT "Deleting all breakpoints...\n";
3707 for $file (keys %had_breakpoints) {
3708 local *dbline = $main::{'_<' . $file};
3712 for ($i = 1; $i <= $max ; $i++) {
3713 if (defined $dbline{$i}) {
3714 $dbline{$i} =~ s/^[^\0]+//;
3715 if ($dbline{$i} =~ s/^\0?$//) {
3721 if (not $had_breakpoints{$file} &= ~1) {
3722 delete $had_breakpoints{$file};
3726 undef %postponed_file;
3727 undef %break_on_load;
3734 if ($cmd =~ /^\s*$/) {
3735 print_help($pre580_help);
3736 } elsif ($cmd =~ /^h\s*/) {
3737 print_help($pre580_summary);
3738 } elsif ($cmd =~ /^h\s+(\S.*)$/) {
3739 my $asked = $1; # for proper errmsg
3740 my $qasked = quotemeta($asked); # for searching
3741 # XXX: finds CR but not <CR>
3742 if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) {
3743 while ($pre580_help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
3747 print_help("B<$asked> is not a debugger command.\n");
3757 @to_watch = @old_watch = ();
3758 } elsif ($cmd =~ /^(.*)/s) {
3762 $val = (defined $val) ? "'$val'" : 'undef' ;
3763 push @old_watch, $val;
3768 sub cmd_pre590_prepost {
3770 my $line = shift || '*'; # delete
3773 return &cmd_prepost($cmd, $line, $dbline);
3776 sub cmd_prepost { # cannot do &cmd_<(), <, <<, >>, {, {{, etc.
3778 my $line = shift || '?';
3782 if ($cmd =~ /^\</o) {
3783 $which = 'pre-perl';
3785 } elsif ($cmd =~ /^\>/o) {
3786 $which = 'post-perl';
3788 } elsif ($cmd =~ /^\{/o) {
3789 if ($cmd =~ /^\{.*\}$/o && unbalanced(substr($cmd,1))) {
3790 print $OUT "$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n";
3791 # $DB::cmd = "h $cmd";
3794 $which = 'pre-debugger';
3800 print $OUT "Confused by command: $cmd\n";
3802 if ($line =~ /^\s*\?\s*$/o) {
3804 print $OUT "No $which actions.\n";
3805 # print $OUT "If you meant to delete them all - use '$cmd *' or 'o commandSet=pre590'\n"; # hint
3807 print $OUT "$which commands:\n";
3808 foreach my $action (@$aref) {
3809 print $OUT "\t$cmd -- $action\n";
3813 if (length($cmd) == 1) {
3814 if ($line =~ /^\s*\*\s*$/o) {
3815 @$aref = (); # delete
3816 print $OUT "All $cmd actions cleared.\n";
3818 @$aref = action($line); # set
3820 } elsif (length($cmd) == 2) { # append
3821 push @$aref, action($line);
3823 print $OUT "Confused by strange length of $which command($cmd)...\n";
3832 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3835 package DB; # Do not trace this 1; below!