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;
539 # untaint $^O, which may have been tainted by the last statement.
540 # see bug [perl #24674]
541 $^O =~ m/^(.*)\z/; $^O = $1;
543 # Here begin the unreadable code. It needs fixing.
545 if (exists $ENV{PERLDB_RESTART}) {
546 delete $ENV{PERLDB_RESTART};
548 @hist = get_list('PERLDB_HIST');
549 %break_on_load = get_list("PERLDB_ON_LOAD");
550 %postponed = get_list("PERLDB_POSTPONE");
551 my @had_breakpoints= get_list("PERLDB_VISITED");
552 for (0 .. $#had_breakpoints) {
553 my %pf = get_list("PERLDB_FILE_$_");
554 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
556 my %opt = get_list("PERLDB_OPT");
558 while (($opt,$val) = each %opt) {
559 $val =~ s/[\\\']/\\$1/g;
560 parse_options("$opt'$val'");
562 @INC = get_list("PERLDB_INC");
564 $pretype = [get_list("PERLDB_PRETYPE")];
565 $pre = [get_list("PERLDB_PRE")];
566 $post = [get_list("PERLDB_POST")];
567 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
573 # Is Perl being run from a slave editor or graphical debugger?
574 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
575 $rl = 0, shift(@main::ARGV) if $slave_editor;
577 #require Term::ReadLine;
579 if ($^O eq 'cygwin') {
580 # /dev/tty is binary. use stdin for textmode
582 } elsif (-e "/dev/tty") {
583 $console = "/dev/tty";
584 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
586 } elsif ($^O eq 'MacOS') {
587 if ($MacPerl::Version !~ /MPW/) {
588 $console = "Dev:Console:Perl Debug"; # Separate window for application
590 $console = "Dev:Console";
593 $console = "sys\$command";
596 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
600 if ($^O eq 'NetWare') {
605 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
613 $console = $tty if defined $tty;
615 if (defined $remoteport) {
617 $OUT = new IO::Socket::INET( Timeout => '10',
618 PeerAddr => $remoteport,
621 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
624 create_IN_OUT(4) if $CreateTTY & 4;
626 my ($i, $o) = split /,/, $console;
627 $o = $i unless defined $o;
628 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
629 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
630 || open(OUT,">&STDOUT"); # so we don't dongle stdout
631 } elsif (not defined $console) {
633 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
634 $console = 'STDIN/OUT';
636 # so open("|more") can read from STDOUT and so we don't dingle stdin
637 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
639 my $previous = select($OUT);
640 $| = 1; # for DB::OUT
643 $LINEINFO = $OUT unless defined $LINEINFO;
644 $lineinfo = $console unless defined $lineinfo;
646 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
647 unless ($runnonstop) {
650 if ($term_pid eq '-1') {
651 print $OUT "\nDaughter DB session started...\n";
653 print $OUT "\nLoading DB routines from $header\n";
654 print $OUT ("Editor support ",
655 $slave_editor ? "enabled" : "available",
657 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
665 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
668 if (defined &afterinit) { # May be defined in $rcfile
674 ############################################################ Subroutines
677 # _After_ the perl program is compiled, $single is set to 1:
678 if ($single and not $second_time++) {
679 if ($runnonstop) { # Disable until signal
680 for ($i=0; $i <= $stack_depth; ) {
684 # return; # Would not print trace!
685 } elsif ($ImmediateStop) {
690 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
692 local($package, $filename, $line) = caller;
693 local $filename_ini = $filename;
694 local $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
695 "package $package;"; # this won't let them modify, alas
696 local(*dbline) = $main::{'_<' . $filename};
698 # we need to check for pseudofiles on Mac OS (these are files
699 # not attached to a filename, but instead stored in Dev:Pseudo)
700 if ($^O eq 'MacOS' && $#dbline < 0) {
701 $filename_ini = $filename = 'Dev:Pseudo';
702 *dbline = $main::{'_<' . $filename};
705 local $max = $#dbline;
706 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
710 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
711 $dbline{$line} =~ s/;9($|\0)/$1/;
714 my $was_signal = $signal;
716 for (my $n = 0; $n <= $#to_watch; $n++) {
717 $evalarg = $to_watch[$n];
718 local $onetimeDump; # Do not output results
719 my ($val) = join("', '", &eval); # Fix context (&eval is doing array)? - rjsf
720 $val = ( (defined $val) ? "'$val'" : 'undef' );
721 if ($val ne $old_watch[$n]) {
724 Watchpoint $n:\t$to_watch[$n] changed:
725 old value:\t$old_watch[$n]
728 $old_watch[$n] = $val;
732 if ($trace & 4) { # User-installed watch
733 return if watchfunction($package, $filename, $line)
734 and not $single and not $was_signal and not ($trace & ~4);
736 $was_signal = $signal;
738 if ($single || ($trace & 1) || $was_signal) {
740 $position = "\032\032$filename:$line:0\n";
741 print_lineinfo($position);
742 } elsif ($package eq 'DB::fake') {
745 Debugged program terminated. Use B<q> to quit or B<R> to restart,
746 use B<O> I<inhibit_exit> to avoid stopping after program termination,
747 B<h q>, B<h R> or B<h O> to get additional info.
750 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
751 "package $package;"; # this won't let them modify, alas
754 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
755 $prefix .= "$sub($filename:";
756 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
757 if (length($prefix) > 30) {
758 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
763 $position = "$prefix$line$infix$dbline[$line]$after";
766 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
768 print_lineinfo($position);
770 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
771 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
773 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
774 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
775 $position .= $incr_pos;
777 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
779 print_lineinfo($incr_pos);
784 $evalarg = $action, &eval if $action;
785 if ($single || $was_signal) {
786 local $level = $level + 1;
787 foreach $evalarg (@$pre) {
790 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
793 $incr = -1; # for backward motion.
794 @typeahead = (@$pretype, @typeahead);
796 while (($term || &setterm),
797 ($term_pid == $$ or resetterm(1)),
798 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
799 ($#hist+1) . ('>' x $level) . " ")))
803 $cmd =~ s/\\$/\n/ && do {
804 $cmd .= &readline(" cont: ");
807 $cmd =~ /^$/ && ($cmd = $laststep);
808 push(@hist,$cmd) if length($cmd) > 1;
810 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
811 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
812 ($i) = split(/\s+/,$cmd);
814 # squelch the sigmangler
816 local $SIG{__WARN__};
817 eval "\$cmd =~ $alias{$i}";
820 print $OUT "Couldn't evaluate `$i' alias: $@";
824 $cmd =~ /^q$/ && do {
829 $cmd =~ /^t$/ && do {
832 print $OUT "Trace = " .
833 (($trace & 1) ? "on" : "off" ) . "\n";
835 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
836 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
839 foreach $subname (sort(keys %sub)) {
840 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
841 print $OUT $subname,"\n";
845 $cmd =~ s/^X\b/V $package/;
846 $cmd =~ /^V$/ && do {
847 $cmd = "V $package"; };
848 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
849 local ($savout) = select($OUT);
851 @vars = split(' ',$2);
852 do 'dumpvar.pl' unless defined &main::dumpvar;
853 if (defined &main::dumpvar) {
856 # must detect sigpipe failures
857 eval { &main::dumpvar($packname,
858 defined $option{dumpDepth}
859 ? $option{dumpDepth} : -1,
862 die unless $@ =~ /dumpvar print failed/;
865 print $OUT "dumpvar.pl not available.\n";
869 $cmd =~ s/^x\b/ / && do { # So that will be evaled
870 $onetimeDump = 'dump';
871 # handle special "x 3 blah" syntax
872 if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
873 $onetimedumpDepth = $1;
876 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
877 methods($1); next CMD};
878 $cmd =~ s/^m\b/ / && do { # So this will be evaled
879 $onetimeDump = 'methods'; };
880 $cmd =~ /^f\b\s*(.*)/ && do {
884 print $OUT "The old f command is now the r command.\n"; # hint
885 print $OUT "The new f command switches filenames.\n";
888 if (!defined $main::{'_<' . $file}) {
889 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
890 $try = substr($try,2);
891 print $OUT "Choosing $try matching `$file':\n";
895 if (!defined $main::{'_<' . $file}) {
896 print $OUT "No file matching `$file' is loaded.\n";
898 } elsif ($file ne $filename) {
899 *dbline = $main::{'_<' . $file};
905 print $OUT "Already in $file.\n";
909 $cmd =~ /^\.$/ && do {
910 $incr = -1; # for backward motion.
912 $filename = $filename_ini;
913 *dbline = $main::{'_<' . $filename};
915 print_lineinfo($position);
917 $cmd =~ /^-$/ && do {
918 $start -= $incr + $window + 1;
919 $start = 1 if $start <= 0;
921 $cmd = 'l ' . ($start) . '+'; };
923 $cmd =~ /^([aAbBhlLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
924 &cmd_wrapper($1, $2, $line);
927 # rjsf <- pre|post commands stripped out
928 $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
929 eval { require PadWalker; PadWalker->VERSION(0.08) }
930 or &warn($@ =~ /locate/
931 ? "PadWalker module not found - please install\n"
934 do 'dumpvar.pl' unless defined &main::dumpvar;
935 defined &main::dumpvar
936 or print $OUT "dumpvar.pl not available.\n"
938 my @vars = split(' ', $2 || '');
939 my $h = eval { PadWalker::peek_my(($1 || 0) + 1) };
940 $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
941 my $savout = select($OUT);
942 dumpvar::dumplex($_, $h->{$_},
943 defined $option{dumpDepth}
944 ? $option{dumpDepth} : -1,
949 $cmd =~ /^n$/ && do {
950 end_report(), next CMD if $finished and $level <= 1;
954 $cmd =~ /^s$/ && do {
955 end_report(), next CMD if $finished and $level <= 1;
959 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
960 end_report(), next CMD if $finished and $level <= 1;
962 # Probably not needed, since we finish an interactive
963 # sub-session anyway...
964 # local $filename = $filename;
965 # local *dbline = *dbline; # XXX Would this work?!
966 if ($subname =~ /\D/) { # subroutine name
967 $subname = $package."::".$subname
968 unless $subname =~ /::/;
969 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
973 *dbline = $main::{'_<' . $filename};
974 $had_breakpoints{$filename} |= 1;
976 ++$i while $dbline[$i] == 0 && $i < $max;
978 print $OUT "Subroutine $subname not found.\n";
983 if ($dbline[$i] == 0) {
984 print $OUT "Line $i not breakable.\n";
987 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
989 for ($i=0; $i <= $stack_depth; ) {
993 $cmd =~ /^r$/ && do {
994 end_report(), next CMD if $finished and $level <= 1;
995 $stack[$stack_depth] |= 1;
996 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
998 $cmd =~ /^R$/ && do {
999 print $OUT "Warning: some settings and command-line options may be lost!\n";
1000 my (@script, @flags, $cl);
1001 push @flags, '-w' if $ini_warn;
1002 if ($ini_assertion and @{^ASSERTING}) {
1003 push @flags, (map { /\:\^\(\?\:(.*)\)\$\)/ ?
1004 "-A$1" : "-A$_" } @{^ASSERTING});
1006 # Put all the old includes at the start to get
1007 # the same debugger.
1009 push @flags, '-I', $_;
1011 push @flags, '-T' if ${^TAINT};
1012 # Arrange for setting the old INC:
1013 set_list("PERLDB_INC", @ini_INC);
1015 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1016 chomp ($cl = ${'::_<-e'}[$_]);
1017 push @script, '-e', $cl;
1022 set_list("PERLDB_HIST",
1023 $term->Features->{getHistory}
1024 ? $term->GetHistory : @hist);
1025 my @had_breakpoints = keys %had_breakpoints;
1026 set_list("PERLDB_VISITED", @had_breakpoints);
1027 set_list("PERLDB_OPT", options2remember());
1028 set_list("PERLDB_ON_LOAD", %break_on_load);
1030 for (0 .. $#had_breakpoints) {
1031 my $file = $had_breakpoints[$_];
1032 *dbline = $main::{'_<' . $file};
1033 next unless %dbline or $postponed_file{$file};
1034 (push @hard, $file), next
1035 if $file =~ /^\(\w*eval/;
1037 @add = %{$postponed_file{$file}}
1038 if $postponed_file{$file};
1039 set_list("PERLDB_FILE_$_", %dbline, @add);
1041 for (@hard) { # Yes, really-really...
1042 # Find the subroutines in this eval
1043 *dbline = $main::{'_<' . $_};
1044 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1045 for $sub (keys %sub) {
1046 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1047 $subs{$sub} = [$1, $2];
1051 "No subroutines in $_, ignoring breakpoints.\n";
1054 LINES: for $line (keys %dbline) {
1055 # One breakpoint per sub only:
1056 my ($offset, $sub, $found);
1057 SUBS: for $sub (keys %subs) {
1058 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1059 and (not defined $offset # Not caught
1060 or $offset < 0 )) { # or badly caught
1062 $offset = $line - $subs{$sub}->[0];
1063 $offset = "+$offset", last SUBS if $offset >= 0;
1066 if (defined $offset) {
1067 $postponed{$found} =
1068 "break $offset if $dbline{$line}";
1070 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1074 set_list("PERLDB_POSTPONE", %postponed);
1075 set_list("PERLDB_PRETYPE", @$pretype);
1076 set_list("PERLDB_PRE", @$pre);
1077 set_list("PERLDB_POST", @$post);
1078 set_list("PERLDB_TYPEAHEAD", @typeahead);
1079 $ENV{PERLDB_RESTART} = 1;
1080 delete $ENV{PERLDB_PIDS}; # Restore ini state
1081 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1082 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1083 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1084 print $OUT "exec failed: $!\n";
1086 $cmd =~ /^T$/ && do {
1087 print_trace($OUT, 1); # skip DB
1089 $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; };
1090 $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W('W', $1); next CMD; };
1091 $cmd =~ /^\/(.*)$/ && do {
1093 $inpat =~ s:([^\\])/$:$1:;
1095 # squelch the sigmangler
1096 local $SIG{__DIE__};
1097 local $SIG{__WARN__};
1098 eval '$inpat =~ m'."\a$inpat\a";
1110 $start = 1 if ($start > $max);
1111 last if ($start == $end);
1112 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1113 if ($slave_editor) {
1114 print $OUT "\032\032$filename:$start:0\n";
1116 print $OUT "$start:\t", $dbline[$start], "\n";
1121 print $OUT "/$pat/: not found\n" if ($start == $end);
1123 $cmd =~ /^\?(.*)$/ && do {
1125 $inpat =~ s:([^\\])\?$:$1:;
1127 # squelch the sigmangler
1128 local $SIG{__DIE__};
1129 local $SIG{__WARN__};
1130 eval '$inpat =~ m'."\a$inpat\a";
1142 $start = $max if ($start <= 0);
1143 last if ($start == $end);
1144 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1145 if ($slave_editor) {
1146 print $OUT "\032\032$filename:$start:0\n";
1148 print $OUT "$start:\t", $dbline[$start], "\n";
1153 print $OUT "?$pat?: not found\n" if ($start == $end);
1155 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1156 pop(@hist) if length($cmd) > 1;
1157 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1159 print $OUT $cmd, "\n";
1161 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1164 $cmd =~ /^$rc([^$rc].*)$/ && do {
1166 pop(@hist) if length($cmd) > 1;
1167 for ($i = $#hist; $i; --$i) {
1168 last if $hist[$i] =~ /$pat/;
1171 print $OUT "No such command!\n\n";
1175 print $OUT $cmd, "\n";
1177 $cmd =~ /^$sh$/ && do {
1178 &system($ENV{SHELL}||"/bin/sh");
1180 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1181 # XXX: using csh or tcsh destroys sigint retvals!
1182 #&system($1); # use this instead
1183 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1185 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1186 $end = $2 ? ($#hist-$2) : 0;
1187 $hist = 0 if $hist < 0;
1188 for ($i=$#hist; $i>$end; $i--) {
1189 print $OUT "$i: ",$hist[$i],"\n"
1190 unless $hist[$i] =~ /^.?$/;
1193 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1196 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1197 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1198 $cmd =~ s/^=\s*// && do {
1200 if (length $cmd == 0) {
1201 @keys = sort keys %alias;
1202 } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1203 # can't use $_ or kill //g state
1204 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1205 $alias{$k} = "s\a$k\a$v\a";
1206 # squelch the sigmangler
1207 local $SIG{__DIE__};
1208 local $SIG{__WARN__};
1209 unless (eval "sub { s\a$k\a$v\a }; 1") {
1210 print $OUT "Can't alias $k to $v: $@\n";
1219 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1220 print $OUT "$k\t= $1\n";
1222 elsif (defined $alias{$k}) {
1223 print $OUT "$k\t$alias{$k}\n";
1226 print "No alias for $k\n";
1230 $cmd =~ /^source\s+(.*\S)/ && do {
1231 if (open my $fh, $1) {
1234 &warn("Can't execute `$1': $!\n");
1237 $cmd =~ /^\|\|?\s*[^|]/ && do {
1238 if ($pager =~ /^\|/) {
1239 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1240 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1242 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1245 unless ($piped=open(OUT,$pager)) {
1246 &warn("Can't pipe output to `$pager'");
1247 if ($pager =~ /^\|/) {
1248 open(OUT,">&STDOUT") # XXX: lost message
1249 || &warn("Can't restore DB::OUT");
1250 open(STDOUT,">&SAVEOUT")
1251 || &warn("Can't restore STDOUT");
1254 open(OUT,">&STDOUT") # XXX: lost message
1255 || &warn("Can't restore DB::OUT");
1259 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1260 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1261 $selected= select(OUT);
1263 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1264 $cmd =~ s/^\|+\s*//;
1267 # XXX Local variants do not work!
1268 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1269 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1270 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1272 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1274 $onetimeDump = undef;
1275 $onetimedumpDepth = undef;
1276 } elsif ($term_pid == $$) {
1283 if ($pager =~ /^\|/) {
1285 # we cannot warn here: the handle is missing --tchrist
1286 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1288 # most of the $? crud was coping with broken cshisms
1290 print SAVEOUT "Pager `$pager' failed: ";
1292 print SAVEOUT "shell returned -1\n";
1295 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1296 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1298 print SAVEOUT "status ", ($? >> 8), "\n";
1302 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1303 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1304 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1305 # Will stop ignoring SIGPIPE if done like nohup(1)
1306 # does SIGINT but Perl doesn't give us a choice.
1308 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1311 select($selected), $selected= "" unless $selected eq "";
1315 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1316 foreach $evalarg (@$post) {
1319 } # if ($single || $signal)
1320 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1324 # The following code may be executed now:
1328 my ($al, $ret, @ret) = "";
1329 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1332 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1333 $#stack = $stack_depth;
1334 $stack[-1] = $single;
1336 $single |= 4 if $stack_depth == $deep;
1338 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1339 # Why -1? But it works! :-(
1340 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1341 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1350 $signal=1 unless $warnassertions;
1356 $single |= $stack[$stack_depth--];
1358 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1359 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1360 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1361 if ($doret eq $stack_depth or $frame & 16) {
1363 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1364 print $fh ' ' x $stack_depth if $frame & 16;
1365 print $fh "list context return from $sub:\n";
1366 dumpit($fh, \@ret );
1378 $signal=1 unless $warnassertions;
1380 $ret=undef unless defined wantarray;
1383 if (defined wantarray) {
1389 $single |= $stack[$stack_depth--];
1391 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1392 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1393 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1394 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1396 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1397 print $fh (' ' x $stack_depth) if $frame & 16;
1398 print $fh (defined wantarray
1399 ? "scalar context return from $sub: "
1400 : "void context return from $sub\n");
1401 dumpit( $fh, $ret ) if defined wantarray;
1410 ### Functions with multiple modes of failure die on error, the rest
1411 ### returns FALSE on error.
1412 ### User-interface functions cmd_* output error message.
1414 ### Note all cmd_[a-zA-Z]'s require $cmd, $line, $dblineno as first arguments
1419 'A' => 'pre580_null',
1421 'B' => 'pre580_null',
1422 'd' => 'pre580_null',
1425 'M' => 'pre580_null',
1427 'o' => 'pre580_null',
1433 '<' => 'pre590_prepost',
1434 '<<' => 'pre590_prepost',
1435 '>' => 'pre590_prepost',
1436 '>>' => 'pre590_prepost',
1437 '{' => 'pre590_prepost',
1438 '{{' => 'pre590_prepost',
1445 my $dblineno = shift;
1447 # with this level of indirection we can wrap
1448 # to old (pre580) or other command sets easily
1451 $set{$CommandSet}{$cmd} || ($cmd =~ /^[<>{]+/o ? 'prepost' : $cmd)
1453 # print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
1455 return &$call($cmd, $line, $dblineno);
1459 my $cmd = shift; # a
1460 my $line = shift || ''; # [.|line] expr
1461 my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
1462 if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
1463 my ($lineno, $expr) = ($1, $2);
1465 if ($dbline[$lineno] == 0) {
1466 print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
1468 $had_breakpoints{$filename} |= 2;
1469 $dbline{$lineno} =~ s/\0[^\0]*//;
1470 $dbline{$lineno} .= "\0" . action($expr);
1474 print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
1479 my $cmd = shift; # A
1480 my $line = shift || '';
1481 my $dbline = shift; $line =~ s/^\./$dbline/;
1483 eval { &delete_action(); 1 } or print $OUT $@ and return;
1484 } elsif ($line =~ /^(\S.*)/) {
1485 eval { &delete_action($1); 1 } or print $OUT $@ and return;
1487 print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
1494 die "Line $i has no action .\n" if $dbline[$i] == 0;
1495 $dbline{$i} =~ s/\0[^\0]*//; # \^a
1496 delete $dbline{$i} if $dbline{$i} eq '';
1498 print $OUT "Deleting all actions...\n";
1499 for my $file (keys %had_breakpoints) {
1500 local *dbline = $main::{'_<' . $file};
1503 for ($i = 1; $i <= $max ; $i++) {
1504 if (defined $dbline{$i}) {
1505 $dbline{$i} =~ s/\0[^\0]*//;
1506 delete $dbline{$i} if $dbline{$i} eq '';
1508 unless ($had_breakpoints{$file} &= ~2) {
1509 delete $had_breakpoints{$file};
1517 my $cmd = shift; # b
1518 my $line = shift; # [.|line] [cond]
1519 my $dbline = shift; $line =~ s/^\./$dbline/;
1520 if ($line =~ /^\s*$/) {
1521 &cmd_b_line($dbline, 1);
1522 } elsif ($line =~ /^load\b\s*(.*)/) {
1523 my $file = $1; $file =~ s/\s+$//;
1525 } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
1526 my $cond = length $3 ? $3 : '1';
1527 my ($subname, $break) = ($2, $1 eq 'postpone');
1528 $subname =~ s/\'/::/g;
1529 $subname = "${'package'}::" . $subname unless $subname =~ /::/;
1530 $subname = "main".$subname if substr($subname,0,2) eq "::";
1531 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
1532 } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
1534 $cond = length $2 ? $2 : '1';
1535 &cmd_b_sub($subname, $cond);
1536 } elsif ($line =~ /^(\d*)\s*(.*)/) {
1537 $line = $1 || $dbline;
1538 $cond = length $2 ? $2 : '1';
1539 &cmd_b_line($line, $cond);
1541 print "confused by line($line)?\n";
1547 $break_on_load{$file} = 1;
1548 $had_breakpoints{$file} |= 1;
1551 sub report_break_on_load {
1552 sort keys %break_on_load;
1560 push @files, $::INC{$file} if $::INC{$file};
1561 $file .= '.pm', redo unless $file =~ /\./;
1563 break_on_load($_) for @files;
1564 @files = report_break_on_load;
1567 print $OUT "Will stop on load of `@files'.\n";
1570 $filename_error = '';
1572 sub breakable_line {
1573 my ($from, $to) = @_;
1576 my $delta = $from < $to ? +1 : -1;
1577 my $limit = $delta > 0 ? $#dbline : 1;
1578 $limit = $to if ($limit - $to) * $delta > 0;
1579 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1581 return $i unless $dbline[$i] == 0;
1582 my ($pl, $upto) = ('', '');
1583 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1584 die "Line$pl $from$upto$filename_error not breakable\n";
1587 sub breakable_line_in_filename {
1589 local *dbline = $main::{'_<' . $f};
1590 local $filename_error = " of `$f'";
1595 my ($i, $cond) = @_;
1596 $cond = 1 unless @_ >= 2;
1600 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1601 $had_breakpoints{$filename} |= 1;
1602 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1603 else { $dbline{$i} = $cond; }
1607 eval { break_on_line(@_); 1 } or do {
1609 print $OUT $@ and return;
1613 sub break_on_filename_line {
1614 my ($f, $i, $cond) = @_;
1615 $cond = 1 unless @_ >= 3;
1616 local *dbline = $main::{'_<' . $f};
1617 local $filename_error = " of `$f'";
1618 local $filename = $f;
1619 break_on_line($i, $cond);
1622 sub break_on_filename_line_range {
1623 my ($f, $from, $to, $cond) = @_;
1624 my $i = breakable_line_in_filename($f, $from, $to);
1625 $cond = 1 unless @_ >= 3;
1626 break_on_filename_line($f,$i,$cond);
1629 sub subroutine_filename_lines {
1630 my ($subname,$cond) = @_;
1631 # Filename below can contain ':'
1632 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1635 sub break_subroutine {
1636 my $subname = shift;
1637 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1638 die "Subroutine $subname not found.\n";
1639 $cond = 1 unless @_ >= 2;
1640 break_on_filename_line_range($file,$s,$e,@_);
1644 my ($subname,$cond) = @_;
1645 $cond = 1 unless @_ >= 2;
1646 unless (ref $subname eq 'CODE') {
1647 $subname =~ s/\'/::/g;
1649 $subname = "${'package'}::" . $subname
1650 unless $subname =~ /::/;
1651 $subname = "CORE::GLOBAL::$s"
1652 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1653 $subname = "main".$subname if substr($subname,0,2) eq "::";
1655 eval { break_subroutine($subname,$cond); 1 } or do {
1657 print $OUT $@ and return;
1662 my $cmd = shift; # B
1663 my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
1664 my $dbline = shift; $line =~ s/^\./$dbline/;
1666 eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
1667 } elsif ($line =~ /^(\S.*)/) {
1668 eval { &delete_breakpoint($line || $dbline); 1 } or do {
1670 print $OUT $@ and return;
1673 print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
1677 sub delete_breakpoint {
1680 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1681 $dbline{$i} =~ s/^[^\0]*//;
1682 delete $dbline{$i} if $dbline{$i} eq '';
1684 print $OUT "Deleting all breakpoints...\n";
1685 for my $file (keys %had_breakpoints) {
1686 local *dbline = $main::{'_<' . $file};
1689 for ($i = 1; $i <= $max ; $i++) {
1690 if (defined $dbline{$i}) {
1691 $dbline{$i} =~ s/^[^\0]+//;
1692 if ($dbline{$i} =~ s/^\0?$//) {
1697 if (not $had_breakpoints{$file} &= ~1) {
1698 delete $had_breakpoints{$file};
1702 undef %postponed_file;
1703 undef %break_on_load;
1707 sub cmd_stop { # As on ^C, but not signal-safy.
1712 my $cmd = shift; # h
1713 my $line = shift || '';
1714 if ($line =~ /^h\s*/) {
1716 } elsif ($line =~ /^(\S.*)$/) {
1717 # support long commands; otherwise bogus errors
1718 # happen when you ask for h on <CR> for example
1719 my $asked = $1; # for proper errmsg
1720 my $qasked = quotemeta($asked); # for searching
1721 # XXX: finds CR but not <CR>
1722 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
1723 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
1727 print_help("B<$asked> is not a debugger command.\n");
1730 print_help($summary);
1735 my $current_line = $line;
1736 my $cmd = shift; # l
1738 $line =~ s/^-\s*$/-/;
1739 if ($line =~ /^(\$.*)/s) {
1742 print($OUT "Error: $@\n"), next CMD if $@;
1744 print($OUT "Interpreted as: $1 $s\n");
1747 } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
1748 my $s = $subname = $1;
1749 $subname =~ s/\'/::/;
1750 $subname = $package."::".$subname
1751 unless $subname =~ /::/;
1752 $subname = "CORE::GLOBAL::$s"
1753 if not defined &$subname and $s !~ /::/
1754 and defined &{"CORE::GLOBAL::$s"};
1755 $subname = "main".$subname if substr($subname,0,2) eq "::";
1756 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
1757 $subrange = pop @pieces;
1758 $file = join(':', @pieces);
1759 if ($file ne $filename) {
1760 print $OUT "Switching to file '$file'.\n"
1761 unless $slave_editor;
1762 *dbline = $main::{'_<' . $file};
1767 if (eval($subrange) < -$window) {
1768 $subrange =~ s/-.*/+/;
1771 &cmd_l('l', $subrange);
1773 print $OUT "Subroutine $subname not found.\n";
1775 } elsif ($line =~ /^\s*$/) {
1776 $incr = $window - 1;
1777 $line = $start . '-' . ($start + $incr);
1779 } elsif ($line =~ /^(\d*)\+(\d*)$/) {
1782 $incr = $window - 1 unless $incr;
1783 $line = $start . '-' . ($start + $incr);
1785 } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
1786 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
1787 $end = $max if $end > $max;
1789 $i = $line if $i eq '.';
1792 if ($slave_editor) {
1793 print $OUT "\032\032$filename:$i:0\n";
1796 for (; $i <= $end; $i++) {
1798 ($stop,$action) = split(/\0/, $dbline{$i}) if
1800 $arrow = ($i==$current_line
1801 and $filename eq $filename_ini)
1803 : ($dbline[$i]+0 ? ':' : ' ') ;
1804 $arrow .= 'b' if $stop;
1805 $arrow .= 'a' if $action;
1806 print $OUT "$i$arrow\t", $dbline[$i];
1807 $i++, last if $signal;
1809 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
1811 $start = $i; # remember in case they want more
1812 $start = $max if $start > $max;
1817 my $cmd = shift; # L
1818 my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
1819 my $action_wanted = ($arg =~ /a/) ? 1 : 0;
1820 my $break_wanted = ($arg =~ /b/) ? 1 : 0;
1821 my $watch_wanted = ($arg =~ /w/) ? 1 : 0;
1823 if ($break_wanted or $action_wanted) {
1824 for my $file (keys %had_breakpoints) {
1825 local *dbline = $main::{'_<' . $file};
1828 for ($i = 1; $i <= $max; $i++) {
1829 if (defined $dbline{$i}) {
1830 print $OUT "$file:\n" unless $was++;
1831 print $OUT " $i:\t", $dbline[$i];
1832 ($stop,$action) = split(/\0/, $dbline{$i});
1833 print $OUT " break if (", $stop, ")\n"
1834 if $stop and $break_wanted;
1835 print $OUT " action: ", $action, "\n"
1836 if $action and $action_wanted;
1842 if (%postponed and $break_wanted) {
1843 print $OUT "Postponed breakpoints in subroutines:\n";
1845 for $subname (keys %postponed) {
1846 print $OUT " $subname\t$postponed{$subname}\n";
1850 my @have = map { # Combined keys
1851 keys %{$postponed_file{$_}}
1852 } keys %postponed_file;
1853 if (@have and ($break_wanted or $action_wanted)) {
1854 print $OUT "Postponed breakpoints in files:\n";
1856 for $file (keys %postponed_file) {
1857 my $db = $postponed_file{$file};
1858 print $OUT " $file:\n";
1859 for $line (sort {$a <=> $b} keys %$db) {
1860 print $OUT " $line:\n";
1861 my ($stop,$action) = split(/\0/, $$db{$line});
1862 print $OUT " break if (", $stop, ")\n"
1863 if $stop and $break_wanted;
1864 print $OUT " action: ", $action, "\n"
1865 if $action and $action_wanted;
1871 if (%break_on_load and $break_wanted) {
1872 print $OUT "Breakpoints on load:\n";
1874 for $file (keys %break_on_load) {
1875 print $OUT " $file\n";
1879 if ($watch_wanted) {
1881 print $OUT "Watch-expressions:\n" if @to_watch;
1882 for my $expr (@to_watch) {
1883 print $OUT " $expr\n";
1895 my $cmd = shift; # o
1896 my $opt = shift || ''; # opt[=val]
1897 if ($opt =~ /^(\S.*)/) {
1907 print $OUT "The old O command is now the o command.\n"; # hint
1908 print $OUT "Use 'h' to get current command help synopsis or\n"; #
1909 print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; #
1913 my $cmd = shift; # v
1916 if ($line =~ /^(\d*)$/) {
1917 $incr = $window - 1;
1920 $line = $start . '-' . ($start + $incr);
1926 my $cmd = shift; # w
1927 my $expr = shift || '';
1928 if ($expr =~ /^(\S.*)/) {
1929 push @to_watch, $expr;
1931 my ($val) = join(' ', &eval);
1932 $val = (defined $val) ? "'$val'" : 'undef' ;
1933 push @old_watch, $val;
1936 print $OUT "Adding a watch-expression requires an expression\n"; # hint
1941 my $cmd = shift; # W
1942 my $expr = shift || '';
1945 print $OUT "Deleting all watch expressions ...\n";
1946 @to_watch = @old_watch = ();
1947 } elsif ($expr =~ /^(\S.*)/) {
1949 foreach (@to_watch) {
1950 my $val = $to_watch[$i_cnt];
1951 if ($val eq $expr) { # =~ m/^\Q$i$/) {
1952 splice(@to_watch, $i_cnt, 1);
1957 print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
1964 if ($cmd =~ /^.\b\s*([+-]?)\s*(~?)\s*(\w+(\s*\|\s*\w+)*)\s*$/) {
1965 my ($how, $neg, $flags)=($1, $2, $3);
1966 my $acu=parse_DollarCaretP_flags($flags);
1968 $acu= ~$acu if $neg;
1969 if ($how eq '+') { $^P|=$acu }
1970 elsif ($how eq '-') { $^P&=~$acu }
1973 # else { print $OUT "undefined acu\n" }
1975 my $expanded=expand_DollarCaretP_flags($^P);
1976 print $OUT "Internal Perl debugger flags:\n\$^P=$expanded\n";
1980 ### END of the API section
1983 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1984 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1987 sub print_lineinfo {
1988 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1994 # The following takes its argument via $evalarg to preserve current @_
1997 my $subname = shift;
1998 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1999 my $offset = $1 || 0;
2000 # Filename below can contain ':'
2001 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
2004 local *dbline = $main::{'_<' . $file};
2005 local $^W = 0; # != 0 is magical below
2006 $had_breakpoints{$file} |= 1;
2008 ++$i until $dbline[$i] != 0 or $i >= $max;
2009 $dbline{$i} = delete $postponed{$subname};
2012 print $OUT "Subroutine $subname not found.\n";
2016 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
2017 #print $OUT "In postponed_sub for `$subname'.\n";
2021 if ($ImmediateStop) {
2025 return &postponed_sub
2026 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
2027 # Cannot be done before the file is compiled
2028 local *dbline = shift;
2029 my $filename = $dbline;
2030 $filename =~ s/^_<//;
2032 $signal = 1, print $OUT "'$filename' loaded...\n"
2033 if $break_on_load{$filename};
2034 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
2035 return unless $postponed_file{$filename};
2036 $had_breakpoints{$filename} |= 1;
2037 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
2039 for $key (keys %{$postponed_file{$filename}}) {
2040 $dbline{$key} = ${$postponed_file{$filename}}{$key};
2042 delete $postponed_file{$filename};
2046 local ($savout) = select(shift);
2047 my $osingle = $single;
2048 my $otrace = $trace;
2049 $single = $trace = 0;
2052 unless (defined &main::dumpValue) {
2055 if (defined &main::dumpValue) {
2060 my $maxdepth = shift || $option{dumpDepth};
2061 $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
2062 &main::dumpValue($v, $maxdepth);
2065 print $OUT "dumpvar.pl not available.\n";
2072 # Tied method do not create a context, so may get wrong message:
2077 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
2078 my @sub = dump_trace($_[0] + 1, $_[1]);
2079 my $short = $_[2]; # Print short report, next one for sub name
2081 for ($i=0; $i <= $#sub; $i++) {
2084 my $args = defined $sub[$i]{args}
2085 ? "(@{ $sub[$i]{args} })"
2087 $args = (substr $args, 0, $maxtrace - 3) . '...'
2088 if length $args > $maxtrace;
2089 my $file = $sub[$i]{file};
2090 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
2092 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
2094 my $sub = @_ >= 4 ? $_[3] : $s;
2095 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
2097 print $fh "$sub[$i]{context} = $s$args" .
2098 " called from $file" .
2099 " line $sub[$i]{line}\n";
2106 my $count = shift || 1e9;
2109 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
2110 my $nothard = not $frame & 8;
2111 local $frame = 0; # Do not want to trace this.
2112 my $otrace = $trace;
2115 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
2120 if (not defined $arg) {
2122 } elsif ($nothard and tied $arg) {
2124 } elsif ($nothard and $type = ref $arg) {
2125 push @a, "ref($type)";
2127 local $_ = "$arg"; # Safe to stringify now - should not call f().
2130 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
2131 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
2132 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
2136 $context = $context ? '@' : (defined $context ? "\$" : '.');
2137 $args = $h ? [@a] : undef;
2138 $e =~ s/\n\s*\;\s*\Z// if $e;
2139 $e =~ s/([\\\'])/\\$1/g if $e;
2141 $sub = "require '$e'";
2142 } elsif (defined $r) {
2144 } elsif ($sub eq '(eval)') {
2145 $sub = "eval {...}";
2147 push(@sub, {context => $context, sub => $sub, args => $args,
2148 file => $file, line => $line});
2157 while ($action =~ s/\\$//) {
2166 # i hate using globals!
2167 $balanced_brace_re ||= qr{
2170 (?> [^{}] + ) # Non-parens without backtracking
2172 (??{ $balanced_brace_re }) # Group with matching parens
2176 return $_[0] !~ m/$balanced_brace_re/;
2180 &readline("cont: ");
2184 # We save, change, then restore STDIN and STDOUT to avoid fork() since
2185 # some non-Unix systems can do system() but have problems with fork().
2186 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
2187 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
2188 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
2189 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
2191 # XXX: using csh or tcsh destroys sigint retvals!
2193 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
2194 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
2199 # most of the $? crud was coping with broken cshisms
2201 &warn("(Command exited ", ($? >> 8), ")\n");
2203 &warn( "(Command died of SIG#", ($? & 127),
2204 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
2214 eval { require Term::ReadLine } or die $@;
2217 my ($i, $o) = split $tty, /,/;
2218 $o = $i unless defined $o;
2219 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
2220 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
2223 my $sel = select($OUT);
2227 eval "require Term::Rendezvous;" or die;
2228 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
2229 my $term_rv = new Term::Rendezvous $rv;
2231 $OUT = $term_rv->OUT;
2234 if ($term_pid eq '-1') { # In a TTY with another debugger
2238 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2240 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2242 $rl_attribs = $term->Attribs;
2243 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2244 if defined $rl_attribs->{basic_word_break_characters}
2245 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2246 $rl_attribs->{special_prefixes} = '$@&%';
2247 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2248 $rl_attribs->{completion_function} = \&db_complete;
2250 $LINEINFO = $OUT unless defined $LINEINFO;
2251 $lineinfo = $console unless defined $lineinfo;
2253 if ($term->Features->{setHistory} and "@hist" ne "?") {
2254 $term->SetHistory(@hist);
2256 ornaments($ornaments) if defined $ornaments;
2260 # Example get_fork_TTY functions
2261 sub xterm_get_fork_TTY {
2262 (my $name = $0) =~ s,^.*[/\\],,s;
2263 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2267 $pidprompt = ''; # Shown anyway in titlebar
2271 # This example function resets $IN, $OUT itself
2272 sub os2_get_fork_TTY {
2273 local $^F = 40; # XXXX Fixme!
2275 my ($in1, $out1, $in2, $out2);
2276 # Having -d in PERL5OPT would lead to a disaster...
2277 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2278 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2279 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2280 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2281 local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB};
2282 $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB};
2283 $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB};
2284 (my $name = $0) =~ s,^.*[/\\],,s;
2286 if ( pipe $in1, $out1 and pipe $in2, $out2
2287 # system P_SESSION will fail if there is another process
2288 # in the same session with a "dependent" asynchronous child session.
2289 and @args = ($rl, fileno $in1, fileno $out2,
2290 "Daughter Perl debugger $pids $name") and
2291 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2292 END {sleep 5 unless $loaded}
2293 BEGIN {open STDIN, '</dev/con' or warn "reopen stdin: $!"}
2296 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2298 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2299 open IN, '<&=$in' or die "open <&=$in: \$!";
2300 \$| = 1; print while sysread IN, \$_, 1<<16;
2304 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2306 require Term::ReadKey if $rl;
2307 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2308 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2310 or warn "system P_SESSION: $!, $^E" and 0)
2311 and close $in1 and close $out2 ) {
2312 $pidprompt = ''; # Shown anyway in titlebar
2313 reset_IN_OUT($in2, $out1);
2315 return ''; # Indicate that reset_IN_OUT is called
2320 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2321 my $in = &get_fork_TTY if defined &get_fork_TTY;
2322 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2323 if (not defined $in) {
2325 print_help(<<EOP) if $why == 1;
2326 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2328 print_help(<<EOP) if $why == 2;
2329 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2330 This may be an asynchronous session, so the parent debugger may be active.
2332 print_help(<<EOP) if $why != 4;
2333 Since two debuggers fight for the same TTY, input is severely entangled.
2337 I know how to switch the output to a different window in xterms
2338 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2339 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2341 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2342 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2345 } elsif ($in ne '') {
2348 $console = ''; # Indicate no need to open-from-the-console
2353 sub resetterm { # We forked, so we need a different TTY
2355 my $systemed = $in > 1 ? '-' : '';
2357 $pids =~ s/\]/$systemed->$$]/;
2359 $pids = "[$term_pid->$$]";
2363 return unless $CreateTTY & $in;
2370 my $left = @typeahead;
2371 my $got = shift @typeahead;
2373 print $OUT "auto(-$left)", shift, $got, "\n";
2374 $term->AddHistory($got)
2375 if length($got) > 1 and defined $term->Features->{addHistory};
2381 my $line = CORE::readline($cmdfhs[-1]);
2382 defined $line ? (print $OUT ">> $line" and return $line)
2383 : close pop @cmdfhs;
2385 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2386 $OUT->write(join('', @_));
2388 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2392 $term->readline(@_);
2397 my ($opt, $val)= @_;
2398 $val = option_val($opt,'N/A');
2399 $val =~ s/([\\\'])/\\$1/g;
2400 printf $OUT "%20s = '%s'\n", $opt, $val;
2403 sub options2remember {
2404 foreach my $k (@RememberOnROptions) {
2405 $option{$k}=option_val($k, 'N/A');
2411 my ($opt, $default)= @_;
2413 if (defined $optionVars{$opt}
2414 and defined ${$optionVars{$opt}}) {
2415 $val = ${$optionVars{$opt}};
2416 } elsif (defined $optionAction{$opt}
2417 and defined &{$optionAction{$opt}}) {
2418 $val = &{$optionAction{$opt}}();
2419 } elsif (defined $optionAction{$opt}
2420 and not defined $option{$opt}
2421 or defined $optionVars{$opt}
2422 and not defined ${$optionVars{$opt}}) {
2425 $val = $option{$opt};
2427 $val = $default unless defined $val;
2434 # too dangerous to let intuitive usage overwrite important things
2435 # defaultion should never be the default
2436 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2437 dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2438 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2443 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2444 my ($opt,$sep) = ($1,$2);
2447 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2449 #&dump_option($opt);
2450 } elsif ($sep !~ /\S/) {
2452 $val = "1"; # this is an evil default; make 'em set it!
2453 } elsif ($sep eq "=") {
2454 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2456 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2460 print OUT qq(Option better cleared using $opt=""\n)
2464 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2465 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2466 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2467 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2468 ($val = $1) =~ s/\\([\\$end])/$1/g;
2472 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2473 || grep( /^\Q$opt/i && ($option = $_), @options );
2475 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2476 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2478 if ($opt_needs_val{$option} && $val_defaulted) {
2479 my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
2480 print $OUT "Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
2484 $option{$option} = $val if defined $val;
2489 require '$optionRequire{$option}';
2491 } || die # XXX: shouldn't happen
2492 if defined $optionRequire{$option} &&
2495 ${$optionVars{$option}} = $val
2496 if defined $optionVars{$option} &&
2499 &{$optionAction{$option}} ($val)
2500 if defined $optionAction{$option} &&
2501 defined &{$optionAction{$option}} &&
2505 dump_option($option) unless $OUT eq \*STDERR;
2510 my ($stem,@list) = @_;
2512 $ENV{"${stem}_n"} = @list;
2513 for $i (0 .. $#list) {
2515 $val =~ s/\\/\\\\/g;
2516 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2517 $ENV{"${stem}_$i"} = $val;
2524 my $n = delete $ENV{"${stem}_n"};
2526 for $i (0 .. $n - 1) {
2527 $val = delete $ENV{"${stem}_$i"};
2528 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2536 return; # Put nothing on the stack - malloc/free land!
2540 my($msg)= join("",@_);
2541 $msg .= ": $!\n" unless $msg =~ /\n$/;
2547 my $switch_li = $LINEINFO eq $OUT;
2548 if ($term and $term->Features->{newTTY}) {
2549 ($IN, $OUT) = (shift, shift);
2550 $term->newTTY($IN, $OUT);
2552 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2554 ($IN, $OUT) = (shift, shift);
2556 my $o = select $OUT;
2559 $LINEINFO = $OUT if $switch_li;
2563 if (@_ and $term and $term->Features->{newTTY}) {
2564 my ($in, $out) = shift;
2566 ($in, $out) = split /,/, $in, 2;
2570 open IN, $in or die "cannot open `$in' for read: $!";
2571 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2572 reset_IN_OUT(\*IN,\*OUT);
2575 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2576 # Useful if done through PERLDB_OPTS:
2577 $console = $tty = shift if @_;
2583 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2585 $notty = shift if @_;
2591 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2599 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2601 $remoteport = shift if @_;
2606 if (${$term->Features}{tkRunning}) {
2607 return $term->tkRunning(@_);
2610 print $OUT "tkRunning not supported by current ReadLine package.\n";
2617 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2619 $runnonstop = shift if @_;
2625 &warn("Some flag changes could not take effect until next 'R'!\n") if @_;
2627 $^P = parse_DollarCaretP_flags(shift) if @_;
2628 expand_DollarCaretP_flags($^P)
2631 sub OnlyAssertions {
2633 &warn("Too late to set up OnlyAssertions mode, enabled on next 'R'!\n") if @_;
2636 unless (defined $ini_assertion) {
2638 &warn("Current Perl interpreter doesn't support assertions");
2643 unless ($ini_assertion) {
2644 print "Assertions will be active on next 'R'!\n";
2647 $^P&= ~$DollarCaretP_flags{PERLDBf_SUB};
2648 $^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
2651 $^P|=$DollarCaretP_flags{PERLDBf_SUB};
2654 !($^P & $DollarCaretP_flags{PERLDBf_SUB}) || 0;
2660 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2667 $sh = quotemeta shift;
2668 $sh .= "\\b" if $sh =~ /\w$/;
2672 $psh =~ s/\\(.)/$1/g;
2677 if (defined $term) {
2678 local ($warnLevel,$dieLevel) = (0, 1);
2679 return '' unless $term->Features->{ornaments};
2680 eval { $term->ornaments(@_) } || '';
2688 $rc = quotemeta shift;
2689 $rc .= "\\b" if $rc =~ /\w$/;
2693 $prc =~ s/\\(.)/$1/g;
2698 return $lineinfo unless @_;
2700 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2701 $slave_editor = ($stream =~ /^\|/);
2702 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2703 $LINEINFO = \*LINEINFO;
2704 my $save = select($LINEINFO);
2710 sub list_modules { # versions
2718 s/^Term::ReadLine::readline$/readline/;
2719 if (defined ${ $_ . '::VERSION' }) {
2720 $version{$file} = "${ $_ . '::VERSION' } from ";
2722 $version{$file} .= $INC{$file};
2724 dumpit($OUT,\%version);
2728 # XXX: make sure there are tabs between the command and explanation,
2729 # or print_help will screw up your formatting if you have
2730 # eeevil ornaments enabled. This is an insane mess.
2733 Help is currently only available for the new 580 CommandSet,
2734 if you really want old behaviour, presumably you know what
2738 B<s> [I<expr>] Single step [in I<expr>].
2739 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2740 <B<CR>> Repeat last B<n> or B<s> command.
2741 B<r> Return from current subroutine.
2742 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2743 at the specified position.
2744 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2745 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2746 B<l> I<line> List single I<line>.
2747 B<l> I<subname> List first window of lines from subroutine.
2748 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2749 B<l> List next window of lines.
2750 B<-> List previous window of lines.
2751 B<v> [I<line>] View window around I<line>.
2752 B<.> Return to the executed line.
2753 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2754 I<filename> may be either the full name of the file, or a regular
2755 expression matching the full file name:
2756 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2757 Evals (with saved bodies) are considered to be filenames:
2758 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2759 (in the order of execution).
2760 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2761 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2762 B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions.
2763 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2764 B<t> Toggle trace mode.
2765 B<t> I<expr> Trace through execution of I<expr>.
2766 B<b> Sets breakpoint on current line)
2767 B<b> [I<line>] [I<condition>]
2768 Set breakpoint; I<line> defaults to the current execution line;
2769 I<condition> breaks if it evaluates to true, defaults to '1'.
2770 B<b> I<subname> [I<condition>]
2771 Set breakpoint at first line of subroutine.
2772 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2773 B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
2774 B<b> B<postpone> I<subname> [I<condition>]
2775 Set breakpoint at first line of subroutine after
2777 B<b> B<compile> I<subname>
2778 Stop after the subroutine is compiled.
2779 B<B> [I<line>] Delete the breakpoint for I<line>.
2780 B<B> I<*> Delete all breakpoints.
2781 B<a> [I<line>] I<command>
2782 Set an action to be done before the I<line> is executed;
2783 I<line> defaults to the current execution line.
2784 Sequence is: check for breakpoint/watchpoint, print line
2785 if necessary, do action, prompt user if necessary,
2788 B<A> [I<line>] Delete the action for I<line>.
2789 B<A> I<*> Delete all actions.
2790 B<w> I<expr> Add a global watch-expression.
2792 B<W> I<expr> Delete a global watch-expression.
2793 B<W> I<*> Delete all watch-expressions.
2794 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2795 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2796 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2797 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2798 B<x> I<expr> Evals expression in list context, dumps the result.
2799 B<m> I<expr> Evals expression in list context, prints methods callable
2800 on the first element of the result.
2801 B<m> I<class> Prints methods callable via the given class.
2802 B<M> Show versions of loaded modules.
2803 B<y> [I<n> [I<vars>]] List lexical variables I<n> levels up from current sub
2805 B<<> ? List Perl commands to run before each prompt.
2806 B<<> I<expr> Define Perl command to run before each prompt.
2807 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2808 B<< *> Delete the list of perl commands to run before each prompt.
2809 B<>> ? List Perl commands to run after each prompt.
2810 B<>> I<expr> Define Perl command to run after each prompt.
2811 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2812 B<>>B< *> Delete the list of Perl commands to run after each prompt.
2813 B<{> I<db_command> Define debugger command to run before each prompt.
2814 B<{> ? List debugger commands to run before each prompt.
2815 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2816 B<{ *> Delete the list of debugger commands to run before each prompt.
2817 B<$prc> I<number> Redo a previous command (default previous command).
2818 B<$prc> I<-number> Redo number'th-to-last command.
2819 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2820 See 'B<O> I<recallCommand>' too.
2821 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2822 . ( $rc eq $sh ? "" : "
2823 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2824 See 'B<O> I<shellBang>' too.
2825 B<source> I<file> Execute I<file> containing debugger commands (may nest).
2826 B<H> I<-number> Display last number commands (default all).
2827 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2828 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2829 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2830 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2831 I<command> Execute as a perl statement in current package.
2832 B<R> Pure-man-restart of debugger, some of debugger state
2833 and command-line options may be lost.
2834 Currently the following settings are preserved:
2835 history, breakpoints and actions, debugger B<O>ptions
2836 and the following command-line options: I<-w>, I<-I>, I<-e>.
2838 B<o> [I<opt>] ... Set boolean option to true
2839 B<o> [I<opt>B<?>] Query options
2840 B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2841 Set options. Use quotes in spaces in value.
2842 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2843 I<pager> program for output of \"|cmd\";
2844 I<tkRunning> run Tk while prompting (with ReadLine);
2845 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2846 I<inhibit_exit> Allows stepping off the end of the script.
2847 I<ImmediateStop> Debugger should stop as early as possible.
2848 I<RemotePort> Remote hostname:port for remote debugging
2849 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2850 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2851 I<compactDump>, I<veryCompact> change style of array and hash dump;
2852 I<globPrint> whether to print contents of globs;
2853 I<DumpDBFiles> dump arrays holding debugged files;
2854 I<DumpPackages> dump symbol tables of packages;
2855 I<DumpReused> dump contents of \"reused\" addresses;
2856 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2857 I<bareStringify> Do not print the overload-stringified value;
2858 Other options include:
2859 I<PrintRet> affects printing of return value after B<r> command,
2860 I<frame> affects printing messages on subroutine entry/exit.
2861 I<AutoTrace> affects printing messages on possible breaking points.
2862 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2863 I<ornaments> affects screen appearance of the command line.
2864 I<CreateTTY> bits control attempts to create a new TTY on events:
2865 1: on fork() 2: debugger is started inside debugger
2867 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2868 You can put additional initialization options I<TTY>, I<noTTY>,
2869 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2870 `B<R>' after you set them).
2872 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2873 B<h> Summary of debugger commands.
2874 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2875 B<h h> Long help for debugger commands
2876 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2877 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2878 Set B<\$DB::doccmd> to change viewer.
2880 Type `|h h' for a paged display if this was too hard to read.
2882 "; # Fix balance of vi % matching: }}}}
2884 # note: tabs in the following section are not-so-helpful
2885 $summary = <<"END_SUM";
2886 I<List/search source lines:> I<Control script execution:>
2887 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2888 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2889 B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs
2890 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2891 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2892 B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position
2893 I<Debugger controls:> B<L> List break/watch/actions
2894 B<o> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2895 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2896 B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints
2897 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2898 B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions
2899 B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression
2900 B<h h> Complete help page B<W> I<expr|*> Delete a/all watch exprs
2901 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2902 B<q> or B<^D> Quit B<R> Attempt a restart
2903 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2904 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2905 B<p> I<expr> Print expression (uses script's current package).
2906 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2907 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2908 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2909 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2910 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2912 # ')}}; # Fix balance of vi % matching
2914 # and this is really numb...
2917 B<s> [I<expr>] Single step [in I<expr>].
2918 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2919 <B<CR>> Repeat last B<n> or B<s> command.
2920 B<r> Return from current subroutine.
2921 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2922 at the specified position.
2923 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2924 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2925 B<l> I<line> List single I<line>.
2926 B<l> I<subname> List first window of lines from subroutine.
2927 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2928 B<l> List next window of lines.
2929 B<-> List previous window of lines.
2930 B<w> [I<line>] List window around I<line>.
2931 B<.> Return to the executed line.
2932 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2933 I<filename> may be either the full name of the file, or a regular
2934 expression matching the full file name:
2935 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2936 Evals (with saved bodies) are considered to be filenames:
2937 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2938 (in the order of execution).
2939 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2940 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2941 B<L> List all breakpoints and actions.
2942 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2943 B<t> Toggle trace mode.
2944 B<t> I<expr> Trace through execution of I<expr>.
2945 B<b> [I<line>] [I<condition>]
2946 Set breakpoint; I<line> defaults to the current execution line;
2947 I<condition> breaks if it evaluates to true, defaults to '1'.
2948 B<b> I<subname> [I<condition>]
2949 Set breakpoint at first line of subroutine.
2950 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2951 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2952 B<b> B<postpone> I<subname> [I<condition>]
2953 Set breakpoint at first line of subroutine after
2955 B<b> B<compile> I<subname>
2956 Stop after the subroutine is compiled.
2957 B<d> [I<line>] Delete the breakpoint for I<line>.
2958 B<D> Delete all breakpoints.
2959 B<a> [I<line>] I<command>
2960 Set an action to be done before the I<line> is executed;
2961 I<line> defaults to the current execution line.
2962 Sequence is: check for breakpoint/watchpoint, print line
2963 if necessary, do action, prompt user if necessary,
2965 B<a> [I<line>] Delete the action for I<line>.
2966 B<A> Delete all actions.
2967 B<W> I<expr> Add a global watch-expression.
2968 B<W> Delete all watch-expressions.
2969 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2970 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2971 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2972 B<x> I<expr> Evals expression in list context, dumps the result.
2973 B<m> I<expr> Evals expression in list context, prints methods callable
2974 on the first element of the result.
2975 B<m> I<class> Prints methods callable via the given class.
2977 B<<> ? List Perl commands to run before each prompt.
2978 B<<> I<expr> Define Perl command to run before each prompt.
2979 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2980 B<>> ? List Perl commands to run after each prompt.
2981 B<>> I<expr> Define Perl command to run after each prompt.
2982 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2983 B<{> I<db_command> Define debugger command to run before each prompt.
2984 B<{> ? List debugger commands to run before each prompt.
2985 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2986 B<$prc> I<number> Redo a previous command (default previous command).
2987 B<$prc> I<-number> Redo number'th-to-last command.
2988 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2989 See 'B<O> I<recallCommand>' too.
2990 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2991 . ( $rc eq $sh ? "" : "
2992 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2993 See 'B<O> I<shellBang>' too.
2994 B<source> I<file> Execute I<file> containing debugger commands (may nest).
2995 B<H> I<-number> Display last number commands (default all).
2996 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2997 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2998 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2999 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
3000 I<command> Execute as a perl statement in current package.
3001 B<v> Show versions of loaded modules.
3002 B<R> Pure-man-restart of debugger, some of debugger state
3003 and command-line options may be lost.
3004 Currently the following settings are preserved:
3005 history, breakpoints and actions, debugger B<O>ptions
3006 and the following command-line options: I<-w>, I<-I>, I<-e>.
3008 B<O> [I<opt>] ... Set boolean option to true
3009 B<O> [I<opt>B<?>] Query options
3010 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
3011 Set options. Use quotes in spaces in value.
3012 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
3013 I<pager> program for output of \"|cmd\";
3014 I<tkRunning> run Tk while prompting (with ReadLine);
3015 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
3016 I<inhibit_exit> Allows stepping off the end of the script.
3017 I<ImmediateStop> Debugger should stop as early as possible.
3018 I<RemotePort> Remote hostname:port for remote debugging
3019 The following options affect what happens with B<V>, B<X>, and B<x> commands:
3020 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
3021 I<compactDump>, I<veryCompact> change style of array and hash dump;
3022 I<globPrint> whether to print contents of globs;
3023 I<DumpDBFiles> dump arrays holding debugged files;
3024 I<DumpPackages> dump symbol tables of packages;
3025 I<DumpReused> dump contents of \"reused\" addresses;
3026 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
3027 I<bareStringify> Do not print the overload-stringified value;
3028 Other options include:
3029 I<PrintRet> affects printing of return value after B<r> command,
3030 I<frame> affects printing messages on subroutine entry/exit.
3031 I<AutoTrace> affects printing messages on possible breaking points.
3032 I<maxTraceLen> gives max length of evals/args listed in stack trace.
3033 I<ornaments> affects screen appearance of the command line.
3034 I<CreateTTY> bits control attempts to create a new TTY on events:
3035 1: on fork() 2: debugger is started inside debugger
3037 During startup options are initialized from \$ENV{PERLDB_OPTS}.
3038 You can put additional initialization options I<TTY>, I<noTTY>,
3039 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
3040 `B<R>' after you set them).
3042 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
3043 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
3044 B<h h> Summary of debugger commands.
3045 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
3046 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
3047 Set B<\$DB::doccmd> to change viewer.
3049 Type `|h' for a paged display if this was too hard to read.
3051 "; # Fix balance of vi % matching: }}}}
3053 # note: tabs in the following section are not-so-helpful
3054 $pre580_summary = <<"END_SUM";
3055 I<List/search source lines:> I<Control script execution:>
3056 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
3057 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
3058 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
3059 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
3060 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
3061 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
3062 I<Debugger controls:> B<L> List break/watch/actions
3063 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
3064 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
3065 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
3066 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
3067 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
3068 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
3069 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
3070 B<q> or B<^D> Quit B<R> Attempt a restart
3071 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
3072 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
3073 B<p> I<expr> Print expression (uses script's current package).
3074 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
3075 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
3076 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
3077 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
3078 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
3080 # ')}}; # Fix balance of vi % matching
3087 # Restore proper alignment destroyed by eeevil I<> and B<>
3088 # ornaments: A pox on both their houses!
3090 # A help command will have everything up to and including
3091 # the first tab sequence padded into a field 16 (or if indented 20)
3092 # wide. If it's wider than that, an extra space will be added.
3094 ^ # only matters at start of line
3095 ( \040{4} | \t )* # some subcommands are indented
3096 ( < ? # so <CR> works
3097 [BI] < [^\t\n] + ) # find an eeevil ornament
3098 ( \t+ ) # original separation, discarded
3099 ( .* ) # this will now start (no earlier) than
3102 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
3103 my $clean = $command;
3104 $clean =~ s/[BI]<([^>]*)>/$1/g;
3105 # replace with this whole string:
3106 ($leadwhite ? " " x 4 : "")
3108 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
3113 s{ # handle bold ornaments
3114 B < ( [^>] + | > ) >
3116 $Term::ReadLine::TermCap::rl_term_set[2]
3118 . $Term::ReadLine::TermCap::rl_term_set[3]
3121 s{ # handle italic ornaments
3122 I < ( [^>] + | > ) >
3124 $Term::ReadLine::TermCap::rl_term_set[0]
3126 . $Term::ReadLine::TermCap::rl_term_set[1]
3134 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
3135 my $is_less = $pager =~ /\bless\b/;
3136 if ($pager =~ /\bmore\b/) {
3137 my @st_more = stat('/usr/bin/more');
3138 my @st_less = stat('/usr/bin/less');
3139 $is_less = @st_more && @st_less
3140 && $st_more[0] == $st_less[0]
3141 && $st_more[1] == $st_less[1];
3143 # changes environment!
3144 $ENV{LESS} .= 'r' if $is_less;
3150 $SIG{'ABRT'} = 'DEFAULT';
3151 kill 'ABRT', $$ if $panic++;
3152 if (defined &Carp::longmess) {
3153 local $SIG{__WARN__} = '';
3154 local $Carp::CarpLevel = 2; # mydie + confess
3155 &warn(Carp::longmess("Signal @_"));
3159 print $DB::OUT "Got signal @_\n";
3167 local $SIG{__WARN__} = '';
3168 local $SIG{__DIE__} = '';
3169 eval { require Carp } if defined $^S; # If error/warning during compilation,
3170 # require may be broken.
3171 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
3172 return unless defined &Carp::longmess;
3173 my ($mysingle,$mytrace) = ($single,$trace);
3174 $single = 0; $trace = 0;
3175 my $mess = Carp::longmess(@_);
3176 ($single,$trace) = ($mysingle,$mytrace);
3183 local $SIG{__DIE__} = '';
3184 local $SIG{__WARN__} = '';
3185 my $i = 0; my $ineval = 0; my $sub;
3186 if ($dieLevel > 2) {
3187 local $SIG{__WARN__} = \&dbwarn;
3188 &warn(@_); # Yell no matter what
3191 if ($dieLevel < 2) {
3192 die @_ if $^S; # in eval propagate
3194 # No need to check $^S, eval is much more robust nowadays
3195 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
3196 # require may be broken.
3198 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
3199 unless defined &Carp::longmess;
3201 # We do not want to debug this chunk (automatic disabling works
3202 # inside DB::DB, but not in Carp).
3203 my ($mysingle,$mytrace) = ($single,$trace);
3204 $single = 0; $trace = 0;
3207 package Carp; # Do not include us in the list
3209 $mess = Carp::longmess(@_);
3212 ($single,$trace) = ($mysingle,$mytrace);
3218 $prevwarn = $SIG{__WARN__} unless $warnLevel;
3221 $SIG{__WARN__} = \&DB::dbwarn;
3222 } elsif ($prevwarn) {
3223 $SIG{__WARN__} = $prevwarn;
3232 $prevdie = $SIG{__DIE__} unless $dieLevel;
3235 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
3236 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
3237 print $OUT "Stack dump during die enabled",
3238 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
3240 print $OUT "Dump printed too.\n" if $dieLevel > 2;
3241 } elsif ($prevdie) {
3242 $SIG{__DIE__} = $prevdie;
3243 print $OUT "Default die handler restored.\n";
3251 $prevsegv = $SIG{SEGV} unless $signalLevel;
3252 $prevbus = $SIG{BUS} unless $signalLevel;
3253 $signalLevel = shift;
3255 $SIG{SEGV} = \&DB::diesignal;
3256 $SIG{BUS} = \&DB::diesignal;
3258 $SIG{SEGV} = $prevsegv;
3259 $SIG{BUS} = $prevbus;
3267 my $name = CvGV_name_or_bust($in);
3268 defined $name ? $name : $in;
3271 sub CvGV_name_or_bust {
3273 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
3274 return unless ref $in;
3275 $in = \&$in; # Hard reference...
3276 eval {require Devel::Peek; 1} or return;
3277 my $gv = Devel::Peek::CvGV($in) or return;
3278 *$gv{PACKAGE} . '::' . *$gv{NAME};
3284 return unless defined &$subr;
3285 my $name = CvGV_name_or_bust($subr);
3287 $data = $sub{$name} if defined $name;
3288 return $data if defined $data;
3291 $subr = \&$subr; # Hard reference
3294 $s = $_, last if $subr eq \&$_;
3302 $class = ref $class if ref $class;
3305 methods_via($class, '', 1);
3306 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
3311 return if $packs{$class}++;
3313 my $prepend = $prefix ? "via $prefix: " : '';
3315 for $name (grep {defined &{${"${class}::"}{$_}}}
3316 sort keys %{"${class}::"}) {
3317 next if $seen{ $name }++;
3320 print $DB::OUT "$prepend$name\n";
3322 return unless shift; # Recurse?
3323 for $name (@{"${class}::ISA"}) {
3324 $prepend = $prefix ? $prefix . " -> $name" : $name;
3325 methods_via($name, $prepend, 1);
3330 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
3331 ? "man" # O Happy Day!
3332 : "perldoc"; # Alas, poor unfortunates
3338 &system("$doccmd $doccmd");
3341 # this way user can override, like with $doccmd="man -Mwhatever"
3342 # or even just "man " to disable the path check.
3343 unless ($doccmd eq 'man') {
3344 &system("$doccmd $page");
3348 $page = 'perl' if lc($page) eq 'help';
3351 my $man1dir = $Config::Config{'man1dir'};
3352 my $man3dir = $Config::Config{'man3dir'};
3353 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
3355 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
3356 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
3357 chop $manpath if $manpath;
3358 # harmless if missing, I figure
3359 my $oldpath = $ENV{MANPATH};
3360 $ENV{MANPATH} = $manpath if $manpath;
3361 my $nopathopt = $^O =~ /dunno what goes here/;
3362 if (CORE::system($doccmd,
3363 # I just *know* there are men without -M
3364 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3367 unless ($page =~ /^perl\w/) {
3368 if (grep { $page eq $_ } qw{
3369 5004delta 5005delta amiga api apio book boot bot call compile
3370 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
3371 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
3372 form func guts hack hist hpux intern ipc lexwarn locale lol mod
3373 modinstall modlib number obj op opentut os2 os390 pod port
3374 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
3375 trap unicode var vms win32 xs xstut
3379 CORE::system($doccmd,
3380 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3385 if (defined $oldpath) {
3386 $ENV{MANPATH} = $manpath;
3388 delete $ENV{MANPATH};
3392 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
3394 BEGIN { # This does not compile, alas.
3395 $IN = \*STDIN; # For bugs before DB::OUT has been opened
3396 $OUT = \*STDERR; # For errors before DB::OUT has been opened
3400 $deep = 100; # warning if stack gets this deep
3404 $SIG{INT} = \&DB::catch;
3405 # This may be enabled to debug debugger:
3406 #$warnLevel = 1 unless defined $warnLevel;
3407 #$dieLevel = 1 unless defined $dieLevel;
3408 #$signalLevel = 1 unless defined $signalLevel;
3410 $db_stop = 0; # Compiler warning
3412 $level = 0; # Level of recursive debugging
3413 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
3414 # Triggers bug (?) in perl is we postpone this until runtime:
3415 @postponed = @stack = (0);
3416 $stack_depth = 0; # Localized $#stack
3421 BEGIN {$^W = $ini_warn;} # Switch warnings back
3423 #use Carp; # This did break, left for debugging
3426 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
3427 my($text, $line, $start) = @_;
3428 my ($itext, $search, $prefix, $pack) =
3429 ($text, "^\Q${'package'}::\E([^:]+)\$");
3431 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
3432 (map { /$search/ ? ($1) : () } keys %sub)
3433 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
3434 return sort grep /^\Q$text/, values %INC # files
3435 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
3436 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3437 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
3438 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
3439 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3441 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
3443 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
3444 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
3445 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
3446 # We may want to complete to (eval 9), so $text may be wrong
3447 $prefix = length($1) - length($text);
3450 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
3452 if ((substr $text, 0, 1) eq '&') { # subroutines
3453 $text = substr $text, 1;
3455 return sort map "$prefix$_",
3458 (map { /$search/ ? ($1) : () }
3461 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
3462 $pack = ($1 eq 'main' ? '' : $1) . '::';
3463 $prefix = (substr $text, 0, 1) . $1 . '::';
3466 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
3467 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3468 return db_complete($out[0], $line, $start);
3472 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3473 $pack = ($package eq 'main' ? '' : $package) . '::';
3474 $prefix = substr $text, 0, 1;
3475 $text = substr $text, 1;
3476 my @out = map "$prefix$_", grep /^\Q$text/,
3477 (grep /^_?[a-zA-Z]/, keys %$pack),
3478 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3479 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3480 return db_complete($out[0], $line, $start);
3484 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3485 my @out = grep /^\Q$text/, @options;
3486 my $val = option_val($out[0], undef);
3488 if (not defined $val or $val =~ /[\n\r]/) {
3489 # Can do nothing better
3490 } elsif ($val =~ /\s/) {
3492 foreach $l (split //, qq/\"\'\#\|/) {
3493 $out = "$l$val$l ", last if (index $val, $l) == -1;
3498 # Default to value if one completion, to question if many
3499 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3502 return $term->filename_list($text); # filenames
3507 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3511 if (defined($ini_pids)) {
3512 $ENV{PERLDB_PIDS} = $ini_pids;
3514 delete($ENV{PERLDB_PIDS});
3519 # PERLDBf_... flag names from perl.h
3520 our (%DollarCaretP_flags, %DollarCaretP_flags_r);
3522 %DollarCaretP_flags =
3523 ( PERLDBf_SUB => 0x01, # Debug sub enter/exit
3524 PERLDBf_LINE => 0x02, # Keep line #
3525 PERLDBf_NOOPT => 0x04, # Switch off optimizations
3526 PERLDBf_INTER => 0x08, # Preserve more data
3527 PERLDBf_SUBLINE => 0x10, # Keep subr source lines
3528 PERLDBf_SINGLE => 0x20, # Start with single-step on
3529 PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr
3530 PERLDBf_GOTO => 0x80, # Report goto: call DB::goto
3531 PERLDBf_NAMEEVAL => 0x100, # Informative names for evals
3532 PERLDBf_NAMEANON => 0x200, # Informative names for anon subs
3533 PERLDBf_ASSERTION => 0x400, # Debug assertion subs enter/exit
3534 PERLDB_ALL => 0x33f, # No _NONAME, _GOTO, _ASSERTION
3537 %DollarCaretP_flags_r=reverse %DollarCaretP_flags;
3540 sub parse_DollarCaretP_flags {
3545 foreach my $f (split /\s*\|\s*/, $flags) {
3547 if ($f=~/^0x([[:xdigit:]]+)$/) {
3550 elsif ($f=~/^(\d+)$/) {
3553 elsif ($f=~/^DEFAULT$/i) {
3554 $value=$DollarCaretP_flags{PERLDB_ALL};
3557 $f=~/^(?:PERLDBf_)?(.*)$/i;
3558 $value=$DollarCaretP_flags{'PERLDBf_'.uc($1)};
3559 unless (defined $value) {
3560 print $OUT ("Unrecognized \$^P flag '$f'!\n",
3561 "Acceptable flags are: ".
3562 join(', ', sort keys %DollarCaretP_flags),
3563 ", and hexadecimal and decimal numbers.\n");
3572 sub expand_DollarCaretP_flags {
3573 my $DollarCaretP=shift;
3574 my @bits= ( map { my $n=(1<<$_);
3575 ($DollarCaretP & $n)
3576 ? ($DollarCaretP_flags_r{$n}
3577 || sprintf('0x%x', $n))
3579 return @bits ? join('|', @bits) : 0;
3583 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3584 $fall_off_end = 1 unless $inhibit_exit;
3585 # Do not stop in at_exit() and destructors on exit:
3586 $DB::single = !$fall_off_end && !$runnonstop;
3587 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3591 # ===================================== pre580 ================================
3592 # this is very sad below here...
3595 sub cmd_pre580_null {
3602 if ($cmd =~ /^(\d*)\s*(.*)/) {
3603 $i = $1 || $line; $j = $2;
3605 if ($dbline[$i] == 0) {
3606 print $OUT "Line $i may not have an action.\n";
3608 $had_breakpoints{$filename} |= 2;
3609 $dbline{$i} =~ s/\0[^\0]*//;
3610 $dbline{$i} .= "\0" . action($j);
3613 $dbline{$i} =~ s/\0[^\0]*//;
3614 delete $dbline{$i} if $dbline{$i} eq '';
3623 if ($cmd =~ /^load\b\s*(.*)/) {
3624 my $file = $1; $file =~ s/\s+$//;
3626 } elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
3627 my $cond = length $3 ? $3 : '1';
3628 my ($subname, $break) = ($2, $1 eq 'postpone');
3629 $subname =~ s/\'/::/g;
3630 $subname = "${'package'}::" . $subname
3631 unless $subname =~ /::/;
3632 $subname = "main".$subname if substr($subname,0,2) eq "::";
3633 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
3634 } elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
3636 my $cond = length $2 ? $2 : '1';
3637 &cmd_b_sub($subname, $cond);
3638 } elsif ($cmd =~ /^(\d*)\s*(.*)/) {
3639 my $i = $1 || $dbline;
3640 my $cond = length $2 ? $2 : '1';
3641 &cmd_b_line($i, $cond);
3648 if ($cmd =~ /^\s*$/) {
3649 print $OUT "Deleting all breakpoints...\n";
3651 for $file (keys %had_breakpoints) {
3652 local *dbline = $main::{'_<' . $file};
3656 for ($i = 1; $i <= $max ; $i++) {
3657 if (defined $dbline{$i}) {
3658 $dbline{$i} =~ s/^[^\0]+//;
3659 if ($dbline{$i} =~ s/^\0?$//) {
3665 if (not $had_breakpoints{$file} &= ~1) {
3666 delete $had_breakpoints{$file};
3670 undef %postponed_file;
3671 undef %break_on_load;
3678 if ($cmd =~ /^\s*$/) {
3679 print_help($pre580_help);
3680 } elsif ($cmd =~ /^h\s*/) {
3681 print_help($pre580_summary);
3682 } elsif ($cmd =~ /^h\s+(\S.*)$/) {
3683 my $asked = $1; # for proper errmsg
3684 my $qasked = quotemeta($asked); # for searching
3685 # XXX: finds CR but not <CR>
3686 if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) {
3687 while ($pre580_help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
3691 print_help("B<$asked> is not a debugger command.\n");
3701 @to_watch = @old_watch = ();
3702 } elsif ($cmd =~ /^(.*)/s) {
3706 $val = (defined $val) ? "'$val'" : 'undef' ;
3707 push @old_watch, $val;
3712 sub cmd_pre590_prepost {
3714 my $line = shift || '*'; # delete
3717 return &cmd_prepost($cmd, $line, $dbline);
3720 sub cmd_prepost { # cannot do &cmd_<(), <, <<, >>, {, {{, etc.
3722 my $line = shift || '?';
3726 if ($cmd =~ /^\</o) {
3727 $which = 'pre-perl';
3729 } elsif ($cmd =~ /^\>/o) {
3730 $which = 'post-perl';
3732 } elsif ($cmd =~ /^\{/o) {
3733 if ($cmd =~ /^\{.*\}$/o && unbalanced(substr($cmd,1))) {
3734 print $OUT "$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n";
3735 # $DB::cmd = "h $cmd";
3738 $which = 'pre-debugger';
3744 print $OUT "Confused by command: $cmd\n";
3746 if ($line =~ /^\s*\?\s*$/o) {
3748 print $OUT "No $which actions.\n";
3749 # print $OUT "If you meant to delete them all - use '$cmd *' or 'o commandSet=pre590'\n"; # hint
3751 print $OUT "$which commands:\n";
3752 foreach my $action (@$aref) {
3753 print $OUT "\t$cmd -- $action\n";
3757 if (length($cmd) == 1) {
3758 if ($line =~ /^\s*\*\s*$/o) {
3759 @$aref = (); # delete
3760 print $OUT "All $cmd actions cleared.\n";
3762 @$aref = action($line); # set
3764 } elsif (length($cmd) == 2) { # append
3765 push @$aref, action($line);
3767 print $OUT "Confused by strange length of $which command($cmd)...\n";
3776 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3779 package DB; # Do not trace this 1; below!