3 # Debugger for Perl 5.00x; perl5db.pl patch level:
5 $header = "perl5db.pl version $VERSION";
7 # It is crucial that there is no lexicals in scope of `eval ""' down below
9 # 'my' would make it visible from user code
10 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
13 local $otrace = $trace;
14 local $osingle = $single;
16 { ($evalarg) = $evalarg =~ /(.*)/s; }
17 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
23 local $saved[0]; # Preserve the old value of $@
28 } elsif ($onetimeDump) {
29 if ($onetimeDump eq 'dump') {
30 local $option{dumpDepth} = $onetimedumpDepth
31 if defined $onetimedumpDepth;
33 } elsif ($onetimeDump eq 'methods') {
40 # After this point it is safe to introduce lexicals
41 # However, one should not overdo it: leave as much control from outside as possible
43 # This file is automatically included if you do perl -d.
44 # It's probably not useful to include this yourself.
46 # Before venturing further into these twisty passages, it is
47 # wise to read the perldebguts man page or risk the ire of dragons.
49 # Perl supplies the values for %sub. It effectively inserts
50 # a &DB::DB(); in front of every place that can have a
51 # breakpoint. Instead of a subroutine call it calls &DB::sub with
52 # $DB::sub being the called subroutine. It also inserts a BEGIN
53 # {require 'perl5db.pl'} before the first line.
55 # After each `require'd file is compiled, but before it is executed, a
56 # call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
57 # $filename is the expanded name of the `require'd file (as found as
60 # Additional services from Perl interpreter:
62 # if caller() is called from the package DB, it provides some
65 # The array @{$main::{'_<'.$filename}} (herein called @dbline) is the
66 # line-by-line contents of $filename.
68 # The hash %{'_<'.$filename} (herein called %dbline) contains
69 # breakpoints and action (it is keyed by line number), and individual
70 # entries are settable (as opposed to the whole hash). Only true/false
71 # is important to the interpreter, though the values used by
72 # perl5db.pl have the form "$break_condition\0$action". Values are
73 # magical in numeric context.
75 # The scalar ${'_<'.$filename} contains $filename.
77 # Note that no subroutine call is possible until &DB::sub is defined
78 # (for subroutines defined outside of the package DB). In fact the same is
79 # true if $deep is not defined.
84 # At start reads $rcfile that may set important options. This file
85 # may define a subroutine &afterinit that will be executed after the
86 # debugger is initialized.
88 # After $rcfile is read reads environment variable PERLDB_OPTS and parses
89 # it as a rest of `O ...' line in debugger prompt.
91 # The options that can be specified only at startup:
92 # [To set in $rcfile, call &parse_options("optionName=new_value").]
94 # TTY - the TTY to use for debugging i/o.
96 # noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
97 # uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
98 # Term::Rendezvous. Current variant is to have the name of TTY in this
101 # ReadLine - If false, dummy ReadLine is used, so you can debug
102 # ReadLine applications.
104 # NonStop - if true, no i/o is performed until interrupt.
106 # LineInfo - file or pipe to print line number info to. If it is a
107 # pipe, a short "emacs like" message is used.
109 # RemotePort - host:port to connect to on remote host for remote debugging.
111 # Example $rcfile: (delete leading hashes!)
113 # &parse_options("NonStop=1 LineInfo=db.out");
114 # sub afterinit { $trace = 1; }
116 # The script will run without human intervention, putting trace
117 # information into db.out. (If you interrupt it, you would better
118 # reset LineInfo to something "interactive"!)
120 ##################################################################
122 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
124 # modified Perl debugger, to be run from Emacs in perldb-mode
125 # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
126 # Johan Vromans -- upgrade to 4.0 pl 10
127 # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
131 # A lot of things changed after 0.94. First of all, core now informs
132 # debugger about entry into XSUBs, overloaded operators, tied operations,
133 # BEGIN and END. Handy with `O f=2'.
135 # This can make debugger a little bit too verbose, please be patient
136 # and report your problems promptly.
138 # Now the option frame has 3 values: 0,1,2.
140 # Note that if DESTROY returns a reference to the object (or object),
141 # the deletion of data may be postponed until the next function call,
142 # due to the need to examine the return value.
144 # Changes: 0.95: `v' command shows versions.
145 # Changes: 0.96: `v' command shows version of readline.
146 # primitive completion works (dynamic variables, subs for `b' and `l',
147 # options). Can `p %var'
148 # Better help (`h <' now works). New commands <<, >>, {, {{.
149 # {dump|print}_trace() coded (to be able to do it from <<cmd).
150 # `c sub' documented.
151 # At last enough magic combined to stop after the end of debuggee.
152 # !! should work now (thanks to Emacs bracket matching an extra
153 # `]' in a regexp is caught).
154 # `L', `D' and `A' span files now (as documented).
155 # Breakpoints in `require'd code are possible (used in `R').
156 # Some additional words on internal work of debugger.
157 # `b load filename' implemented.
158 # `b postpone subr' implemented.
159 # now only `q' exits debugger (overwritable on $inhibit_exit).
160 # When restarting debugger breakpoints/actions persist.
161 # Buglet: When restarting debugger only one breakpoint/action per
162 # autoloaded function persists.
163 # Changes: 0.97: NonStop will not stop in at_exit().
164 # Option AutoTrace implemented.
165 # Trace printed differently if frames are printed too.
166 # new `inhibitExit' option.
167 # printing of a very long statement interruptible.
168 # Changes: 0.98: New command `m' for printing possible methods
169 # 'l -' is a synonym for `-'.
170 # Cosmetic bugs in printing stack trace.
171 # `frame' & 8 to print "expanded args" in stack trace.
172 # Can list/break in imported subs.
173 # new `maxTraceLen' option.
174 # frame & 4 and frame & 8 granted.
176 # nonstoppable lines do not have `:' near the line number.
177 # `b compile subname' implemented.
178 # Will not use $` any more.
179 # `-' behaves sane now.
180 # Changes: 0.99: Completion for `f', `m'.
181 # `m' will remove duplicate names instead of duplicate functions.
182 # `b load' strips trailing whitespace.
183 # completion ignores leading `|'; takes into account current package
184 # when completing a subroutine name (same for `l').
185 # Changes: 1.07: Many fixed by tchrist 13-March-2000
187 # + Added bare minimal security checks on perldb rc files, plus
188 # comments on what else is needed.
189 # + Fixed the ornaments that made "|h" completely unusable.
190 # They are not used in print_help if they will hurt. Strip pod
191 # if we're paging to less.
192 # + Fixed mis-formatting of help messages caused by ornaments
193 # to restore Larry's original formatting.
194 # + Fixed many other formatting errors. The code is still suboptimal,
195 # and needs a lot of work at restructuring. It's also misindented
197 # + Fixed bug where trying to look at an option like your pager
199 # + Fixed some $? processing. Note: if you use csh or tcsh, you will
200 # lose. You should consider shell escapes not using their shell,
201 # or else not caring about detailed status. This should really be
202 # unified into one place, too.
203 # + Fixed bug where invisible trailing whitespace on commands hoses you,
204 # tricking Perl into thinking you weren't calling a debugger command!
205 # + Fixed bug where leading whitespace on commands hoses you. (One
206 # suggests a leading semicolon or any other irrelevant non-whitespace
207 # to indicate literal Perl code.)
208 # + Fixed bugs that ate warnings due to wrong selected handle.
209 # + Fixed a precedence bug on signal stuff.
210 # + Fixed some unseemly wording.
211 # + Fixed bug in help command trying to call perl method code.
212 # + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
214 # + Added some comments. This code is still nasty spaghetti.
215 # + Added message if you clear your pre/post command stacks which was
216 # very easy to do if you just typed a bare >, <, or {. (A command
217 # without an argument should *never* be a destructive action; this
218 # API is fundamentally screwed up; likewise option setting, which
219 # is equally buggered.)
220 # + Added command stack dump on argument of "?" for >, <, or {.
221 # + Added a semi-built-in doc viewer command that calls man with the
222 # proper %Config::Config path (and thus gets caching, man -k, etc),
223 # or else perldoc on obstreperous platforms.
224 # + Added to and rearranged the help information.
225 # + Detected apparent misuse of { ... } to declare a block; this used
226 # to work but now is a command, and mysteriously gave no complaint.
228 # Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
230 # + This patch to perl5db.pl cleans up formatting issues on the help
231 # summary (h h) screen in the debugger. Mostly columnar alignment
232 # issues, plus converted the printed text to use all spaces, since
233 # tabs don't seem to help much here.
235 # Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
236 # 0) Minor bugs corrected;
237 # a) Support for auto-creation of new TTY window on startup, either
238 # unconditionally, or if started as a kid of another debugger session;
239 # b) New `O'ption CreateTTY
240 # I<CreateTTY> bits control attempts to create a new TTY on events:
241 # 1: on fork() 2: debugger is started inside debugger
243 # c) Code to auto-create a new TTY window on OS/2 (currently one
244 # extra window per session - need named pipes to have more...);
245 # d) Simplified interface for custom createTTY functions (with a backward
246 # compatibility hack); now returns the TTY name to use; return of ''
247 # means that the function reset the I/O handles itself;
248 # d') Better message on the semantic of custom createTTY function;
249 # e) Convert the existing code to create a TTY into a custom createTTY
251 # f) Consistent support for TTY names of the form "TTYin,TTYout";
252 # g) Switch line-tracing output too to the created TTY window;
253 # h) make `b fork' DWIM with CORE::GLOBAL::fork;
254 # i) High-level debugger API cmd_*():
255 # cmd_b_load($filenamepart) # b load filenamepart
256 # cmd_b_line($lineno [, $cond]) # b lineno [cond]
257 # cmd_b_sub($sub [, $cond]) # b sub [cond]
258 # cmd_stop() # Control-C
259 # cmd_d($lineno) # d lineno (B)
260 # The cmd_*() API returns FALSE on failure; in this case it outputs
261 # the error message to the debugging output.
262 # j) Low-level debugger API
263 # break_on_load($filename) # b load filename
264 # @files = report_break_on_load() # List files with load-breakpoints
265 # breakable_line_in_filename($name, $from [, $to])
266 # # First breakable line in the
267 # # range $from .. $to. $to defaults
268 # # to $from, and may be less than $to
269 # breakable_line($from [, $to]) # Same for the current file
270 # break_on_filename_line($name, $lineno [, $cond])
271 # # Set breakpoint,$cond defaults to 1
272 # break_on_filename_line_range($name, $from, $to [, $cond])
273 # # As above, on the first
274 # # breakable line in range
275 # break_on_line($lineno [, $cond]) # As above, in the current file
276 # break_subroutine($sub [, $cond]) # break on the first breakable line
277 # ($name, $from, $to) = subroutine_filename_lines($sub)
278 # # The range of lines of the text
279 # The low-level API returns TRUE on success, and die()s on failure.
281 # Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
283 # + Fixed warnings generated by "perl -dWe 42"
284 # + Corrected spelling errors
285 # + Squeezed Help (h) output into 80 columns
287 # Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
288 # + Made "x @INC" work like it used to
290 # Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
291 # + Fixed warnings generated by "O" (Show debugger options)
292 # + Fixed warnings generated by "p 42" (Print expression)
293 # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
294 # + Added windowSize option
295 # Changes: 1.14: Oct 9, 2001 multiple
296 # + Clean up after itself on VMS (Charles Lane in 12385)
297 # + Adding "@ file" syntax (Peter Scott in 12014)
298 # + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
299 # + $^S and other debugger fixes (Ilya Zakharevich in 11120)
300 # + Forgot a my() declaration (Ilya Zakharevich in 11085)
301 # Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern@pobox.com>
302 # + Updated 1.14 change log
303 # + Added *dbline explainatory comments
304 # + Mentioning perldebguts man page
305 # Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com>
306 # + $onetimeDump improvements
307 # Changes: 1.17: Feb 20, 2002 Richard Foley <richard.foley@rfi.net>
308 # Moved some code to cmd_[.]()'s for clarity and ease of handling,
309 # rationalised the following commands and added cmd_wrapper() to
310 # enable switching between old and frighteningly consistent new
311 # behaviours for diehards: 'o CommandSet=pre580' (sigh...)
312 # a(add), A(del) # action expr (added del by line)
313 # + b(add), B(del) # break [line] (was b,D)
314 # + w(add), W(del) # watch expr (was W,W) added del by expr
315 # + h(summary), h h(long) # help (hh) (was h h,h)
316 # + m(methods), M(modules) # ... (was m,v)
317 # + o(option) # lc (was O)
318 # + v(view code), V(view Variables) # ... (was w,V)
319 # Changes: 1.18: Mar 17, 2002 Richard Foley <richard.foley@rfi.net>
320 # + fixed missing cmd_O bug
321 # Changes: 1.19: Mar 29, 2002 Spider Boardman
322 # + Added missing local()s -- DB::DB is called recursively.
324 ####################################################################
326 # Needed for the statement after exec():
328 BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
329 local($^W) = 0; # Switch run-time warnings off during init.
332 $dumpvar::arrayDepth,
333 $dumpvar::dumpDBFiles,
334 $dumpvar::dumpPackages,
335 $dumpvar::quoteHighBit,
336 $dumpvar::printUndef,
345 # Command-line + PERLLIB:
348 # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
350 $trace = $signal = $single = 0; # Uninitialized warning suppression
351 # (local $^W cannot help - other packages!).
352 $inhibit_exit = $option{PrintRet} = 1;
354 @options = qw(hashDepth arrayDepth CommandSet dumpDepth
355 DumpDBFiles DumpPackages DumpReused
356 compactDump veryCompact quote HighBit undefPrint
357 globPrint PrintRet UsageOnly frame AutoTrace
358 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
359 recallCommand ShellBang pager tkRunning ornaments
360 signalLevel warnLevel dieLevel inhibit_exit
361 ImmediateStop bareStringify CreateTTY
362 RemotePort windowSize);
365 hashDepth => \$dumpvar::hashDepth,
366 arrayDepth => \$dumpvar::arrayDepth,
367 CommandSet => \$CommandSet,
368 DumpDBFiles => \$dumpvar::dumpDBFiles,
369 DumpPackages => \$dumpvar::dumpPackages,
370 DumpReused => \$dumpvar::dumpReused,
371 HighBit => \$dumpvar::quoteHighBit,
372 undefPrint => \$dumpvar::printUndef,
373 globPrint => \$dumpvar::globPrint,
374 UsageOnly => \$dumpvar::usageOnly,
375 CreateTTY => \$CreateTTY,
376 bareStringify => \$dumpvar::bareStringify,
378 AutoTrace => \$trace,
379 inhibit_exit => \$inhibit_exit,
380 maxTraceLen => \$maxtrace,
381 ImmediateStop => \$ImmediateStop,
382 RemotePort => \$remoteport,
383 windowSize => \$window,
387 compactDump => \&dumpvar::compactDump,
388 veryCompact => \&dumpvar::veryCompact,
389 quote => \&dumpvar::quote,
392 ReadLine => \&ReadLine,
393 NonStop => \&NonStop,
394 LineInfo => \&LineInfo,
395 recallCommand => \&recallCommand,
396 ShellBang => \&shellBang,
398 signalLevel => \&signalLevel,
399 warnLevel => \&warnLevel,
400 dieLevel => \&dieLevel,
401 tkRunning => \&tkRunning,
402 ornaments => \&ornaments,
403 RemotePort => \&RemotePort,
407 compactDump => 'dumpvar.pl',
408 veryCompact => 'dumpvar.pl',
409 quote => 'dumpvar.pl',
412 # These guys may be defined in $ENV{PERL5DB} :
413 $rl = 1 unless defined $rl;
414 $warnLevel = 1 unless defined $warnLevel;
415 $dieLevel = 1 unless defined $dieLevel;
416 $signalLevel = 1 unless defined $signalLevel;
417 $pre = [] unless defined $pre;
418 $post = [] unless defined $post;
419 $pretype = [] unless defined $pretype;
420 $CreateTTY = 3 unless defined $CreateTTY;
421 $CommandSet = '580' unless defined $CommandSet;
423 warnLevel($warnLevel);
425 signalLevel($signalLevel);
428 defined $ENV{PAGER} ? $ENV{PAGER} :
429 eval { require Config } &&
430 defined $Config::Config{pager} ? $Config::Config{pager}
432 ) unless defined $pager;
434 &recallCommand("!") unless defined $prc;
435 &shellBang("!") unless defined $psh;
437 $maxtrace = 400 unless defined $maxtrace;
438 $ini_pids = $ENV{PERLDB_PIDS};
439 if (defined $ENV{PERLDB_PIDS}) {
440 $pids = "[$ENV{PERLDB_PIDS}]";
441 $ENV{PERLDB_PIDS} .= "->$$";
444 $ENV{PERLDB_PIDS} = "$$";
449 *emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
451 if (-e "/dev/tty") { # this is the wrong metric!
454 $rcfile="perldb.ini";
457 # This isn't really safe, because there's a race
458 # between checking and opening. The solution is to
459 # open and fstat the handle, but then you have to read and
460 # eval the contents. But then the silly thing gets
461 # your lexical scope, which is unfortunately at best.
465 # Just exactly what part of the word "CORE::" don't you understand?
466 local $SIG{__WARN__};
469 unless (is_safe_file($file)) {
470 CORE::warn <<EO_GRIPE;
471 perldb: Must not source insecure rcfile $file.
472 You or the superuser must be the owner, and it must not
473 be writable by anyone but its owner.
479 CORE::warn("perldb: couldn't parse $file: $@") if $@;
483 # Verifies that owner is either real user or superuser and that no
484 # one but owner may write to it. This function is of limited use
485 # when called on a path instead of upon a handle, because there are
486 # no guarantees that filename (by dirent) whose file (by ino) is
487 # eventually accessed is the same as the one tested.
488 # Assumes that the file's existence is not in doubt.
491 stat($path) || return; # mysteriously vaporized
492 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
494 return 0 if $uid != 0 && $uid != $<;
495 return 0 if $mode & 022;
500 safe_do("./$rcfile");
502 elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
503 safe_do("$ENV{HOME}/$rcfile");
505 elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
506 safe_do("$ENV{LOGDIR}/$rcfile");
509 if (defined $ENV{PERLDB_OPTS}) {
510 parse_options($ENV{PERLDB_OPTS});
513 if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
514 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
515 *get_fork_TTY = \&xterm_get_fork_TTY;
516 } elsif ($^O eq 'os2') {
517 *get_fork_TTY = \&os2_get_fork_TTY;
520 # Here begin the unreadable code. It needs fixing.
522 if (exists $ENV{PERLDB_RESTART}) {
523 delete $ENV{PERLDB_RESTART};
525 @hist = get_list('PERLDB_HIST');
526 %break_on_load = get_list("PERLDB_ON_LOAD");
527 %postponed = get_list("PERLDB_POSTPONE");
528 my @had_breakpoints= get_list("PERLDB_VISITED");
529 for (0 .. $#had_breakpoints) {
530 my %pf = get_list("PERLDB_FILE_$_");
531 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
533 my %opt = get_list("PERLDB_OPT");
535 while (($opt,$val) = each %opt) {
536 $val =~ s/[\\\']/\\$1/g;
537 parse_options("$opt'$val'");
539 @INC = get_list("PERLDB_INC");
541 $pretype = [get_list("PERLDB_PRETYPE")];
542 $pre = [get_list("PERLDB_PRE")];
543 $post = [get_list("PERLDB_POST")];
544 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
550 # Is Perl being run from a slave editor or graphical debugger?
551 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
552 $rl = 0, shift(@main::ARGV) if $slave_editor;
554 #require Term::ReadLine;
556 if ($^O eq 'cygwin') {
557 # /dev/tty is binary. use stdin for textmode
559 } elsif (-e "/dev/tty") {
560 $console = "/dev/tty";
561 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
563 } elsif ($^O eq 'MacOS') {
564 if ($MacPerl::Version !~ /MPW/) {
565 $console = "Dev:Console:Perl Debug"; # Separate window for application
567 $console = "Dev:Console";
570 $console = "sys\$command";
573 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
577 if ($^O eq 'NetWare') {
582 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
590 $console = $tty if defined $tty;
592 if (defined $remoteport) {
594 $OUT = new IO::Socket::INET( Timeout => '10',
595 PeerAddr => $remoteport,
598 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
601 create_IN_OUT(4) if $CreateTTY & 4;
603 my ($i, $o) = split /,/, $console;
604 $o = $i unless defined $o;
605 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
606 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
607 || open(OUT,">&STDOUT"); # so we don't dongle stdout
608 } elsif (not defined $console) {
610 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
611 $console = 'STDIN/OUT';
613 # so open("|more") can read from STDOUT and so we don't dingle stdin
614 $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
616 my $previous = select($OUT);
617 $| = 1; # for DB::OUT
620 $LINEINFO = $OUT unless defined $LINEINFO;
621 $lineinfo = $console unless defined $lineinfo;
623 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
624 unless ($runnonstop) {
627 if ($term_pid eq '-1') {
628 print $OUT "\nDaughter DB session started...\n";
630 print $OUT "\nLoading DB routines from $header\n";
631 print $OUT ("Editor support ",
632 $slave_editor ? "enabled" : "available",
634 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
642 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
645 if (defined &afterinit) { # May be defined in $rcfile
651 ############################################################ Subroutines
654 # _After_ the perl program is compiled, $single is set to 1:
655 if ($single and not $second_time++) {
656 if ($runnonstop) { # Disable until signal
657 for ($i=0; $i <= $stack_depth; ) {
661 # return; # Would not print trace!
662 } elsif ($ImmediateStop) {
667 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
669 local($package, $filename, $line) = caller;
670 local $filename_ini = $filename;
671 local $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
672 "package $package;"; # this won't let them modify, alas
673 local(*dbline) = $main::{'_<' . $filename};
675 # we need to check for pseudofiles on Mac OS (these are files
676 # not attached to a filename, but instead stored in Dev:Pseudo)
677 if ($^O eq 'MacOS' && $#dbline < 0) {
678 $filename_ini = $filename = 'Dev:Pseudo';
679 *dbline = $main::{'_<' . $filename};
682 local $max = $#dbline;
683 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
687 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
688 $dbline{$line} =~ s/;9($|\0)/$1/;
691 my $was_signal = $signal;
693 for (my $n = 0; $n <= $#to_watch; $n++) {
694 $evalarg = $to_watch[$n];
695 local $onetimeDump; # Do not output results
696 my ($val) = &eval; # Fix context (&eval is doing array)?
697 $val = ( (defined $val) ? "'$val'" : 'undef' );
698 if ($val ne $old_watch[$n]) {
701 Watchpoint $n:\t$to_watch[$n] changed:
702 old value:\t$old_watch[$n]
705 $old_watch[$n] = $val;
709 if ($trace & 4) { # User-installed watch
710 return if watchfunction($package, $filename, $line)
711 and not $single and not $was_signal and not ($trace & ~4);
713 $was_signal = $signal;
715 if ($single || ($trace & 1) || $was_signal) {
717 $position = "\032\032$filename:$line:0\n";
718 print_lineinfo($position);
719 } elsif ($package eq 'DB::fake') {
722 Debugged program terminated. Use B<q> to quit or B<R> to restart,
723 use B<O> I<inhibit_exit> to avoid stopping after program termination,
724 B<h q>, B<h R> or B<h O> to get additional info.
727 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
728 "package $package;"; # this won't let them modify, alas
731 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
732 $prefix .= "$sub($filename:";
733 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
734 if (length($prefix) > 30) {
735 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
740 $position = "$prefix$line$infix$dbline[$line]$after";
743 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
745 print_lineinfo($position);
747 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
748 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
750 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
751 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
752 $position .= $incr_pos;
754 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
756 print_lineinfo($incr_pos);
761 $evalarg = $action, &eval if $action;
762 if ($single || $was_signal) {
763 local $level = $level + 1;
764 foreach $evalarg (@$pre) {
767 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
770 $incr = -1; # for backward motion.
771 @typeahead = (@$pretype, @typeahead);
773 while (($term || &setterm),
774 ($term_pid == $$ or resetterm(1)),
775 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
776 ($#hist+1) . ('>' x $level) . " ")))
780 $cmd =~ s/\\$/\n/ && do {
781 $cmd .= &readline(" cont: ");
784 $cmd =~ /^$/ && ($cmd = $laststep);
785 push(@hist,$cmd) if length($cmd) > 1;
787 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
788 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
789 ($i) = split(/\s+/,$cmd);
791 # squelch the sigmangler
793 local $SIG{__WARN__};
794 eval "\$cmd =~ $alias{$i}";
797 print $OUT "Couldn't evaluate `$i' alias: $@";
801 $cmd =~ /^q$/ && do {
806 $cmd =~ /^t$/ && do {
809 print $OUT "Trace = " .
810 (($trace & 1) ? "on" : "off" ) . "\n";
812 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
813 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
816 foreach $subname (sort(keys %sub)) {
817 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
818 print $OUT $subname,"\n";
822 $cmd =~ s/^X\b/V $package/;
823 $cmd =~ /^V$/ && do {
824 $cmd = "V $package"; };
825 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
826 local ($savout) = select($OUT);
828 @vars = split(' ',$2);
829 do 'dumpvar.pl' unless defined &main::dumpvar;
830 if (defined &main::dumpvar) {
833 # must detect sigpipe failures
834 eval { &main::dumpvar($packname,
835 defined $option{dumpDepth}
836 ? $option{dumpDepth} : -1,
839 die unless $@ =~ /dumpvar print failed/;
842 print $OUT "dumpvar.pl not available.\n";
846 $cmd =~ s/^x\b/ / && do { # So that will be evaled
847 $onetimeDump = 'dump';
848 # handle special "x 3 blah" syntax
849 if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
850 $onetimedumpDepth = $1;
853 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
854 methods($1); next CMD};
855 $cmd =~ s/^m\b/ / && do { # So this will be evaled
856 $onetimeDump = 'methods'; };
857 $cmd =~ /^f\b\s*(.*)/ && do {
861 print $OUT "The old f command is now the r command.\n"; # hint
862 print $OUT "The new f command switches filenames.\n";
865 if (!defined $main::{'_<' . $file}) {
866 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
867 $try = substr($try,2);
868 print $OUT "Choosing $try matching `$file':\n";
872 if (!defined $main::{'_<' . $file}) {
873 print $OUT "No file matching `$file' is loaded.\n";
875 } elsif ($file ne $filename) {
876 *dbline = $main::{'_<' . $file};
882 print $OUT "Already in $file.\n";
886 $cmd =~ /^\.$/ && do {
887 $incr = -1; # for backward motion.
889 $filename = $filename_ini;
890 *dbline = $main::{'_<' . $filename};
892 print_lineinfo($position);
894 $cmd =~ /^-$/ && do {
895 $start -= $incr + $window + 1;
896 $start = 1 if $start <= 0;
898 $cmd = 'l ' . ($start) . '+'; };
900 $cmd =~ /^([aAbBDhlLMoOvwW])\b\s*(.*)/s && do {
901 &cmd_wrapper($1, $2, $line);
905 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
906 push @$pre, action($1);
908 $cmd =~ /^>>\s*(.*)/ && do {
909 push @$post, action($1);
911 $cmd =~ /^<\s*(.*)/ && do {
913 print $OUT "All < actions cleared.\n";
919 print $OUT "No pre-prompt Perl actions.\n";
922 print $OUT "Perl commands run before each prompt:\n";
923 for my $action ( @$pre ) {
924 print $OUT "\t< -- $action\n";
930 $cmd =~ /^>\s*(.*)/ && do {
932 print $OUT "All > actions cleared.\n";
938 print $OUT "No post-prompt Perl actions.\n";
941 print $OUT "Perl commands run after each prompt:\n";
942 for my $action ( @$post ) {
943 print $OUT "\t> -- $action\n";
947 $post = [action($1)];
949 $cmd =~ /^\{\{\s*(.*)/ && do {
950 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
951 print $OUT "{{ is now a debugger command\n",
952 "use `;{{' if you mean Perl code\n";
958 $cmd =~ /^\{\s*(.*)/ && do {
960 print $OUT "All { actions cleared.\n";
966 print $OUT "No pre-prompt debugger actions.\n";
969 print $OUT "Debugger commands run before each prompt:\n";
970 for my $action ( @$pretype ) {
971 print $OUT "\t{ -- $action\n";
975 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
976 print $OUT "{ is now a debugger command\n",
977 "use `;{' if you mean Perl code\n";
983 $cmd =~ /^n$/ && do {
984 end_report(), next CMD if $finished and $level <= 1;
988 $cmd =~ /^s$/ && do {
989 end_report(), next CMD if $finished and $level <= 1;
993 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
994 end_report(), next CMD if $finished and $level <= 1;
996 # Probably not needed, since we finish an interactive
997 # sub-session anyway...
998 # local $filename = $filename;
999 # local *dbline = *dbline; # XXX Would this work?!
1000 if ($subname =~ /\D/) { # subroutine name
1001 $subname = $package."::".$subname
1002 unless $subname =~ /::/;
1003 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
1007 *dbline = $main::{'_<' . $filename};
1008 $had_breakpoints{$filename} |= 1;
1010 ++$i while $dbline[$i] == 0 && $i < $max;
1012 print $OUT "Subroutine $subname not found.\n";
1017 if ($dbline[$i] == 0) {
1018 print $OUT "Line $i not breakable.\n";
1021 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1023 for ($i=0; $i <= $stack_depth; ) {
1027 $cmd =~ /^r$/ && do {
1028 end_report(), next CMD if $finished and $level <= 1;
1029 $stack[$stack_depth] |= 1;
1030 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
1032 $cmd =~ /^R$/ && do {
1033 print $OUT "Warning: some settings and command-line options may be lost!\n";
1034 my (@script, @flags, $cl);
1035 push @flags, '-w' if $ini_warn;
1036 # Put all the old includes at the start to get
1037 # the same debugger.
1039 push @flags, '-I', $_;
1041 push @flags, '-T' if ${^TAINT};
1042 # Arrange for setting the old INC:
1043 set_list("PERLDB_INC", @ini_INC);
1045 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
1046 chomp ($cl = ${'::_<-e'}[$_]);
1047 push @script, '-e', $cl;
1052 set_list("PERLDB_HIST",
1053 $term->Features->{getHistory}
1054 ? $term->GetHistory : @hist);
1055 my @had_breakpoints = keys %had_breakpoints;
1056 set_list("PERLDB_VISITED", @had_breakpoints);
1057 set_list("PERLDB_OPT", %option);
1058 set_list("PERLDB_ON_LOAD", %break_on_load);
1060 for (0 .. $#had_breakpoints) {
1061 my $file = $had_breakpoints[$_];
1062 *dbline = $main::{'_<' . $file};
1063 next unless %dbline or $postponed_file{$file};
1064 (push @hard, $file), next
1065 if $file =~ /^\(\w*eval/;
1067 @add = %{$postponed_file{$file}}
1068 if $postponed_file{$file};
1069 set_list("PERLDB_FILE_$_", %dbline, @add);
1071 for (@hard) { # Yes, really-really...
1072 # Find the subroutines in this eval
1073 *dbline = $main::{'_<' . $_};
1074 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1075 for $sub (keys %sub) {
1076 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1077 $subs{$sub} = [$1, $2];
1081 "No subroutines in $_, ignoring breakpoints.\n";
1084 LINES: for $line (keys %dbline) {
1085 # One breakpoint per sub only:
1086 my ($offset, $sub, $found);
1087 SUBS: for $sub (keys %subs) {
1088 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1089 and (not defined $offset # Not caught
1090 or $offset < 0 )) { # or badly caught
1092 $offset = $line - $subs{$sub}->[0];
1093 $offset = "+$offset", last SUBS if $offset >= 0;
1096 if (defined $offset) {
1097 $postponed{$found} =
1098 "break $offset if $dbline{$line}";
1100 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1104 set_list("PERLDB_POSTPONE", %postponed);
1105 set_list("PERLDB_PRETYPE", @$pretype);
1106 set_list("PERLDB_PRE", @$pre);
1107 set_list("PERLDB_POST", @$post);
1108 set_list("PERLDB_TYPEAHEAD", @typeahead);
1109 $ENV{PERLDB_RESTART} = 1;
1110 delete $ENV{PERLDB_PIDS}; # Restore ini state
1111 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
1112 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1113 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
1114 print $OUT "exec failed: $!\n";
1116 $cmd =~ /^T$/ && do {
1117 print_trace($OUT, 1); # skip DB
1119 $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w($1); next CMD; };
1120 $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W($1); next CMD; };
1121 $cmd =~ /^\/(.*)$/ && do {
1123 $inpat =~ s:([^\\])/$:$1:;
1125 # squelch the sigmangler
1126 local $SIG{__DIE__};
1127 local $SIG{__WARN__};
1128 eval '$inpat =~ m'."\a$inpat\a";
1140 $start = 1 if ($start > $max);
1141 last if ($start == $end);
1142 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1143 if ($slave_editor) {
1144 print $OUT "\032\032$filename:$start:0\n";
1146 print $OUT "$start:\t", $dbline[$start], "\n";
1151 print $OUT "/$pat/: not found\n" if ($start == $end);
1153 $cmd =~ /^\?(.*)$/ && do {
1155 $inpat =~ s:([^\\])\?$:$1:;
1157 # squelch the sigmangler
1158 local $SIG{__DIE__};
1159 local $SIG{__WARN__};
1160 eval '$inpat =~ m'."\a$inpat\a";
1172 $start = $max if ($start <= 0);
1173 last if ($start == $end);
1174 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1175 if ($slave_editor) {
1176 print $OUT "\032\032$filename:$start:0\n";
1178 print $OUT "$start:\t", $dbline[$start], "\n";
1183 print $OUT "?$pat?: not found\n" if ($start == $end);
1185 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1186 pop(@hist) if length($cmd) > 1;
1187 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
1189 print $OUT $cmd, "\n";
1191 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
1194 $cmd =~ /^$rc([^$rc].*)$/ && do {
1196 pop(@hist) if length($cmd) > 1;
1197 for ($i = $#hist; $i; --$i) {
1198 last if $hist[$i] =~ /$pat/;
1201 print $OUT "No such command!\n\n";
1205 print $OUT $cmd, "\n";
1207 $cmd =~ /^$sh$/ && do {
1208 &system($ENV{SHELL}||"/bin/sh");
1210 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1211 # XXX: using csh or tcsh destroys sigint retvals!
1212 #&system($1); # use this instead
1213 &system($ENV{SHELL}||"/bin/sh","-c",$1);
1215 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1216 $end = $2 ? ($#hist-$2) : 0;
1217 $hist = 0 if $hist < 0;
1218 for ($i=$#hist; $i>$end; $i--) {
1219 print $OUT "$i: ",$hist[$i],"\n"
1220 unless $hist[$i] =~ /^.?$/;
1223 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1226 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1227 $cmd =~ s/^p\b/print {\$DB::OUT} /;
1228 $cmd =~ s/^=\s*// && do {
1230 if (length $cmd == 0) {
1231 @keys = sort keys %alias;
1232 } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1233 # can't use $_ or kill //g state
1234 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1235 $alias{$k} = "s\a$k\a$v\a";
1236 # squelch the sigmangler
1237 local $SIG{__DIE__};
1238 local $SIG{__WARN__};
1239 unless (eval "sub { s\a$k\a$v\a }; 1") {
1240 print $OUT "Can't alias $k to $v: $@\n";
1249 if ((my $v = $alias{$k}) =~ s
\as\a$k\a(.*)\a$
\a1
\a) {
1250 print $OUT "$k\t= $1\n";
1252 elsif (defined $alias{$k}) {
1253 print $OUT "$k\t$alias{$k}\n";
1256 print "No alias for $k\n";
1260 $cmd =~ /^\@\s*(.*\S)/ && do {
1261 if (open my $fh, $1) {
1264 &warn("Can't execute `$1': $!\n");
1267 $cmd =~ /^\|\|?\s*[^|]/ && do {
1268 if ($pager =~ /^\|/) {
1269 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1270 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1272 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1275 unless ($piped=open(OUT,$pager)) {
1276 &warn("Can't pipe output to `$pager'");
1277 if ($pager =~ /^\|/) {
1278 open(OUT,">&STDOUT") # XXX: lost message
1279 || &warn("Can't restore DB::OUT");
1280 open(STDOUT,">&SAVEOUT")
1281 || &warn("Can't restore STDOUT");
1284 open(OUT,">&STDOUT") # XXX: lost message
1285 || &warn("Can't restore DB::OUT");
1289 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
1290 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
1291 $selected= select(OUT);
1293 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1294 $cmd =~ s/^\|+\s*//;
1297 # XXX Local variants do not work!
1298 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
1299 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1300 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1302 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1304 $onetimeDump = undef;
1305 $onetimedumpDepth = undef;
1306 } elsif ($term_pid == $$) {
1311 if ($pager =~ /^\|/) {
1313 # we cannot warn here: the handle is missing --tchrist
1314 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1316 # most of the $? crud was coping with broken cshisms
1318 print SAVEOUT "Pager `$pager' failed: ";
1320 print SAVEOUT "shell returned -1\n";
1323 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1324 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1326 print SAVEOUT "status ", ($? >> 8), "\n";
1330 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1331 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1332 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
1333 # Will stop ignoring SIGPIPE if done like nohup(1)
1334 # does SIGINT but Perl doesn't give us a choice.
1336 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1339 select($selected), $selected= "" unless $selected eq "";
1343 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
1344 foreach $evalarg (@$post) {
1347 } # if ($single || $signal)
1348 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
1352 # The following code may be executed now:
1356 my ($al, $ret, @ret) = "";
1357 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1360 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1361 $#stack = $stack_depth;
1362 $stack[-1] = $single;
1364 $single |= 4 if $stack_depth == $deep;
1366 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
1367 # Why -1? But it works! :-(
1368 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1369 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
1372 $single |= $stack[$stack_depth--];
1374 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1375 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1376 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1377 if ($doret eq $stack_depth or $frame & 16) {
1379 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1380 print $fh ' ' x $stack_depth if $frame & 16;
1381 print $fh "list context return from $sub:\n";
1382 dumpit($fh, \@ret );
1387 if (defined wantarray) {
1392 $single |= $stack[$stack_depth--];
1394 ? ( print_lineinfo(' ' x $stack_depth, "out "),
1395 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1396 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
1397 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1399 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1400 print $fh (' ' x $stack_depth) if $frame & 16;
1401 print $fh (defined wantarray
1402 ? "scalar context return from $sub: "
1403 : "void context return from $sub\n");
1404 dumpit( $fh, $ret ) if defined wantarray;
1413 ### Functions with multiple modes of failure die on error, the rest
1414 ### returns FALSE on error.
1415 ### User-interface functions cmd_* output error message.
1417 ### Note all cmd_[a-zA-Z]'s require $line, $dblineno as first arguments
1422 'A' => 'pre580_null',
1424 'B' => 'pre580_null',
1425 'd' => 'pre580_null',
1428 'M' => 'pre580_null',
1430 'o' => 'pre580_null',
1440 my $dblineno = shift;
1442 # with this level of indirection we can wrap
1443 # to old (pre580) or other command sets easily
1446 $set{$CommandSet}{$cmd} || $cmd
1448 # print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
1450 return &$call($line, $dblineno);
1454 my $line = shift || ''; # [.|line] expr
1455 my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
1456 if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
1457 my ($lineno, $expr) = ($1, $2);
1459 if ($dbline[$lineno] == 0) {
1460 print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
1462 $had_breakpoints{$filename} |= 2;
1463 $dbline{$lineno} =~ s/\0[^\0]*//;
1464 $dbline{$lineno} .= "\0" . action($expr);
1468 print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
1473 my $line = shift || '';
1474 my $dbline = shift; $line =~ s/^\./$dbline/;
1476 eval { &delete_action(); 1 } or print $OUT $@ and return;
1477 } elsif ($line =~ /^(\S.*)/) {
1478 eval { &delete_action($1); 1 } or print $OUT $@ and return;
1480 print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
1487 die "Line $i has no action .\n" if $dbline[$i] == 0;
1488 $dbline{$i} =~ s/\0[^\0]*//; # \^a
1489 delete $dbline{$i} if $dbline{$i} eq '';
1491 print $OUT "Deleting all actions...\n";
1492 for my $file (keys %had_breakpoints) {
1493 local *dbline = $main::{'_<' . $file};
1496 for ($i = 1; $i <= $max ; $i++) {
1497 if (defined $dbline{$i}) {
1498 $dbline{$i} =~ s/\0[^\0]*//;
1499 delete $dbline{$i} if $dbline{$i} eq '';
1501 unless ($had_breakpoints{$file} &= ~2) {
1502 delete $had_breakpoints{$file};
1510 my $line = shift; # [.|line] [cond]
1511 my $dbline = shift; $line =~ s/^\./$dbline/;
1512 if ($line =~ /^\s*$/) {
1513 &cmd_b_line($dbline, 1);
1514 } elsif ($line =~ /^load\b\s*(.*)/) {
1515 my $file = $1; $file =~ s/\s+$//;
1517 } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
1518 my $cond = length $3 ? $3 : '1';
1519 my ($subname, $break) = ($2, $1 eq 'postpone');
1520 $subname =~ s/\'/::/g;
1521 $subname = "${'package'}::" . $subname unless $subname =~ /::/;
1522 $subname = "main".$subname if substr($subname,0,2) eq "::";
1523 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
1524 } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
1526 $cond = length $2 ? $2 : '1';
1527 &cmd_b_sub($subname, $cond);
1528 } elsif ($line =~ /^(\d*)\s*(.*)/) {
1529 $line = $1 || $dbline;
1530 $cond = length $2 ? $2 : '1';
1531 &cmd_b_line($line, $cond);
1533 print "confused by line($line)?\n";
1539 $break_on_load{$file} = 1;
1540 $had_breakpoints{$file} |= 1;
1543 sub report_break_on_load {
1544 sort keys %break_on_load;
1552 push @files, $::INC{$file} if $::INC{$file};
1553 $file .= '.pm', redo unless $file =~ /\./;
1555 break_on_load($_) for @files;
1556 @files = report_break_on_load;
1559 print $OUT "Will stop on load of `@files'.\n";
1562 $filename_error = '';
1564 sub breakable_line {
1565 my ($from, $to) = @_;
1568 my $delta = $from < $to ? +1 : -1;
1569 my $limit = $delta > 0 ? $#dbline : 1;
1570 $limit = $to if ($limit - $to) * $delta > 0;
1571 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1573 return $i unless $dbline[$i] == 0;
1574 my ($pl, $upto) = ('', '');
1575 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1576 die "Line$pl $from$upto$filename_error not breakable\n";
1579 sub breakable_line_in_filename {
1581 local *dbline = $main::{'_<' . $f};
1582 local $filename_error = " of `$f'";
1587 my ($i, $cond) = @_;
1588 $cond = 1 unless @_ >= 2;
1592 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1593 $had_breakpoints{$filename} |= 1;
1594 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1595 else { $dbline{$i} = $cond; }
1599 eval { break_on_line(@_); 1 } or do {
1601 print $OUT $@ and return;
1605 sub break_on_filename_line {
1606 my ($f, $i, $cond) = @_;
1607 $cond = 1 unless @_ >= 3;
1608 local *dbline = $main::{'_<' . $f};
1609 local $filename_error = " of `$f'";
1610 local $filename = $f;
1611 break_on_line($i, $cond);
1614 sub break_on_filename_line_range {
1615 my ($f, $from, $to, $cond) = @_;
1616 my $i = breakable_line_in_filename($f, $from, $to);
1617 $cond = 1 unless @_ >= 3;
1618 break_on_filename_line($f,$i,$cond);
1621 sub subroutine_filename_lines {
1622 my ($subname,$cond) = @_;
1623 # Filename below can contain ':'
1624 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1627 sub break_subroutine {
1628 my $subname = shift;
1629 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1630 die "Subroutine $subname not found.\n";
1631 $cond = 1 unless @_ >= 2;
1632 break_on_filename_line_range($file,$s,$e,@_);
1636 my ($subname,$cond) = @_;
1637 $cond = 1 unless @_ >= 2;
1638 unless (ref $subname eq 'CODE') {
1639 $subname =~ s/\'/::/g;
1641 $subname = "${'package'}::" . $subname
1642 unless $subname =~ /::/;
1643 $subname = "CORE::GLOBAL::$s"
1644 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1645 $subname = "main".$subname if substr($subname,0,2) eq "::";
1647 eval { break_subroutine($subname,$cond); 1 } or do {
1649 print $OUT $@ and return;
1654 my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
1655 my $dbline = shift; $line =~ s/^\./$dbline/;
1657 eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
1658 } elsif ($line =~ /^(\S.*)/) {
1659 eval { &delete_breakpoint($line || $dbline); 1 } or do {
1661 print $OUT $@ and return;
1664 print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
1668 sub delete_breakpoint {
1671 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1672 $dbline{$i} =~ s/^[^\0]*//;
1673 delete $dbline{$i} if $dbline{$i} eq '';
1675 print $OUT "Deleting all breakpoints...\n";
1676 for my $file (keys %had_breakpoints) {
1677 local *dbline = $main::{'_<' . $file};
1680 for ($i = 1; $i <= $max ; $i++) {
1681 if (defined $dbline{$i}) {
1682 $dbline{$i} =~ s/^[^\0]+//;
1683 if ($dbline{$i} =~ s/^\0?$//) {
1688 if (not $had_breakpoints{$file} &= ~1) {
1689 delete $had_breakpoints{$file};
1693 undef %postponed_file;
1694 undef %break_on_load;
1698 sub cmd_stop { # As on ^C, but not signal-safy.
1703 my $line = shift || '';
1704 if ($line =~ /^h\s*/) {
1706 } elsif ($line =~ /^(\S.*)$/) {
1707 # support long commands; otherwise bogus errors
1708 # happen when you ask for h on <CR> for example
1709 my $asked = $1; # for proper errmsg
1710 my $qasked = quotemeta($asked); # for searching
1711 # XXX: finds CR but not <CR>
1712 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
1713 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
1717 print_help("B<$asked> is not a debugger command.\n");
1720 print_help($summary);
1726 $line =~ s/^-\s*$/-/;
1727 if ($line =~ /^(\$.*)/s) {
1730 print($OUT "Error: $@\n"), next CMD if $@;
1732 print($OUT "Interpreted as: $1 $s\n");
1735 } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
1736 my $s = $subname = $1;
1737 $subname =~ s/\'/::/;
1738 $subname = $package."::".$subname
1739 unless $subname =~ /::/;
1740 $subname = "CORE::GLOBAL::$s"
1741 if not defined &$subname and $s !~ /::/
1742 and defined &{"CORE::GLOBAL::$s"};
1743 $subname = "main".$subname if substr($subname,0,2) eq "::";
1744 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
1745 $subrange = pop @pieces;
1746 $file = join(':', @pieces);
1747 if ($file ne $filename) {
1748 print $OUT "Switching to file '$file'.\n"
1749 unless $slave_editor;
1750 *dbline = $main::{'_<' . $file};
1755 if (eval($subrange) < -$window) {
1756 $subrange =~ s/-.*/+/;
1761 print $OUT "Subroutine $subname not found.\n";
1763 } elsif ($line =~ /^\s*$/) {
1764 $incr = $window - 1;
1765 $line = $start . '-' . ($start + $incr);
1767 } elsif ($line =~ /^(\d*)\+(\d*)$/) {
1770 $incr = $window - 1 unless $incr;
1771 $line = $start . '-' . ($start + $incr);
1773 } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
1774 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
1775 $end = $max if $end > $max;
1777 $i = $line if $i eq '.';
1780 if ($slave_editor) {
1781 print $OUT "\032\032$filename:$i:0\n";
1784 for (; $i <= $end; $i++) {
1786 ($stop,$action) = split(/\0/, $dbline{$i}) if
1789 and $filename eq $filename_ini)
1791 : ($dbline[$i]+0 ? ':' : ' ') ;
1792 $arrow .= 'b' if $stop;
1793 $arrow .= 'a' if $action;
1794 print $OUT "$i$arrow\t", $dbline[$i];
1795 $i++, last if $signal;
1797 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
1799 $start = $i; # remember in case they want more
1800 $start = $max if $start > $max;
1805 my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
1806 my $action_wanted = ($arg =~ /a/) ? 1 : 0;
1807 my $break_wanted = ($arg =~ /b/) ? 1 : 0;
1808 my $watch_wanted = ($arg =~ /w/) ? 1 : 0;
1810 if ($break_wanted or $action_wanted) {
1811 for my $file (keys %had_breakpoints) {
1812 local *dbline = $main::{'_<' . $file};
1815 for ($i = 1; $i <= $max; $i++) {
1816 if (defined $dbline{$i}) {
1817 print $OUT "$file:\n" unless $was++;
1818 print $OUT " $i:\t", $dbline[$i];
1819 ($stop,$action) = split(/\0/, $dbline{$i});
1820 print $OUT " break if (", $stop, ")\n"
1821 if $stop and $break_wanted;
1822 print $OUT " action: ", $action, "\n"
1823 if $action and $action_wanted;
1829 if (%postponed and $break_wanted) {
1830 print $OUT "Postponed breakpoints in subroutines:\n";
1832 for $subname (keys %postponed) {
1833 print $OUT " $subname\t$postponed{$subname}\n";
1837 my @have = map { # Combined keys
1838 keys %{$postponed_file{$_}}
1839 } keys %postponed_file;
1840 if (@have and ($break_wanted or $action_wanted)) {
1841 print $OUT "Postponed breakpoints in files:\n";
1843 for $file (keys %postponed_file) {
1844 my $db = $postponed_file{$file};
1845 print $OUT " $file:\n";
1846 for $line (sort {$a <=> $b} keys %$db) {
1847 print $OUT " $line:\n";
1848 my ($stop,$action) = split(/\0/, $$db{$line});
1849 print $OUT " break if (", $stop, ")\n"
1850 if $stop and $break_wanted;
1851 print $OUT " action: ", $action, "\n"
1852 if $action and $action_wanted;
1858 if (%break_on_load and $break_wanted) {
1859 print $OUT "Breakpoints on load:\n";
1861 for $file (keys %break_on_load) {
1862 print $OUT " $file\n";
1866 if ($watch_wanted) {
1868 print $OUT "Watch-expressions:\n" if @to_watch;
1869 for my $expr (@to_watch) {
1870 print $OUT " $expr\n";
1882 my $opt = shift || ''; # opt[=val]
1883 if ($opt =~ /^(\S.*)/) {
1893 print $OUT "The old O command is now the o command.\n"; # hint
1894 print $OUT "Use 'h' to get current command help synopsis or\n"; #
1895 print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; #
1901 if ($line =~ /^(\d*)$/) {
1902 $incr = $window - 1;
1905 $line = $start . '-' . ($start + $incr);
1911 my $expr = shift || '';
1912 if ($expr =~ /^(\S.*)/) {
1913 push @to_watch, $expr;
1916 $val = (defined $val) ? "'$val'" : 'undef' ;
1917 push @old_watch, $val;
1920 print $OUT "Adding a watch-expression requires an expression\n"; # hint
1925 my $expr = shift || '';
1928 print $OUT "Deleting all watch expressions ...\n";
1929 @to_watch = @old_watch = ();
1930 } elsif ($expr =~ /^(\S.*)/) {
1932 foreach (@to_watch) {
1933 my $val = $to_watch[$i_cnt];
1934 if ($val eq $expr) { # =~ m/^\Q$i$/) {
1935 splice(@to_watch, $i_cnt, 1);
1940 print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
1944 ### END of the API section
1947 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
1948 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1951 sub print_lineinfo {
1952 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1958 # The following takes its argument via $evalarg to preserve current @_
1961 my $subname = shift;
1962 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
1963 my $offset = $1 || 0;
1964 # Filename below can contain ':'
1965 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
1968 local *dbline = $main::{'_<' . $file};
1969 local $^W = 0; # != 0 is magical below
1970 $had_breakpoints{$file} |= 1;
1972 ++$i until $dbline[$i] != 0 or $i >= $max;
1973 $dbline{$i} = delete $postponed{$subname};
1976 print $OUT "Subroutine $subname not found.\n";
1980 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
1981 #print $OUT "In postponed_sub for `$subname'.\n";
1985 if ($ImmediateStop) {
1989 return &postponed_sub
1990 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1991 # Cannot be done before the file is compiled
1992 local *dbline = shift;
1993 my $filename = $dbline;
1994 $filename =~ s/^_<//;
1996 $signal = 1, print $OUT "'$filename' loaded...\n"
1997 if $break_on_load{$filename};
1998 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
1999 return unless $postponed_file{$filename};
2000 $had_breakpoints{$filename} |= 1;
2001 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
2003 for $key (keys %{$postponed_file{$filename}}) {
2004 $dbline{$key} = ${$postponed_file{$filename}}{$key};
2006 delete $postponed_file{$filename};
2010 local ($savout) = select(shift);
2011 my $osingle = $single;
2012 my $otrace = $trace;
2013 $single = $trace = 0;
2016 unless (defined &main::dumpValue) {
2019 if (defined &main::dumpValue) {
2024 my $maxdepth = shift || $option{dumpDepth};
2025 $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
2026 &main::dumpValue($v, $maxdepth);
2029 print $OUT "dumpvar.pl not available.\n";
2036 # Tied method do not create a context, so may get wrong message:
2041 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
2042 my @sub = dump_trace($_[0] + 1, $_[1]);
2043 my $short = $_[2]; # Print short report, next one for sub name
2045 for ($i=0; $i <= $#sub; $i++) {
2048 my $args = defined $sub[$i]{args}
2049 ? "(@{ $sub[$i]{args} })"
2051 $args = (substr $args, 0, $maxtrace - 3) . '...'
2052 if length $args > $maxtrace;
2053 my $file = $sub[$i]{file};
2054 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
2056 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
2058 my $sub = @_ >= 4 ? $_[3] : $s;
2059 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
2061 print $fh "$sub[$i]{context} = $s$args" .
2062 " called from $file" .
2063 " line $sub[$i]{line}\n";
2070 my $count = shift || 1e9;
2073 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
2074 my $nothard = not $frame & 8;
2075 local $frame = 0; # Do not want to trace this.
2076 my $otrace = $trace;
2079 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
2084 if (not defined $arg) {
2086 } elsif ($nothard and tied $arg) {
2088 } elsif ($nothard and $type = ref $arg) {
2089 push @a, "ref($type)";
2091 local $_ = "$arg"; # Safe to stringify now - should not call f().
2094 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
2095 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
2096 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
2100 $context = $context ? '@' : (defined $context ? "\$" : '.');
2101 $args = $h ? [@a] : undef;
2102 $e =~ s/\n\s*\;\s*\Z// if $e;
2103 $e =~ s/([\\\'])/\\$1/g if $e;
2105 $sub = "require '$e'";
2106 } elsif (defined $r) {
2108 } elsif ($sub eq '(eval)') {
2109 $sub = "eval {...}";
2111 push(@sub, {context => $context, sub => $sub, args => $args,
2112 file => $file, line => $line});
2121 while ($action =~ s/\\$//) {
2130 # i hate using globals!
2131 $balanced_brace_re ||= qr{
2134 (?> [^{}] + ) # Non-parens without backtracking
2136 (??{ $balanced_brace_re }) # Group with matching parens
2140 return $_[0] !~ m/$balanced_brace_re/;
2144 &readline("cont: ");
2148 # We save, change, then restore STDIN and STDOUT to avoid fork() since
2149 # some non-Unix systems can do system() but have problems with fork().
2150 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
2151 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
2152 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
2153 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
2155 # XXX: using csh or tcsh destroys sigint retvals!
2157 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
2158 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
2163 # most of the $? crud was coping with broken cshisms
2165 &warn("(Command exited ", ($? >> 8), ")\n");
2167 &warn( "(Command died of SIG#", ($? & 127),
2168 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
2178 eval { require Term::ReadLine } or die $@;
2181 my ($i, $o) = split $tty, /,/;
2182 $o = $i unless defined $o;
2183 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
2184 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
2187 my $sel = select($OUT);
2191 eval "require Term::Rendezvous;" or die;
2192 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
2193 my $term_rv = new Term::Rendezvous $rv;
2195 $OUT = $term_rv->OUT;
2198 if ($term_pid eq '-1') { # In a TTY with another debugger
2202 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
2204 $term = new Term::ReadLine 'perldb', $IN, $OUT;
2206 $rl_attribs = $term->Attribs;
2207 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
2208 if defined $rl_attribs->{basic_word_break_characters}
2209 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
2210 $rl_attribs->{special_prefixes} = '$@&%';
2211 $rl_attribs->{completer_word_break_characters} .= '$@&%';
2212 $rl_attribs->{completion_function} = \&db_complete;
2214 $LINEINFO = $OUT unless defined $LINEINFO;
2215 $lineinfo = $console unless defined $lineinfo;
2217 if ($term->Features->{setHistory} and "@hist" ne "?") {
2218 $term->SetHistory(@hist);
2220 ornaments($ornaments) if defined $ornaments;
2224 # Example get_fork_TTY functions
2225 sub xterm_get_fork_TTY {
2226 (my $name = $0) =~ s,^.*[/\\],,s;
2227 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
2231 $pidprompt = ''; # Shown anyway in titlebar
2235 # This example function resets $IN, $OUT itself
2236 sub os2_get_fork_TTY {
2237 local $^F = 40; # XXXX Fixme!
2239 my ($in1, $out1, $in2, $out2);
2240 # Having -d in PERL5OPT would lead to a disaster...
2241 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2242 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2243 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2244 print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2245 local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB};
2246 $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB};
2247 $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB};
2248 (my $name = $0) =~ s,^.*[/\\],,s;
2250 if ( pipe $in1, $out1 and pipe $in2, $out2
2251 # system P_SESSION will fail if there is another process
2252 # in the same session with a "dependent" asynchronous child session.
2253 and @args = ($rl, fileno $in1, fileno $out2,
2254 "Daughter Perl debugger $pids $name") and
2255 (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
2256 END {sleep 5 unless $loaded}
2257 BEGIN {open STDIN, '</dev/con' or warn "reopen stdin: $!"}
2260 my ($rl, $in) = (shift, shift); # Read from $in and pass through
2262 system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2263 open IN, '<&=$in' or die "open <&=$in: \$!";
2264 \$| = 1; print while sysread IN, \$_, 1<<16;
2268 open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2270 require Term::ReadKey if $rl;
2271 Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
2272 print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
2274 or warn "system P_SESSION: $!, $^E" and 0)
2275 and close $in1 and close $out2 ) {
2276 $pidprompt = ''; # Shown anyway in titlebar
2277 reset_IN_OUT($in2, $out1);
2279 return ''; # Indicate that reset_IN_OUT is called
2284 sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2285 my $in = &get_fork_TTY if defined &get_fork_TTY;
2286 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2287 if (not defined $in) {
2289 print_help(<<EOP) if $why == 1;
2290 I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2292 print_help(<<EOP) if $why == 2;
2293 I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
2294 This may be an asynchronous session, so the parent debugger may be active.
2296 print_help(<<EOP) if $why != 4;
2297 Since two debuggers fight for the same TTY, input is severely entangled.
2301 I know how to switch the output to a different window in xterms
2302 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2303 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2305 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2306 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
2309 } elsif ($in ne '') {
2312 $console = ''; # Indicate no need to open-from-the-console
2317 sub resetterm { # We forked, so we need a different TTY
2319 my $systemed = $in > 1 ? '-' : '';
2321 $pids =~ s/\]/$systemed->$$]/;
2323 $pids = "[$term_pid->$$]";
2327 return unless $CreateTTY & $in;
2334 my $left = @typeahead;
2335 my $got = shift @typeahead;
2337 print $OUT "auto(-$left)", shift, $got, "\n";
2338 $term->AddHistory($got)
2339 if length($got) > 1 and defined $term->Features->{addHistory};
2345 my $line = CORE::readline($cmdfhs[-1]);
2346 defined $line ? (print $OUT ">> $line" and return $line)
2347 : close pop @cmdfhs;
2349 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
2350 $OUT->write(join('', @_));
2352 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
2356 $term->readline(@_);
2361 my ($opt, $val)= @_;
2362 $val = option_val($opt,'N/A');
2363 $val =~ s/([\\\'])/\\$1/g;
2364 printf $OUT "%20s = '%s'\n", $opt, $val;
2368 my ($opt, $default)= @_;
2370 if (defined $optionVars{$opt}
2371 and defined ${$optionVars{$opt}}) {
2372 $val = ${$optionVars{$opt}};
2373 } elsif (defined $optionAction{$opt}
2374 and defined &{$optionAction{$opt}}) {
2375 $val = &{$optionAction{$opt}}();
2376 } elsif (defined $optionAction{$opt}
2377 and not defined $option{$opt}
2378 or defined $optionVars{$opt}
2379 and not defined ${$optionVars{$opt}}) {
2382 $val = $option{$opt};
2384 $val = $default unless defined $val;
2391 # too dangerous to let intuitive usage overwrite important things
2392 # defaultion should never be the default
2393 my %opt_needs_val = map { ( $_ => 1 ) } qw{
2394 dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
2395 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2400 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
2401 my ($opt,$sep) = ($1,$2);
2404 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2406 #&dump_option($opt);
2407 } elsif ($sep !~ /\S/) {
2409 $val = "1"; # this is an evil default; make 'em set it!
2410 } elsif ($sep eq "=") {
2411 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2413 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2417 print OUT qq(Option better cleared using $opt=""\n)
2421 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2422 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2423 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2424 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
2425 ($val = $1) =~ s/\\([\\$end])/$1/g;
2429 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2430 || grep( /^\Q$opt/i && ($option = $_), @options );
2432 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2433 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2435 if ($opt_needs_val{$option} && $val_defaulted) {
2436 my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
2437 print $OUT "Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
2441 $option{$option} = $val if defined $val;
2446 require '$optionRequire{$option}';
2448 } || die # XXX: shouldn't happen
2449 if defined $optionRequire{$option} &&
2452 ${$optionVars{$option}} = $val
2453 if defined $optionVars{$option} &&
2456 &{$optionAction{$option}} ($val)
2457 if defined $optionAction{$option} &&
2458 defined &{$optionAction{$option}} &&
2462 dump_option($option) unless $OUT eq \*STDERR;
2467 my ($stem,@list) = @_;
2469 $ENV{"${stem}_n"} = @list;
2470 for $i (0 .. $#list) {
2472 $val =~ s/\\/\\\\/g;
2473 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
2474 $ENV{"${stem}_$i"} = $val;
2481 my $n = delete $ENV{"${stem}_n"};
2483 for $i (0 .. $n - 1) {
2484 $val = delete $ENV{"${stem}_$i"};
2485 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2493 return; # Put nothing on the stack - malloc/free land!
2497 my($msg)= join("",@_);
2498 $msg .= ": $!\n" unless $msg =~ /\n$/;
2504 my $switch_li = $LINEINFO eq $OUT;
2505 if ($term and $term->Features->{newTTY}) {
2506 ($IN, $OUT) = (shift, shift);
2507 $term->newTTY($IN, $OUT);
2509 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2511 ($IN, $OUT) = (shift, shift);
2513 my $o = select $OUT;
2516 $LINEINFO = $OUT if $switch_li;
2520 if (@_ and $term and $term->Features->{newTTY}) {
2521 my ($in, $out) = shift;
2523 ($in, $out) = split /,/, $in, 2;
2527 open IN, $in or die "cannot open `$in' for read: $!";
2528 open OUT, ">$out" or die "cannot open `$out' for write: $!";
2529 reset_IN_OUT(\*IN,\*OUT);
2532 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2533 # Useful if done through PERLDB_OPTS:
2534 $console = $tty = shift if @_;
2540 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
2542 $notty = shift if @_;
2548 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
2556 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2558 $remoteport = shift if @_;
2563 if (${$term->Features}{tkRunning}) {
2564 return $term->tkRunning(@_);
2567 print $OUT "tkRunning not supported by current ReadLine package.\n";
2574 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
2576 $runnonstop = shift if @_;
2583 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2590 $sh = quotemeta shift;
2591 $sh .= "\\b" if $sh =~ /\w$/;
2595 $psh =~ s/\\(.)/$1/g;
2600 if (defined $term) {
2601 local ($warnLevel,$dieLevel) = (0, 1);
2602 return '' unless $term->Features->{ornaments};
2603 eval { $term->ornaments(@_) } || '';
2611 $rc = quotemeta shift;
2612 $rc .= "\\b" if $rc =~ /\w$/;
2616 $prc =~ s/\\(.)/$1/g;
2621 return $lineinfo unless @_;
2623 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
2624 $slave_editor = ($stream =~ /^\|/);
2625 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2626 $LINEINFO = \*LINEINFO;
2627 my $save = select($LINEINFO);
2633 sub list_modules { # versions
2641 s/^Term::ReadLine::readline$/readline/;
2642 if (defined ${ $_ . '::VERSION' }) {
2643 $version{$file} = "${ $_ . '::VERSION' } from ";
2645 $version{$file} .= $INC{$file};
2647 dumpit($OUT,\%version);
2651 # XXX: make sure there are tabs between the command and explanation,
2652 # or print_help will screw up your formatting if you have
2653 # eeevil ornaments enabled. This is an insane mess.
2656 Help is currently only available for the new 580 CommandSet,
2657 if you really want old behaviour, presumably you know what
2661 B<s> [I<expr>] Single step [in I<expr>].
2662 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2663 <B<CR>> Repeat last B<n> or B<s> command.
2664 B<r> Return from current subroutine.
2665 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2666 at the specified position.
2667 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2668 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2669 B<l> I<line> List single I<line>.
2670 B<l> I<subname> List first window of lines from subroutine.
2671 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2672 B<l> List next window of lines.
2673 B<-> List previous window of lines.
2674 B<v> [I<line>] View window around I<line>.
2675 B<.> Return to the executed line.
2676 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2677 I<filename> may be either the full name of the file, or a regular
2678 expression matching the full file name:
2679 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2680 Evals (with saved bodies) are considered to be filenames:
2681 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2682 (in the order of execution).
2683 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2684 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2685 B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions.
2686 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2687 B<t> Toggle trace mode.
2688 B<t> I<expr> Trace through execution of I<expr>.
2689 B<b> Sets breakpoint on current line)
2690 B<b> [I<line>] [I<condition>]
2691 Set breakpoint; I<line> defaults to the current execution line;
2692 I<condition> breaks if it evaluates to true, defaults to '1'.
2693 B<b> I<subname> [I<condition>]
2694 Set breakpoint at first line of subroutine.
2695 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2696 B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
2697 B<b> B<postpone> I<subname> [I<condition>]
2698 Set breakpoint at first line of subroutine after
2700 B<b> B<compile> I<subname>
2701 Stop after the subroutine is compiled.
2702 B<B> [I<line>] Delete the breakpoint for I<line>.
2703 B<B> I<*> Delete all breakpoints.
2704 B<a> [I<line>] I<command>
2705 Set an action to be done before the I<line> is executed;
2706 I<line> defaults to the current execution line.
2707 Sequence is: check for breakpoint/watchpoint, print line
2708 if necessary, do action, prompt user if necessary,
2711 B<A> [I<line>] Delete the action for I<line>.
2712 B<A> I<*> Delete all actions.
2713 B<w> I<expr> Add a global watch-expression.
2715 B<W> I<expr> Delete a global watch-expression.
2716 B<W> I<*> Delete all watch-expressions.
2717 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2718 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2719 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2720 B<x> I<expr> Evals expression in list context, dumps the result.
2721 B<m> I<expr> Evals expression in list context, prints methods callable
2722 on the first element of the result.
2723 B<m> I<class> Prints methods callable via the given class.
2724 B<M> Show versions of loaded modules.
2726 B<<> ? List Perl commands to run before each prompt.
2727 B<<> I<expr> Define Perl command to run before each prompt.
2728 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2729 B<>> ? List Perl commands to run after each prompt.
2730 B<>> I<expr> Define Perl command to run after each prompt.
2731 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2732 B<{> I<db_command> Define debugger command to run before each prompt.
2733 B<{> ? List debugger commands to run before each prompt.
2734 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2735 B<$prc> I<number> Redo a previous command (default previous command).
2736 B<$prc> I<-number> Redo number'th-to-last command.
2737 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2738 See 'B<O> I<recallCommand>' too.
2739 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2740 . ( $rc eq $sh ? "" : "
2741 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2742 See 'B<O> I<shellBang>' too.
2743 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2744 B<H> I<-number> Display last number commands (default all).
2745 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2746 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2747 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2748 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2749 I<command> Execute as a perl statement in current package.
2750 B<R> Pure-man-restart of debugger, some of debugger state
2751 and command-line options may be lost.
2752 Currently the following settings are preserved:
2753 history, breakpoints and actions, debugger B<O>ptions
2754 and the following command-line options: I<-w>, I<-I>, I<-e>.
2756 B<o> [I<opt>] ... Set boolean option to true
2757 B<o> [I<opt>B<?>] Query options
2758 B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2759 Set options. Use quotes in spaces in value.
2760 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2761 I<pager> program for output of \"|cmd\";
2762 I<tkRunning> run Tk while prompting (with ReadLine);
2763 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2764 I<inhibit_exit> Allows stepping off the end of the script.
2765 I<ImmediateStop> Debugger should stop as early as possible.
2766 I<RemotePort> Remote hostname:port for remote debugging
2767 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2768 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2769 I<compactDump>, I<veryCompact> change style of array and hash dump;
2770 I<globPrint> whether to print contents of globs;
2771 I<DumpDBFiles> dump arrays holding debugged files;
2772 I<DumpPackages> dump symbol tables of packages;
2773 I<DumpReused> dump contents of \"reused\" addresses;
2774 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2775 I<bareStringify> Do not print the overload-stringified value;
2776 Other options include:
2777 I<PrintRet> affects printing of return value after B<r> command,
2778 I<frame> affects printing messages on subroutine entry/exit.
2779 I<AutoTrace> affects printing messages on possible breaking points.
2780 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2781 I<ornaments> affects screen appearance of the command line.
2782 I<CreateTTY> bits control attempts to create a new TTY on events:
2783 1: on fork() 2: debugger is started inside debugger
2785 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2786 You can put additional initialization options I<TTY>, I<noTTY>,
2787 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2788 `B<R>' after you set them).
2790 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2791 B<h> Summary of debugger commands.
2792 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2793 B<h h> Long help for debugger commands
2794 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2795 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2796 Set B<\$DB::doccmd> to change viewer.
2798 Type `|h h' for a paged display if this was too hard to read.
2800 "; # Fix balance of vi % matching: }}}}
2802 # note: tabs in the following section are not-so-helpful
2803 $summary = <<"END_SUM";
2804 I<List/search source lines:> I<Control script execution:>
2805 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2806 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2807 B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs
2808 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2809 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2810 B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position
2811 I<Debugger controls:> B<L> List break/watch/actions
2812 B<o> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2813 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2814 B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints
2815 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2816 B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions
2817 B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression
2818 B<h h> Complete help page B<W> I<expr|*> Delete a/all watch expressions
2819 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2820 B<q> or B<^D> Quit B<R> Attempt a restart
2821 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2822 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2823 B<p> I<expr> Print expression (uses script's current package).
2824 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2825 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2826 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2827 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2828 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2830 # ')}}; # Fix balance of vi % matching
2832 # and this is really numb...
2835 B<s> [I<expr>] Single step [in I<expr>].
2836 B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2837 <B<CR>> Repeat last B<n> or B<s> command.
2838 B<r> Return from current subroutine.
2839 B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
2840 at the specified position.
2841 B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2842 B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2843 B<l> I<line> List single I<line>.
2844 B<l> I<subname> List first window of lines from subroutine.
2845 B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
2846 B<l> List next window of lines.
2847 B<-> List previous window of lines.
2848 B<w> [I<line>] List window around I<line>.
2849 B<.> Return to the executed line.
2850 B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2851 I<filename> may be either the full name of the file, or a regular
2852 expression matching the full file name:
2853 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2854 Evals (with saved bodies) are considered to be filenames:
2855 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2856 (in the order of execution).
2857 B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2858 B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2859 B<L> List all breakpoints and actions.
2860 B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2861 B<t> Toggle trace mode.
2862 B<t> I<expr> Trace through execution of I<expr>.
2863 B<b> [I<line>] [I<condition>]
2864 Set breakpoint; I<line> defaults to the current execution line;
2865 I<condition> breaks if it evaluates to true, defaults to '1'.
2866 B<b> I<subname> [I<condition>]
2867 Set breakpoint at first line of subroutine.
2868 B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
2869 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2870 B<b> B<postpone> I<subname> [I<condition>]
2871 Set breakpoint at first line of subroutine after
2873 B<b> B<compile> I<subname>
2874 Stop after the subroutine is compiled.
2875 B<d> [I<line>] Delete the breakpoint for I<line>.
2876 B<D> Delete all breakpoints.
2877 B<a> [I<line>] I<command>
2878 Set an action to be done before the I<line> is executed;
2879 I<line> defaults to the current execution line.
2880 Sequence is: check for breakpoint/watchpoint, print line
2881 if necessary, do action, prompt user if necessary,
2883 B<a> [I<line>] Delete the action for I<line>.
2884 B<A> Delete all actions.
2885 B<W> I<expr> Add a global watch-expression.
2886 B<W> Delete all watch-expressions.
2887 B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2888 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2889 B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
2890 B<x> I<expr> Evals expression in list context, dumps the result.
2891 B<m> I<expr> Evals expression in list context, prints methods callable
2892 on the first element of the result.
2893 B<m> I<class> Prints methods callable via the given class.
2895 B<<> ? List Perl commands to run before each prompt.
2896 B<<> I<expr> Define Perl command to run before each prompt.
2897 B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
2898 B<>> ? List Perl commands to run after each prompt.
2899 B<>> I<expr> Define Perl command to run after each prompt.
2900 B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
2901 B<{> I<db_command> Define debugger command to run before each prompt.
2902 B<{> ? List debugger commands to run before each prompt.
2903 B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2904 B<$prc> I<number> Redo a previous command (default previous command).
2905 B<$prc> I<-number> Redo number'th-to-last command.
2906 B<$prc> I<pattern> Redo last command that started with I<pattern>.
2907 See 'B<O> I<recallCommand>' too.
2908 B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
2909 . ( $rc eq $sh ? "" : "
2910 B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2911 See 'B<O> I<shellBang>' too.
2912 B<@>I<file> Execute I<file> containing debugger commands (may nest).
2913 B<H> I<-number> Display last number commands (default all).
2914 B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2915 B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2916 B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2917 B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2918 I<command> Execute as a perl statement in current package.
2919 B<v> Show versions of loaded modules.
2920 B<R> Pure-man-restart of debugger, some of debugger state
2921 and command-line options may be lost.
2922 Currently the following settings are preserved:
2923 history, breakpoints and actions, debugger B<O>ptions
2924 and the following command-line options: I<-w>, I<-I>, I<-e>.
2926 B<O> [I<opt>] ... Set boolean option to true
2927 B<O> [I<opt>B<?>] Query options
2928 B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2929 Set options. Use quotes in spaces in value.
2930 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2931 I<pager> program for output of \"|cmd\";
2932 I<tkRunning> run Tk while prompting (with ReadLine);
2933 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2934 I<inhibit_exit> Allows stepping off the end of the script.
2935 I<ImmediateStop> Debugger should stop as early as possible.
2936 I<RemotePort> Remote hostname:port for remote debugging
2937 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2938 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2939 I<compactDump>, I<veryCompact> change style of array and hash dump;
2940 I<globPrint> whether to print contents of globs;
2941 I<DumpDBFiles> dump arrays holding debugged files;
2942 I<DumpPackages> dump symbol tables of packages;
2943 I<DumpReused> dump contents of \"reused\" addresses;
2944 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2945 I<bareStringify> Do not print the overload-stringified value;
2946 Other options include:
2947 I<PrintRet> affects printing of return value after B<r> command,
2948 I<frame> affects printing messages on subroutine entry/exit.
2949 I<AutoTrace> affects printing messages on possible breaking points.
2950 I<maxTraceLen> gives max length of evals/args listed in stack trace.
2951 I<ornaments> affects screen appearance of the command line.
2952 I<CreateTTY> bits control attempts to create a new TTY on events:
2953 1: on fork() 2: debugger is started inside debugger
2955 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2956 You can put additional initialization options I<TTY>, I<noTTY>,
2957 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2958 `B<R>' after you set them).
2960 B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
2961 B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2962 B<h h> Summary of debugger commands.
2963 B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2964 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2965 Set B<\$DB::doccmd> to change viewer.
2967 Type `|h' for a paged display if this was too hard to read.
2969 "; # Fix balance of vi % matching: }}}}
2971 # note: tabs in the following section are not-so-helpful
2972 $pre580_summary = <<"END_SUM";
2973 I<List/search source lines:> I<Control script execution:>
2974 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2975 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2976 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
2977 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
2978 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2979 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2980 I<Debugger controls:> B<L> List break/watch/actions
2981 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
2982 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
2983 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2984 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2985 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2986 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
2987 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
2988 B<q> or B<^D> Quit B<R> Attempt a restart
2989 I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2990 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2991 B<p> I<expr> Print expression (uses script's current package).
2992 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2993 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2994 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
2995 B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
2996 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
2998 # ')}}; # Fix balance of vi % matching
3005 # Restore proper alignment destroyed by eeevil I<> and B<>
3006 # ornaments: A pox on both their houses!
3008 # A help command will have everything up to and including
3009 # the first tab sequence padded into a field 16 (or if indented 20)
3010 # wide. If it's wider than that, an extra space will be added.
3012 ^ # only matters at start of line
3013 ( \040{4} | \t )* # some subcommands are indented
3014 ( < ? # so <CR> works
3015 [BI] < [^\t\n] + ) # find an eeevil ornament
3016 ( \t+ ) # original separation, discarded
3017 ( .* ) # this will now start (no earlier) than
3020 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
3021 my $clean = $command;
3022 $clean =~ s/[BI]<([^>]*)>/$1/g;
3023 # replace with this whole string:
3024 ($leadwhite ? " " x 4 : "")
3026 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
3031 s{ # handle bold ornaments
3032 B < ( [^>] + | > ) >
3034 $Term::ReadLine::TermCap::rl_term_set[2]
3036 . $Term::ReadLine::TermCap::rl_term_set[3]
3039 s{ # handle italic ornaments
3040 I < ( [^>] + | > ) >
3042 $Term::ReadLine::TermCap::rl_term_set[0]
3044 . $Term::ReadLine::TermCap::rl_term_set[1]
3052 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
3053 my $is_less = $pager =~ /\bless\b/;
3054 if ($pager =~ /\bmore\b/) {
3055 my @st_more = stat('/usr/bin/more');
3056 my @st_less = stat('/usr/bin/less');
3057 $is_less = @st_more && @st_less
3058 && $st_more[0] == $st_less[0]
3059 && $st_more[1] == $st_less[1];
3061 # changes environment!
3062 $ENV{LESS} .= 'r' if $is_less;
3068 $SIG{'ABRT'} = 'DEFAULT';
3069 kill 'ABRT', $$ if $panic++;
3070 if (defined &Carp::longmess) {
3071 local $SIG{__WARN__} = '';
3072 local $Carp::CarpLevel = 2; # mydie + confess
3073 &warn(Carp::longmess("Signal @_"));
3077 print $DB::OUT "Got signal @_\n";
3085 local $SIG{__WARN__} = '';
3086 local $SIG{__DIE__} = '';
3087 eval { require Carp } if defined $^S; # If error/warning during compilation,
3088 # require may be broken.
3089 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
3090 return unless defined &Carp::longmess;
3091 my ($mysingle,$mytrace) = ($single,$trace);
3092 $single = 0; $trace = 0;
3093 my $mess = Carp::longmess(@_);
3094 ($single,$trace) = ($mysingle,$mytrace);
3101 local $SIG{__DIE__} = '';
3102 local $SIG{__WARN__} = '';
3103 my $i = 0; my $ineval = 0; my $sub;
3104 if ($dieLevel > 2) {
3105 local $SIG{__WARN__} = \&dbwarn;
3106 &warn(@_); # Yell no matter what
3109 if ($dieLevel < 2) {
3110 die @_ if $^S; # in eval propagate
3112 # No need to check $^S, eval is much more robust nowadays
3113 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
3114 # require may be broken.
3116 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
3117 unless defined &Carp::longmess;
3119 # We do not want to debug this chunk (automatic disabling works
3120 # inside DB::DB, but not in Carp).
3121 my ($mysingle,$mytrace) = ($single,$trace);
3122 $single = 0; $trace = 0;
3125 package Carp; # Do not include us in the list
3127 $mess = Carp::longmess(@_);
3130 ($single,$trace) = ($mysingle,$mytrace);
3136 $prevwarn = $SIG{__WARN__} unless $warnLevel;
3139 $SIG{__WARN__} = \&DB::dbwarn;
3140 } elsif ($prevwarn) {
3141 $SIG{__WARN__} = $prevwarn;
3150 $prevdie = $SIG{__DIE__} unless $dieLevel;
3153 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
3154 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
3155 print $OUT "Stack dump during die enabled",
3156 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
3158 print $OUT "Dump printed too.\n" if $dieLevel > 2;
3159 } elsif ($prevdie) {
3160 $SIG{__DIE__} = $prevdie;
3161 print $OUT "Default die handler restored.\n";
3169 $prevsegv = $SIG{SEGV} unless $signalLevel;
3170 $prevbus = $SIG{BUS} unless $signalLevel;
3171 $signalLevel = shift;
3173 $SIG{SEGV} = \&DB::diesignal;
3174 $SIG{BUS} = \&DB::diesignal;
3176 $SIG{SEGV} = $prevsegv;
3177 $SIG{BUS} = $prevbus;
3185 my $name = CvGV_name_or_bust($in);
3186 defined $name ? $name : $in;
3189 sub CvGV_name_or_bust {
3191 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
3192 return unless ref $in;
3193 $in = \&$in; # Hard reference...
3194 eval {require Devel::Peek; 1} or return;
3195 my $gv = Devel::Peek::CvGV($in) or return;
3196 *$gv{PACKAGE} . '::' . *$gv{NAME};
3202 return unless defined &$subr;
3203 my $name = CvGV_name_or_bust($subr);
3205 $data = $sub{$name} if defined $name;
3206 return $data if defined $data;
3209 $subr = \&$subr; # Hard reference
3212 $s = $_, last if $subr eq \&$_;
3220 $class = ref $class if ref $class;
3223 methods_via($class, '', 1);
3224 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
3229 return if $packs{$class}++;
3231 my $prepend = $prefix ? "via $prefix: " : '';
3233 for $name (grep {defined &{${"${class}::"}{$_}}}
3234 sort keys %{"${class}::"}) {
3235 next if $seen{ $name }++;
3238 print $DB::OUT "$prepend$name\n";
3240 return unless shift; # Recurse?
3241 for $name (@{"${class}::ISA"}) {
3242 $prepend = $prefix ? $prefix . " -> $name" : $name;
3243 methods_via($name, $prepend, 1);
3248 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
3249 ? "man" # O Happy Day!
3250 : "perldoc"; # Alas, poor unfortunates
3256 &system("$doccmd $doccmd");
3259 # this way user can override, like with $doccmd="man -Mwhatever"
3260 # or even just "man " to disable the path check.
3261 unless ($doccmd eq 'man') {
3262 &system("$doccmd $page");
3266 $page = 'perl' if lc($page) eq 'help';
3269 my $man1dir = $Config::Config{'man1dir'};
3270 my $man3dir = $Config::Config{'man3dir'};
3271 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
3273 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
3274 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
3275 chop $manpath if $manpath;
3276 # harmless if missing, I figure
3277 my $oldpath = $ENV{MANPATH};
3278 $ENV{MANPATH} = $manpath if $manpath;
3279 my $nopathopt = $^O =~ /dunno what goes here/;
3280 if (CORE::system($doccmd,
3281 # I just *know* there are men without -M
3282 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3285 unless ($page =~ /^perl\w/) {
3286 if (grep { $page eq $_ } qw{
3287 5004delta 5005delta amiga api apio book boot bot call compile
3288 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
3289 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
3290 form func guts hack hist hpux intern ipc lexwarn locale lol mod
3291 modinstall modlib number obj op opentut os2 os390 pod port
3292 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
3293 trap unicode var vms win32 xs xstut
3297 CORE::system($doccmd,
3298 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
3303 if (defined $oldpath) {
3304 $ENV{MANPATH} = $manpath;
3306 delete $ENV{MANPATH};
3310 # The following BEGIN is very handy if debugger goes havoc, debugging debugger?
3312 BEGIN { # This does not compile, alas.
3313 $IN = \*STDIN; # For bugs before DB::OUT has been opened
3314 $OUT = \*STDERR; # For errors before DB::OUT has been opened
3318 $deep = 100; # warning if stack gets this deep
3322 $SIG{INT} = \&DB::catch;
3323 # This may be enabled to debug debugger:
3324 #$warnLevel = 1 unless defined $warnLevel;
3325 #$dieLevel = 1 unless defined $dieLevel;
3326 #$signalLevel = 1 unless defined $signalLevel;
3328 $db_stop = 0; # Compiler warning
3330 $level = 0; # Level of recursive debugging
3331 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
3332 # Triggers bug (?) in perl is we postpone this until runtime:
3333 @postponed = @stack = (0);
3334 $stack_depth = 0; # Localized $#stack
3339 BEGIN {$^W = $ini_warn;} # Switch warnings back
3341 #use Carp; # This did break, left for debugging
3344 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
3345 my($text, $line, $start) = @_;
3346 my ($itext, $search, $prefix, $pack) =
3347 ($text, "^\Q${'package'}::\E([^:]+)\$");
3349 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
3350 (map { /$search/ ? ($1) : () } keys %sub)
3351 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
3352 return sort grep /^\Q$text/, values %INC # files
3353 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
3354 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3355 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
3356 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
3357 return sort map {($_, db_complete($_ . "::", "V ", 2))}
3359 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
3361 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
3362 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
3363 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
3364 # We may want to complete to (eval 9), so $text may be wrong
3365 $prefix = length($1) - length($text);
3368 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
3370 if ((substr $text, 0, 1) eq '&') { # subroutines
3371 $text = substr $text, 1;
3373 return sort map "$prefix$_",
3376 (map { /$search/ ? ($1) : () }
3379 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
3380 $pack = ($1 eq 'main' ? '' : $1) . '::';
3381 $prefix = (substr $text, 0, 1) . $1 . '::';
3384 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
3385 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3386 return db_complete($out[0], $line, $start);
3390 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
3391 $pack = ($package eq 'main' ? '' : $package) . '::';
3392 $prefix = substr $text, 0, 1;
3393 $text = substr $text, 1;
3394 my @out = map "$prefix$_", grep /^\Q$text/,
3395 (grep /^_?[a-zA-Z]/, keys %$pack),
3396 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
3397 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
3398 return db_complete($out[0], $line, $start);
3402 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
3403 my @out = grep /^\Q$text/, @options;
3404 my $val = option_val($out[0], undef);
3406 if (not defined $val or $val =~ /[\n\r]/) {
3407 # Can do nothing better
3408 } elsif ($val =~ /\s/) {
3410 foreach $l (split //, qq/\"\'\#\|/) {
3411 $out = "$l$val$l ", last if (index $val, $l) == -1;
3416 # Default to value if one completion, to question if many
3417 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
3420 return $term->filename_list($text); # filenames
3425 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
3429 if (defined($ini_pids)) {
3430 $ENV{PERLDB_PIDS} = $ini_pids;
3432 delete($ENV{PERLDB_PIDS});
3437 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
3438 $fall_off_end = 1 unless $inhibit_exit;
3439 # Do not stop in at_exit() and destructors on exit:
3440 $DB::single = !$fall_off_end && !$runnonstop;
3441 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
3445 # ===================================== pre580 ================================
3446 # this is very sad below here...
3449 sub cmd_pre580_null {
3455 if ($cmd =~ /^(\d*)\s*(.*)/) {
3456 $i = $1 || $line; $j = $2;
3458 if ($dbline[$i] == 0) {
3459 print $OUT "Line $i may not have an action.\n";
3461 $had_breakpoints{$filename} |= 2;
3462 $dbline{$i} =~ s/\0[^\0]*//;
3463 $dbline{$i} .= "\0" . action($j);
3466 $dbline{$i} =~ s/\0[^\0]*//;
3467 delete $dbline{$i} if $dbline{$i} eq '';
3475 if ($cmd =~ /^load\b\s*(.*)/) {
3476 my $file = $1; $file =~ s/\s+$//;
3478 } elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
3479 my $cond = length $3 ? $3 : '1';
3480 my ($subname, $break) = ($2, $1 eq 'postpone');
3481 $subname =~ s/\'/::/g;
3482 $subname = "${'package'}::" . $subname
3483 unless $subname =~ /::/;
3484 $subname = "main".$subname if substr($subname,0,2) eq "::";
3485 $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
3486 } elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
3488 my $cond = length $2 ? $2 : '1';
3489 &cmd_b_sub($subname, $cond);
3490 } elsif ($cmd =~ /^(\d*)\s*(.*)/) {
3491 my $i = $1 || $dbline;
3492 my $cond = length $2 ? $2 : '1';
3493 &cmd_b_line($i, $cond);
3499 if ($cmd =~ /^\s*$/) {
3500 print $OUT "Deleting all breakpoints...\n";
3502 for $file (keys %had_breakpoints) {
3503 local *dbline = $main::{'_<' . $file};
3507 for ($i = 1; $i <= $max ; $i++) {
3508 if (defined $dbline{$i}) {
3509 $dbline{$i} =~ s/^[^\0]+//;
3510 if ($dbline{$i} =~ s/^\0?$//) {
3516 if (not $had_breakpoints{$file} &= ~1) {
3517 delete $had_breakpoints{$file};
3521 undef %postponed_file;
3522 undef %break_on_load;
3528 if ($cmd =~ /^\s*$/) {
3529 print_help($pre580_help);
3530 } elsif ($cmd =~ /^h\s*/) {
3531 print_help($pre580_summary);
3532 } elsif ($cmd =~ /^h\s+(\S.*)$/) {
3533 my $asked = $1; # for proper errmsg
3534 my $qasked = quotemeta($asked); # for searching
3535 # XXX: finds CR but not <CR>
3536 if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) {
3537 while ($pre580_help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
3541 print_help("B<$asked> is not a debugger command.\n");
3550 @to_watch = @old_watch = ();
3551 } elsif ($cmd =~ /^(.*)/s) {
3555 $val = (defined $val) ? "'$val'" : 'undef' ;
3556 push @old_watch, $val;
3564 "Debugged program terminated. Use `q' to quit or `R' to restart.";
3567 package DB; # Do not trace this 1; below!