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 "/tmp/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()
328 ####################################################################
330 # Needed for the statement after exec():
332 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
334 # test if assertions are supported and actived:
337 eval "sub asserting_test : assertion {1}; 1";
338 # $ini_assertion = undef => assertions unsupported,
339 # " = 1 => assertions suported
340 # print "\$ini_assertion=$ini_assertion\n";
343 local($^W) = 0; # Switch run-time warnings off during init.
346 $dumpvar::arrayDepth,
347 $dumpvar::dumpDBFiles,
348 $dumpvar::dumpPackages,
349 $dumpvar::quoteHighBit,
350 $dumpvar::printUndef,
359 # Command-line + PERLLIB:
362 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
364 $trace = $signal = $single = 0; # Uninitialized warning suppression
365 # (local $^W cannot help - other packages!).
366 $inhibit_exit = $option{PrintRet} = 1;
368 @options = qw(hashDepth arrayDepth CommandSet dumpDepth
369 DumpDBFiles DumpPackages DumpReused
370 compactDump veryCompact quote HighBit undefPrint
371 globPrint PrintRet UsageOnly frame AutoTrace
372 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
373 recallCommand ShellBang pager tkRunning ornaments
374 signalLevel warnLevel dieLevel inhibit_exit
375 ImmediateStop bareStringify CreateTTY
376 RemotePort windowSize DollarCaretP OnlyAssertions
379 @RememberOnROptions = qw(DollarCaretP OnlyAssertions);
382 hashDepth => \$dumpvar::hashDepth,
383 arrayDepth => \$dumpvar::arrayDepth,
384 CommandSet => \$CommandSet,
385 DumpDBFiles => \$dumpvar::dumpDBFiles,
386 DumpPackages => \$dumpvar::dumpPackages,
387 DumpReused => \$dumpvar::dumpReused,
388 HighBit => \$dumpvar::quoteHighBit,
389 undefPrint => \$dumpvar::printUndef,
390 globPrint => \$dumpvar::globPrint,
391 UsageOnly => \$dumpvar::usageOnly,
392 CreateTTY => \$CreateTTY,
393 bareStringify => \$dumpvar::bareStringify,
395 AutoTrace => \$trace,
396 inhibit_exit => \$inhibit_exit,
397 maxTraceLen => \$maxtrace,
398 ImmediateStop => \$ImmediateStop,
399 RemotePort => \$remoteport,
400 windowSize => \$window,
401 WarnAssertions => \$warnassertions,
405 compactDump => \&dumpvar::compactDump,
406 veryCompact => \&dumpvar::veryCompact,
407 quote => \&dumpvar::quote,
410 ReadLine => \&ReadLine,
411 NonStop => \&NonStop,
412 LineInfo => \&LineInfo,
413 recallCommand => \&recallCommand,
414 ShellBang => \&shellBang,
416 signalLevel => \&signalLevel,
417 warnLevel => \&warnLevel,
418 dieLevel => \&dieLevel,
419 tkRunning => \&tkRunning,
420 ornaments => \&ornaments,
421 RemotePort => \&RemotePort,
422 DollarCaretP => \&DollarCaretP,
423 OnlyAssertions=> \&OnlyAssertions,
427 compactDump => 'dumpvar.pl',
428 veryCompact => 'dumpvar.pl',
429 quote => 'dumpvar.pl',
432 # These guys may be defined in $ENV{PERL5DB} :
433 $rl = 1 unless defined $rl;
434 $warnLevel = 1 unless defined $warnLevel;
435 $dieLevel = 1 unless defined $dieLevel;
436 $signalLevel = 1 unless defined $signalLevel;
437 $pre = [] unless defined $pre;
438 $post = [] unless defined $post;
439 $pretype = [] unless defined $pretype;
440 $CreateTTY = 3 unless defined $CreateTTY;
441 $CommandSet = '580' unless defined $CommandSet;
443 warnLevel($warnLevel);
445 signalLevel($signalLevel);
448 defined $ENV{PAGER} ? $ENV{PAGER} :
449 eval { require Config } &&
450 defined $Config::Config{pager} ? $Config::Config{pager}
452 ) unless defined $pager;
454 &recallCommand("!") unless defined $prc;
455 &shellBang("!") unless defined $psh;
457 $maxtrace = 400 unless defined $maxtrace;
458 $ini_pids = $ENV{PERLDB_PIDS};
459 if (defined $ENV{PERLDB_PIDS}) {
460 $pids = "[$ENV{PERLDB_PIDS}]";
461 $ENV{PERLDB_PIDS} .= "->$$";
464 $ENV{PERLDB_PIDS} = "$$";
469 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
471 if (-e "/dev/tty") { # this is the wrong metric!
474 $rcfile="perldb.ini";
477 # This isn't really safe, because there's a race
478 # between checking and opening. The solution is to
479 # open and fstat the handle, but then you have to read and
480 # eval the contents. But then the silly thing gets
481 # your lexical scope, which is unfortunately at best.
485 # Just exactly what part of the word "CORE::" don't you understand?
486 local $SIG{__WARN__};
489 unless (is_safe_file($file)) {
490 CORE::warn <<EO_GRIPE;
491 perldb: Must not source insecure rcfile $file.
492 You or the superuser must be the owner, and it must not
493 be writable by anyone but its owner.
499 CORE::warn("perldb: couldn't parse $file: $@") if $@;
503 # Verifies that owner is either real user or superuser and that no
504 # one but owner may write to it. This function is of limited use
505 # when called on a path instead of upon a handle, because there are
506 # no guarantees that filename (by dirent) whose file (by ino) is
507 # eventually accessed is the same as the one tested.
508 # Assumes that the file's existence is not in doubt.
511 stat($path) || return; # mysteriously vaporized
512 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
514 return 0 if $uid != 0 && $uid != $<;
515 return 0 if $mode & 022;
520 safe_do("./$rcfile");
522 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
523 safe_do("$ENV{HOME}/$rcfile");
525 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
526 safe_do("$ENV{LOGDIR}/$rcfile");
529 if (defined $ENV{PERLDB_OPTS}) {
530 parse_options($ENV{PERLDB_OPTS});
533 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
534 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
535 *get_fork_TTY = \&xterm_get_fork_TTY;
536 } elsif ($^O eq 'os2') {
537 *get_fork_TTY = \&os2_get_fork_TTY;
540 # Here begin the unreadable code. It needs fixing.
542 if (exists $ENV{PERLDB_RESTART}) {
543 delete $ENV{PERLDB_RESTART};
545 @hist = get_list('PERLDB_HIST');
546 %break_on_load = get_list("PERLDB_ON_LOAD");
547 %postponed = get_list("PERLDB_POSTPONE");
548 my @had_breakpoints= get_list("PERLDB_VISITED");
549 for (0 .. $#had_breakpoints) {
550 my %pf = get_list("PERLDB_FILE_$_");
551 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
553 my %opt = get_list("PERLDB_OPT");
555 while (($opt,$val) = each %opt) {
556 $val =~ s/[\\\']/\\$1/g;
557 parse_options("$opt'$val'");
559 @INC = get_list("PERLDB_INC");
561 $pretype = [get_list("PERLDB_PRETYPE")];
562 $pre = [get_list("PERLDB_PRE")];
563 $post = [get_list("PERLDB_POST")];
564 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
570 # Is Perl being run from a slave editor or graphical debugger?
571 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
572 $rl = 0, shift(@main::ARGV) if $slave_editor;
574 #require Term::ReadLine;
576 if ($^O eq 'cygwin') {
577 # /dev/tty is binary. use stdin for textmode
579 } elsif (-e "/dev/tty") {
580 $console = "/dev/tty";
581 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
583 } elsif ($^O eq 'MacOS') {
584 if ($MacPerl::Version !~ /MPW/) {
585 $console = "Dev:Console:Perl Debug"; # Separate window for application
587 $console = "Dev:Console";
590 $console = "sys\$command";
593 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
597 if ($^O eq 'NetWare') {
602 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
610 $console = $tty if defined $tty;
612 if (defined $remoteport) {
614 $OUT = new IO::Socket::INET( Timeout => '10',
615 PeerAddr => $remoteport,
618 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
621 create_IN_OUT(4) if $CreateTTY & 4;
623 my ($i, $o) = split /,/, $console;
624 $o = $i unless defined $o;
625 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
626 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
627 || open(OUT,">&STDOUT"); # so we don't dongle stdout
628 } elsif (not defined $console) {
630 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
631 $console = 'STDIN/OUT';
633 # so open("|more") can read from STDOUT and so we don't dingle stdin
634 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
636 my $previous = select($OUT);
637 $| = 1; # for DB::OUT
640 $LINEINFO = $OUT unless defined $LINEINFO;
641 $lineinfo = $console unless defined $lineinfo;
643 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
644 unless ($runnonstop) {
647 if ($term_pid eq '-1') {
648 print $OUT "\nDaughter DB session started...\n";
650 print $OUT "\nLoading DB routines from $header\n";
651 print $OUT ("Editor support ",
652 $slave_editor ? "enabled" : "available",
654 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
662 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
665 if (defined &afterinit) { # May be defined in $rcfile
671 ############################################################ Subroutines
674 # _After_ the perl program is compiled, $single is set to 1:
675 if ($single and not $second_time++) {
676 if ($runnonstop) { # Disable until signal
677 for ($i=0; $i <= $stack_depth; ) {
681 # return; # Would not print trace!
682 } elsif ($ImmediateStop) {
687 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
689 local($package, $filename, $line) = caller;
690 local $filename_ini = $filename;
691 local $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
692 "package $package;"; # this won't let them modify, alas
693 local(*dbline) = $main::{'_<' . $filename};
695 # we need to check for pseudofiles on Mac OS (these are files
696 # not attached to a filename, but instead stored in Dev:Pseudo)
697 if ($^O eq 'MacOS' && $#dbline < 0) {
698 $filename_ini = $filename = 'Dev:Pseudo';
699 *dbline = $main::{'_<' . $filename};
702 local $max = $#dbline;
703 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
707 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
708 $dbline{$line} =~ s/;9($|\0)/$1/;
711 my $was_signal = $signal;
713 for (my $n = 0; $n <= $#to_watch; $n++) {
714 $evalarg = $to_watch[$n];
715 local $onetimeDump; # Do not output results
716 my ($val) = join("', '", &eval); # Fix context (&eval is doing array)? - rjsf
717 $val = ( (defined $val) ? "'$val'" : 'undef' );
718 if ($val ne $old_watch[$n]) {
721 Watchpoint $n:\t$to_watch[$n] changed:
722 old value:\t$old_watch[$n]
725 $old_watch[$n] = $val;
729 if ($trace & 4) { # User-installed watch
730 return if watchfunction($package, $filename, $line)
731 and not $single and not $was_signal and not ($trace & ~4);
733 $was_signal = $signal;
735 if ($single || ($trace & 1) || $was_signal) {
737 $position = "\032\032$filename:$line:0\n";
738 print_lineinfo($position);
739 } elsif ($package eq 'DB::fake') {
742 Debugged program terminated. Use B<q> to quit or B<R> to restart,
743 use B<O> I<inhibit_exit> to avoid stopping after program termination,
744 B<h q>, B<h R> or B<h O> to get additional info.
747 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
748 "package $package;"; # this won't let them modify, alas
751 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
752 $prefix .= "$sub($filename:";
753 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
754 if (length($prefix) > 30) {
755 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
760 $position = "$prefix$line$infix$dbline[$line]$after";
763 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
765 print_lineinfo($position);
767 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
768 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
770 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
771 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
772 $position .= $incr_pos;
774 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
776 print_lineinfo($incr_pos);
781 $evalarg = $action, &eval if $action;
782 if ($single || $was_signal) {
783 local $level = $level + 1;
784 foreach $evalarg (@$pre) {
787 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
790 $incr = -1; # for backward motion.
791 @typeahead = (@$pretype, @typeahead);
793 while (($term || &setterm),
794 ($term_pid == $$ or resetterm(1)),
795 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
796 ($#hist+1) . ('>' x $level) . " ")))
800 $cmd =~ s/\\$/\n/ && do {
801 $cmd .= &readline(" cont: ");
804 $cmd =~ /^$/ && ($cmd = $laststep);
805 push(@hist,$cmd) if length($cmd) > 1;
807 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
808 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
809 ($i) = split(/\s+/,$cmd);
811 # squelch the sigmangler
813 local $SIG{__WARN__};
814 eval "\$cmd =~ $alias{$i}";
817 print $OUT "Couldn't evaluate `$i' alias: $@";
821 $cmd =~ /^q$/ && do {
826 $cmd =~ /^t$/ && do {
829 print $OUT "Trace = " .
830 (($trace & 1) ? "on" : "off" ) . "\n";
832 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
833 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
836 foreach $subname (sort(keys %sub)) {
837 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
838 print $OUT $subname,"\n";
842 $cmd =~ s/^X\b/V $package/;
843 $cmd =~ /^V$/ && do {
844 $cmd = "V $package"; };
845 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
846 local ($savout) = select($OUT);
848 @vars = split(' ',$2);
849 do 'dumpvar.pl' unless defined &main::dumpvar;
850 if (defined &main::dumpvar) {
853 # must detect sigpipe failures
854 eval { &main::dumpvar($packname,
855 defined $option{dumpDepth}
856 ? $option{dumpDepth} : -1,
859 die unless $@ =~ /dumpvar print failed/;
862 print $OUT "dumpvar.pl not available.\n";
866 $cmd =~ s/^x\b/ / && do { # So that will be evaled
867 $onetimeDump = 'dump';
868 # handle special "x 3 blah" syntax
869 if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
870 $onetimedumpDepth = $1;
873 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
874 methods($1); next CMD};
875 $cmd =~ s/^m\b/ / && do { # So this will be evaled
876 $onetimeDump = 'methods'; };
877 $cmd =~ /^f\b\s*(.*)/ && do {
881 print $OUT "The old f command is now the r command.\n"; # hint
882 print $OUT "The new f command switches filenames.\n";
885 if (!defined $main::{'_<' . $file}) {
886 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
887 $try = substr($try,2);
888 print $OUT "Choosing $try matching `$file':\n";
892 if (!defined $main::{'_<' . $file}) {
893 print $OUT "No file matching `$file' is loaded.\n";
895 } elsif ($file ne $filename) {
896 *dbline = $main::{'_<' . $file};
902 print $OUT "Already in $file.\n";
906 $cmd =~ /^\.$/ && do {
907 $incr = -1; # for backward motion.
909 $filename = $filename_ini;
910 *dbline = $main::{'_<' . $filename};
912 print_lineinfo($position);
914 $cmd =~ /^-$/ && do {
915 $start -= $incr + $window + 1;
916 $start = 1 if $start <= 0;
918 $cmd = 'l ' . ($start) . '+'; };
920 $cmd =~ /^([aAbBhlLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
921 &cmd_wrapper($1, $2, $line);
924 # rjsf <- pre|post commands stripped out
925 $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
926 eval { require PadWalker; PadWalker->VERSION(0.08) }
927 or &warn($@ =~ /locate/
928 ? "PadWalker module not found - please install\n"
931 do 'dumpvar.pl' unless defined &main::dumpvar;
932 defined &main::dumpvar
933 or print $OUT "dumpvar.pl not available.\n"
935 my @vars = split(' ', $2 || '');
936 my $h = eval { PadWalker::peek_my(($1 || 0) + 1) };
937 $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
938 my $savout = select($OUT);
939 dumpvar::dumplex($_, $h->{$_},
940 defined $option{dumpDepth}
941 ? $option{dumpDepth} : -1,
946 $cmd =~ /^n$/ && do {
947 end_report(), next CMD if $finished and $level <= 1;
951 $cmd =~ /^s$/ && do {
952 end_report(), next CMD if $finished and $level <= 1;
956 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
957 end_report(), next CMD if $finished and $level <= 1;
959 # Probably not needed, since we finish an interactive
960 # sub-session anyway...
961 # local $filename = $filename;
962 # local *dbline = *dbline; # XXX Would this work?!
963 if ($subname =~ /\D/) { # subroutine name
964 $subname = $package."::".$subname
965 unless $subname =~ /::/;
966 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
970 *dbline = $main::{'_<' . $filename};
971 $had_breakpoints{$filename} |= 1;
973 ++$i while $dbline[$i] == 0 && $i < $max;
975 print $OUT "Subroutine $subname not found.\n";
980 if ($dbline[$i] == 0) {
981 print $OUT "Line $i not breakable.\n";
984 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
986 for ($i=0; $i <= $stack_depth; ) {
990 $cmd =~ /^r$/ && do {
991 end_report(), next CMD if $finished and $level <= 1;
992 $stack[$stack_depth] |= 1;
993 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
995 $cmd =~ /^R$/ && do {
996 print $OUT "Warning: some settings and command-line options may be lost!\n";
997 my (@script, @flags, $cl);
998 push @flags, '-w' if $ini_warn;
999 if ($ini_assertion and @{^ASSERTING}) {
1000 push @flags, (map { /\:\^\(\?\:(.*)\)\$\)/ ?
1001 "-A$1" : "-A$_" } @{^ASSERTING});
1003 # Put all the old includes at the start to get
1004 # the same debugger.
1006 push @flags, '-I', $_;
1008 push @flags, '-T' if ${^TAINT};
1009 # Arrange for setting the old INC:
1010 set_list("PERLDB_INC", @ini_INC);
1012 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1013 chomp ($cl = ${'::_<-e'}[$_]);
1014 push @script, '-e', $cl;
1019 set_list("PERLDB_HIST",
1020 $term->Features->{getHistory}
1021 ? $term->GetHistory : @hist);
1022 my @had_breakpoints = keys %had_breakpoints;
1023 set_list("PERLDB_VISITED", @had_breakpoints);
1024 set_list("PERLDB_OPT", options2remember());
1025 set_list("PERLDB_ON_LOAD", %break_on_load);
1027 for (0 .. $#had_breakpoints) {
1028 my $file = $had_breakpoints[$_];
1029 *dbline = $main::{'_<' . $file};
1030 next unless %dbline or $postponed_file{$file};
1031 (push @hard, $file), next
1032 if $file =~ /^\(\w*eval/;
1034 @add = %{$postponed_file{$file}}
1035 if $postponed_file{$file};
1036 set_list("PERLDB_FILE_$_", %dbline, @add);
1038 for (@hard) { # Yes, really-really...
1039 # Find the subroutines in this eval
1040 *dbline = $main::{'_<' . $_};
1041 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1042 for $sub (keys %sub) {
1043 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1044 $subs{$sub} = [$1, $2];
1048 "No subroutines in $_, ignoring breakpoints.\n";
1051 LINES: for $line (keys %dbline) {
1052 # One breakpoint per sub only:
1053 my ($offset, $sub, $found);
1054 SUBS: for $sub (keys %subs) {
1055 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1056 and (not defined $offset # Not caught
1057 or $offset < 0 )) { # or badly caught
1059 $offset = $line - $subs{$sub}->[0];
1060 $offset = "+$offset", last SUBS if $offset >= 0;
1063 if (defined $offset) {
1064 $postponed{$found} =
1065 "break $offset if $dbline{$line}";
1067 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1071 set_list("PERLDB_POSTPONE", %postponed);
1072 set_list("PERLDB_PRETYPE", @$pretype);
1073 set_list("PERLDB_PRE", @$pre);
1074 set_list("PERLDB_POST", @$post);
1075 set_list("PERLDB_TYPEAHEAD", @typeahead);
1076 $ENV{PERLDB_RESTART} = 1;
1077 delete $ENV{PERLDB_PIDS}; # Restore ini state
1078 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1079 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1080 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1081 print $OUT "exec failed: $!\n";
1083 $cmd =~ /^T$/ && do {
1084 print_trace($OUT, 1); # skip DB
1086 $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; };
1087 $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W('W', $1); next CMD; };
1088 $cmd =~ /^\/(.*)$/ && do {
1090 $inpat =~ s:([^\\])/$:$1:;
1092 # squelch the sigmangler
1093 local $SIG{__DIE__};
1094 local $SIG{__WARN__};
1095 eval '$inpat =~ m'."\a$inpat\a";
1107 $start = 1 if ($start > $max);
1108 last if ($start == $end);
1109 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1110 if ($slave_editor) {
1111 print $OUT "\032\032$filename:$start:0\n";
1113 print $OUT "$start:\t", $dbline[$start], "\n";
1118 print $OUT "/$pat/: not found\n" if ($start == $end);
1120 $cmd =~ /^\?(.*)$/ && do {
1122 $inpat =~ s:([^\\])\?$:$1:;
1124 # squelch the sigmangler
1125 local $SIG{__DIE__};
1126 local $SIG{__WARN__};
1127 eval '$inpat =~ m'."\a$inpat\a";
1139 $start = $max if ($start <= 0);
1140 last if ($start == $end);
1141 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1142 if ($slave_editor) {
1143 print $OUT "\032\032$filename:$start:0\n";
1145 print $OUT "$start:\t", $dbline[$start], "\n";
1150 print $OUT "?$pat?: not found\n" if ($start == $end);
1152 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1153 pop(@hist) if length($cmd) > 1;
1154 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1156 print $OUT $cmd, "\n";
1158 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1161 $cmd =~ /^$rc([^$rc].*)$/ && do {
1163 pop(@hist) if length($cmd) > 1;
1164 for ($i = $#hist; $i; --$i) {
1165 last if $hist[$i] =~ /$pat/;
1168 print $OUT "No such command!\n\n";
1172 print $OUT $cmd, "\n";
1174 $cmd =~ /^$sh$/ && do {
1175 &system($ENV{SHELL}||"/bin/sh");
1177 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1178 # XXX: using csh or tcsh destroys sigint retvals!
1179 #&system($1); # use this instead
1180 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1182 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1183 $end = $2 ? ($#hist-$2) : 0;
1184 $hist = 0 if $hist < 0;
1185 for ($i=$#hist; $i>$end; $i--) {
1186 print $OUT "$i: ",$hist[$i],"\n"
1187 unless $hist[$i] =~ /^.?$/;
1190 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1193 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1194 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1195 $cmd =~ s/^=\s*// && do {
1197 if (length $cmd == 0) {
1198 @keys = sort keys %alias;
1199 } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1200 # can't use $_ or kill //g state
1201 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1202 $alias{$k} = "s\a$k\a$v\a";
1203 # squelch the sigmangler
1204 local $SIG{__DIE__};
1205 local $SIG{__WARN__};
1206 unless (eval "sub { s\a$k\a$v\a }; 1") {
1207 print $OUT "Can't alias $k to $v: $@\n";
1216 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1217 print $OUT "$k\t= $1\n";
1219 elsif (defined $alias{$k}) {
1220 print $OUT "$k\t$alias{$k}\n";
1223 print "No alias for $k\n";
1227 $cmd =~ /^source\s+(.*\S)/ && do {
1228 if (open my $fh, $1) {
1231 &warn("Can't execute `$1': $!\n");
1234 $cmd =~ /^\|\|?\s*[^|]/ && do {
1235 if ($pager =~ /^\|/) {
1236 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1237 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1239 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1242 unless ($piped=open(OUT,$pager)) {
1243 &warn("Can't pipe output to `$pager'");
1244 if ($pager =~ /^\|/) {
1245 open(OUT,">&STDOUT") # XXX: lost message
1246 || &warn("Can't restore DB::OUT");
1247 open(STDOUT,">&SAVEOUT")
1248 || &warn("Can't restore STDOUT");
1251 open(OUT,">&STDOUT") # XXX: lost message
1252 || &warn("Can't restore DB::OUT");
1256 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1257 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1258 $selected= select(OUT);
1260 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1261 $cmd =~ s/^\|+\s*//;
1264 # XXX Local variants do not work!
1265 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1266 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1267 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1269 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1271 $onetimeDump = undef;
1272 $onetimedumpDepth = undef;
1273 } elsif ($term_pid == $$) {
1280 if ($pager =~ /^\|/) {
1282 # we cannot warn here: the handle is missing --tchrist
1283 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1285 # most of the $? crud was coping with broken cshisms
1287 print SAVEOUT "Pager `$pager' failed: ";
1289 print SAVEOUT "shell returned -1\n";
1292 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1293 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1295 print SAVEOUT "status ", ($? >> 8), "\n";
1299 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1300 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1301 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1302 # Will stop ignoring SIGPIPE if done like nohup(1)
1303 # does SIGINT but Perl doesn't give us a choice.
1305 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1308 select($selected), $selected= "" unless $selected eq "";
1312 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1313 foreach $evalarg (@$post) {
1316 } # if ($single || $signal)
1317 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1321 # The following code may be executed now:
1325 my ($al, $ret, @ret) = "";
1326 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1329 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1330 $#stack = $stack_depth;
1331 $stack[-1] = $single;
1333 $single |= 4 if $stack_depth == $deep;
1335 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1336 # Why -1? But it works! :-(
1337 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1338 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1347 $signal=1 unless $warnassertions;
1353 $single |= $stack[$stack_depth--];
1355 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1356 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1357 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1358 if ($doret eq $stack_depth or $frame & 16) {
1360 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1361 print $fh ' ' x $stack_depth if $frame & 16;
1362 print $fh "list context return from $sub:\n";
1363 dumpit($fh, \@ret );
1375 $signal=1 unless $warnassertions;
1377 $ret=undef unless defined wantarray;
1380 if (defined wantarray) {
1386 $single |= $stack[$stack_depth--];
1388 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1389 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1390 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1391 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1393 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1394 print $fh (' ' x $stack_depth) if $frame & 16;
1395 print $fh (defined wantarray
1396 ? "scalar context return from $sub: "
1397 : "void context return from $sub\n");
1398 dumpit( $fh, $ret ) if defined wantarray;
1407 ### Functions with multiple modes of failure die on error, the rest
1408 ### returns FALSE on error.
1409 ### User-interface functions cmd_* output error message.
1411 ### Note all cmd_[a-zA-Z]'s require $cmd, $line, $dblineno as first arguments
1416 'A' => 'pre580_null',
1418 'B' => 'pre580_null',
1419 'd' => 'pre580_null',
1422 'M' => 'pre580_null',
1424 'o' => 'pre580_null',
1430 '<' => 'pre590_prepost',
1431 '<<' => 'pre590_prepost',
1432 '>' => 'pre590_prepost',
1433 '>>' => 'pre590_prepost',
1434 '{' => 'pre590_prepost',
1435 '{{' => 'pre590_prepost',
1442 my $dblineno = shift;
1444 # with this level of indirection we can wrap
1445 # to old (pre580) or other command sets easily
1448 $set{$CommandSet}{$cmd} || ($cmd =~ /^[<>{]+/o ? 'prepost' : $cmd)
1450 # print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
1452 return &$call($cmd, $line, $dblineno);
1456 my $cmd = shift; # a
1457 my $line = shift || ''; # [.|line] expr
1458 my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
1459 if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
1460 my ($lineno, $expr) = ($1, $2);
1462 if ($dbline[$lineno] == 0) {
1463 print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
1465 $had_breakpoints{$filename} |= 2;
1466 $dbline{$lineno} =~ s/\0[^\0]*//;
1467 $dbline{$lineno} .= "\0" . action($expr);
1471 print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
1476 my $cmd = shift; # A
1477 my $line = shift || '';
1478 my $dbline = shift; $line =~ s/^\./$dbline/;
1480 eval { &delete_action(); 1 } or print $OUT $@ and return;
1481 } elsif ($line =~ /^(\S.*)/) {
1482 eval { &delete_action($1); 1 } or print $OUT $@ and return;
1484 print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
1491 die "Line $i has no action .\n" if $dbline[$i] == 0;
1492 $dbline{$i} =~ s/\0[^\0]*//; # \^a
1493 delete $dbline{$i} if $dbline{$i} eq '';
1495 print $OUT "Deleting all actions...\n";
1496 for my $file (keys %had_breakpoints) {
1497 local *dbline = $main::{'_<' . $file};
1500 for ($i = 1; $i <= $max ; $i++) {
1501 if (defined $dbline{$i}) {
1502 $dbline{$i} =~ s/\0[^\0]*//;
1503 delete $dbline{$i} if $dbline{$i} eq '';
1505 unless ($had_breakpoints{$file} &= ~2) {
1506 delete $had_breakpoints{$file};
1514 my $cmd = shift; # b
1515 my $line = shift; # [.|line] [cond]
1516 my $dbline = shift; $line =~ s/^\./$dbline/;
1517 if ($line =~ /^\s*$/) {
1518 &cmd_b_line($dbline, 1);
1519 } elsif ($line =~ /^load\b\s*(.*)/) {
1520 my $file = $1; $file =~ s/\s+$//;
1522 } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
1523 my $cond = length $3 ? $3 : '1';
1524 my ($subname, $break) = ($2, $1 eq 'postpone');
1525 $subname =~ s/\'/::/g;
1526 $subname = "${'package'}::" . $subname unless $subname =~ /::/;
1527 $subname = "main".$subname if substr($subname,0,2) eq "::";
1528 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
1529 } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
1531 $cond = length $2 ? $2 : '1';
1532 &cmd_b_sub($subname, $cond);
1533 } elsif ($line =~ /^(\d*)\s*(.*)/) {
1534 $line = $1 || $dbline;
1535 $cond = length $2 ? $2 : '1';
1536 &cmd_b_line($line, $cond);
1538 print "confused by line($line)?\n";
1544 $break_on_load{$file} = 1;
1545 $had_breakpoints{$file} |= 1;
1548 sub report_break_on_load {
1549 sort keys %break_on_load;
1557 push @files, $::INC{$file} if $::INC{$file};
1558 $file .= '.pm', redo unless $file =~ /\./;
1560 break_on_load($_) for @files;
1561 @files = report_break_on_load;
1564 print $OUT "Will stop on load of `@files'.\n";
1567 $filename_error = '';
1569 sub breakable_line {
1570 my ($from, $to) = @_;
1573 my $delta = $from < $to ? +1 : -1;
1574 my $limit = $delta > 0 ? $#dbline : 1;
1575 $limit = $to if ($limit - $to) * $delta > 0;
1576 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1578 return $i unless $dbline[$i] == 0;
1579 my ($pl, $upto) = ('', '');
1580 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1581 die "Line$pl $from$upto$filename_error not breakable\n";
1584 sub breakable_line_in_filename {
1586 local *dbline = $main::{'_<' . $f};
1587 local $filename_error = " of `$f'";
1592 my ($i, $cond) = @_;
1593 $cond = 1 unless @_ >= 2;
1597 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1598 $had_breakpoints{$filename} |= 1;
1599 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1600 else { $dbline{$i} = $cond; }
1604 eval { break_on_line(@_); 1 } or do {
1606 print $OUT $@ and return;
1610 sub break_on_filename_line {
1611 my ($f, $i, $cond) = @_;
1612 $cond = 1 unless @_ >= 3;
1613 local *dbline = $main::{'_<' . $f};
1614 local $filename_error = " of `$f'";
1615 local $filename = $f;
1616 break_on_line($i, $cond);
1619 sub break_on_filename_line_range {
1620 my ($f, $from, $to, $cond) = @_;
1621 my $i = breakable_line_in_filename($f, $from, $to);
1622 $cond = 1 unless @_ >= 3;
1623 break_on_filename_line($f,$i,$cond);
1626 sub subroutine_filename_lines {
1627 my ($subname,$cond) = @_;
1628 # Filename below can contain ':'
1629 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1632 sub break_subroutine {
1633 my $subname = shift;
1634 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1635 die "Subroutine $subname not found.\n";
1636 $cond = 1 unless @_ >= 2;
1637 break_on_filename_line_range($file,$s,$e,@_);
1641 my ($subname,$cond) = @_;
1642 $cond = 1 unless @_ >= 2;
1643 unless (ref $subname eq 'CODE') {
1644 $subname =~ s/\'/::/g;
1646 $subname = "${'package'}::" . $subname
1647 unless $subname =~ /::/;
1648 $subname = "CORE::GLOBAL::$s"
1649 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1650 $subname = "main".$subname if substr($subname,0,2) eq "::";
1652 eval { break_subroutine($subname,$cond); 1 } or do {
1654 print $OUT $@ and return;
1659 my $cmd = shift; # B
1660 my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
1661 my $dbline = shift; $line =~ s/^\./$dbline/;
1663 eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
1664 } elsif ($line =~ /^(\S.*)/) {
1665 eval { &delete_breakpoint($line || $dbline); 1 } or do {
1667 print $OUT $@ and return;
1670 print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
1674 sub delete_breakpoint {
1677 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1678 $dbline{$i} =~ s/^[^\0]*//;
1679 delete $dbline{$i} if $dbline{$i} eq '';
1681 print $OUT "Deleting all breakpoints...\n";
1682 for my $file (keys %had_breakpoints) {
1683 local *dbline = $main::{'_<' . $file};
1686 for ($i = 1; $i <= $max ; $i++) {
1687 if (defined $dbline{$i}) {
1688 $dbline{$i} =~ s/^[^\0]+//;
1689 if ($dbline{$i} =~ s/^\0?$//) {
1694 if (not $had_breakpoints{$file} &= ~1) {
1695 delete $had_breakpoints{$file};
1699 undef %postponed_file;
1700 undef %break_on_load;
1704 sub cmd_stop { # As on ^C, but not signal-safy.
1709 my $cmd = shift; # h
1710 my $line = shift || '';
1711 if ($line =~ /^h\s*/) {
1713 } elsif ($line =~ /^(\S.*)$/) {
1714 # support long commands; otherwise bogus errors
1715 # happen when you ask for h on <CR> for example
1716 my $asked = $1; # for proper errmsg
1717 my $qasked = quotemeta($asked); # for searching
1718 # XXX: finds CR but not <CR>
1719 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
1720 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
1724 print_help("B<$asked> is not a debugger command.\n");
1727 print_help($summary);
1732 my $current_line = $line;
1733 my $cmd = shift; # l
1735 $line =~ s/^-\s*$/-/;
1736 if ($line =~ /^(\$.*)/s) {
1739 print($OUT "Error: $@\n"), next CMD if $@;
1741 print($OUT "Interpreted as: $1 $s\n");
1744 } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
1745 my $s = $subname = $1;
1746 $subname =~ s/\'/::/;
1747 $subname = $package."::".$subname
1748 unless $subname =~ /::/;
1749 $subname = "CORE::GLOBAL::$s"
1750 if not defined &$subname and $s !~ /::/
1751 and defined &{"CORE::GLOBAL::$s"};
1752 $subname = "main".$subname if substr($subname,0,2) eq "::";
1753 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
1754 $subrange = pop @pieces;
1755 $file = join(':', @pieces);
1756 if ($file ne $filename) {
1757 print $OUT "Switching to file '$file'.\n"
1758 unless $slave_editor;
1759 *dbline = $main::{'_<' . $file};
1764 if (eval($subrange) < -$window) {
1765 $subrange =~ s/-.*/+/;
1768 &cmd_l('l', $subrange);
1770 print $OUT "Subroutine $subname not found.\n";
1772 } elsif ($line =~ /^\s*$/) {
1773 $incr = $window - 1;
1774 $line = $start . '-' . ($start + $incr);
1776 } elsif ($line =~ /^(\d*)\+(\d*)$/) {
1779 $incr = $window - 1 unless $incr;
1780 $line = $start . '-' . ($start + $incr);
1782 } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
1783 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
1784 $end = $max if $end > $max;
1786 $i = $line if $i eq '.';
1789 if ($slave_editor) {
1790 print $OUT "\032\032$filename:$i:0\n";
1793 for (; $i <= $end; $i++) {
1795 ($stop,$action) = split(/\0/, $dbline{$i}) if
1797 $arrow = ($i==$current_line
1798 and $filename eq $filename_ini)
1800 : ($dbline[$i]+0 ? ':' : ' ') ;
1801 $arrow .= 'b' if $stop;
1802 $arrow .= 'a' if $action;
1803 print $OUT "$i$arrow\t", $dbline[$i];
1804 $i++, last if $signal;
1806 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
1808 $start = $i; # remember in case they want more
1809 $start = $max if $start > $max;
1814 my $cmd = shift; # L
1815 my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
1816 my $action_wanted = ($arg =~ /a/) ? 1 : 0;
1817 my $break_wanted = ($arg =~ /b/) ? 1 : 0;
1818 my $watch_wanted = ($arg =~ /w/) ? 1 : 0;
1820 if ($break_wanted or $action_wanted) {
1821 for my $file (keys %had_breakpoints) {
1822 local *dbline = $main::{'_<' . $file};
1825 for ($i = 1; $i <= $max; $i++) {
1826 if (defined $dbline{$i}) {
1827 print $OUT "$file:\n" unless $was++;
1828 print $OUT " $i:\t", $dbline[$i];
1829 ($stop,$action) = split(/\0/, $dbline{$i});
1830 print $OUT " break if (", $stop, ")\n"
1831 if $stop and $break_wanted;
1832 print $OUT " action: ", $action, "\n"
1833 if $action and $action_wanted;
1839 if (%postponed and $break_wanted) {
1840 print $OUT "Postponed breakpoints in subroutines:\n";
1842 for $subname (keys %postponed) {
1843 print $OUT " $subname\t$postponed{$subname}\n";
1847 my @have = map { # Combined keys
1848 keys %{$postponed_file{$_}}
1849 } keys %postponed_file;
1850 if (@have and ($break_wanted or $action_wanted)) {
1851 print $OUT "Postponed breakpoints in files:\n";
1853 for $file (keys %postponed_file) {
1854 my $db = $postponed_file{$file};
1855 print $OUT " $file:\n";
1856 for $line (sort {$a <=> $b} keys %$db) {
1857 print $OUT " $line:\n";
1858 my ($stop,$action) = split(/\0/, $$db{$line});
1859 print $OUT " break if (", $stop, ")\n"
1860 if $stop and $break_wanted;
1861 print $OUT " action: ", $action, "\n"
1862 if $action and $action_wanted;
1868 if (%break_on_load and $break_wanted) {
1869 print $OUT "Breakpoints on load:\n";
1871 for $file (keys %break_on_load) {
1872 print $OUT " $file\n";
1876 if ($watch_wanted) {
1878 print $OUT "Watch-expressions:\n" if @to_watch;
1879 for my $expr (@to_watch) {
1880 print $OUT " $expr\n";
1892 my $cmd = shift; # o
1893 my $opt = shift || ''; # opt[=val]
1894 if ($opt =~ /^(\S.*)/) {
1904 print $OUT "The old O command is now the o command.\n"; # hint
1905 print $OUT "Use 'h' to get current command help synopsis or\n"; #
1906 print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; #
1910 my $cmd = shift; # v
1913 if ($line =~ /^(\d*)$/) {
1914 $incr = $window - 1;
1917 $line = $start . '-' . ($start + $incr);
1923 my $cmd = shift; # w
1924 my $expr = shift || '';
1925 if ($expr =~ /^(\S.*)/) {
1926 push @to_watch, $expr;
1928 my ($val) = join(' ', &eval);
1929 $val = (defined $val) ? "'$val'" : 'undef' ;
1930 push @old_watch, $val;
1933 print $OUT "Adding a watch-expression requires an expression\n"; # hint
1938 my $cmd = shift; # W
1939 my $expr = shift || '';
1942 print $OUT "Deleting all watch expressions ...\n";
1943 @to_watch = @old_watch = ();
1944 } elsif ($expr =~ /^(\S.*)/) {
1946 foreach (@to_watch) {
1947 my $val = $to_watch[$i_cnt];
1948 if ($val eq $expr) { # =~ m/^\Q$i$/) {
1949 splice(@to_watch, $i_cnt, 1);
1954 print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
1961 if ($cmd =~ /^.\b\s*([+-]?)\s*(~?)\s*(\w+(\s*\|\s*\w+)*)\s*$/) {
1962 my ($how, $neg, $flags)=($1, $2, $3);
1963 my $acu=parse_DollarCaretP_flags($flags);
1965 $acu= ~$acu if $neg;
1966 if ($how eq '+') { $^P|=$acu }
1967 elsif ($how eq '-') { $^P&=~$acu }
1970 # else { print $OUT "undefined acu\n" }
1972 my $expanded=expand_DollarCaretP_flags($^P);
1973 print $OUT "Internal Perl debugger flags:\n\$^P=$expanded\n";
1977 ### END of the API section
1980 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1981 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1984 sub print_lineinfo {
1985 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1991 # The following takes its argument via $evalarg to preserve current @_
1994 my $subname = shift;
1995 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1996 my $offset = $1 || 0;
1997 # Filename below can contain ':'
1998 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
2001 local *dbline = $main::{'_<' . $file};
2002 local $^W = 0; # != 0 is magical below
2003 $had_breakpoints{$file} |= 1;
2005 ++$i until $dbline[$i] != 0 or $i >= $max;
2006 $dbline{$i} = delete $postponed{$subname};
2009 print $OUT "Subroutine $subname not found.\n";
2013 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
2014 #print $OUT "In postponed_sub for `$subname'.\n";
2018 if ($ImmediateStop) {
2022 return &postponed_sub
2023 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
2024 # Cannot be done before the file is compiled
2025 local *dbline = shift;
2026 my $filename = $dbline;
2027 $filename =~ s/^_<//;
2029 $signal = 1, print $OUT "'$filename' loaded...\n"
2030 if $break_on_load{$filename};
2031 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
2032 return unless $postponed_file{$filename};
2033 $had_breakpoints{$filename} |= 1;
2034 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
2036 for $key (keys %{$postponed_file{$filename}}) {
2037 $dbline{$key} = ${$postponed_file{$filename}}{$key};
2039 delete $postponed_file{$filename};
2043 local ($savout) = select(shift);
2044 my $osingle = $single;
2045 my $otrace = $trace;
2046 $single = $trace = 0;
2049 unless (defined &main::dumpValue) {
2052 if (defined &main::dumpValue) {
2057 my $maxdepth = shift || $option{dumpDepth};
2058 $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
2059 &main::dumpValue($v, $maxdepth);
2062 print $OUT "dumpvar.pl not available.\n";
2069 # Tied method do not create a context, so may get wrong message:
2074 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
2075 my @sub = dump_trace($_[0] + 1, $_[1]);
2076 my $short = $_[2]; # Print short report, next one for sub name
2078 for ($i=0; $i <= $#sub; $i++) {
2081 my $args = defined $sub[$i]{args}
2082 ? "(@{ $sub[$i]{args} })"
2084 $args = (substr $args, 0, $maxtrace - 3) . '...'
2085 if length $args > $maxtrace;
2086 my $file = $sub[$i]{file};
2087 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
2089 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
2091 my $sub = @_ >= 4 ? $_[3] : $s;
2092 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
2094 print $fh "$sub[$i]{context} = $s$args" .
2095 " called from $file" .
2096 " line $sub[$i]{line}\n";
2103 my $count = shift || 1e9;
2106 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
2107 my $nothard = not $frame & 8;
2108 local $frame = 0; # Do not want to trace this.
2109 my $otrace = $trace;
2112 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
2117 if (not defined $arg) {
2119 } elsif ($nothard and tied $arg) {
2121 } elsif ($nothard and $type = ref $arg) {
2122 push @a, "ref($type)";
2124 local $_ = "$arg"; # Safe to stringify now - should not call f().
2127 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
2128 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
2129 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
2133 $context = $context ? '@' : (defined $context ? "\$" : '.');
2134 $args = $h ? [@a] : undef;
2135 $e =~ s/\n\s*\;\s*\Z// if $e;
2136 $e =~ s/([\\\'])/\\$1/g if $e;
2138 $sub = "require '$e'";
2139 } elsif (defined $r) {
2141 } elsif ($sub eq '(eval)') {
2142 $sub = "eval {...}";
2144 push(@sub, {context => $context, sub => $sub, args => $args,
2145 file => $file, line => $line});
2154 while ($action =~ s/\\$//) {
2163 # i hate using globals!
2164 $balanced_brace_re ||= qr{
2167 (?> [^{}] + ) # Non-parens without backtracking
2169 (??{ $balanced_brace_re }) # Group with matching parens
2173 return $_[0] !~ m/$balanced_brace_re/;
2177 &readline("cont: ");
2181 # We save, change, then restore STDIN and STDOUT to avoid fork() since
2182 # some non-Unix systems can do system() but have problems with fork().
2183 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
2184 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
2185 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
2186 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
2188 # XXX: using csh or tcsh destroys sigint retvals!
2190 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
2191 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
2196 # most of the $? crud was coping with broken cshisms
2198 &warn("(Command exited ", ($? >> 8), ")\n");
2200 &warn( "(Command died of SIG#", ($? & 127),
2201 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
2211 eval { require Term::ReadLine } or die $@;
2214 my ($i, $o) = split $tty, /,/;
2215 $o = $i unless defined $o;
2216 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
2217 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
2220 my $sel = select($OUT);
2224 eval "require Term::Rendezvous;" or die;
2225 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
2226 my $term_rv = new Term::Rendezvous $rv;
2228 $OUT = $term_rv->OUT;
2231 if ($term_pid eq '-1') { # In a TTY with another debugger
2235 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2237 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2239 $rl_attribs = $term->Attribs;
2240 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2241 if defined $rl_attribs->{basic_word_break_characters}
2242 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2243 $rl_attribs->{special_prefixes} = '$@&%';
2244 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2245 $rl_attribs->{completion_function} = \&db_complete;
2247 $LINEINFO = $OUT unless defined $LINEINFO;
2248 $lineinfo = $console unless defined $lineinfo;
2250 if ($term->Features->{setHistory} and "@hist" ne "?") {
2251 $term->SetHistory(@hist);
2253 ornaments($ornaments) if defined $ornaments;
2257 # Example get_fork_TTY functions
2258 sub xterm_get_fork_TTY {
2259 (my $name = $0) =~ s,^.*[/\\],,s;
2260 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2264 $pidprompt = ''; # Shown anyway in titlebar
2268 # This example function resets $IN, $OUT itself
2269 sub os2_get_fork_TTY {
2270 local $^F = 40; # XXXX Fixme!
2272 my ($in1, $out1, $in2, $out2);
2273 # Having -d in PERL5OPT would lead to a disaster...
2274 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2275 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2276 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2277 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2278 local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB};
2279 $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB};
2280 $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB};
2281 (my $name = $0) =~ s,^.*[/\\],,s;
2283 if ( pipe $in1, $out1 and pipe $in2, $out2
2284 # system P_SESSION will fail if there is another process
2285 # in the same session with a "dependent" asynchronous child session.
2286 and @args = ($rl, fileno $in1, fileno $out2,
2287 "Daughter Perl debugger $pids $name") and
2288 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2289 END {sleep 5 unless $loaded}
2290 BEGIN {open STDIN, '</dev/con' or warn "reopen stdin: $!"}
2293 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2295 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2296 open IN, '<&=$in' or die "open <&=$in: \$!";
2297 \$| = 1; print while sysread IN, \$_, 1<<16;
2301 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2303 require Term::ReadKey if $rl;
2304 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2305 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2307 or warn "system P_SESSION: $!, $^E" and 0)
2308 and close $in1 and close $out2 ) {
2309 $pidprompt = ''; # Shown anyway in titlebar
2310 reset_IN_OUT($in2, $out1);
2312 return ''; # Indicate that reset_IN_OUT is called
2317 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2318 my $in = &get_fork_TTY if defined &get_fork_TTY;
2319 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2320 if (not defined $in) {
2322 print_help(<<EOP) if $why == 1;
2323 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2325 print_help(<<EOP) if $why == 2;
2326 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2327 This may be an asynchronous session, so the parent debugger may be active.
2329 print_help(<<EOP) if $why != 4;
2330 Since two debuggers fight for the same TTY, input is severely entangled.
2334 I know how to switch the output to a different window in xterms
2335 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2336 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2338 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2339 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2342 } elsif ($in ne '') {
2345 $console = ''; # Indicate no need to open-from-the-console
2350 sub resetterm { # We forked, so we need a different TTY
2352 my $systemed = $in > 1 ? '-' : '';
2354 $pids =~ s/\]/$systemed->$$]/;
2356 $pids = "[$term_pid->$$]";
2360 return unless $CreateTTY & $in;
2367 my $left = @typeahead;
2368 my $got = shift @typeahead;
2370 print $OUT "auto(-$left)", shift, $got, "\n";
2371 $term->AddHistory($got)
2372 if length($got) > 1 and defined $term->Features->{addHistory};
2378 my $line = CORE::readline($cmdfhs[-1]);
2379 defined $line ? (print $OUT ">> $line" and return $line)
2380 : close pop @cmdfhs;
2382 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2383 $OUT->write(join('', @_));
2385 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2389 $term->readline(@_);
2394 my ($opt, $val)= @_;
2395 $val = option_val($opt,'N/A');
2396 $val =~ s/([\\\'])/\\$1/g;
2397 printf $OUT "%20s = '%s'\n", $opt, $val;
2400 sub options2remember {
2401 foreach my $k (@RememberOnROptions) {
2402 $option{$k}=option_val($k, 'N/A');
2408 my ($opt, $default)= @_;
2410 if (defined $optionVars{$opt}
2411 and defined ${$optionVars{$opt}}) {
2412 $val = ${$optionVars{$opt}};
2413 } elsif (defined $optionAction{$opt}
2414 and defined &{$optionAction{$opt}}) {
2415 $val = &{$optionAction{$opt}}();
2416 } elsif (defined $optionAction{$opt}
2417 and not defined $option{$opt}
2418 or defined $optionVars{$opt}
2419 and not defined ${$optionVars{$opt}}) {
2422 $val = $option{$opt};
2424 $val = $default unless defined $val;
2431 # too dangerous to let intuitive usage overwrite important things
2432 # defaultion should never be the default
2433 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2434 dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2435 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2440 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2441 my ($opt,$sep) = ($1,$2);
2444 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2446 #&dump_option($opt);
2447 } elsif ($sep !~ /\S/) {
2449 $val = "1"; # this is an evil default; make 'em set it!
2450 } elsif ($sep eq "=") {
2451 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2453 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2457 print OUT qq(Option better cleared using $opt=""\n)
2461 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2462 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2463 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2464 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2465 ($val = $1) =~ s/\\([\\$end])/$1/g;
2469 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2470 || grep( /^\Q$opt/i && ($option = $_), @options );
2472 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2473 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2475 if ($opt_needs_val{$option} && $val_defaulted) {
2476 my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
2477 print $OUT "Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
2481 $option{$option} = $val if defined $val;
2486 require '$optionRequire{$option}';
2488 } || die # XXX: shouldn't happen
2489 if defined $optionRequire{$option} &&
2492 ${$optionVars{$option}} = $val
2493 if defined $optionVars{$option} &&
2496 &{$optionAction{$option}} ($val)
2497 if defined $optionAction{$option} &&
2498 defined &{$optionAction{$option}} &&
2502 dump_option($option) unless $OUT eq \*STDERR;
2507 my ($stem,@list) = @_;
2509 $ENV{"${stem}_n"} = @list;
2510 for $i (0 .. $#list) {
2512 $val =~ s/\\/\\\\/g;
2513 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2514 $ENV{"${stem}_$i"} = $val;
2521 my $n = delete $ENV{"${stem}_n"};
2523 for $i (0 .. $n - 1) {
2524 $val = delete $ENV{"${stem}_$i"};
2525 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2533 return; # Put nothing on the stack - malloc/free land!
2537 my($msg)= join("",@_);
2538 $msg .= ": $!\n" unless $msg =~ /\n$/;
2544 my $switch_li = $LINEINFO eq $OUT;
2545 if ($term and $term->Features->{newTTY}) {
2546 ($IN, $OUT) = (shift, shift);
2547 $term->newTTY($IN, $OUT);
2549 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2551 ($IN, $OUT) = (shift, shift);
2553 my $o = select $OUT;
2556 $LINEINFO = $OUT if $switch_li;
2560 if (@_ and $term and $term->Features->{newTTY}) {
2561 my ($in, $out) = shift;
2563 ($in, $out) = split /,/, $in, 2;
2567 open IN, $in or die "cannot open `$in' for read: $!";
2568 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2569 reset_IN_OUT(\*IN,\*OUT);
2572 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2573 # Useful if done through PERLDB_OPTS:
2574 $console = $tty = shift if @_;
2580 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2582 $notty = shift if @_;
2588 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2596 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2598 $remoteport = shift if @_;
2603 if (${$term->Features}{tkRunning}) {
2604 return $term->tkRunning(@_);
2607 print $OUT "tkRunning not supported by current ReadLine package.\n";
2614 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2616 $runnonstop = shift if @_;
2622 &warn("Some flag changes could not take effect until next 'R'!\n") if @_;
2624 $^P = parse_DollarCaretP_flags(shift) if @_;
2625 expand_DollarCaretP_flags($^P)
2628 sub OnlyAssertions {
2630 &warn("Too late to set up OnlyAssertions mode, enabled on next 'R'!\n") if @_;
2633 unless (defined $ini_assertion) {
2635 &warn("Current Perl interpreter doesn't support assertions");
2640 unless ($ini_assertion) {
2641 print "Assertions will be active on next 'R'!\n";
2644 $^P&= ~$DollarCaretP_flags{PERLDBf_SUB};
2645 $^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
2648 $^P|=$DollarCaretP_flags{PERLDBf_SUB};
2651 !($^P & $DollarCaretP_flags{PERLDBf_SUB}) || 0;
2657 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2664 $sh = quotemeta shift;
2665 $sh .= "\\b" if $sh =~ /\w$/;
2669 $psh =~ s/\\(.)/$1/g;
2674 if (defined $term) {
2675 local ($warnLevel,$dieLevel) = (0, 1);
2676 return '' unless $term->Features->{ornaments};
2677 eval { $term->ornaments(@_) } || '';
2685 $rc = quotemeta shift;
2686 $rc .= "\\b" if $rc =~ /\w$/;
2690 $prc =~ s/\\(.)/$1/g;
2695 return $lineinfo unless @_;
2697 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2698 $slave_editor = ($stream =~ /^\|/);
2699 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2700 $LINEINFO = \*LINEINFO;
2701 my $save = select($LINEINFO);
2707 sub list_modules { # versions
2715 s/^Term::ReadLine::readline$/readline/;
2716 if (defined ${ $_ . '::VERSION' }) {
2717 $version{$file} = "${ $_ . '::VERSION' } from ";
2719 $version{$file} .= $INC{$file};
2721 dumpit($OUT,\%version);
2725 # XXX: make sure there are tabs between the command and explanation,
2726 # or print_help will screw up your formatting if you have
2727 # eeevil ornaments enabled. This is an insane mess.
2730 Help is currently only available for the new 580 CommandSet,
2731 if you really want old behaviour, presumably you know what
2735 B<s> [I<expr>] Single step [in I<expr>].
2736 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2737 <B<CR>> Repeat last B<n> or B<s> command.
2738 B<r> Return from current subroutine.
2739 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2740 at the specified position.
2741 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2742 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2743 B<l> I<line> List single I<line>.
2744 B<l> I<subname> List first window of lines from subroutine.
2745 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2746 B<l> List next window of lines.
2747 B<-> List previous window of lines.
2748 B<v> [I<line>] View window around I<line>.
2749 B<.> Return to the executed line.
2750 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2751 I<filename> may be either the full name of the file, or a regular
2752 expression matching the full file name:
2753 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2754 Evals (with saved bodies) are considered to be filenames:
2755 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2756 (in the order of execution).
2757 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2758 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2759 B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions.
2760 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2761 B<t> Toggle trace mode.
2762 B<t> I<expr> Trace through execution of I<expr>.
2763 B<b> Sets breakpoint on current line)
2764 B<b> [I<line>] [I<condition>]
2765 Set breakpoint; I<line> defaults to the current execution line;
2766 I<condition> breaks if it evaluates to true, defaults to '1'.
2767 B<b> I<subname> [I<condition>]
2768 Set breakpoint at first line of subroutine.
2769 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2770 B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
2771 B<b> B<postpone> I<subname> [I<condition>]
2772 Set breakpoint at first line of subroutine after
2774 B<b> B<compile> I<subname>
2775 Stop after the subroutine is compiled.
2776 B<B> [I<line>] Delete the breakpoint for I<line>.
2777 B<B> I<*> Delete all breakpoints.
2778 B<a> [I<line>] I<command>
2779 Set an action to be done before the I<line> is executed;
2780 I<line> defaults to the current execution line.
2781 Sequence is: check for breakpoint/watchpoint, print line
2782 if necessary, do action, prompt user if necessary,
2785 B<A> [I<line>] Delete the action for I<line>.
2786 B<A> I<*> Delete all actions.
2787 B<w> I<expr> Add a global watch-expression.
2789 B<W> I<expr> Delete a global watch-expression.
2790 B<W> I<*> Delete all watch-expressions.
2791 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2792 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2793 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2794 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2795 B<x> I<expr> Evals expression in list context, dumps the result.
2796 B<m> I<expr> Evals expression in list context, prints methods callable
2797 on the first element of the result.
2798 B<m> I<class> Prints methods callable via the given class.
2799 B<M> Show versions of loaded modules.
2800 B<y> [I<n> [I<vars>]] List lexical variables I<n> levels up from current sub
2802 B<<> ? List Perl commands to run before each prompt.
2803 B<<> I<expr> Define Perl command to run before each prompt.
2804 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2805 B<< *> Delete the list of perl commands to run before each prompt.
2806 B<>> ? List Perl commands to run after each prompt.
2807 B<>> I<expr> Define Perl command to run after each prompt.
2808 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2809 B<>>B< *> Delete the list of Perl commands to run after each prompt.
2810 B<{> I<db_command> Define debugger command to run before each prompt.
2811 B<{> ? List debugger commands to run before each prompt.
2812 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2813 B<{ *> Delete the list of debugger commands to run before each prompt.
2814 B<$prc> I<number> Redo a previous command (default previous command).
2815 B<$prc> I<-number> Redo number'th-to-last command.
2816 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2817 See 'B<O> I<recallCommand>' too.
2818 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2819 . ( $rc eq $sh ? "" : "
2820 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2821 See 'B<O> I<shellBang>' too.
2822 B<source> I<file> Execute I<file> containing debugger commands (may nest).
2823 B<H> I<-number> Display last number commands (default all).
2824 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2825 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2826 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2827 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2828 I<command> Execute as a perl statement in current package.
2829 B<R> Pure-man-restart of debugger, some of debugger state
2830 and command-line options may be lost.
2831 Currently the following settings are preserved:
2832 history, breakpoints and actions, debugger B<O>ptions
2833 and the following command-line options: I<-w>, I<-I>, I<-e>.
2835 B<o> [I<opt>] ... Set boolean option to true
2836 B<o> [I<opt>B<?>] Query options
2837 B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2838 Set options. Use quotes in spaces in value.
2839 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2840 I<pager> program for output of \"|cmd\";
2841 I<tkRunning> run Tk while prompting (with ReadLine);
2842 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2843 I<inhibit_exit> Allows stepping off the end of the script.
2844 I<ImmediateStop> Debugger should stop as early as possible.
2845 I<RemotePort> Remote hostname:port for remote debugging
2846 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2847 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2848 I<compactDump>, I<veryCompact> change style of array and hash dump;
2849 I<globPrint> whether to print contents of globs;
2850 I<DumpDBFiles> dump arrays holding debugged files;
2851 I<DumpPackages> dump symbol tables of packages;
2852 I<DumpReused> dump contents of \"reused\" addresses;
2853 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2854 I<bareStringify> Do not print the overload-stringified value;
2855 Other options include:
2856 I<PrintRet> affects printing of return value after B<r> command,
2857 I<frame> affects printing messages on subroutine entry/exit.
2858 I<AutoTrace> affects printing messages on possible breaking points.
2859 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2860 I<ornaments> affects screen appearance of the command line.
2861 I<CreateTTY> bits control attempts to create a new TTY on events:
2862 1: on fork() 2: debugger is started inside debugger
2864 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2865 You can put additional initialization options I<TTY>, I<noTTY>,
2866 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2867 `B<R>' after you set them).
2869 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2870 B<h> Summary of debugger commands.
2871 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2872 B<h h> Long help for debugger commands
2873 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2874 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2875 Set B<\$DB::doccmd> to change viewer.
2877 Type `|h h' for a paged display if this was too hard to read.
2879 "; # Fix balance of vi % matching: }}}}
2881 # note: tabs in the following section are not-so-helpful
2882 $summary = <<"END_SUM";
2883 I<List/search source lines:> I<Control script execution:>
2884 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2885 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2886 B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs
2887 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2888 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2889 B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position
2890 I<Debugger controls:> B<L> List break/watch/actions
2891 B<o> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2892 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2893 B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints
2894 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2895 B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions
2896 B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression
2897 B<h h> Complete help page B<W> I<expr|*> Delete a/all watch exprs
2898 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2899 B<q> or B<^D> Quit B<R> Attempt a restart
2900 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2901 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2902 B<p> I<expr> Print expression (uses script's current package).
2903 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2904 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2905 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2906 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2907 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2909 # ')}}; # Fix balance of vi % matching
2911 # and this is really numb...
2914 B<s> [I<expr>] Single step [in I<expr>].
2915 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2916 <B<CR>> Repeat last B<n> or B<s> command.
2917 B<r> Return from current subroutine.
2918 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2919 at the specified position.
2920 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2921 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2922 B<l> I<line> List single I<line>.
2923 B<l> I<subname> List first window of lines from subroutine.
2924 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2925 B<l> List next window of lines.
2926 B<-> List previous window of lines.
2927 B<w> [I<line>] List window around I<line>.
2928 B<.> Return to the executed line.
2929 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2930 I<filename> may be either the full name of the file, or a regular
2931 expression matching the full file name:
2932 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2933 Evals (with saved bodies) are considered to be filenames:
2934 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2935 (in the order of execution).
2936 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2937 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2938 B<L> List all breakpoints and actions.
2939 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2940 B<t> Toggle trace mode.
2941 B<t> I<expr> Trace through execution of I<expr>.
2942 B<b> [I<line>] [I<condition>]
2943 Set breakpoint; I<line> defaults to the current execution line;
2944 I<condition> breaks if it evaluates to true, defaults to '1'.
2945 B<b> I<subname> [I<condition>]
2946 Set breakpoint at first line of subroutine.
2947 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2948 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2949 B<b> B<postpone> I<subname> [I<condition>]
2950 Set breakpoint at first line of subroutine after
2952 B<b> B<compile> I<subname>
2953 Stop after the subroutine is compiled.
2954 B<d> [I<line>] Delete the breakpoint for I<line>.
2955 B<D> Delete all breakpoints.
2956 B<a> [I<line>] I<command>
2957 Set an action to be done before the I<line> is executed;
2958 I<line> defaults to the current execution line.
2959 Sequence is: check for breakpoint/watchpoint, print line
2960 if necessary, do action, prompt user if necessary,
2962 B<a> [I<line>] Delete the action for I<line>.
2963 B<A> Delete all actions.
2964 B<W> I<expr> Add a global watch-expression.
2965 B<W> Delete all watch-expressions.
2966 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2967 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2968 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2969 B<x> I<expr> Evals expression in list context, dumps the result.
2970 B<m> I<expr> Evals expression in list context, prints methods callable
2971 on the first element of the result.
2972 B<m> I<class> Prints methods callable via the given class.
2974 B<<> ? List Perl commands to run before each prompt.
2975 B<<> I<expr> Define Perl command to run before each prompt.
2976 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2977 B<>> ? List Perl commands to run after each prompt.
2978 B<>> I<expr> Define Perl command to run after each prompt.
2979 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2980 B<{> I<db_command> Define debugger command to run before each prompt.
2981 B<{> ? List debugger commands to run before each prompt.
2982 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2983 B<$prc> I<number> Redo a previous command (default previous command).
2984 B<$prc> I<-number> Redo number'th-to-last command.
2985 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2986 See 'B<O> I<recallCommand>' too.
2987 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2988 . ( $rc eq $sh ? "" : "
2989 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2990 See 'B<O> I<shellBang>' too.
2991 B<source> I<file> Execute I<file> containing debugger commands (may nest).
2992 B<H> I<-number> Display last number commands (default all).
2993 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2994 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2995 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2996 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2997 I<command> Execute as a perl statement in current package.
2998 B<v> Show versions of loaded modules.
2999 B<R> Pure-man-restart of debugger, some of debugger state
3000 and command-line options may be lost.
3001 Currently the following settings are preserved:
3002 history, breakpoints and actions, debugger B<O>ptions
3003 and the following command-line options: I<-w>, I<-I>, I<-e>.
3005 B<O> [I<opt>] ... Set boolean option to true
3006 B<O> [I<opt>B<?>] Query options
3007 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
3008 Set options. Use quotes in spaces in value.
3009 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
3010 I<pager> program for output of \"|cmd\";
3011 I<tkRunning> run Tk while prompting (with ReadLine);
3012 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
3013 I<inhibit_exit> Allows stepping off the end of the script.
3014 I<ImmediateStop> Debugger should stop as early as possible.
3015 I<RemotePort> Remote hostname:port for remote debugging
3016 The following options affect what happens with B<V>, B<X>, and B<x> commands:
3017 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
3018 I<compactDump>, I<veryCompact> change style of array and hash dump;
3019 I<globPrint> whether to print contents of globs;
3020 I<DumpDBFiles> dump arrays holding debugged files;
3021 I<DumpPackages> dump symbol tables of packages;
3022 I<DumpReused> dump contents of \"reused\" addresses;
3023 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
3024 I<bareStringify> Do not print the overload-stringified value;
3025 Other options include:
3026 I<PrintRet> affects printing of return value after B<r> command,
3027 I<frame> affects printing messages on subroutine entry/exit.
3028 I<AutoTrace> affects printing messages on possible breaking points.
3029 I<maxTraceLen> gives max length of evals/args listed in stack trace.
3030 I<ornaments> affects screen appearance of the command line.
3031 I<CreateTTY> bits control attempts to create a new TTY on events:
3032 1: on fork() 2: debugger is started inside debugger
3034 During startup options are initialized from \$ENV{PERLDB_OPTS}.
3035 You can put additional initialization options I<TTY>, I<noTTY>,
3036 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
3037 `B<R>' after you set them).
3039 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
3040 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
3041 B<h h> Summary of debugger commands.
3042 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
3043 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
3044 Set B<\$DB::doccmd> to change viewer.
3046 Type `|h' for a paged display if this was too hard to read.
3048 "; # Fix balance of vi % matching: }}}}
3050 # note: tabs in the following section are not-so-helpful
3051 $pre580_summary = <<"END_SUM";
3052 I<List/search source lines:> I<Control script execution:>
3053 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
3054 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
3055 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
3056 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
3057 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
3058 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
3059 I<Debugger controls:> B<L> List break/watch/actions
3060 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
3061 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
3062 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
3063 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
3064 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
3065 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
3066 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
3067 B<q> or B<^D> Quit B<R> Attempt a restart
3068 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
3069 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
3070 B<p> I<expr> Print expression (uses script's current package).
3071 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
3072 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
3073 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
3074 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
3075 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
3077 # ')}}; # Fix balance of vi % matching
3084 # Restore proper alignment destroyed by eeevil I<> and B<>
3085 # ornaments: A pox on both their houses!
3087 # A help command will have everything up to and including
3088 # the first tab sequence padded into a field 16 (or if indented 20)
3089 # wide. If it's wider than that, an extra space will be added.
3091 ^ # only matters at start of line
3092 ( \040{4} | \t )* # some subcommands are indented
3093 ( < ? # so <CR> works
3094 [BI] < [^\t\n] + ) # find an eeevil ornament
3095 ( \t+ ) # original separation, discarded
3096 ( .* ) # this will now start (no earlier) than
3099 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
3100 my $clean = $command;
3101 $clean =~ s/[BI]<([^>]*)>/$1/g;
3102 # replace with this whole string:
3103 ($leadwhite ? " " x 4 : "")
3105 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
3110 s{ # handle bold ornaments
3111 B < ( [^>] + | > ) >
3113 $Term::ReadLine::TermCap::rl_term_set[2]
3115 . $Term::ReadLine::TermCap::rl_term_set[3]
3118 s{ # handle italic ornaments
3119 I < ( [^>] + | > ) >
3121 $Term::ReadLine::TermCap::rl_term_set[0]
3123 . $Term::ReadLine::TermCap::rl_term_set[1]
3131 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
3132 my $is_less = $pager =~ /\bless\b/;
3133 if ($pager =~ /\bmore\b/) {
3134 my @st_more = stat('/usr/bin/more');
3135 my @st_less = stat('/usr/bin/less');
3136 $is_less = @st_more && @st_less
3137 && $st_more[0] == $st_less[0]
3138 && $st_more[1] == $st_less[1];
3140 # changes environment!
3141 $ENV{LESS} .= 'r' if $is_less;
3147 $SIG{'ABRT'} = 'DEFAULT';
3148 kill 'ABRT', $$ if $panic++;
3149 if (defined &Carp::longmess) {
3150 local $SIG{__WARN__} = '';
3151 local $Carp::CarpLevel = 2; # mydie + confess
3152 &warn(Carp::longmess("Signal @_"));
3156 print $DB::OUT "Got signal @_\n";
3164 local $SIG{__WARN__} = '';
3165 local $SIG{__DIE__} = '';
3166 eval { require Carp } if defined $^S; # If error/warning during compilation,
3167 # require may be broken.
3168 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
3169 return unless defined &Carp::longmess;
3170 my ($mysingle,$mytrace) = ($single,$trace);
3171 $single = 0; $trace = 0;
3172 my $mess = Carp::longmess(@_);
3173 ($single,$trace) = ($mysingle,$mytrace);
3180 local $SIG{__DIE__} = '';
3181 local $SIG{__WARN__} = '';
3182 my $i = 0; my $ineval = 0; my $sub;
3183 if ($dieLevel > 2) {
3184 local $SIG{__WARN__} = \&dbwarn;
3185 &warn(@_); # Yell no matter what
3188 if ($dieLevel < 2) {
3189 die @_ if $^S; # in eval propagate
3191 # No need to check $^S, eval is much more robust nowadays
3192 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
3193 # require may be broken.
3195 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
3196 unless defined &Carp::longmess;
3198 # We do not want to debug this chunk (automatic disabling works
3199 # inside DB::DB, but not in Carp).
3200 my ($mysingle,$mytrace) = ($single,$trace);
3201 $single = 0; $trace = 0;
3204 package Carp; # Do not include us in the list
3206 $mess = Carp::longmess(@_);
3209 ($single,$trace) = ($mysingle,$mytrace);
3215 $prevwarn = $SIG{__WARN__} unless $warnLevel;
3218 $SIG{__WARN__} = \&DB::dbwarn;
3219 } elsif ($prevwarn) {
3220 $SIG{__WARN__} = $prevwarn;
3229 $prevdie = $SIG{__DIE__} unless $dieLevel;
3232 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
3233 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
3234 print $OUT "Stack dump during die enabled",
3235 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
3237 print $OUT "Dump printed too.\n" if $dieLevel > 2;
3238 } elsif ($prevdie) {
3239 $SIG{__DIE__} = $prevdie;
3240 print $OUT "Default die handler restored.\n";
3248 $prevsegv = $SIG{SEGV} unless $signalLevel;
3249 $prevbus = $SIG{BUS} unless $signalLevel;
3250 $signalLevel = shift;
3252 $SIG{SEGV} = \&DB::diesignal;
3253 $SIG{BUS} = \&DB::diesignal;
3255 $SIG{SEGV} = $prevsegv;
3256 $SIG{BUS} = $prevbus;
3264 my $name = CvGV_name_or_bust($in);
3265 defined $name ? $name : $in;
3268 sub CvGV_name_or_bust {
3270 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
3271 return unless ref $in;
3272 $in = \&$in; # Hard reference...
3273 eval {require Devel::Peek; 1} or return;
3274 my $gv = Devel::Peek::CvGV($in) or return;
3275 *$gv{PACKAGE} . '::' . *$gv{NAME};
3281 return unless defined &$subr;
3282 my $name = CvGV_name_or_bust($subr);
3284 $data = $sub{$name} if defined $name;
3285 return $data if defined $data;
3288 $subr = \&$subr; # Hard reference
3291 $s = $_, last if $subr eq \&$_;
3299 $class = ref $class if ref $class;
3302 methods_via($class, '', 1);
3303 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
3308 return if $packs{$class}++;
3310 my $prepend = $prefix ? "via $prefix: " : '';
3312 for $name (grep {defined &{${"${class}::"}{$_}}}
3313 sort keys %{"${class}::"}) {
3314 next if $seen{ $name }++;
3317 print $DB::OUT "$prepend$name\n";
3319 return unless shift; # Recurse?
3320 for $name (@{"${class}::ISA"}) {
3321 $prepend = $prefix ? $prefix . " -> $name" : $name;
3322 methods_via($name, $prepend, 1);
3327 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
3328 ? "man" # O Happy Day!
3329 : "perldoc"; # Alas, poor unfortunates
3335 &system("$doccmd $doccmd");
3338 # this way user can override, like with $doccmd="man -Mwhatever"
3339 # or even just "man " to disable the path check.
3340 unless ($doccmd eq 'man') {
3341 &system("$doccmd $page");
3345 $page = 'perl' if lc($page) eq 'help';
3348 my $man1dir = $Config::Config{'man1dir'};
3349 my $man3dir = $Config::Config{'man3dir'};
3350 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
3352 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
3353 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
3354 chop $manpath if $manpath;
3355 # harmless if missing, I figure
3356 my $oldpath = $ENV{MANPATH};
3357 $ENV{MANPATH} = $manpath if $manpath;
3358 my $nopathopt = $^O =~ /dunno what goes here/;
3359 if (CORE::system($doccmd,
3360 # I just *know* there are men without -M
3361 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3364 unless ($page =~ /^perl\w/) {
3365 if (grep { $page eq $_ } qw{
3366 5004delta 5005delta amiga api apio book boot bot call compile
3367 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
3368 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
3369 form func guts hack hist hpux intern ipc lexwarn locale lol mod
3370 modinstall modlib number obj op opentut os2 os390 pod port
3371 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
3372 trap unicode var vms win32 xs xstut
3376 CORE::system($doccmd,
3377 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3382 if (defined $oldpath) {
3383 $ENV{MANPATH} = $manpath;
3385 delete $ENV{MANPATH};
3389 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
3391 BEGIN { # This does not compile, alas.
3392 $IN = \*STDIN; # For bugs before DB::OUT has been opened
3393 $OUT = \*STDERR; # For errors before DB::OUT has been opened
3397 $deep = 100; # warning if stack gets this deep
3401 $SIG{INT} = \&DB::catch;
3402 # This may be enabled to debug debugger:
3403 #$warnLevel = 1 unless defined $warnLevel;
3404 #$dieLevel = 1 unless defined $dieLevel;
3405 #$signalLevel = 1 unless defined $signalLevel;
3407 $db_stop = 0; # Compiler warning
3409 $level = 0; # Level of recursive debugging
3410 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
3411 # Triggers bug (?) in perl is we postpone this until runtime:
3412 @postponed = @stack = (0);
3413 $stack_depth = 0; # Localized $#stack
3418 BEGIN {$^W = $ini_warn;} # Switch warnings back
3420 #use Carp; # This did break, left for debugging
3423 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
3424 my($text, $line, $start) = @_;
3425 my ($itext, $search, $prefix, $pack) =
3426 ($text, "^\Q${'package'}::\E([^:]+)\$");
3428 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
3429 (map { /$search/ ? ($1) : () } keys %sub)
3430 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
3431 return sort grep /^\Q$text/, values %INC # files
3432 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
3433 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3434 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
3435 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
3436 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3438 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
3440 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
3441 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
3442 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
3443 # We may want to complete to (eval 9), so $text may be wrong
3444 $prefix = length($1) - length($text);
3447 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
3449 if ((substr $text, 0, 1) eq '&') { # subroutines
3450 $text = substr $text, 1;
3452 return sort map "$prefix$_",
3455 (map { /$search/ ? ($1) : () }
3458 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
3459 $pack = ($1 eq 'main' ? '' : $1) . '::';
3460 $prefix = (substr $text, 0, 1) . $1 . '::';
3463 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
3464 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3465 return db_complete($out[0], $line, $start);
3469 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3470 $pack = ($package eq 'main' ? '' : $package) . '::';
3471 $prefix = substr $text, 0, 1;
3472 $text = substr $text, 1;
3473 my @out = map "$prefix$_", grep /^\Q$text/,
3474 (grep /^_?[a-zA-Z]/, keys %$pack),
3475 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3476 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3477 return db_complete($out[0], $line, $start);
3481 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3482 my @out = grep /^\Q$text/, @options;
3483 my $val = option_val($out[0], undef);
3485 if (not defined $val or $val =~ /[\n\r]/) {
3486 # Can do nothing better
3487 } elsif ($val =~ /\s/) {
3489 foreach $l (split //, qq/\"\'\#\|/) {
3490 $out = "$l$val$l ", last if (index $val, $l) == -1;
3495 # Default to value if one completion, to question if many
3496 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3499 return $term->filename_list($text); # filenames
3504 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3508 if (defined($ini_pids)) {
3509 $ENV{PERLDB_PIDS} = $ini_pids;
3511 delete($ENV{PERLDB_PIDS});
3516 # PERLDBf_... flag names from perl.h
3517 our (%DollarCaretP_flags, %DollarCaretP_flags_r);
3519 %DollarCaretP_flags =
3520 ( PERLDBf_SUB => 0x01, # Debug sub enter/exit
3521 PERLDBf_LINE => 0x02, # Keep line #
3522 PERLDBf_NOOPT => 0x04, # Switch off optimizations
3523 PERLDBf_INTER => 0x08, # Preserve more data
3524 PERLDBf_SUBLINE => 0x10, # Keep subr source lines
3525 PERLDBf_SINGLE => 0x20, # Start with single-step on
3526 PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr
3527 PERLDBf_GOTO => 0x80, # Report goto: call DB::goto
3528 PERLDBf_NAMEEVAL => 0x100, # Informative names for evals
3529 PERLDBf_NAMEANON => 0x200, # Informative names for anon subs
3530 PERLDBf_ASSERTION => 0x400, # Debug assertion subs enter/exit
3531 PERLDB_ALL => 0x33f, # No _NONAME, _GOTO, _ASSERTION
3534 %DollarCaretP_flags_r=reverse %DollarCaretP_flags;
3537 sub parse_DollarCaretP_flags {
3542 foreach my $f (split /\s*\|\s*/, $flags) {
3544 if ($f=~/^0x([[:xdigit:]]+)$/) {
3547 elsif ($f=~/^(\d+)$/) {
3550 elsif ($f=~/^DEFAULT$/i) {
3551 $value=$DollarCaretP_flags{PERLDB_ALL};
3554 $f=~/^(?:PERLDBf_)?(.*)$/i;
3555 $value=$DollarCaretP_flags{'PERLDBf_'.uc($1)};
3556 unless (defined $value) {
3557 print $OUT ("Unrecognized \$^P flag '$f'!\n",
3558 "Acceptable flags are: ".
3559 join(', ', sort keys %DollarCaretP_flags),
3560 ", and hexadecimal and decimal numbers.\n");
3569 sub expand_DollarCaretP_flags {
3570 my $DollarCaretP=shift;
3571 my @bits= ( map { my $n=(1<<$_);
3572 ($DollarCaretP & $n)
3573 ? ($DollarCaretP_flags_r{$n}
3574 || sprintf('0x%x', $n))
3576 return @bits ? join('|', @bits) : 0;
3580 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3581 $fall_off_end = 1 unless $inhibit_exit;
3582 # Do not stop in at_exit() and destructors on exit:
3583 $DB::single = !$fall_off_end && !$runnonstop;
3584 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3588 # ===================================== pre580 ================================
3589 # this is very sad below here...
3592 sub cmd_pre580_null {
3599 if ($cmd =~ /^(\d*)\s*(.*)/) {
3600 $i = $1 || $line; $j = $2;
3602 if ($dbline[$i] == 0) {
3603 print $OUT "Line $i may not have an action.\n";
3605 $had_breakpoints{$filename} |= 2;
3606 $dbline{$i} =~ s/\0[^\0]*//;
3607 $dbline{$i} .= "\0" . action($j);
3610 $dbline{$i} =~ s/\0[^\0]*//;
3611 delete $dbline{$i} if $dbline{$i} eq '';
3620 if ($cmd =~ /^load\b\s*(.*)/) {
3621 my $file = $1; $file =~ s/\s+$//;
3623 } elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
3624 my $cond = length $3 ? $3 : '1';
3625 my ($subname, $break) = ($2, $1 eq 'postpone');
3626 $subname =~ s/\'/::/g;
3627 $subname = "${'package'}::" . $subname
3628 unless $subname =~ /::/;
3629 $subname = "main".$subname if substr($subname,0,2) eq "::";
3630 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
3631 } elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
3633 my $cond = length $2 ? $2 : '1';
3634 &cmd_b_sub($subname, $cond);
3635 } elsif ($cmd =~ /^(\d*)\s*(.*)/) {
3636 my $i = $1 || $dbline;
3637 my $cond = length $2 ? $2 : '1';
3638 &cmd_b_line($i, $cond);
3645 if ($cmd =~ /^\s*$/) {
3646 print $OUT "Deleting all breakpoints...\n";
3648 for $file (keys %had_breakpoints) {
3649 local *dbline = $main::{'_<' . $file};
3653 for ($i = 1; $i <= $max ; $i++) {
3654 if (defined $dbline{$i}) {
3655 $dbline{$i} =~ s/^[^\0]+//;
3656 if ($dbline{$i} =~ s/^\0?$//) {
3662 if (not $had_breakpoints{$file} &= ~1) {
3663 delete $had_breakpoints{$file};
3667 undef %postponed_file;
3668 undef %break_on_load;
3675 if ($cmd =~ /^\s*$/) {
3676 print_help($pre580_help);
3677 } elsif ($cmd =~ /^h\s*/) {
3678 print_help($pre580_summary);
3679 } elsif ($cmd =~ /^h\s+(\S.*)$/) {
3680 my $asked = $1; # for proper errmsg
3681 my $qasked = quotemeta($asked); # for searching
3682 # XXX: finds CR but not <CR>
3683 if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) {
3684 while ($pre580_help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
3688 print_help("B<$asked> is not a debugger command.\n");
3698 @to_watch = @old_watch = ();
3699 } elsif ($cmd =~ /^(.*)/s) {
3703 $val = (defined $val) ? "'$val'" : 'undef' ;
3704 push @old_watch, $val;
3709 sub cmd_pre590_prepost {
3711 my $line = shift || '*'; # delete
3714 return &cmd_prepost($cmd, $line, $dbline);
3717 sub cmd_prepost { # cannot do &cmd_<(), <, <<, >>, {, {{, etc.
3719 my $line = shift || '?';
3723 if ($cmd =~ /^\</o) {
3724 $which = 'pre-perl';
3726 } elsif ($cmd =~ /^\>/o) {
3727 $which = 'post-perl';
3729 } elsif ($cmd =~ /^\{/o) {
3730 if ($cmd =~ /^\{.*\}$/o && unbalanced(substr($cmd,1))) {
3731 print $OUT "$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n";
3732 # $DB::cmd = "h $cmd";
3735 $which = 'pre-debugger';
3741 print $OUT "Confused by command: $cmd\n";
3743 if ($line =~ /^\s*\?\s*$/o) {
3745 print $OUT "No $which actions.\n";
3746 # print $OUT "If you meant to delete them all - use '$cmd *' or 'o commandSet=pre590'\n"; # hint
3748 print $OUT "$which commands:\n";
3749 foreach my $action (@$aref) {
3750 print $OUT "\t$cmd -- $action\n";
3754 if (length($cmd) == 1) {
3755 if ($line =~ /^\s*\*\s*$/o) {
3756 @$aref = (); # delete
3757 print $OUT "All $cmd actions cleared.\n";
3759 @$aref = action($line); # set
3761 } elsif (length($cmd) == 2) { # append
3762 push @$aref, action($line);
3764 print $OUT "Confused by strange length of $which command($cmd)...\n";
3773 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3776 package DB; # Do not trace this 1; below!