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")
330 ####################################################################
332 # Needed for the statement after exec():
334 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
336 # test if assertions are supported and actived:
339 eval "sub asserting_test : assertion {1}; 1";
340 # $ini_assertion = undef => assertions unsupported,
341 # " = 1 => assertions suported
342 # print "\$ini_assertion=$ini_assertion\n";
345 local($^W) = 0; # Switch run-time warnings off during init.
348 $dumpvar::arrayDepth,
349 $dumpvar::dumpDBFiles,
350 $dumpvar::dumpPackages,
351 $dumpvar::quoteHighBit,
352 $dumpvar::printUndef,
361 # Command-line + PERLLIB:
364 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
366 $trace = $signal = $single = 0; # Uninitialized warning suppression
367 # (local $^W cannot help - other packages!).
368 $inhibit_exit = $option{PrintRet} = 1;
370 @options = qw(hashDepth arrayDepth CommandSet dumpDepth
371 DumpDBFiles DumpPackages DumpReused
372 compactDump veryCompact quote HighBit undefPrint
373 globPrint PrintRet UsageOnly frame AutoTrace
374 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
375 recallCommand ShellBang pager tkRunning ornaments
376 signalLevel warnLevel dieLevel inhibit_exit
377 ImmediateStop bareStringify CreateTTY
378 RemotePort windowSize DollarCaretP OnlyAssertions
381 @RememberOnROptions = qw(DollarCaretP OnlyAssertions);
384 hashDepth => \$dumpvar::hashDepth,
385 arrayDepth => \$dumpvar::arrayDepth,
386 CommandSet => \$CommandSet,
387 DumpDBFiles => \$dumpvar::dumpDBFiles,
388 DumpPackages => \$dumpvar::dumpPackages,
389 DumpReused => \$dumpvar::dumpReused,
390 HighBit => \$dumpvar::quoteHighBit,
391 undefPrint => \$dumpvar::printUndef,
392 globPrint => \$dumpvar::globPrint,
393 UsageOnly => \$dumpvar::usageOnly,
394 CreateTTY => \$CreateTTY,
395 bareStringify => \$dumpvar::bareStringify,
397 AutoTrace => \$trace,
398 inhibit_exit => \$inhibit_exit,
399 maxTraceLen => \$maxtrace,
400 ImmediateStop => \$ImmediateStop,
401 RemotePort => \$remoteport,
402 windowSize => \$window,
403 WarnAssertions => \$warnassertions,
407 compactDump => \&dumpvar::compactDump,
408 veryCompact => \&dumpvar::veryCompact,
409 quote => \&dumpvar::quote,
412 ReadLine => \&ReadLine,
413 NonStop => \&NonStop,
414 LineInfo => \&LineInfo,
415 recallCommand => \&recallCommand,
416 ShellBang => \&shellBang,
418 signalLevel => \&signalLevel,
419 warnLevel => \&warnLevel,
420 dieLevel => \&dieLevel,
421 tkRunning => \&tkRunning,
422 ornaments => \&ornaments,
423 RemotePort => \&RemotePort,
424 DollarCaretP => \&DollarCaretP,
425 OnlyAssertions=> \&OnlyAssertions,
429 compactDump => 'dumpvar.pl',
430 veryCompact => 'dumpvar.pl',
431 quote => 'dumpvar.pl',
434 # These guys may be defined in $ENV{PERL5DB} :
435 $rl = 1 unless defined $rl;
436 $warnLevel = 1 unless defined $warnLevel;
437 $dieLevel = 1 unless defined $dieLevel;
438 $signalLevel = 1 unless defined $signalLevel;
439 $pre = [] unless defined $pre;
440 $post = [] unless defined $post;
441 $pretype = [] unless defined $pretype;
442 $CreateTTY = 3 unless defined $CreateTTY;
443 $CommandSet = '580' unless defined $CommandSet;
445 warnLevel($warnLevel);
447 signalLevel($signalLevel);
450 defined $ENV{PAGER} ? $ENV{PAGER} :
451 eval { require Config } &&
452 defined $Config::Config{pager} ? $Config::Config{pager}
454 ) unless defined $pager;
456 &recallCommand("!") unless defined $prc;
457 &shellBang("!") unless defined $psh;
459 $maxtrace = 400 unless defined $maxtrace;
460 $ini_pids = $ENV{PERLDB_PIDS};
461 if (defined $ENV{PERLDB_PIDS}) {
462 $pids = "[$ENV{PERLDB_PIDS}]";
463 $ENV{PERLDB_PIDS} .= "->$$";
466 $ENV{PERLDB_PIDS} = "$$";
471 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
473 if (-e "/dev/tty") { # this is the wrong metric!
476 $rcfile="perldb.ini";
479 # This isn't really safe, because there's a race
480 # between checking and opening. The solution is to
481 # open and fstat the handle, but then you have to read and
482 # eval the contents. But then the silly thing gets
483 # your lexical scope, which is unfortunately at best.
487 # Just exactly what part of the word "CORE::" don't you understand?
488 local $SIG{__WARN__};
491 unless (is_safe_file($file)) {
492 CORE::warn <<EO_GRIPE;
493 perldb: Must not source insecure rcfile $file.
494 You or the superuser must be the owner, and it must not
495 be writable by anyone but its owner.
501 CORE::warn("perldb: couldn't parse $file: $@") if $@;
505 # Verifies that owner is either real user or superuser and that no
506 # one but owner may write to it. This function is of limited use
507 # when called on a path instead of upon a handle, because there are
508 # no guarantees that filename (by dirent) whose file (by ino) is
509 # eventually accessed is the same as the one tested.
510 # Assumes that the file's existence is not in doubt.
513 stat($path) || return; # mysteriously vaporized
514 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
516 return 0 if $uid != 0 && $uid != $<;
517 return 0 if $mode & 022;
522 safe_do("./$rcfile");
524 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
525 safe_do("$ENV{HOME}/$rcfile");
527 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
528 safe_do("$ENV{LOGDIR}/$rcfile");
531 if (defined $ENV{PERLDB_OPTS}) {
532 parse_options($ENV{PERLDB_OPTS});
535 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
536 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
537 *get_fork_TTY = \&xterm_get_fork_TTY;
538 } elsif ($^O eq 'os2') {
539 *get_fork_TTY = \&os2_get_fork_TTY;
541 # untaint $^O, which may have been tainted by the last statement.
542 # see bug [perl #24674]
543 $^O =~ m/^(.*)\z/; $^O = $1;
545 # Here begin the unreadable code. It needs fixing.
547 if (exists $ENV{PERLDB_RESTART}) {
548 delete $ENV{PERLDB_RESTART};
550 @hist = get_list('PERLDB_HIST');
551 %break_on_load = get_list("PERLDB_ON_LOAD");
552 %postponed = get_list("PERLDB_POSTPONE");
553 my @had_breakpoints= get_list("PERLDB_VISITED");
554 for (0 .. $#had_breakpoints) {
555 my %pf = get_list("PERLDB_FILE_$_");
556 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
558 my %opt = get_list("PERLDB_OPT");
560 while (($opt,$val) = each %opt) {
561 $val =~ s/[\\\']/\\$1/g;
562 parse_options("$opt'$val'");
564 @INC = get_list("PERLDB_INC");
566 $pretype = [get_list("PERLDB_PRETYPE")];
567 $pre = [get_list("PERLDB_PRE")];
568 $post = [get_list("PERLDB_POST")];
569 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
575 # Is Perl being run from a slave editor or graphical debugger?
576 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
577 $rl = 0, shift(@main::ARGV) if $slave_editor;
579 #require Term::ReadLine;
581 if ($^O eq 'cygwin') {
582 # /dev/tty is binary. use stdin for textmode
584 } elsif (-e "/dev/tty") {
585 $console = "/dev/tty";
586 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
588 } elsif ($^O eq 'MacOS') {
589 if ($MacPerl::Version !~ /MPW/) {
590 $console = "Dev:Console:Perl Debug"; # Separate window for application
592 $console = "Dev:Console";
595 $console = "sys\$command";
598 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
602 if ($^O eq 'NetWare') {
607 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
615 $console = $tty if defined $tty;
617 if (defined $remoteport) {
619 $OUT = new IO::Socket::INET( Timeout => '10',
620 PeerAddr => $remoteport,
623 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
626 create_IN_OUT(4) if $CreateTTY & 4;
628 my ($i, $o) = split /,/, $console;
629 $o = $i unless defined $o;
630 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
631 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
632 || open(OUT,">&STDOUT"); # so we don't dongle stdout
633 } elsif (not defined $console) {
635 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
636 $console = 'STDIN/OUT';
638 # so open("|more") can read from STDOUT and so we don't dingle stdin
639 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
641 my $previous = select($OUT);
642 $| = 1; # for DB::OUT
645 $LINEINFO = $OUT unless defined $LINEINFO;
646 $lineinfo = $console unless defined $lineinfo;
648 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
649 unless ($runnonstop) {
652 if ($term_pid eq '-1') {
653 print $OUT "\nDaughter DB session started...\n";
655 print $OUT "\nLoading DB routines from $header\n";
656 print $OUT ("Editor support ",
657 $slave_editor ? "enabled" : "available",
659 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
667 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
670 if (defined &afterinit) { # May be defined in $rcfile
676 ############################################################ Subroutines
679 # _After_ the perl program is compiled, $single is set to 1:
680 if ($single and not $second_time++) {
681 if ($runnonstop) { # Disable until signal
682 for ($i=0; $i <= $stack_depth; ) {
686 # return; # Would not print trace!
687 } elsif ($ImmediateStop) {
692 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
694 local($package, $filename, $line) = caller;
695 local $filename_ini = $filename;
696 local $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
697 "package $package;"; # this won't let them modify, alas
698 local(*dbline) = $main::{'_<' . $filename};
700 # we need to check for pseudofiles on Mac OS (these are files
701 # not attached to a filename, but instead stored in Dev:Pseudo)
702 if ($^O eq 'MacOS' && $#dbline < 0) {
703 $filename_ini = $filename = 'Dev:Pseudo';
704 *dbline = $main::{'_<' . $filename};
707 local $max = $#dbline;
708 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
712 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
713 $dbline{$line} =~ s/;9($|\0)/$1/;
716 my $was_signal = $signal;
718 for (my $n = 0; $n <= $#to_watch; $n++) {
719 $evalarg = $to_watch[$n];
720 local $onetimeDump; # Do not output results
721 my ($val) = join("', '", &eval); # Fix context (&eval is doing array)? - rjsf
722 $val = ( (defined $val) ? "'$val'" : 'undef' );
723 if ($val ne $old_watch[$n]) {
726 Watchpoint $n:\t$to_watch[$n] changed:
727 old value:\t$old_watch[$n]
730 $old_watch[$n] = $val;
734 if ($trace & 4) { # User-installed watch
735 return if watchfunction($package, $filename, $line)
736 and not $single and not $was_signal and not ($trace & ~4);
738 $was_signal = $signal;
740 if ($single || ($trace & 1) || $was_signal) {
742 $position = "\032\032$filename:$line:0\n";
743 print_lineinfo($position);
744 } elsif ($package eq 'DB::fake') {
747 Debugged program terminated. Use B<q> to quit or B<R> to restart,
748 use B<O> I<inhibit_exit> to avoid stopping after program termination,
749 B<h q>, B<h R> or B<h O> to get additional info.
752 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
753 "package $package;"; # this won't let them modify, alas
756 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
757 $prefix .= "$sub($filename:";
758 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
759 if (length($prefix) > 30) {
760 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
765 $position = "$prefix$line$infix$dbline[$line]$after";
768 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
770 print_lineinfo($position);
772 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
773 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
775 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
776 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
777 $position .= $incr_pos;
779 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
781 print_lineinfo($incr_pos);
786 $evalarg = $action, &eval if $action;
787 if ($single || $was_signal) {
788 local $level = $level + 1;
789 foreach $evalarg (@$pre) {
792 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
795 $incr = -1; # for backward motion.
796 @typeahead = (@$pretype, @typeahead);
798 while (($term || &setterm),
799 ($term_pid == $$ or resetterm(1)),
800 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
801 ($#hist+1) . ('>' x $level) . " ")))
805 $cmd =~ s/\\$/\n/ && do {
806 $cmd .= &readline(" cont: ");
809 $cmd =~ /^$/ && ($cmd = $laststep);
810 push(@hist,$cmd) if length($cmd) > 1;
812 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
813 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
814 ($i) = split(/\s+/,$cmd);
816 # squelch the sigmangler
818 local $SIG{__WARN__};
819 eval "\$cmd =~ $alias{$i}";
822 print $OUT "Couldn't evaluate `$i' alias: $@";
826 $cmd =~ /^q$/ && do {
831 $cmd =~ /^t$/ && do {
834 print $OUT "Trace = " .
835 (($trace & 1) ? "on" : "off" ) . "\n";
837 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
838 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
841 foreach $subname (sort(keys %sub)) {
842 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
843 print $OUT $subname,"\n";
847 $cmd =~ s/^X\b/V $package/;
848 $cmd =~ /^V$/ && do {
849 $cmd = "V $package"; };
850 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
851 local ($savout) = select($OUT);
853 @vars = split(' ',$2);
854 do 'dumpvar.pl' unless defined &main::dumpvar;
855 if (defined &main::dumpvar) {
858 # must detect sigpipe failures
859 eval { &main::dumpvar($packname,
860 defined $option{dumpDepth}
861 ? $option{dumpDepth} : -1,
864 die unless $@ =~ /dumpvar print failed/;
867 print $OUT "dumpvar.pl not available.\n";
871 $cmd =~ s/^x\b/ / && do { # So that will be evaled
872 $onetimeDump = 'dump';
873 # handle special "x 3 blah" syntax
874 if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
875 $onetimedumpDepth = $1;
878 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
879 methods($1); next CMD};
880 $cmd =~ s/^m\b/ / && do { # So this will be evaled
881 $onetimeDump = 'methods'; };
882 $cmd =~ /^f\b\s*(.*)/ && do {
886 print $OUT "The old f command is now the r command.\n"; # hint
887 print $OUT "The new f command switches filenames.\n";
890 if (!defined $main::{'_<' . $file}) {
891 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
892 $try = substr($try,2);
893 print $OUT "Choosing $try matching `$file':\n";
897 if (!defined $main::{'_<' . $file}) {
898 print $OUT "No file matching `$file' is loaded.\n";
900 } elsif ($file ne $filename) {
901 *dbline = $main::{'_<' . $file};
907 print $OUT "Already in $file.\n";
911 $cmd =~ /^\.$/ && do {
912 $incr = -1; # for backward motion.
914 $filename = $filename_ini;
915 *dbline = $main::{'_<' . $filename};
917 print_lineinfo($position);
919 $cmd =~ /^-$/ && do {
920 $start -= $incr + $window + 1;
921 $start = 1 if $start <= 0;
923 $cmd = 'l ' . ($start) . '+'; };
925 $cmd =~ /^([aAbBhlLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
926 &cmd_wrapper($1, $2, $line);
929 # rjsf <- pre|post commands stripped out
930 $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
931 eval { require PadWalker; PadWalker->VERSION(0.08) }
932 or &warn($@ =~ /locate/
933 ? "PadWalker module not found - please install\n"
936 do 'dumpvar.pl' unless defined &main::dumpvar;
937 defined &main::dumpvar
938 or print $OUT "dumpvar.pl not available.\n"
940 my @vars = split(' ', $2 || '');
941 my $h = eval { PadWalker::peek_my(($1 || 0) + 1) };
942 $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
943 my $savout = select($OUT);
944 dumpvar::dumplex($_, $h->{$_},
945 defined $option{dumpDepth}
946 ? $option{dumpDepth} : -1,
951 $cmd =~ /^n$/ && do {
952 end_report(), next CMD if $finished and $level <= 1;
956 $cmd =~ /^s$/ && do {
957 end_report(), next CMD if $finished and $level <= 1;
961 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
962 end_report(), next CMD if $finished and $level <= 1;
964 # Probably not needed, since we finish an interactive
965 # sub-session anyway...
966 # local $filename = $filename;
967 # local *dbline = *dbline; # XXX Would this work?!
968 if ($subname =~ /\D/) { # subroutine name
969 $subname = $package."::".$subname
970 unless $subname =~ /::/;
971 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
975 *dbline = $main::{'_<' . $filename};
976 $had_breakpoints{$filename} |= 1;
978 ++$i while $dbline[$i] == 0 && $i < $max;
980 print $OUT "Subroutine $subname not found.\n";
985 if ($dbline[$i] == 0) {
986 print $OUT "Line $i not breakable.\n";
989 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
991 for ($i=0; $i <= $stack_depth; ) {
995 $cmd =~ /^r$/ && do {
996 end_report(), next CMD if $finished and $level <= 1;
997 $stack[$stack_depth] |= 1;
998 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1000 $cmd =~ /^R$/ && do {
1001 print $OUT "Warning: some settings and command-line options may be lost!\n";
1002 my (@script, @flags, $cl);
1003 push @flags, '-w' if $ini_warn;
1004 if ($ini_assertion and @{^ASSERTING}) {
1005 push @flags, (map { /\:\^\(\?\:(.*)\)\$\)/ ?
1006 "-A$1" : "-A$_" } @{^ASSERTING});
1008 # Put all the old includes at the start to get
1009 # the same debugger.
1011 push @flags, '-I', $_;
1013 push @flags, '-T' if ${^TAINT};
1014 # Arrange for setting the old INC:
1015 set_list("PERLDB_INC", @ini_INC);
1017 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1018 chomp ($cl = ${'::_<-e'}[$_]);
1019 push @script, '-e', $cl;
1024 set_list("PERLDB_HIST",
1025 $term->Features->{getHistory}
1026 ? $term->GetHistory : @hist);
1027 my @had_breakpoints = keys %had_breakpoints;
1028 set_list("PERLDB_VISITED", @had_breakpoints);
1029 set_list("PERLDB_OPT", options2remember());
1030 set_list("PERLDB_ON_LOAD", %break_on_load);
1032 for (0 .. $#had_breakpoints) {
1033 my $file = $had_breakpoints[$_];
1034 *dbline = $main::{'_<' . $file};
1035 next unless %dbline or $postponed_file{$file};
1036 (push @hard, $file), next
1037 if $file =~ /^\(\w*eval/;
1039 @add = %{$postponed_file{$file}}
1040 if $postponed_file{$file};
1041 set_list("PERLDB_FILE_$_", %dbline, @add);
1043 for (@hard) { # Yes, really-really...
1044 # Find the subroutines in this eval
1045 *dbline = $main::{'_<' . $_};
1046 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1047 for $sub (keys %sub) {
1048 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1049 $subs{$sub} = [$1, $2];
1053 "No subroutines in $_, ignoring breakpoints.\n";
1056 LINES: for $line (keys %dbline) {
1057 # One breakpoint per sub only:
1058 my ($offset, $sub, $found);
1059 SUBS: for $sub (keys %subs) {
1060 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1061 and (not defined $offset # Not caught
1062 or $offset < 0 )) { # or badly caught
1064 $offset = $line - $subs{$sub}->[0];
1065 $offset = "+$offset", last SUBS if $offset >= 0;
1068 if (defined $offset) {
1069 $postponed{$found} =
1070 "break $offset if $dbline{$line}";
1072 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1076 set_list("PERLDB_POSTPONE", %postponed);
1077 set_list("PERLDB_PRETYPE", @$pretype);
1078 set_list("PERLDB_PRE", @$pre);
1079 set_list("PERLDB_POST", @$post);
1080 set_list("PERLDB_TYPEAHEAD", @typeahead);
1081 $ENV{PERLDB_RESTART} = 1;
1082 delete $ENV{PERLDB_PIDS}; # Restore ini state
1083 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1084 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1085 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1086 print $OUT "exec failed: $!\n";
1088 $cmd =~ /^T$/ && do {
1089 print_trace($OUT, 1); # skip DB
1091 $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; };
1092 $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W('W', $1); next CMD; };
1093 $cmd =~ /^\/(.*)$/ && do {
1095 $inpat =~ s:([^\\])/$:$1:;
1097 # squelch the sigmangler
1098 local $SIG{__DIE__};
1099 local $SIG{__WARN__};
1100 eval '$inpat =~ m'."\a$inpat\a";
1112 $start = 1 if ($start > $max);
1113 last if ($start == $end);
1114 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1115 if ($slave_editor) {
1116 print $OUT "\032\032$filename:$start:0\n";
1118 print $OUT "$start:\t", $dbline[$start], "\n";
1123 print $OUT "/$pat/: not found\n" if ($start == $end);
1125 $cmd =~ /^\?(.*)$/ && do {
1127 $inpat =~ s:([^\\])\?$:$1:;
1129 # squelch the sigmangler
1130 local $SIG{__DIE__};
1131 local $SIG{__WARN__};
1132 eval '$inpat =~ m'."\a$inpat\a";
1144 $start = $max if ($start <= 0);
1145 last if ($start == $end);
1146 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1147 if ($slave_editor) {
1148 print $OUT "\032\032$filename:$start:0\n";
1150 print $OUT "$start:\t", $dbline[$start], "\n";
1155 print $OUT "?$pat?: not found\n" if ($start == $end);
1157 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1158 pop(@hist) if length($cmd) > 1;
1159 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1161 print $OUT $cmd, "\n";
1163 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1166 $cmd =~ /^$rc([^$rc].*)$/ && do {
1168 pop(@hist) if length($cmd) > 1;
1169 for ($i = $#hist; $i; --$i) {
1170 last if $hist[$i] =~ /$pat/;
1173 print $OUT "No such command!\n\n";
1177 print $OUT $cmd, "\n";
1179 $cmd =~ /^$sh$/ && do {
1180 &system($ENV{SHELL}||"/bin/sh");
1182 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1183 # XXX: using csh or tcsh destroys sigint retvals!
1184 #&system($1); # use this instead
1185 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1187 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1188 $end = $2 ? ($#hist-$2) : 0;
1189 $hist = 0 if $hist < 0;
1190 for ($i=$#hist; $i>$end; $i--) {
1191 print $OUT "$i: ",$hist[$i],"\n"
1192 unless $hist[$i] =~ /^.?$/;
1195 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1198 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1199 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1200 $cmd =~ s/^=\s*// && do {
1202 if (length $cmd == 0) {
1203 @keys = sort keys %alias;
1204 } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1205 # can't use $_ or kill //g state
1206 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1207 $alias{$k} = "s\a$k\a$v\a";
1208 # squelch the sigmangler
1209 local $SIG{__DIE__};
1210 local $SIG{__WARN__};
1211 unless (eval "sub { s\a$k\a$v\a }; 1") {
1212 print $OUT "Can't alias $k to $v: $@\n";
1221 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1222 print $OUT "$k\t= $1\n";
1224 elsif (defined $alias{$k}) {
1225 print $OUT "$k\t$alias{$k}\n";
1228 print "No alias for $k\n";
1232 $cmd =~ /^source\s+(.*\S)/ && do {
1233 if (open my $fh, $1) {
1236 &warn("Can't execute `$1': $!\n");
1239 $cmd =~ /^\|\|?\s*[^|]/ && do {
1240 if ($pager =~ /^\|/) {
1241 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1242 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1244 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1247 unless ($piped=open(OUT,$pager)) {
1248 &warn("Can't pipe output to `$pager'");
1249 if ($pager =~ /^\|/) {
1250 open(OUT,">&STDOUT") # XXX: lost message
1251 || &warn("Can't restore DB::OUT");
1252 open(STDOUT,">&SAVEOUT")
1253 || &warn("Can't restore STDOUT");
1256 open(OUT,">&STDOUT") # XXX: lost message
1257 || &warn("Can't restore DB::OUT");
1261 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1262 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1263 $selected= select(OUT);
1265 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1266 $cmd =~ s/^\|+\s*//;
1269 # XXX Local variants do not work!
1270 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1271 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1272 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1274 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1276 $onetimeDump = undef;
1277 $onetimedumpDepth = undef;
1278 } elsif ($term_pid == $$) {
1285 if ($pager =~ /^\|/) {
1287 # we cannot warn here: the handle is missing --tchrist
1288 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1290 # most of the $? crud was coping with broken cshisms
1292 print SAVEOUT "Pager `$pager' failed: ";
1294 print SAVEOUT "shell returned -1\n";
1297 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1298 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1300 print SAVEOUT "status ", ($? >> 8), "\n";
1304 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1305 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1306 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1307 # Will stop ignoring SIGPIPE if done like nohup(1)
1308 # does SIGINT but Perl doesn't give us a choice.
1310 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1313 select($selected), $selected= "" unless $selected eq "";
1317 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1318 foreach $evalarg (@$post) {
1321 } # if ($single || $signal)
1322 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1326 # The following code may be executed now:
1330 my ($al, $ret, @ret) = "";
1331 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1334 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1335 $#stack = $stack_depth;
1336 $stack[-1] = $single;
1338 $single |= 4 if $stack_depth == $deep;
1340 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1341 # Why -1? But it works! :-(
1342 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1343 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1352 $signal=1 unless $warnassertions;
1358 $single |= $stack[$stack_depth--];
1360 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1361 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1362 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1363 if ($doret eq $stack_depth or $frame & 16) {
1365 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1366 print $fh ' ' x $stack_depth if $frame & 16;
1367 print $fh "list context return from $sub:\n";
1368 dumpit($fh, \@ret );
1380 $signal=1 unless $warnassertions;
1382 $ret=undef unless defined wantarray;
1385 if (defined wantarray) {
1391 $single |= $stack[$stack_depth--];
1393 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1394 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1395 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1396 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1398 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1399 print $fh (' ' x $stack_depth) if $frame & 16;
1400 print $fh (defined wantarray
1401 ? "scalar context return from $sub: "
1402 : "void context return from $sub\n");
1403 dumpit( $fh, $ret ) if defined wantarray;
1412 ### Functions with multiple modes of failure die on error, the rest
1413 ### returns FALSE on error.
1414 ### User-interface functions cmd_* output error message.
1416 ### Note all cmd_[a-zA-Z]'s require $cmd, $line, $dblineno as first arguments
1421 'A' => 'pre580_null',
1423 'B' => 'pre580_null',
1424 'd' => 'pre580_null',
1427 'M' => 'pre580_null',
1429 'o' => 'pre580_null',
1435 '<' => 'pre590_prepost',
1436 '<<' => 'pre590_prepost',
1437 '>' => 'pre590_prepost',
1438 '>>' => 'pre590_prepost',
1439 '{' => 'pre590_prepost',
1440 '{{' => 'pre590_prepost',
1447 my $dblineno = shift;
1449 # with this level of indirection we can wrap
1450 # to old (pre580) or other command sets easily
1453 $set{$CommandSet}{$cmd} || ($cmd =~ /^[<>{]+/o ? 'prepost' : $cmd)
1455 # print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
1457 return &$call($cmd, $line, $dblineno);
1461 my $cmd = shift; # a
1462 my $line = shift || ''; # [.|line] expr
1463 my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
1464 if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
1465 my ($lineno, $expr) = ($1, $2);
1467 if ($dbline[$lineno] == 0) {
1468 print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
1470 $had_breakpoints{$filename} |= 2;
1471 $dbline{$lineno} =~ s/\0[^\0]*//;
1472 $dbline{$lineno} .= "\0" . action($expr);
1476 print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
1481 my $cmd = shift; # A
1482 my $line = shift || '';
1483 my $dbline = shift; $line =~ s/^\./$dbline/;
1485 eval { &delete_action(); 1 } or print $OUT $@ and return;
1486 } elsif ($line =~ /^(\S.*)/) {
1487 eval { &delete_action($1); 1 } or print $OUT $@ and return;
1489 print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
1496 die "Line $i has no action .\n" if $dbline[$i] == 0;
1497 $dbline{$i} =~ s/\0[^\0]*//; # \^a
1498 delete $dbline{$i} if $dbline{$i} eq '';
1500 print $OUT "Deleting all actions...\n";
1501 for my $file (keys %had_breakpoints) {
1502 local *dbline = $main::{'_<' . $file};
1505 for ($i = 1; $i <= $max ; $i++) {
1506 if (defined $dbline{$i}) {
1507 $dbline{$i} =~ s/\0[^\0]*//;
1508 delete $dbline{$i} if $dbline{$i} eq '';
1510 unless ($had_breakpoints{$file} &= ~2) {
1511 delete $had_breakpoints{$file};
1519 my $cmd = shift; # b
1520 my $line = shift; # [.|line] [cond]
1521 my $dbline = shift; $line =~ s/^\./$dbline/;
1522 if ($line =~ /^\s*$/) {
1523 &cmd_b_line($dbline, 1);
1524 } elsif ($line =~ /^load\b\s*(.*)/) {
1525 my $file = $1; $file =~ s/\s+$//;
1527 } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
1528 my $cond = length $3 ? $3 : '1';
1529 my ($subname, $break) = ($2, $1 eq 'postpone');
1530 $subname =~ s/\'/::/g;
1531 $subname = "${'package'}::" . $subname unless $subname =~ /::/;
1532 $subname = "main".$subname if substr($subname,0,2) eq "::";
1533 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
1534 } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
1536 $cond = length $2 ? $2 : '1';
1537 &cmd_b_sub($subname, $cond);
1538 } elsif ($line =~ /^(\d*)\s*(.*)/) {
1539 $line = $1 || $dbline;
1540 $cond = length $2 ? $2 : '1';
1541 &cmd_b_line($line, $cond);
1543 print "confused by line($line)?\n";
1549 $break_on_load{$file} = 1;
1550 $had_breakpoints{$file} |= 1;
1553 sub report_break_on_load {
1554 sort keys %break_on_load;
1562 push @files, $::INC{$file} if $::INC{$file};
1563 $file .= '.pm', redo unless $file =~ /\./;
1565 break_on_load($_) for @files;
1566 @files = report_break_on_load;
1569 print $OUT "Will stop on load of `@files'.\n";
1572 $filename_error = '';
1574 sub breakable_line {
1575 my ($from, $to) = @_;
1578 my $delta = $from < $to ? +1 : -1;
1579 my $limit = $delta > 0 ? $#dbline : 1;
1580 $limit = $to if ($limit - $to) * $delta > 0;
1581 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1583 return $i unless $dbline[$i] == 0;
1584 my ($pl, $upto) = ('', '');
1585 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1586 die "Line$pl $from$upto$filename_error not breakable\n";
1589 sub breakable_line_in_filename {
1591 local *dbline = $main::{'_<' . $f};
1592 local $filename_error = " of `$f'";
1597 my ($i, $cond) = @_;
1598 $cond = 1 unless @_ >= 2;
1602 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1603 $had_breakpoints{$filename} |= 1;
1604 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1605 else { $dbline{$i} = $cond; }
1609 eval { break_on_line(@_); 1 } or do {
1611 print $OUT $@ and return;
1615 sub break_on_filename_line {
1616 my ($f, $i, $cond) = @_;
1617 $cond = 1 unless @_ >= 3;
1618 local *dbline = $main::{'_<' . $f};
1619 local $filename_error = " of `$f'";
1620 local $filename = $f;
1621 break_on_line($i, $cond);
1624 sub break_on_filename_line_range {
1625 my ($f, $from, $to, $cond) = @_;
1626 my $i = breakable_line_in_filename($f, $from, $to);
1627 $cond = 1 unless @_ >= 3;
1628 break_on_filename_line($f,$i,$cond);
1631 sub subroutine_filename_lines {
1632 my ($subname,$cond) = @_;
1633 # Filename below can contain ':'
1634 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1637 sub break_subroutine {
1638 my $subname = shift;
1639 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1640 die "Subroutine $subname not found.\n";
1641 $cond = 1 unless @_ >= 2;
1642 break_on_filename_line_range($file,$s,$e,@_);
1646 my ($subname,$cond) = @_;
1647 $cond = 1 unless @_ >= 2;
1648 unless (ref $subname eq 'CODE') {
1649 $subname =~ s/\'/::/g;
1651 $subname = "${'package'}::" . $subname
1652 unless $subname =~ /::/;
1653 $subname = "CORE::GLOBAL::$s"
1654 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1655 $subname = "main".$subname if substr($subname,0,2) eq "::";
1657 eval { break_subroutine($subname,$cond); 1 } or do {
1659 print $OUT $@ and return;
1664 my $cmd = shift; # B
1665 my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
1666 my $dbline = shift; $line =~ s/^\./$dbline/;
1668 eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
1669 } elsif ($line =~ /^(\S.*)/) {
1670 eval { &delete_breakpoint($line || $dbline); 1 } or do {
1672 print $OUT $@ and return;
1675 print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
1679 sub delete_breakpoint {
1682 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1683 $dbline{$i} =~ s/^[^\0]*//;
1684 delete $dbline{$i} if $dbline{$i} eq '';
1686 print $OUT "Deleting all breakpoints...\n";
1687 for my $file (keys %had_breakpoints) {
1688 local *dbline = $main::{'_<' . $file};
1691 for ($i = 1; $i <= $max ; $i++) {
1692 if (defined $dbline{$i}) {
1693 $dbline{$i} =~ s/^[^\0]+//;
1694 if ($dbline{$i} =~ s/^\0?$//) {
1699 if (not $had_breakpoints{$file} &= ~1) {
1700 delete $had_breakpoints{$file};
1704 undef %postponed_file;
1705 undef %break_on_load;
1709 sub cmd_stop { # As on ^C, but not signal-safy.
1714 my $cmd = shift; # h
1715 my $line = shift || '';
1716 if ($line =~ /^h\s*/) {
1718 } elsif ($line =~ /^(\S.*)$/) {
1719 # support long commands; otherwise bogus errors
1720 # happen when you ask for h on <CR> for example
1721 my $asked = $1; # for proper errmsg
1722 my $qasked = quotemeta($asked); # for searching
1723 # XXX: finds CR but not <CR>
1724 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
1725 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
1729 print_help("B<$asked> is not a debugger command.\n");
1732 print_help($summary);
1737 my $current_line = $line;
1738 my $cmd = shift; # l
1740 $line =~ s/^-\s*$/-/;
1741 if ($line =~ /^(\$.*)/s) {
1744 print($OUT "Error: $@\n"), next CMD if $@;
1746 print($OUT "Interpreted as: $1 $s\n");
1749 } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
1750 my $s = $subname = $1;
1751 $subname =~ s/\'/::/;
1752 $subname = $package."::".$subname
1753 unless $subname =~ /::/;
1754 $subname = "CORE::GLOBAL::$s"
1755 if not defined &$subname and $s !~ /::/
1756 and defined &{"CORE::GLOBAL::$s"};
1757 $subname = "main".$subname if substr($subname,0,2) eq "::";
1758 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
1759 $subrange = pop @pieces;
1760 $file = join(':', @pieces);
1761 if ($file ne $filename) {
1762 print $OUT "Switching to file '$file'.\n"
1763 unless $slave_editor;
1764 *dbline = $main::{'_<' . $file};
1769 if (eval($subrange) < -$window) {
1770 $subrange =~ s/-.*/+/;
1773 &cmd_l('l', $subrange);
1775 print $OUT "Subroutine $subname not found.\n";
1777 } elsif ($line =~ /^\s*$/) {
1778 $incr = $window - 1;
1779 $line = $start . '-' . ($start + $incr);
1781 } elsif ($line =~ /^(\d*)\+(\d*)$/) {
1784 $incr = $window - 1 unless $incr;
1785 $line = $start . '-' . ($start + $incr);
1787 } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
1788 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
1789 $end = $max if $end > $max;
1791 $i = $line if $i eq '.';
1794 if ($slave_editor) {
1795 print $OUT "\032\032$filename:$i:0\n";
1798 for (; $i <= $end; $i++) {
1800 ($stop,$action) = split(/\0/, $dbline{$i}) if
1802 $arrow = ($i==$current_line
1803 and $filename eq $filename_ini)
1805 : ($dbline[$i]+0 ? ':' : ' ') ;
1806 $arrow .= 'b' if $stop;
1807 $arrow .= 'a' if $action;
1808 print $OUT "$i$arrow\t", $dbline[$i];
1809 $i++, last if $signal;
1811 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
1813 $start = $i; # remember in case they want more
1814 $start = $max if $start > $max;
1819 my $cmd = shift; # L
1820 my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
1821 my $action_wanted = ($arg =~ /a/) ? 1 : 0;
1822 my $break_wanted = ($arg =~ /b/) ? 1 : 0;
1823 my $watch_wanted = ($arg =~ /w/) ? 1 : 0;
1825 if ($break_wanted or $action_wanted) {
1826 for my $file (keys %had_breakpoints) {
1827 local *dbline = $main::{'_<' . $file};
1830 for ($i = 1; $i <= $max; $i++) {
1831 if (defined $dbline{$i}) {
1832 print $OUT "$file:\n" unless $was++;
1833 print $OUT " $i:\t", $dbline[$i];
1834 ($stop,$action) = split(/\0/, $dbline{$i});
1835 print $OUT " break if (", $stop, ")\n"
1836 if $stop and $break_wanted;
1837 print $OUT " action: ", $action, "\n"
1838 if $action and $action_wanted;
1844 if (%postponed and $break_wanted) {
1845 print $OUT "Postponed breakpoints in subroutines:\n";
1847 for $subname (keys %postponed) {
1848 print $OUT " $subname\t$postponed{$subname}\n";
1852 my @have = map { # Combined keys
1853 keys %{$postponed_file{$_}}
1854 } keys %postponed_file;
1855 if (@have and ($break_wanted or $action_wanted)) {
1856 print $OUT "Postponed breakpoints in files:\n";
1858 for $file (keys %postponed_file) {
1859 my $db = $postponed_file{$file};
1860 print $OUT " $file:\n";
1861 for $line (sort {$a <=> $b} keys %$db) {
1862 print $OUT " $line:\n";
1863 my ($stop,$action) = split(/\0/, $$db{$line});
1864 print $OUT " break if (", $stop, ")\n"
1865 if $stop and $break_wanted;
1866 print $OUT " action: ", $action, "\n"
1867 if $action and $action_wanted;
1873 if (%break_on_load and $break_wanted) {
1874 print $OUT "Breakpoints on load:\n";
1876 for $file (keys %break_on_load) {
1877 print $OUT " $file\n";
1881 if ($watch_wanted) {
1883 print $OUT "Watch-expressions:\n" if @to_watch;
1884 for my $expr (@to_watch) {
1885 print $OUT " $expr\n";
1897 my $cmd = shift; # o
1898 my $opt = shift || ''; # opt[=val]
1899 if ($opt =~ /^(\S.*)/) {
1909 print $OUT "The old O command is now the o command.\n"; # hint
1910 print $OUT "Use 'h' to get current command help synopsis or\n"; #
1911 print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; #
1915 my $cmd = shift; # v
1918 if ($line =~ /^(\d*)$/) {
1919 $incr = $window - 1;
1922 $line = $start . '-' . ($start + $incr);
1928 my $cmd = shift; # w
1929 my $expr = shift || '';
1930 if ($expr =~ /^(\S.*)/) {
1931 push @to_watch, $expr;
1933 my ($val) = join(' ', &eval);
1934 $val = (defined $val) ? "'$val'" : 'undef' ;
1935 push @old_watch, $val;
1938 print $OUT "Adding a watch-expression requires an expression\n"; # hint
1943 my $cmd = shift; # W
1944 my $expr = shift || '';
1947 print $OUT "Deleting all watch expressions ...\n";
1948 @to_watch = @old_watch = ();
1949 } elsif ($expr =~ /^(\S.*)/) {
1951 foreach (@to_watch) {
1952 my $val = $to_watch[$i_cnt];
1953 if ($val eq $expr) { # =~ m/^\Q$i$/) {
1954 splice(@to_watch, $i_cnt, 1);
1959 print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
1966 if ($cmd =~ /^.\b\s*([+-]?)\s*(~?)\s*(\w+(\s*\|\s*\w+)*)\s*$/) {
1967 my ($how, $neg, $flags)=($1, $2, $3);
1968 my $acu=parse_DollarCaretP_flags($flags);
1970 $acu= ~$acu if $neg;
1971 if ($how eq '+') { $^P|=$acu }
1972 elsif ($how eq '-') { $^P&=~$acu }
1975 # else { print $OUT "undefined acu\n" }
1977 my $expanded=expand_DollarCaretP_flags($^P);
1978 print $OUT "Internal Perl debugger flags:\n\$^P=$expanded\n";
1982 ### END of the API section
1985 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1986 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1989 sub print_lineinfo {
1990 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1996 # The following takes its argument via $evalarg to preserve current @_
1999 my $subname = shift;
2000 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
2001 my $offset = $1 || 0;
2002 # Filename below can contain ':'
2003 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
2006 local *dbline = $main::{'_<' . $file};
2007 local $^W = 0; # != 0 is magical below
2008 $had_breakpoints{$file} |= 1;
2010 ++$i until $dbline[$i] != 0 or $i >= $max;
2011 $dbline{$i} = delete $postponed{$subname};
2014 print $OUT "Subroutine $subname not found.\n";
2018 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
2019 #print $OUT "In postponed_sub for `$subname'.\n";
2023 if ($ImmediateStop) {
2027 return &postponed_sub
2028 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
2029 # Cannot be done before the file is compiled
2030 local *dbline = shift;
2031 my $filename = $dbline;
2032 $filename =~ s/^_<//;
2034 $signal = 1, print $OUT "'$filename' loaded...\n"
2035 if $break_on_load{$filename};
2036 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
2037 return unless $postponed_file{$filename};
2038 $had_breakpoints{$filename} |= 1;
2039 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
2041 for $key (keys %{$postponed_file{$filename}}) {
2042 $dbline{$key} = ${$postponed_file{$filename}}{$key};
2044 delete $postponed_file{$filename};
2048 local ($savout) = select(shift);
2049 my $osingle = $single;
2050 my $otrace = $trace;
2051 $single = $trace = 0;
2054 unless (defined &main::dumpValue) {
2057 if (defined &main::dumpValue) {
2062 my $maxdepth = shift || $option{dumpDepth};
2063 $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
2064 &main::dumpValue($v, $maxdepth);
2067 print $OUT "dumpvar.pl not available.\n";
2074 # Tied method do not create a context, so may get wrong message:
2079 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
2080 my @sub = dump_trace($_[0] + 1, $_[1]);
2081 my $short = $_[2]; # Print short report, next one for sub name
2083 for ($i=0; $i <= $#sub; $i++) {
2086 my $args = defined $sub[$i]{args}
2087 ? "(@{ $sub[$i]{args} })"
2089 $args = (substr $args, 0, $maxtrace - 3) . '...'
2090 if length $args > $maxtrace;
2091 my $file = $sub[$i]{file};
2092 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
2094 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
2096 my $sub = @_ >= 4 ? $_[3] : $s;
2097 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
2099 print $fh "$sub[$i]{context} = $s$args" .
2100 " called from $file" .
2101 " line $sub[$i]{line}\n";
2108 my $count = shift || 1e9;
2111 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
2112 my $nothard = not $frame & 8;
2113 local $frame = 0; # Do not want to trace this.
2114 my $otrace = $trace;
2117 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
2122 if (not defined $arg) {
2124 } elsif ($nothard and tied $arg) {
2126 } elsif ($nothard and $type = ref $arg) {
2127 push @a, "ref($type)";
2129 local $_ = "$arg"; # Safe to stringify now - should not call f().
2132 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
2133 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
2134 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
2138 $context = $context ? '@' : (defined $context ? "\$" : '.');
2139 $args = $h ? [@a] : undef;
2140 $e =~ s/\n\s*\;\s*\Z// if $e;
2141 $e =~ s/([\\\'])/\\$1/g if $e;
2143 $sub = "require '$e'";
2144 } elsif (defined $r) {
2146 } elsif ($sub eq '(eval)') {
2147 $sub = "eval {...}";
2149 push(@sub, {context => $context, sub => $sub, args => $args,
2150 file => $file, line => $line});
2159 while ($action =~ s/\\$//) {
2168 # i hate using globals!
2169 $balanced_brace_re ||= qr{
2172 (?> [^{}] + ) # Non-parens without backtracking
2174 (??{ $balanced_brace_re }) # Group with matching parens
2178 return $_[0] !~ m/$balanced_brace_re/;
2182 &readline("cont: ");
2186 # We save, change, then restore STDIN and STDOUT to avoid fork() since
2187 # some non-Unix systems can do system() but have problems with fork().
2188 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
2189 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
2190 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
2191 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
2193 # XXX: using csh or tcsh destroys sigint retvals!
2195 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
2196 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
2201 # most of the $? crud was coping with broken cshisms
2203 &warn("(Command exited ", ($? >> 8), ")\n");
2205 &warn( "(Command died of SIG#", ($? & 127),
2206 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
2216 eval { require Term::ReadLine } or die $@;
2219 my ($i, $o) = split $tty, /,/;
2220 $o = $i unless defined $o;
2221 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
2222 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
2225 my $sel = select($OUT);
2229 eval "require Term::Rendezvous;" or die;
2230 my $rv = $ENV{PERLDB_NOTTY} || ".perldbtty$$";
2231 my $term_rv = new Term::Rendezvous $rv;
2233 $OUT = $term_rv->OUT;
2236 if ($term_pid eq '-1') { # In a TTY with another debugger
2240 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2242 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2244 $rl_attribs = $term->Attribs;
2245 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2246 if defined $rl_attribs->{basic_word_break_characters}
2247 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2248 $rl_attribs->{special_prefixes} = '$@&%';
2249 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2250 $rl_attribs->{completion_function} = \&db_complete;
2252 $LINEINFO = $OUT unless defined $LINEINFO;
2253 $lineinfo = $console unless defined $lineinfo;
2255 if ($term->Features->{setHistory} and "@hist" ne "?") {
2256 $term->SetHistory(@hist);
2258 ornaments($ornaments) if defined $ornaments;
2262 # Example get_fork_TTY functions
2263 sub xterm_get_fork_TTY {
2264 (my $name = $0) =~ s,^.*[/\\],,s;
2265 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2269 $pidprompt = ''; # Shown anyway in titlebar
2273 # This example function resets $IN, $OUT itself
2274 sub os2_get_fork_TTY {
2275 local $^F = 40; # XXXX Fixme!
2277 my ($in1, $out1, $in2, $out2);
2278 # Having -d in PERL5OPT would lead to a disaster...
2279 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2280 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2281 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2282 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2283 local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB};
2284 $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB};
2285 $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB};
2286 (my $name = $0) =~ s,^.*[/\\],,s;
2288 if ( pipe $in1, $out1 and pipe $in2, $out2
2289 # system P_SESSION will fail if there is another process
2290 # in the same session with a "dependent" asynchronous child session.
2291 and @args = ($rl, fileno $in1, fileno $out2,
2292 "Daughter Perl debugger $pids $name") and
2293 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2294 END {sleep 5 unless $loaded}
2295 BEGIN {open STDIN, '</dev/con' or warn "reopen stdin: $!"}
2298 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2300 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2301 open IN, '<&=$in' or die "open <&=$in: \$!";
2302 \$| = 1; print while sysread IN, \$_, 1<<16;
2306 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2308 require Term::ReadKey if $rl;
2309 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2310 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2312 or warn "system P_SESSION: $!, $^E" and 0)
2313 and close $in1 and close $out2 ) {
2314 $pidprompt = ''; # Shown anyway in titlebar
2315 reset_IN_OUT($in2, $out1);
2317 return ''; # Indicate that reset_IN_OUT is called
2322 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2323 my $in = &get_fork_TTY if defined &get_fork_TTY;
2324 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2325 if (not defined $in) {
2327 print_help(<<EOP) if $why == 1;
2328 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2330 print_help(<<EOP) if $why == 2;
2331 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2332 This may be an asynchronous session, so the parent debugger may be active.
2334 print_help(<<EOP) if $why != 4;
2335 Since two debuggers fight for the same TTY, input is severely entangled.
2339 I know how to switch the output to a different window in xterms
2340 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2341 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2343 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2344 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2347 } elsif ($in ne '') {
2350 $console = ''; # Indicate no need to open-from-the-console
2355 sub resetterm { # We forked, so we need a different TTY
2357 my $systemed = $in > 1 ? '-' : '';
2359 $pids =~ s/\]/$systemed->$$]/;
2361 $pids = "[$term_pid->$$]";
2365 return unless $CreateTTY & $in;
2372 my $left = @typeahead;
2373 my $got = shift @typeahead;
2375 print $OUT "auto(-$left)", shift, $got, "\n";
2376 $term->AddHistory($got)
2377 if length($got) > 1 and defined $term->Features->{addHistory};
2383 my $line = CORE::readline($cmdfhs[-1]);
2384 defined $line ? (print $OUT ">> $line" and return $line)
2385 : close pop @cmdfhs;
2387 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2388 $OUT->write(join('', @_));
2390 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2394 $term->readline(@_);
2399 my ($opt, $val)= @_;
2400 $val = option_val($opt,'N/A');
2401 $val =~ s/([\\\'])/\\$1/g;
2402 printf $OUT "%20s = '%s'\n", $opt, $val;
2405 sub options2remember {
2406 foreach my $k (@RememberOnROptions) {
2407 $option{$k}=option_val($k, 'N/A');
2413 my ($opt, $default)= @_;
2415 if (defined $optionVars{$opt}
2416 and defined ${$optionVars{$opt}}) {
2417 $val = ${$optionVars{$opt}};
2418 } elsif (defined $optionAction{$opt}
2419 and defined &{$optionAction{$opt}}) {
2420 $val = &{$optionAction{$opt}}();
2421 } elsif (defined $optionAction{$opt}
2422 and not defined $option{$opt}
2423 or defined $optionVars{$opt}
2424 and not defined ${$optionVars{$opt}}) {
2427 $val = $option{$opt};
2429 $val = $default unless defined $val;
2436 # too dangerous to let intuitive usage overwrite important things
2437 # defaultion should never be the default
2438 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2439 dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2440 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2445 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2446 my ($opt,$sep) = ($1,$2);
2449 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2451 #&dump_option($opt);
2452 } elsif ($sep !~ /\S/) {
2454 $val = "1"; # this is an evil default; make 'em set it!
2455 } elsif ($sep eq "=") {
2456 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2458 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2462 print OUT qq(Option better cleared using $opt=""\n)
2466 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2467 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2468 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2469 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2470 ($val = $1) =~ s/\\([\\$end])/$1/g;
2474 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2475 || grep( /^\Q$opt/i && ($option = $_), @options );
2477 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2478 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2480 if ($opt_needs_val{$option} && $val_defaulted) {
2481 my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
2482 print $OUT "Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
2486 $option{$option} = $val if defined $val;
2491 require '$optionRequire{$option}';
2493 } || die # XXX: shouldn't happen
2494 if defined $optionRequire{$option} &&
2497 ${$optionVars{$option}} = $val
2498 if defined $optionVars{$option} &&
2501 &{$optionAction{$option}} ($val)
2502 if defined $optionAction{$option} &&
2503 defined &{$optionAction{$option}} &&
2507 dump_option($option) unless $OUT eq \*STDERR;
2512 my ($stem,@list) = @_;
2514 $ENV{"${stem}_n"} = @list;
2515 for $i (0 .. $#list) {
2517 $val =~ s/\\/\\\\/g;
2518 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2519 $ENV{"${stem}_$i"} = $val;
2526 my $n = delete $ENV{"${stem}_n"};
2528 for $i (0 .. $n - 1) {
2529 $val = delete $ENV{"${stem}_$i"};
2530 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2538 return; # Put nothing on the stack - malloc/free land!
2542 my($msg)= join("",@_);
2543 $msg .= ": $!\n" unless $msg =~ /\n$/;
2549 my $switch_li = $LINEINFO eq $OUT;
2550 if ($term and $term->Features->{newTTY}) {
2551 ($IN, $OUT) = (shift, shift);
2552 $term->newTTY($IN, $OUT);
2554 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2556 ($IN, $OUT) = (shift, shift);
2558 my $o = select $OUT;
2561 $LINEINFO = $OUT if $switch_li;
2565 if (@_ and $term and $term->Features->{newTTY}) {
2566 my ($in, $out) = shift;
2568 ($in, $out) = split /,/, $in, 2;
2572 open IN, $in or die "cannot open `$in' for read: $!";
2573 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2574 reset_IN_OUT(\*IN,\*OUT);
2577 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2578 # Useful if done through PERLDB_OPTS:
2579 $console = $tty = shift if @_;
2585 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2587 $notty = shift if @_;
2593 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2601 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2603 $remoteport = shift if @_;
2608 if (${$term->Features}{tkRunning}) {
2609 return $term->tkRunning(@_);
2612 print $OUT "tkRunning not supported by current ReadLine package.\n";
2619 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2621 $runnonstop = shift if @_;
2627 &warn("Some flag changes could not take effect until next 'R'!\n") if @_;
2629 $^P = parse_DollarCaretP_flags(shift) if @_;
2630 expand_DollarCaretP_flags($^P)
2633 sub OnlyAssertions {
2635 &warn("Too late to set up OnlyAssertions mode, enabled on next 'R'!\n") if @_;
2638 unless (defined $ini_assertion) {
2640 &warn("Current Perl interpreter doesn't support assertions");
2645 unless ($ini_assertion) {
2646 print "Assertions will be active on next 'R'!\n";
2649 $^P&= ~$DollarCaretP_flags{PERLDBf_SUB};
2650 $^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
2653 $^P|=$DollarCaretP_flags{PERLDBf_SUB};
2656 !($^P & $DollarCaretP_flags{PERLDBf_SUB}) || 0;
2662 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2669 $sh = quotemeta shift;
2670 $sh .= "\\b" if $sh =~ /\w$/;
2674 $psh =~ s/\\(.)/$1/g;
2679 if (defined $term) {
2680 local ($warnLevel,$dieLevel) = (0, 1);
2681 return '' unless $term->Features->{ornaments};
2682 eval { $term->ornaments(@_) } || '';
2690 $rc = quotemeta shift;
2691 $rc .= "\\b" if $rc =~ /\w$/;
2695 $prc =~ s/\\(.)/$1/g;
2700 return $lineinfo unless @_;
2702 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2703 $slave_editor = ($stream =~ /^\|/);
2704 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2705 $LINEINFO = \*LINEINFO;
2706 my $save = select($LINEINFO);
2712 sub list_modules { # versions
2720 s/^Term::ReadLine::readline$/readline/;
2721 if (defined ${ $_ . '::VERSION' }) {
2722 $version{$file} = "${ $_ . '::VERSION' } from ";
2724 $version{$file} .= $INC{$file};
2726 dumpit($OUT,\%version);
2730 # XXX: make sure there are tabs between the command and explanation,
2731 # or print_help will screw up your formatting if you have
2732 # eeevil ornaments enabled. This is an insane mess.
2735 Help is currently only available for the new 580 CommandSet,
2736 if you really want old behaviour, presumably you know what
2740 B<s> [I<expr>] Single step [in I<expr>].
2741 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2742 <B<CR>> Repeat last B<n> or B<s> command.
2743 B<r> Return from current subroutine.
2744 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2745 at the specified position.
2746 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2747 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2748 B<l> I<line> List single I<line>.
2749 B<l> I<subname> List first window of lines from subroutine.
2750 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2751 B<l> List next window of lines.
2752 B<-> List previous window of lines.
2753 B<v> [I<line>] View window around I<line>.
2754 B<.> Return to the executed line.
2755 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2756 I<filename> may be either the full name of the file, or a regular
2757 expression matching the full file name:
2758 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2759 Evals (with saved bodies) are considered to be filenames:
2760 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2761 (in the order of execution).
2762 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2763 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2764 B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions.
2765 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2766 B<t> Toggle trace mode.
2767 B<t> I<expr> Trace through execution of I<expr>.
2768 B<b> Sets breakpoint on current line)
2769 B<b> [I<line>] [I<condition>]
2770 Set breakpoint; I<line> defaults to the current execution line;
2771 I<condition> breaks if it evaluates to true, defaults to '1'.
2772 B<b> I<subname> [I<condition>]
2773 Set breakpoint at first line of subroutine.
2774 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2775 B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
2776 B<b> B<postpone> I<subname> [I<condition>]
2777 Set breakpoint at first line of subroutine after
2779 B<b> B<compile> I<subname>
2780 Stop after the subroutine is compiled.
2781 B<B> [I<line>] Delete the breakpoint for I<line>.
2782 B<B> I<*> Delete all breakpoints.
2783 B<a> [I<line>] I<command>
2784 Set an action to be done before the I<line> is executed;
2785 I<line> defaults to the current execution line.
2786 Sequence is: check for breakpoint/watchpoint, print line
2787 if necessary, do action, prompt user if necessary,
2790 B<A> [I<line>] Delete the action for I<line>.
2791 B<A> I<*> Delete all actions.
2792 B<w> I<expr> Add a global watch-expression.
2794 B<W> I<expr> Delete a global watch-expression.
2795 B<W> I<*> Delete all watch-expressions.
2796 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2797 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2798 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2799 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2800 B<x> I<expr> Evals expression in list context, dumps the result.
2801 B<m> I<expr> Evals expression in list context, prints methods callable
2802 on the first element of the result.
2803 B<m> I<class> Prints methods callable via the given class.
2804 B<M> Show versions of loaded modules.
2805 B<y> [I<n> [I<vars>]] List lexical variables I<n> levels up from current sub
2807 B<<> ? List Perl commands to run before each prompt.
2808 B<<> I<expr> Define Perl command to run before each prompt.
2809 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2810 B<< *> Delete the list of perl commands to run before each prompt.
2811 B<>> ? List Perl commands to run after each prompt.
2812 B<>> I<expr> Define Perl command to run after each prompt.
2813 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2814 B<>>B< *> Delete the list of Perl commands to run after each prompt.
2815 B<{> I<db_command> Define debugger command to run before each prompt.
2816 B<{> ? List debugger commands to run before each prompt.
2817 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2818 B<{ *> Delete the list of debugger commands to run before each prompt.
2819 B<$prc> I<number> Redo a previous command (default previous command).
2820 B<$prc> I<-number> Redo number'th-to-last command.
2821 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2822 See 'B<O> I<recallCommand>' too.
2823 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2824 . ( $rc eq $sh ? "" : "
2825 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2826 See 'B<O> I<shellBang>' too.
2827 B<source> I<file> Execute I<file> containing debugger commands (may nest).
2828 B<H> I<-number> Display last number commands (default all).
2829 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2830 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2831 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2832 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2833 I<command> Execute as a perl statement in current package.
2834 B<R> Pure-man-restart of debugger, some of debugger state
2835 and command-line options may be lost.
2836 Currently the following settings are preserved:
2837 history, breakpoints and actions, debugger B<O>ptions
2838 and the following command-line options: I<-w>, I<-I>, I<-e>.
2840 B<o> [I<opt>] ... Set boolean option to true
2841 B<o> [I<opt>B<?>] Query options
2842 B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2843 Set options. Use quotes in spaces in value.
2844 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2845 I<pager> program for output of \"|cmd\";
2846 I<tkRunning> run Tk while prompting (with ReadLine);
2847 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2848 I<inhibit_exit> Allows stepping off the end of the script.
2849 I<ImmediateStop> Debugger should stop as early as possible.
2850 I<RemotePort> Remote hostname:port for remote debugging
2851 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2852 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2853 I<compactDump>, I<veryCompact> change style of array and hash dump;
2854 I<globPrint> whether to print contents of globs;
2855 I<DumpDBFiles> dump arrays holding debugged files;
2856 I<DumpPackages> dump symbol tables of packages;
2857 I<DumpReused> dump contents of \"reused\" addresses;
2858 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2859 I<bareStringify> Do not print the overload-stringified value;
2860 Other options include:
2861 I<PrintRet> affects printing of return value after B<r> command,
2862 I<frame> affects printing messages on subroutine entry/exit.
2863 I<AutoTrace> affects printing messages on possible breaking points.
2864 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2865 I<ornaments> affects screen appearance of the command line.
2866 I<CreateTTY> bits control attempts to create a new TTY on events:
2867 1: on fork() 2: debugger is started inside debugger
2869 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2870 You can put additional initialization options I<TTY>, I<noTTY>,
2871 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2872 `B<R>' after you set them).
2874 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2875 B<h> Summary of debugger commands.
2876 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2877 B<h h> Long help for debugger commands
2878 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2879 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2880 Set B<\$DB::doccmd> to change viewer.
2882 Type `|h h' for a paged display if this was too hard to read.
2884 "; # Fix balance of vi % matching: }}}}
2886 # note: tabs in the following section are not-so-helpful
2887 $summary = <<"END_SUM";
2888 I<List/search source lines:> I<Control script execution:>
2889 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2890 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2891 B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs
2892 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2893 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2894 B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position
2895 I<Debugger controls:> B<L> List break/watch/actions
2896 B<o> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2897 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2898 B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints
2899 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2900 B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions
2901 B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression
2902 B<h h> Complete help page B<W> I<expr|*> Delete a/all watch exprs
2903 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2904 B<q> or B<^D> Quit B<R> Attempt a restart
2905 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2906 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2907 B<p> I<expr> Print expression (uses script's current package).
2908 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2909 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2910 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2911 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2912 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2914 # ')}}; # Fix balance of vi % matching
2916 # and this is really numb...
2919 B<s> [I<expr>] Single step [in I<expr>].
2920 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2921 <B<CR>> Repeat last B<n> or B<s> command.
2922 B<r> Return from current subroutine.
2923 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2924 at the specified position.
2925 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2926 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2927 B<l> I<line> List single I<line>.
2928 B<l> I<subname> List first window of lines from subroutine.
2929 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2930 B<l> List next window of lines.
2931 B<-> List previous window of lines.
2932 B<w> [I<line>] List window around I<line>.
2933 B<.> Return to the executed line.
2934 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2935 I<filename> may be either the full name of the file, or a regular
2936 expression matching the full file name:
2937 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2938 Evals (with saved bodies) are considered to be filenames:
2939 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2940 (in the order of execution).
2941 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2942 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2943 B<L> List all breakpoints and actions.
2944 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2945 B<t> Toggle trace mode.
2946 B<t> I<expr> Trace through execution of I<expr>.
2947 B<b> [I<line>] [I<condition>]
2948 Set breakpoint; I<line> defaults to the current execution line;
2949 I<condition> breaks if it evaluates to true, defaults to '1'.
2950 B<b> I<subname> [I<condition>]
2951 Set breakpoint at first line of subroutine.
2952 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2953 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2954 B<b> B<postpone> I<subname> [I<condition>]
2955 Set breakpoint at first line of subroutine after
2957 B<b> B<compile> I<subname>
2958 Stop after the subroutine is compiled.
2959 B<d> [I<line>] Delete the breakpoint for I<line>.
2960 B<D> Delete all breakpoints.
2961 B<a> [I<line>] I<command>
2962 Set an action to be done before the I<line> is executed;
2963 I<line> defaults to the current execution line.
2964 Sequence is: check for breakpoint/watchpoint, print line
2965 if necessary, do action, prompt user if necessary,
2967 B<a> [I<line>] Delete the action for I<line>.
2968 B<A> Delete all actions.
2969 B<W> I<expr> Add a global watch-expression.
2970 B<W> Delete all watch-expressions.
2971 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2972 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2973 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2974 B<x> I<expr> Evals expression in list context, dumps the result.
2975 B<m> I<expr> Evals expression in list context, prints methods callable
2976 on the first element of the result.
2977 B<m> I<class> Prints methods callable via the given class.
2979 B<<> ? List Perl commands to run before each prompt.
2980 B<<> I<expr> Define Perl command to run before each prompt.
2981 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2982 B<>> ? List Perl commands to run after each prompt.
2983 B<>> I<expr> Define Perl command to run after each prompt.
2984 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2985 B<{> I<db_command> Define debugger command to run before each prompt.
2986 B<{> ? List debugger commands to run before each prompt.
2987 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2988 B<$prc> I<number> Redo a previous command (default previous command).
2989 B<$prc> I<-number> Redo number'th-to-last command.
2990 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2991 See 'B<O> I<recallCommand>' too.
2992 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2993 . ( $rc eq $sh ? "" : "
2994 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2995 See 'B<O> I<shellBang>' too.
2996 B<source> I<file> Execute I<file> containing debugger commands (may nest).
2997 B<H> I<-number> Display last number commands (default all).
2998 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2999 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
3000 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
3001 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
3002 I<command> Execute as a perl statement in current package.
3003 B<v> Show versions of loaded modules.
3004 B<R> Pure-man-restart of debugger, some of debugger state
3005 and command-line options may be lost.
3006 Currently the following settings are preserved:
3007 history, breakpoints and actions, debugger B<O>ptions
3008 and the following command-line options: I<-w>, I<-I>, I<-e>.
3010 B<O> [I<opt>] ... Set boolean option to true
3011 B<O> [I<opt>B<?>] Query options
3012 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
3013 Set options. Use quotes in spaces in value.
3014 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
3015 I<pager> program for output of \"|cmd\";
3016 I<tkRunning> run Tk while prompting (with ReadLine);
3017 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
3018 I<inhibit_exit> Allows stepping off the end of the script.
3019 I<ImmediateStop> Debugger should stop as early as possible.
3020 I<RemotePort> Remote hostname:port for remote debugging
3021 The following options affect what happens with B<V>, B<X>, and B<x> commands:
3022 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
3023 I<compactDump>, I<veryCompact> change style of array and hash dump;
3024 I<globPrint> whether to print contents of globs;
3025 I<DumpDBFiles> dump arrays holding debugged files;
3026 I<DumpPackages> dump symbol tables of packages;
3027 I<DumpReused> dump contents of \"reused\" addresses;
3028 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
3029 I<bareStringify> Do not print the overload-stringified value;
3030 Other options include:
3031 I<PrintRet> affects printing of return value after B<r> command,
3032 I<frame> affects printing messages on subroutine entry/exit.
3033 I<AutoTrace> affects printing messages on possible breaking points.
3034 I<maxTraceLen> gives max length of evals/args listed in stack trace.
3035 I<ornaments> affects screen appearance of the command line.
3036 I<CreateTTY> bits control attempts to create a new TTY on events:
3037 1: on fork() 2: debugger is started inside debugger
3039 During startup options are initialized from \$ENV{PERLDB_OPTS}.
3040 You can put additional initialization options I<TTY>, I<noTTY>,
3041 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
3042 `B<R>' after you set them).
3044 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
3045 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
3046 B<h h> Summary of debugger commands.
3047 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
3048 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
3049 Set B<\$DB::doccmd> to change viewer.
3051 Type `|h' for a paged display if this was too hard to read.
3053 "; # Fix balance of vi % matching: }}}}
3055 # note: tabs in the following section are not-so-helpful
3056 $pre580_summary = <<"END_SUM";
3057 I<List/search source lines:> I<Control script execution:>
3058 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
3059 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
3060 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
3061 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
3062 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
3063 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
3064 I<Debugger controls:> B<L> List break/watch/actions
3065 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
3066 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
3067 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
3068 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
3069 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
3070 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
3071 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
3072 B<q> or B<^D> Quit B<R> Attempt a restart
3073 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
3074 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
3075 B<p> I<expr> Print expression (uses script's current package).
3076 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
3077 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
3078 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
3079 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
3080 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
3082 # ')}}; # Fix balance of vi % matching
3089 # Restore proper alignment destroyed by eeevil I<> and B<>
3090 # ornaments: A pox on both their houses!
3092 # A help command will have everything up to and including
3093 # the first tab sequence padded into a field 16 (or if indented 20)
3094 # wide. If it's wider than that, an extra space will be added.
3096 ^ # only matters at start of line
3097 ( \040{4} | \t )* # some subcommands are indented
3098 ( < ? # so <CR> works
3099 [BI] < [^\t\n] + ) # find an eeevil ornament
3100 ( \t+ ) # original separation, discarded
3101 ( .* ) # this will now start (no earlier) than
3104 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
3105 my $clean = $command;
3106 $clean =~ s/[BI]<([^>]*)>/$1/g;
3107 # replace with this whole string:
3108 ($leadwhite ? " " x 4 : "")
3110 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
3115 s{ # handle bold ornaments
3116 B < ( [^>] + | > ) >
3118 $Term::ReadLine::TermCap::rl_term_set[2]
3120 . $Term::ReadLine::TermCap::rl_term_set[3]
3123 s{ # handle italic ornaments
3124 I < ( [^>] + | > ) >
3126 $Term::ReadLine::TermCap::rl_term_set[0]
3128 . $Term::ReadLine::TermCap::rl_term_set[1]
3136 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
3137 my $is_less = $pager =~ /\bless\b/;
3138 if ($pager =~ /\bmore\b/) {
3139 my @st_more = stat('/usr/bin/more');
3140 my @st_less = stat('/usr/bin/less');
3141 $is_less = @st_more && @st_less
3142 && $st_more[0] == $st_less[0]
3143 && $st_more[1] == $st_less[1];
3145 # changes environment!
3146 $ENV{LESS} .= 'r' if $is_less;
3152 $SIG{'ABRT'} = 'DEFAULT';
3153 kill 'ABRT', $$ if $panic++;
3154 if (defined &Carp::longmess) {
3155 local $SIG{__WARN__} = '';
3156 local $Carp::CarpLevel = 2; # mydie + confess
3157 &warn(Carp::longmess("Signal @_"));
3161 print $DB::OUT "Got signal @_\n";
3169 local $SIG{__WARN__} = '';
3170 local $SIG{__DIE__} = '';
3171 eval { require Carp } if defined $^S; # If error/warning during compilation,
3172 # require may be broken.
3173 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
3174 return unless defined &Carp::longmess;
3175 my ($mysingle,$mytrace) = ($single,$trace);
3176 $single = 0; $trace = 0;
3177 my $mess = Carp::longmess(@_);
3178 ($single,$trace) = ($mysingle,$mytrace);
3185 local $SIG{__DIE__} = '';
3186 local $SIG{__WARN__} = '';
3187 my $i = 0; my $ineval = 0; my $sub;
3188 if ($dieLevel > 2) {
3189 local $SIG{__WARN__} = \&dbwarn;
3190 &warn(@_); # Yell no matter what
3193 if ($dieLevel < 2) {
3194 die @_ if $^S; # in eval propagate
3196 # No need to check $^S, eval is much more robust nowadays
3197 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
3198 # require may be broken.
3200 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
3201 unless defined &Carp::longmess;
3203 # We do not want to debug this chunk (automatic disabling works
3204 # inside DB::DB, but not in Carp).
3205 my ($mysingle,$mytrace) = ($single,$trace);
3206 $single = 0; $trace = 0;
3209 package Carp; # Do not include us in the list
3211 $mess = Carp::longmess(@_);
3214 ($single,$trace) = ($mysingle,$mytrace);
3220 $prevwarn = $SIG{__WARN__} unless $warnLevel;
3223 $SIG{__WARN__} = \&DB::dbwarn;
3224 } elsif ($prevwarn) {
3225 $SIG{__WARN__} = $prevwarn;
3234 $prevdie = $SIG{__DIE__} unless $dieLevel;
3237 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
3238 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
3239 print $OUT "Stack dump during die enabled",
3240 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
3242 print $OUT "Dump printed too.\n" if $dieLevel > 2;
3243 } elsif ($prevdie) {
3244 $SIG{__DIE__} = $prevdie;
3245 print $OUT "Default die handler restored.\n";
3253 $prevsegv = $SIG{SEGV} unless $signalLevel;
3254 $prevbus = $SIG{BUS} unless $signalLevel;
3255 $signalLevel = shift;
3257 $SIG{SEGV} = \&DB::diesignal;
3258 $SIG{BUS} = \&DB::diesignal;
3260 $SIG{SEGV} = $prevsegv;
3261 $SIG{BUS} = $prevbus;
3269 my $name = CvGV_name_or_bust($in);
3270 defined $name ? $name : $in;
3273 sub CvGV_name_or_bust {
3275 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
3276 return unless ref $in;
3277 $in = \&$in; # Hard reference...
3278 eval {require Devel::Peek; 1} or return;
3279 my $gv = Devel::Peek::CvGV($in) or return;
3280 *$gv{PACKAGE} . '::' . *$gv{NAME};
3286 return unless defined &$subr;
3287 my $name = CvGV_name_or_bust($subr);
3289 $data = $sub{$name} if defined $name;
3290 return $data if defined $data;
3293 $subr = \&$subr; # Hard reference
3296 $s = $_, last if $subr eq \&$_;
3304 $class = ref $class if ref $class;
3307 methods_via($class, '', 1);
3308 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
3313 return if $packs{$class}++;
3315 my $prepend = $prefix ? "via $prefix: " : '';
3317 for $name (grep {defined &{${"${class}::"}{$_}}}
3318 sort keys %{"${class}::"}) {
3319 next if $seen{ $name }++;
3322 print $DB::OUT "$prepend$name\n";
3324 return unless shift; # Recurse?
3325 for $name (@{"${class}::ISA"}) {
3326 $prepend = $prefix ? $prefix . " -> $name" : $name;
3327 methods_via($name, $prepend, 1);
3332 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
3333 ? "man" # O Happy Day!
3334 : "perldoc"; # Alas, poor unfortunates
3340 &system("$doccmd $doccmd");
3343 # this way user can override, like with $doccmd="man -Mwhatever"
3344 # or even just "man " to disable the path check.
3345 unless ($doccmd eq 'man') {
3346 &system("$doccmd $page");
3350 $page = 'perl' if lc($page) eq 'help';
3353 my $man1dir = $Config::Config{'man1dir'};
3354 my $man3dir = $Config::Config{'man3dir'};
3355 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
3357 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
3358 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
3359 chop $manpath if $manpath;
3360 # harmless if missing, I figure
3361 my $oldpath = $ENV{MANPATH};
3362 $ENV{MANPATH} = $manpath if $manpath;
3363 my $nopathopt = $^O =~ /dunno what goes here/;
3364 if (CORE::system($doccmd,
3365 # I just *know* there are men without -M
3366 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3369 unless ($page =~ /^perl\w/) {
3370 if (grep { $page eq $_ } qw{
3371 5004delta 5005delta amiga api apio book boot bot call compile
3372 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
3373 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
3374 form func guts hack hist hpux intern ipc lexwarn locale lol mod
3375 modinstall modlib number obj op opentut os2 os390 pod port
3376 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
3377 trap unicode var vms win32 xs xstut
3381 CORE::system($doccmd,
3382 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3387 if (defined $oldpath) {
3388 $ENV{MANPATH} = $manpath;
3390 delete $ENV{MANPATH};
3394 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
3396 BEGIN { # This does not compile, alas.
3397 $IN = \*STDIN; # For bugs before DB::OUT has been opened
3398 $OUT = \*STDERR; # For errors before DB::OUT has been opened
3402 $deep = 100; # warning if stack gets this deep
3406 $SIG{INT} = \&DB::catch;
3407 # This may be enabled to debug debugger:
3408 #$warnLevel = 1 unless defined $warnLevel;
3409 #$dieLevel = 1 unless defined $dieLevel;
3410 #$signalLevel = 1 unless defined $signalLevel;
3412 $db_stop = 0; # Compiler warning
3414 $level = 0; # Level of recursive debugging
3415 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
3416 # Triggers bug (?) in perl is we postpone this until runtime:
3417 @postponed = @stack = (0);
3418 $stack_depth = 0; # Localized $#stack
3423 BEGIN {$^W = $ini_warn;} # Switch warnings back
3425 #use Carp; # This did break, left for debugging
3428 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
3429 my($text, $line, $start) = @_;
3430 my ($itext, $search, $prefix, $pack) =
3431 ($text, "^\Q${'package'}::\E([^:]+)\$");
3433 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
3434 (map { /$search/ ? ($1) : () } keys %sub)
3435 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
3436 return sort grep /^\Q$text/, values %INC # files
3437 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
3438 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3439 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
3440 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
3441 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3443 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
3445 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
3446 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
3447 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
3448 # We may want to complete to (eval 9), so $text may be wrong
3449 $prefix = length($1) - length($text);
3452 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
3454 if ((substr $text, 0, 1) eq '&') { # subroutines
3455 $text = substr $text, 1;
3457 return sort map "$prefix$_",
3460 (map { /$search/ ? ($1) : () }
3463 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
3464 $pack = ($1 eq 'main' ? '' : $1) . '::';
3465 $prefix = (substr $text, 0, 1) . $1 . '::';
3468 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
3469 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3470 return db_complete($out[0], $line, $start);
3474 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3475 $pack = ($package eq 'main' ? '' : $package) . '::';
3476 $prefix = substr $text, 0, 1;
3477 $text = substr $text, 1;
3478 my @out = map "$prefix$_", grep /^\Q$text/,
3479 (grep /^_?[a-zA-Z]/, keys %$pack),
3480 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3481 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3482 return db_complete($out[0], $line, $start);
3486 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3487 my @out = grep /^\Q$text/, @options;
3488 my $val = option_val($out[0], undef);
3490 if (not defined $val or $val =~ /[\n\r]/) {
3491 # Can do nothing better
3492 } elsif ($val =~ /\s/) {
3494 foreach $l (split //, qq/\"\'\#\|/) {
3495 $out = "$l$val$l ", last if (index $val, $l) == -1;
3500 # Default to value if one completion, to question if many
3501 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3504 return $term->filename_list($text); # filenames
3509 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3513 if (defined($ini_pids)) {
3514 $ENV{PERLDB_PIDS} = $ini_pids;
3516 delete($ENV{PERLDB_PIDS});
3521 # PERLDBf_... flag names from perl.h
3522 our (%DollarCaretP_flags, %DollarCaretP_flags_r);
3524 %DollarCaretP_flags =
3525 ( PERLDBf_SUB => 0x01, # Debug sub enter/exit
3526 PERLDBf_LINE => 0x02, # Keep line #
3527 PERLDBf_NOOPT => 0x04, # Switch off optimizations
3528 PERLDBf_INTER => 0x08, # Preserve more data
3529 PERLDBf_SUBLINE => 0x10, # Keep subr source lines
3530 PERLDBf_SINGLE => 0x20, # Start with single-step on
3531 PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr
3532 PERLDBf_GOTO => 0x80, # Report goto: call DB::goto
3533 PERLDBf_NAMEEVAL => 0x100, # Informative names for evals
3534 PERLDBf_NAMEANON => 0x200, # Informative names for anon subs
3535 PERLDBf_ASSERTION => 0x400, # Debug assertion subs enter/exit
3536 PERLDB_ALL => 0x33f, # No _NONAME, _GOTO, _ASSERTION
3539 %DollarCaretP_flags_r=reverse %DollarCaretP_flags;
3542 sub parse_DollarCaretP_flags {
3547 foreach my $f (split /\s*\|\s*/, $flags) {
3549 if ($f=~/^0x([[:xdigit:]]+)$/) {
3552 elsif ($f=~/^(\d+)$/) {
3555 elsif ($f=~/^DEFAULT$/i) {
3556 $value=$DollarCaretP_flags{PERLDB_ALL};
3559 $f=~/^(?:PERLDBf_)?(.*)$/i;
3560 $value=$DollarCaretP_flags{'PERLDBf_'.uc($1)};
3561 unless (defined $value) {
3562 print $OUT ("Unrecognized \$^P flag '$f'!\n",
3563 "Acceptable flags are: ".
3564 join(', ', sort keys %DollarCaretP_flags),
3565 ", and hexadecimal and decimal numbers.\n");
3574 sub expand_DollarCaretP_flags {
3575 my $DollarCaretP=shift;
3576 my @bits= ( map { my $n=(1<<$_);
3577 ($DollarCaretP & $n)
3578 ? ($DollarCaretP_flags_r{$n}
3579 || sprintf('0x%x', $n))
3581 return @bits ? join('|', @bits) : 0;
3585 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3586 $fall_off_end = 1 unless $inhibit_exit;
3587 # Do not stop in at_exit() and destructors on exit:
3588 $DB::single = !$fall_off_end && !$runnonstop;
3589 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3593 # ===================================== pre580 ================================
3594 # this is very sad below here...
3597 sub cmd_pre580_null {
3604 if ($cmd =~ /^(\d*)\s*(.*)/) {
3605 $i = $1 || $line; $j = $2;
3607 if ($dbline[$i] == 0) {
3608 print $OUT "Line $i may not have an action.\n";
3610 $had_breakpoints{$filename} |= 2;
3611 $dbline{$i} =~ s/\0[^\0]*//;
3612 $dbline{$i} .= "\0" . action($j);
3615 $dbline{$i} =~ s/\0[^\0]*//;
3616 delete $dbline{$i} if $dbline{$i} eq '';
3625 if ($cmd =~ /^load\b\s*(.*)/) {
3626 my $file = $1; $file =~ s/\s+$//;
3628 } elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
3629 my $cond = length $3 ? $3 : '1';
3630 my ($subname, $break) = ($2, $1 eq 'postpone');
3631 $subname =~ s/\'/::/g;
3632 $subname = "${'package'}::" . $subname
3633 unless $subname =~ /::/;
3634 $subname = "main".$subname if substr($subname,0,2) eq "::";
3635 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
3636 } elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
3638 my $cond = length $2 ? $2 : '1';
3639 &cmd_b_sub($subname, $cond);
3640 } elsif ($cmd =~ /^(\d*)\s*(.*)/) {
3641 my $i = $1 || $dbline;
3642 my $cond = length $2 ? $2 : '1';
3643 &cmd_b_line($i, $cond);
3650 if ($cmd =~ /^\s*$/) {
3651 print $OUT "Deleting all breakpoints...\n";
3653 for $file (keys %had_breakpoints) {
3654 local *dbline = $main::{'_<' . $file};
3658 for ($i = 1; $i <= $max ; $i++) {
3659 if (defined $dbline{$i}) {
3660 $dbline{$i} =~ s/^[^\0]+//;
3661 if ($dbline{$i} =~ s/^\0?$//) {
3667 if (not $had_breakpoints{$file} &= ~1) {
3668 delete $had_breakpoints{$file};
3672 undef %postponed_file;
3673 undef %break_on_load;
3680 if ($cmd =~ /^\s*$/) {
3681 print_help($pre580_help);
3682 } elsif ($cmd =~ /^h\s*/) {
3683 print_help($pre580_summary);
3684 } elsif ($cmd =~ /^h\s+(\S.*)$/) {
3685 my $asked = $1; # for proper errmsg
3686 my $qasked = quotemeta($asked); # for searching
3687 # XXX: finds CR but not <CR>
3688 if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) {
3689 while ($pre580_help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
3693 print_help("B<$asked> is not a debugger command.\n");
3703 @to_watch = @old_watch = ();
3704 } elsif ($cmd =~ /^(.*)/s) {
3708 $val = (defined $val) ? "'$val'" : 'undef' ;
3709 push @old_watch, $val;
3714 sub cmd_pre590_prepost {
3716 my $line = shift || '*'; # delete
3719 return &cmd_prepost($cmd, $line, $dbline);
3722 sub cmd_prepost { # cannot do &cmd_<(), <, <<, >>, {, {{, etc.
3724 my $line = shift || '?';
3728 if ($cmd =~ /^\</o) {
3729 $which = 'pre-perl';
3731 } elsif ($cmd =~ /^\>/o) {
3732 $which = 'post-perl';
3734 } elsif ($cmd =~ /^\{/o) {
3735 if ($cmd =~ /^\{.*\}$/o && unbalanced(substr($cmd,1))) {
3736 print $OUT "$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n";
3737 # $DB::cmd = "h $cmd";
3740 $which = 'pre-debugger';
3746 print $OUT "Confused by command: $cmd\n";
3748 if ($line =~ /^\s*\?\s*$/o) {
3750 print $OUT "No $which actions.\n";
3751 # print $OUT "If you meant to delete them all - use '$cmd *' or 'o commandSet=pre590'\n"; # hint
3753 print $OUT "$which commands:\n";
3754 foreach my $action (@$aref) {
3755 print $OUT "\t$cmd -- $action\n";
3759 if (length($cmd) == 1) {
3760 if ($line =~ /^\s*\*\s*$/o) {
3761 @$aref = (); # delete
3762 print $OUT "All $cmd actions cleared.\n";
3764 @$aref = action($line); # set
3766 } elsif (length($cmd) == 2) { # append
3767 push @$aref, action($line);
3769 print $OUT "Confused by strange length of $which command($cmd)...\n";
3778 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3781 package DB; # Do not trace this 1; below!