This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add sleep() to avoid race on NeXT (from M.E. O'Neill
[perl5.git] / lib / perl5db.pl
CommitLineData
a687059c
LW
1package DB;
2
54d04a52 3# Debugger for Perl 5.00x; perl5db.pl patch level:
d338d6fe 4
3fbd6552 5$VERSION = 1.06;
43aed9ee 6$header = "perl5db.pl version $VERSION";
d338d6fe
PP
7
8# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
9# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
10
11# modified Perl debugger, to be run from Emacs in perldb-mode
12# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
13# Johan Vromans -- upgrade to 4.0 pl 10
14# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
15
16#
17# This file is automatically included if you do perl -d.
18# It's probably not useful to include this yourself.
19#
36477c24
PP
20# Perl supplies the values for %sub. It effectively inserts
21# a &DB'DB(); in front of every place that can have a
d338d6fe
PP
22# breakpoint. Instead of a subroutine call it calls &DB::sub with
23# $DB::sub being the called subroutine. It also inserts a BEGIN
24# {require 'perl5db.pl'} before the first line.
25#
55497cff 26# After each `require'd file is compiled, but before it is executed, a
477ea2b1 27# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
55497cff
PP
28# $filename is the expanded name of the `require'd file (as found as
29# value of %INC).
30#
31# Additional services from Perl interpreter:
32#
33# if caller() is called from the package DB, it provides some
34# additional data.
35#
477ea2b1 36# The array @{$main::{'_<'.$filename} is the line-by-line contents of
55497cff
PP
37# $filename.
38#
477ea2b1 39# The hash %{'_<'.$filename} contains breakpoints and action (it is
55497cff
PP
40# keyed by line number), and individual entries are settable (as
41# opposed to the whole hash). Only true/false is important to the
42# interpreter, though the values used by perl5db.pl have the form
43# "$break_condition\0$action". Values are magical in numeric context.
44#
477ea2b1 45# The scalar ${'_<'.$filename} contains "_<$filename".
55497cff 46#
d338d6fe 47# Note that no subroutine call is possible until &DB::sub is defined
36477c24 48# (for subroutines defined outside of the package DB). In fact the same is
d338d6fe
PP
49# true if $deep is not defined.
50#
51# $Log: perldb.pl,v $
52
53#
54# At start reads $rcfile that may set important options. This file
55# may define a subroutine &afterinit that will be executed after the
56# debugger is initialized.
57#
58# After $rcfile is read reads environment variable PERLDB_OPTS and parses
59# it as a rest of `O ...' line in debugger prompt.
60#
61# The options that can be specified only at startup:
62# [To set in $rcfile, call &parse_options("optionName=new_value").]
63#
64# TTY - the TTY to use for debugging i/o.
65#
66# noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
67# uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
68# Term::Rendezvous. Current variant is to have the name of TTY in this
69# file.
70#
71# ReadLine - If false, dummy ReadLine is used, so you can debug
72# ReadLine applications.
73#
74# NonStop - if true, no i/o is performed until interrupt.
75#
76# LineInfo - file or pipe to print line number info to. If it is a
77# pipe, a short "emacs like" message is used.
78#
363b4d59
GT
79# RemotePort - host:port to connect to on remote host for remote debugging.
80#
d338d6fe
PP
81# Example $rcfile: (delete leading hashes!)
82#
83# &parse_options("NonStop=1 LineInfo=db.out");
84# sub afterinit { $trace = 1; }
85#
86# The script will run without human intervention, putting trace
87# information into db.out. (If you interrupt it, you would better
88# reset LineInfo to something "interactive"!)
89#
ee971a18
PP
90##################################################################
91# Changelog:
92
93# A lot of things changed after 0.94. First of all, core now informs
94# debugger about entry into XSUBs, overloaded operators, tied operations,
95# BEGIN and END. Handy with `O f=2'.
96
97# This can make debugger a little bit too verbose, please be patient
98# and report your problems promptly.
99
100# Now the option frame has 3 values: 0,1,2.
101
102# Note that if DESTROY returns a reference to the object (or object),
103# the deletion of data may be postponed until the next function call,
104# due to the need to examine the return value.
105
55497cff
PP
106# Changes: 0.95: `v' command shows versions.
107# Changes: 0.96: `v' command shows version of readline.
108# primitive completion works (dynamic variables, subs for `b' and `l',
109# options). Can `p %var'
110# Better help (`h <' now works). New commands <<, >>, {, {{.
111# {dump|print}_trace() coded (to be able to do it from <<cmd).
112# `c sub' documented.
113# At last enough magic combined to stop after the end of debuggee.
114# !! should work now (thanks to Emacs bracket matching an extra
115# `]' in a regexp is caught).
116# `L', `D' and `A' span files now (as documented).
117# Breakpoints in `require'd code are possible (used in `R').
118# Some additional words on internal work of debugger.
119# `b load filename' implemented.
120# `b postpone subr' implemented.
121# now only `q' exits debugger (overwriteable on $inhibit_exit).
122# When restarting debugger breakpoints/actions persist.
123# Buglet: When restarting debugger only one breakpoint/action per
124# autoloaded function persists.
36477c24
PP
125# Changes: 0.97: NonStop will not stop in at_exit().
126# Option AutoTrace implemented.
127# Trace printed differently if frames are printed too.
1d06cb2d
IZ
128# new `inhibitExit' option.
129# printing of a very long statement interruptible.
130# Changes: 0.98: New command `m' for printing possible methods
131# 'l -' is a synonim for `-'.
132# Cosmetic bugs in printing stack trace.
133# `frame' & 8 to print "expanded args" in stack trace.
134# Can list/break in imported subs.
135# new `maxTraceLen' option.
136# frame & 4 and frame & 8 granted.
137# new command `m'
138# nonstoppable lines do not have `:' near the line number.
139# `b compile subname' implemented.
140# Will not use $` any more.
141# `-' behaves sane now.
477ea2b1
IZ
142# Changes: 0.99: Completion for `f', `m'.
143# `m' will remove duplicate names instead of duplicate functions.
144# `b load' strips trailing whitespace.
145# completion ignores leading `|'; takes into account current package
146# when completing a subroutine name (same for `l').
55497cff 147
ee971a18 148####################################################################
d338d6fe 149
54d04a52 150# Needed for the statement after exec():
d338d6fe 151
54d04a52
IZ
152BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
153local($^W) = 0; # Switch run-time warnings off during init.
d338d6fe
PP
154warn ( # Do not ;-)
155 $dumpvar::hashDepth,
156 $dumpvar::arrayDepth,
157 $dumpvar::dumpDBFiles,
158 $dumpvar::dumpPackages,
159 $dumpvar::quoteHighBit,
160 $dumpvar::printUndef,
161 $dumpvar::globPrint,
d338d6fe
PP
162 $dumpvar::usageOnly,
163 @ARGS,
164 $Carp::CarpLevel,
54d04a52 165 $panic,
36477c24 166 $second_time,
d338d6fe
PP
167 ) if 0;
168
54d04a52
IZ
169# Command-line + PERLLIB:
170@ini_INC = @INC;
171
d338d6fe
PP
172# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
173
174$trace = $signal = $single = 0; # Uninitialized warning suppression
175 # (local $^W cannot help - other packages!).
55497cff 176$inhibit_exit = $option{PrintRet} = 1;
d338d6fe 177
22fae026 178@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
d338d6fe 179 compactDump veryCompact quote HighBit undefPrint
36477c24 180 globPrint PrintRet UsageOnly frame AutoTrace
1d06cb2d 181 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
7a2e2cd6 182 recallCommand ShellBang pager tkRunning ornaments
3aefca04 183 signalLevel warnLevel dieLevel inhibit_exit
363b4d59
GT
184 ImmediateStop bareStringify
185 RemotePort);
d338d6fe
PP
186
187%optionVars = (
188 hashDepth => \$dumpvar::hashDepth,
189 arrayDepth => \$dumpvar::arrayDepth,
190 DumpDBFiles => \$dumpvar::dumpDBFiles,
191 DumpPackages => \$dumpvar::dumpPackages,
22fae026 192 DumpReused => \$dumpvar::dumpReused,
d338d6fe
PP
193 HighBit => \$dumpvar::quoteHighBit,
194 undefPrint => \$dumpvar::printUndef,
195 globPrint => \$dumpvar::globPrint,
d338d6fe 196 UsageOnly => \$dumpvar::usageOnly,
ee239bfe 197 bareStringify => \$dumpvar::bareStringify,
36477c24
PP
198 frame => \$frame,
199 AutoTrace => \$trace,
200 inhibit_exit => \$inhibit_exit,
1d06cb2d 201 maxTraceLen => \$maxtrace,
3aefca04 202 ImmediateStop => \$ImmediateStop,
363b4d59 203 RemotePort => \$remoteport,
d338d6fe
PP
204);
205
206%optionAction = (
207 compactDump => \&dumpvar::compactDump,
208 veryCompact => \&dumpvar::veryCompact,
209 quote => \&dumpvar::quote,
210 TTY => \&TTY,
211 noTTY => \&noTTY,
212 ReadLine => \&ReadLine,
213 NonStop => \&NonStop,
214 LineInfo => \&LineInfo,
215 recallCommand => \&recallCommand,
216 ShellBang => \&shellBang,
217 pager => \&pager,
218 signalLevel => \&signalLevel,
219 warnLevel => \&warnLevel,
220 dieLevel => \&dieLevel,
a737e074 221 tkRunning => \&tkRunning,
7a2e2cd6 222 ornaments => \&ornaments,
363b4d59 223 RemotePort => \&RemotePort,
d338d6fe
PP
224 );
225
226%optionRequire = (
227 compactDump => 'dumpvar.pl',
228 veryCompact => 'dumpvar.pl',
229 quote => 'dumpvar.pl',
230 );
231
232# These guys may be defined in $ENV{PERL5DB} :
233$rl = 1 unless defined $rl;
ee971a18
PP
234$warnLevel = 1 unless defined $warnLevel;
235$dieLevel = 1 unless defined $dieLevel;
236$signalLevel = 1 unless defined $signalLevel;
55497cff
PP
237$pre = [] unless defined $pre;
238$post = [] unless defined $post;
239$pretype = [] unless defined $pretype;
d338d6fe
PP
240warnLevel($warnLevel);
241dieLevel($dieLevel);
242signalLevel($signalLevel);
65c9c81d
IZ
243&pager((defined($ENV{PAGER})
244 ? $ENV{PAGER}
245 : ($^O eq 'os2'
246 ? 'cmd /c more'
247 : 'more'))) unless defined $pager;
d338d6fe
PP
248&recallCommand("!") unless defined $prc;
249&shellBang("!") unless defined $psh;
1d06cb2d 250$maxtrace = 400 unless defined $maxtrace;
d338d6fe
PP
251
252if (-e "/dev/tty") {
253 $rcfile=".perldb";
254} else {
255 $rcfile="perldb.ini";
256}
257
258if (-f $rcfile) {
259 do "./$rcfile";
260} elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
261 do "$ENV{LOGDIR}/$rcfile";
262} elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
263 do "$ENV{HOME}/$rcfile";
264}
265
266if (defined $ENV{PERLDB_OPTS}) {
267 parse_options($ENV{PERLDB_OPTS});
268}
269
54d04a52
IZ
270if (exists $ENV{PERLDB_RESTART}) {
271 delete $ENV{PERLDB_RESTART};
272 # $restart = 1;
273 @hist = get_list('PERLDB_HIST');
55497cff
PP
274 %break_on_load = get_list("PERLDB_ON_LOAD");
275 %postponed = get_list("PERLDB_POSTPONE");
276 my @had_breakpoints= get_list("PERLDB_VISITED");
277 for (0 .. $#had_breakpoints) {
0c395bd7
CS
278 my %pf = get_list("PERLDB_FILE_$_");
279 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
54d04a52
IZ
280 }
281 my %opt = get_list("PERLDB_OPT");
282 my ($opt,$val);
283 while (($opt,$val) = each %opt) {
284 $val =~ s/[\\\']/\\$1/g;
285 parse_options("$opt'$val'");
286 }
287 @INC = get_list("PERLDB_INC");
288 @ini_INC = @INC;
43aed9ee
IZ
289 $pretype = [get_list("PERLDB_PRETYPE")];
290 $pre = [get_list("PERLDB_PRE")];
291 $post = [get_list("PERLDB_POST")];
292 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
54d04a52
IZ
293}
294
d338d6fe
PP
295if ($notty) {
296 $runnonstop = 1;
297} else {
298 # Is Perl being run from Emacs?
299 $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
300 $rl = 0, shift(@main::ARGV) if $emacs;
301
302 #require Term::ReadLine;
303
4fabb596 304 if ($^O eq 'cygwin') {
8736538c
AS
305 # /dev/tty is binary. use stdin for textmode
306 undef $console;
307 } elsif (-e "/dev/tty") {
d338d6fe 308 $console = "/dev/tty";
39e571d4 309 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
d338d6fe
PP
310 $console = "con";
311 } else {
312 $console = "sys\$command";
313 }
314
96774cc9
JR
315 if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
316 $console = undef;
317 }
318
d338d6fe 319 # Around a bug:
ee971a18 320 if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
d338d6fe
PP
321 $console = undef;
322 }
323
4d2c4e07
OF
324 if ($^O eq 'epoc') {
325 $console = undef;
326 }
327
d338d6fe
PP
328 $console = $tty if defined $tty;
329
363b4d59
GT
330 if (defined $remoteport) {
331 require IO::Socket;
332 $OUT = new IO::Socket::INET( Timeout => '10',
333 PeerAddr => $remoteport,
334 Proto => 'tcp',
335 );
336 if (!$OUT) { die "Could not create socket to connect to remote host."; }
337 $IN = $OUT;
d338d6fe 338 }
363b4d59
GT
339 else {
340 if (defined $console) {
341 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
342 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
343 || open(OUT,">&STDOUT"); # so we don't dongle stdout
344 } else {
345 open(IN,"<&STDIN");
346 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
347 $console = 'STDIN/OUT';
348 }
349 # so open("|more") can read from STDOUT and so we don't dingle stdin
350 $IN = \*IN;
d338d6fe 351
363b4d59
GT
352 $OUT = \*OUT;
353 }
d338d6fe
PP
354 select($OUT);
355 $| = 1; # for DB::OUT
356 select(STDOUT);
357
358 $LINEINFO = $OUT unless defined $LINEINFO;
359 $lineinfo = $console unless defined $lineinfo;
360
361 $| = 1; # for real STDOUT
362
363 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
364 unless ($runnonstop) {
365 print $OUT "\nLoading DB routines from $header\n";
366 print $OUT ("Emacs support ",
367 $emacs ? "enabled" : "available",
368 ".\n");
d9f67849 369 print $OUT "\nEnter h or `h h' for help, run `perldoc perldebug' for more help.\n\n";
d338d6fe
PP
370 }
371}
372
373@ARGS = @ARGV;
374for (@args) {
375 s/\'/\\\'/g;
376 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
377}
378
379if (defined &afterinit) { # May be defined in $rcfile
380 &afterinit();
381}
382
43aed9ee
IZ
383$I_m_init = 1;
384
d338d6fe
PP
385############################################################ Subroutines
386
d338d6fe 387sub DB {
36477c24
PP
388 # _After_ the perl program is compiled, $single is set to 1:
389 if ($single and not $second_time++) {
390 if ($runnonstop) { # Disable until signal
f8b5b99c 391 for ($i=0; $i <= $stack_depth; ) {
d338d6fe
PP
392 $stack[$i++] &= ~1;
393 }
54d04a52 394 $single = 0;
36477c24 395 # return; # Would not print trace!
3aefca04
IZ
396 } elsif ($ImmediateStop) {
397 $ImmediateStop = 0;
398 $signal = 1;
54d04a52 399 }
d338d6fe 400 }
36477c24 401 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
d338d6fe 402 &save;
d338d6fe 403 ($package, $filename, $line) = caller;
54d04a52 404 $filename_ini = $filename;
22fae026 405 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
d338d6fe 406 "package $package;"; # this won't let them modify, alas
8ebc5c01 407 local(*dbline) = $main::{'_<' . $filename};
d338d6fe
PP
408 $max = $#dbline;
409 if (($stop,$action) = split(/\0/,$dbline{$line})) {
410 if ($stop eq '1') {
411 $signal |= 1;
54d04a52 412 } elsif ($stop) {
3f521411 413 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
d338d6fe
PP
414 $dbline{$line} =~ s/;9($|\0)/$1/;
415 }
416 }
36477c24 417 my $was_signal = $signal;
6027b9a3
IZ
418 if ($trace & 2) {
419 for (my $n = 0; $n <= $#to_watch; $n++) {
420 $evalarg = $to_watch[$n];
ed0d1bf7 421 local $onetimeDump; # Do not output results
6027b9a3
IZ
422 my ($val) = &eval; # Fix context (&eval is doing array)?
423 $val = ( (defined $val) ? "'$val'" : 'undef' );
424 if ($val ne $old_watch[$n]) {
425 $signal = 1;
426 print $OUT <<EOP;
405ff068
IZ
427Watchpoint $n:\t$to_watch[$n] changed:
428 old value:\t$old_watch[$n]
429 new value:\t$val
6027b9a3
IZ
430EOP
431 $old_watch[$n] = $val;
432 }
433 }
434 }
435 if ($trace & 4) { # User-installed watch
436 return if watchfunction($package, $filename, $line)
437 and not $single and not $was_signal and not ($trace & ~4);
438 }
439 $was_signal = $signal;
36477c24 440 $signal = 0;
6027b9a3 441 if ($single || ($trace & 1) || $was_signal) {
d338d6fe 442 if ($emacs) {
54d04a52
IZ
443 $position = "\032\032$filename:$line:0\n";
444 print $LINEINFO $position;
405ff068 445 } elsif ($package eq 'DB::fake') {
65c9c81d 446 $term || &setterm;
405ff068
IZ
447 print_help(<<EOP);
448Debugged program terminated. Use B<q> to quit or B<R> to restart,
449 use B<O> I<inhibit_exit> to avoid stopping after program termination,
450 B<h q>, B<h R> or B<h O> to get additional info.
451EOP
452 $package = 'main';
363b4d59 453 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
405ff068 454 "package $package;"; # this won't let them modify, alas
d338d6fe
PP
455 } else {
456 $sub =~ s/\'/::/;
457 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
458 $prefix .= "$sub($filename:";
459 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
460 if (length($prefix) > 30) {
54d04a52 461 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
d338d6fe
PP
462 $prefix = "";
463 $infix = ":\t";
464 } else {
465 $infix = "):\t";
54d04a52 466 $position = "$prefix$line$infix$dbline[$line]$after";
36477c24
PP
467 }
468 if ($frame) {
f8b5b99c 469 print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after";
36477c24 470 } else {
54d04a52 471 print $LINEINFO $position;
d338d6fe
PP
472 }
473 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
474 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
36477c24 475 last if $signal;
d338d6fe 476 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
54d04a52 477 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
54d04a52 478 $position .= $incr_pos;
36477c24 479 if ($frame) {
f8b5b99c 480 print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after";
36477c24
PP
481 } else {
482 print $LINEINFO $incr_pos;
483 }
d338d6fe
PP
484 }
485 }
486 }
487 $evalarg = $action, &eval if $action;
36477c24 488 if ($single || $was_signal) {
d338d6fe 489 local $level = $level + 1;
e63173ce
IZ
490 foreach $evalarg (@$pre) {
491 &eval;
492 }
f8b5b99c 493 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
d338d6fe
PP
494 if $single & 4;
495 $start = $line;
1d06cb2d 496 $incr = -1; # for backward motion.
6657d1ba 497 @typeahead = (@$pretype, @typeahead);
d338d6fe
PP
498 CMD:
499 while (($term || &setterm),
f36776d9 500 ($term_pid == $$ or &resetterm),
54d04a52
IZ
501 defined ($cmd=&readline(" DB" . ('<' x $level) .
502 ($#hist+1) . ('>' x $level) .
503 " "))) {
d338d6fe
PP
504 $single = 0;
505 $signal = 0;
506 $cmd =~ s/\\$/\n/ && do {
54d04a52 507 $cmd .= &readline(" cont: ");
d338d6fe
PP
508 redo CMD;
509 };
d338d6fe
PP
510 $cmd =~ /^$/ && ($cmd = $laststep);
511 push(@hist,$cmd) if length($cmd) > 1;
512 PIPE: {
513 ($i) = split(/\s+/,$cmd);
514 eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
477ea2b1 515 $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
d338d6fe 516 $cmd =~ /^h$/ && do {
6027b9a3 517 print_help($help);
d338d6fe
PP
518 next CMD; };
519 $cmd =~ /^h\s+h$/ && do {
6027b9a3 520 print_help($summary);
d338d6fe
PP
521 next CMD; };
522 $cmd =~ /^h\s+(\S)$/ && do {
523 my $asked = "\Q$1";
6027b9a3
IZ
524 if ($help =~ /^(?:[IB]<)$asked/m) {
525 while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
526 print_help($1);
55497cff 527 }
d338d6fe 528 } else {
6027b9a3 529 print_help("B<$asked> is not a debugger command.\n");
d338d6fe
PP
530 }
531 next CMD; };
532 $cmd =~ /^t$/ && do {
3fbd6552 533 $trace ^= 1;
6027b9a3
IZ
534 print $OUT "Trace = " .
535 (($trace & 1) ? "on" : "off" ) . "\n";
d338d6fe
PP
536 next CMD; };
537 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
538 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
539 foreach $subname (sort(keys %sub)) {
540 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
541 print $OUT $subname,"\n";
542 }
543 }
544 next CMD; };
ee971a18
PP
545 $cmd =~ /^v$/ && do {
546 list_versions(); next CMD};
d338d6fe
PP
547 $cmd =~ s/^X\b/V $package/;
548 $cmd =~ /^V$/ && do {
549 $cmd = "V $package"; };
550 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
551 local ($savout) = select($OUT);
552 $packname = $1;
553 @vars = split(' ',$2);
554 do 'dumpvar.pl' unless defined &main::dumpvar;
555 if (defined &main::dumpvar) {
54d04a52 556 local $frame = 0;
ee971a18 557 local $doret = -2;
d338d6fe
PP
558 &main::dumpvar($packname,@vars);
559 } else {
560 print $OUT "dumpvar.pl not available.\n";
561 }
562 select ($savout);
563 next CMD; };
564 $cmd =~ s/^x\b/ / && do { # So that will be evaled
1d06cb2d
IZ
565 $onetimeDump = 'dump'; };
566 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
567 methods($1); next CMD};
568 $cmd =~ s/^m\b/ / && do { # So this will be evaled
569 $onetimeDump = 'methods'; };
d338d6fe
PP
570 $cmd =~ /^f\b\s*(.*)/ && do {
571 $file = $1;
477ea2b1 572 $file =~ s/\s+$//;
d338d6fe
PP
573 if (!$file) {
574 print $OUT "The old f command is now the r command.\n";
575 print $OUT "The new f command switches filenames.\n";
576 next CMD;
577 }
578 if (!defined $main::{'_<' . $file}) {
579 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
477ea2b1
IZ
580 $try = substr($try,2);
581 print $OUT "Choosing $try matching `$file':\n";
582 $file = $try;
d338d6fe
PP
583 }}
584 }
585 if (!defined $main::{'_<' . $file}) {
04fb8f4b 586 print $OUT "No file matching `$file' is loaded.\n";
d338d6fe
PP
587 next CMD;
588 } elsif ($file ne $filename) {
8ebc5c01 589 *dbline = $main::{'_<' . $file};
d338d6fe
PP
590 $max = $#dbline;
591 $filename = $file;
592 $start = 1;
593 $cmd = "l";
477ea2b1
IZ
594 } else {
595 print $OUT "Already in $file.\n";
596 next CMD;
597 }
598 };
1d06cb2d 599 $cmd =~ s/^l\s+-\s*$/-/;
83ee9e09
GS
600 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
601 $evalarg = $2;
602 my ($s) = &eval;
603 print($OUT "Error: $@\n"), next CMD if $@;
604 $s = CvGV_name($s);
605 print($OUT "Interpreted as: $1 $s\n");
606 $cmd = "$1 $s";
607 };
608 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
d338d6fe
PP
609 $subname = $1;
610 $subname =~ s/\'/::/;
477ea2b1
IZ
611 $subname = $package."::".$subname
612 unless $subname =~ /::/;
d338d6fe 613 $subname = "main".$subname if substr($subname,0,2) eq "::";
83ee9e09 614 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
d338d6fe
PP
615 $subrange = pop @pieces;
616 $file = join(':', @pieces);
617 if ($file ne $filename) {
bee32ff8
GS
618 print $OUT "Switching to file '$file'.\n"
619 unless $emacs;
8ebc5c01 620 *dbline = $main::{'_<' . $file};
d338d6fe
PP
621 $max = $#dbline;
622 $filename = $file;
623 }
624 if ($subrange) {
625 if (eval($subrange) < -$window) {
626 $subrange =~ s/-.*/+/;
627 }
628 $cmd = "l $subrange";
629 } else {
630 print $OUT "Subroutine $subname not found.\n";
631 next CMD;
632 } };
54d04a52 633 $cmd =~ /^\.$/ && do {
1d06cb2d 634 $incr = -1; # for backward motion.
54d04a52
IZ
635 $start = $line;
636 $filename = $filename_ini;
8ebc5c01 637 *dbline = $main::{'_<' . $filename};
54d04a52
IZ
638 $max = $#dbline;
639 print $LINEINFO $position;
640 next CMD };
d338d6fe
PP
641 $cmd =~ /^w\b\s*(\d*)$/ && do {
642 $incr = $window - 1;
643 $start = $1 if $1;
644 $start -= $preview;
54d04a52 645 #print $OUT 'l ' . $start . '-' . ($start + $incr);
d338d6fe
PP
646 $cmd = 'l ' . $start . '-' . ($start + $incr); };
647 $cmd =~ /^-$/ && do {
1d06cb2d
IZ
648 $start -= $incr + $window + 1;
649 $start = 1 if $start <= 0;
d338d6fe 650 $incr = $window - 1;
1d06cb2d 651 $cmd = 'l ' . ($start) . '+'; };
d338d6fe
PP
652 $cmd =~ /^l$/ && do {
653 $incr = $window - 1;
654 $cmd = 'l ' . $start . '-' . ($start + $incr); };
655 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
656 $start = $1 if $1;
657 $incr = $2;
658 $incr = $window - 1 unless $incr;
659 $cmd = 'l ' . $start . '-' . ($start + $incr); };
54d04a52
IZ
660 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
661 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
d338d6fe
PP
662 $end = $max if $end > $max;
663 $i = $2;
664 $i = $line if $i eq '.';
665 $i = 1 if $i < 1;
1d06cb2d 666 $incr = $end - $i;
d338d6fe
PP
667 if ($emacs) {
668 print $OUT "\032\032$filename:$i:0\n";
669 $i = $end;
670 } else {
671 for (; $i <= $end; $i++) {
54d04a52
IZ
672 ($stop,$action) = split(/\0/, $dbline{$i});
673 $arrow = ($i==$line
674 and $filename eq $filename_ini)
675 ? '==>'
36477c24 676 : ($dbline[$i]+0 ? ':' : ' ') ;
54d04a52
IZ
677 $arrow .= 'b' if $stop;
678 $arrow .= 'a' if $action;
679 print $OUT "$i$arrow\t", $dbline[$i];
65c9c81d 680 $i++, last if $signal;
d338d6fe 681 }
65c9c81d 682 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
d338d6fe
PP
683 }
684 $start = $i; # remember in case they want more
685 $start = $max if $start > $max;
686 next CMD; };
687 $cmd =~ /^D$/ && do {
55497cff
PP
688 print $OUT "Deleting all breakpoints...\n";
689 my $file;
690 for $file (keys %had_breakpoints) {
8ebc5c01 691 local *dbline = $main::{'_<' . $file};
55497cff
PP
692 my $max = $#dbline;
693 my $was;
694
d338d6fe
PP
695 for ($i = 1; $i <= $max ; $i++) {
696 if (defined $dbline{$i}) {
697 $dbline{$i} =~ s/^[^\0]+//;
698 if ($dbline{$i} =~ s/^\0?$//) {
699 delete $dbline{$i};
700 }
701 }
702 }
3fbd6552
GS
703
704 if (not $had_breakpoints{$file} &= ~1) {
705 delete $had_breakpoints{$file};
706 }
55497cff
PP
707 }
708 undef %postponed;
709 undef %postponed_file;
710 undef %break_on_load;
55497cff 711 next CMD; };
d338d6fe 712 $cmd =~ /^L$/ && do {
55497cff
PP
713 my $file;
714 for $file (keys %had_breakpoints) {
8ebc5c01 715 local *dbline = $main::{'_<' . $file};
55497cff
PP
716 my $max = $#dbline;
717 my $was;
718
d338d6fe
PP
719 for ($i = 1; $i <= $max; $i++) {
720 if (defined $dbline{$i}) {
2002527a 721 print $OUT "$file:\n" unless $was++;
55497cff 722 print $OUT " $i:\t", $dbline[$i];
d338d6fe 723 ($stop,$action) = split(/\0/, $dbline{$i});
55497cff 724 print $OUT " break if (", $stop, ")\n"
d338d6fe 725 if $stop;
55497cff 726 print $OUT " action: ", $action, "\n"
d338d6fe
PP
727 if $action;
728 last if $signal;
729 }
730 }
55497cff
PP
731 }
732 if (%postponed) {
733 print $OUT "Postponed breakpoints in subroutines:\n";
734 my $subname;
735 for $subname (keys %postponed) {
736 print $OUT " $subname\t$postponed{$subname}\n";
737 last if $signal;
738 }
739 }
740 my @have = map { # Combined keys
741 keys %{$postponed_file{$_}}
742 } keys %postponed_file;
743 if (@have) {
744 print $OUT "Postponed breakpoints in files:\n";
745 my ($file, $line);
746 for $file (keys %postponed_file) {
0c395bd7 747 my $db = $postponed_file{$file};
55497cff 748 print $OUT " $file:\n";
0c395bd7 749 for $line (sort {$a <=> $b} keys %$db) {
08a4aec0 750 print $OUT " $line:\n";
0c395bd7 751 my ($stop,$action) = split(/\0/, $$db{$line});
55497cff
PP
752 print $OUT " break if (", $stop, ")\n"
753 if $stop;
754 print $OUT " action: ", $action, "\n"
755 if $action;
756 last if $signal;
757 }
758 last if $signal;
759 }
760 }
761 if (%break_on_load) {
762 print $OUT "Breakpoints on load:\n";
763 my $file;
764 for $file (keys %break_on_load) {
765 print $OUT " $file\n";
766 last if $signal;
767 }
768 }
6027b9a3
IZ
769 if ($trace & 2) {
770 print $OUT "Watch-expressions:\n";
771 my $expr;
772 for $expr (@to_watch) {
773 print $OUT " $expr\n";
774 last if $signal;
775 }
776 }
55497cff
PP
777 next CMD; };
778 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
477ea2b1 779 my $file = $1; $file =~ s/\s+$//;
55497cff
PP
780 {
781 $break_on_load{$file} = 1;
782 $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
783 $file .= '.pm', redo unless $file =~ /\./;
784 }
3fbd6552 785 $had_breakpoints{$file} |= 1;
55497cff
PP
786 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
787 next CMD; };
1d06cb2d
IZ
788 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
789 my $cond = $3 || '1';
790 my ($subname, $break) = ($2, $1 eq 'postpone');
55497cff
PP
791 $subname =~ s/\'/::/;
792 $subname = "${'package'}::" . $subname
793 unless $subname =~ /::/;
794 $subname = "main".$subname if substr($subname,0,2) eq "::";
1d06cb2d
IZ
795 $postponed{$subname} = $break
796 ? "break +0 if $cond" : "compile";
d338d6fe 797 next CMD; };
83ee9e09 798 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
d338d6fe
PP
799 $subname = $1;
800 $cond = $2 || '1';
801 $subname =~ s/\'/::/;
802 $subname = "${'package'}::" . $subname
803 unless $subname =~ /::/;
804 $subname = "main".$subname if substr($subname,0,2) eq "::";
805 # Filename below can contain ':'
1d06cb2d 806 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
d338d6fe
PP
807 $i += 0;
808 if ($i) {
bee32ff8
GS
809 local $filename = $file;
810 local *dbline = $main::{'_<' . $filename};
3fbd6552 811 $had_breakpoints{$filename} |= 1;
d338d6fe
PP
812 $max = $#dbline;
813 ++$i while $dbline[$i] == 0 && $i < $max;
814 $dbline{$i} =~ s/^[^\0]*/$cond/;
815 } else {
816 print $OUT "Subroutine $subname not found.\n";
817 }
818 next CMD; };
819 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
3fbd6552 820 $i = $1 || $line;
d338d6fe
PP
821 $cond = $2 || '1';
822 if ($dbline[$i] == 0) {
823 print $OUT "Line $i not breakable.\n";
824 } else {
3fbd6552 825 $had_breakpoints{$filename} |= 1;
d338d6fe
PP
826 $dbline{$i} =~ s/^[^\0]*/$cond/;
827 }
828 next CMD; };
3fbd6552
GS
829 $cmd =~ /^d\b\s*(\d*)/ && do {
830 $i = $1 || $line;
d338d6fe
PP
831 $dbline{$i} =~ s/^[^\0]*//;
832 delete $dbline{$i} if $dbline{$i} eq '';
833 next CMD; };
834 $cmd =~ /^A$/ && do {
3fbd6552 835 print $OUT "Deleting all actions...\n";
55497cff
PP
836 my $file;
837 for $file (keys %had_breakpoints) {
8ebc5c01 838 local *dbline = $main::{'_<' . $file};
55497cff
PP
839 my $max = $#dbline;
840 my $was;
841
d338d6fe
PP
842 for ($i = 1; $i <= $max ; $i++) {
843 if (defined $dbline{$i}) {
844 $dbline{$i} =~ s/\0[^\0]*//;
845 delete $dbline{$i} if $dbline{$i} eq '';
846 }
847 }
3fbd6552
GS
848
849 if (not $had_breakpoints{$file} &= ~2) {
850 delete $had_breakpoints{$file};
851 }
55497cff
PP
852 }
853 next CMD; };
d338d6fe
PP
854 $cmd =~ /^O\s*$/ && do {
855 for (@options) {
856 &dump_option($_);
857 }
858 next CMD; };
859 $cmd =~ /^O\s*(\S.*)/ && do {
860 parse_options($1);
861 next CMD; };
55497cff
PP
862 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
863 push @$pre, action($1);
864 next CMD; };
865 $cmd =~ /^>>\s*(.*)/ && do {
866 push @$post, action($1);
867 next CMD; };
d338d6fe 868 $cmd =~ /^<\s*(.*)/ && do {
55497cff
PP
869 $pre = [], next CMD unless $1;
870 $pre = [action($1)];
d338d6fe
PP
871 next CMD; };
872 $cmd =~ /^>\s*(.*)/ && do {
55497cff
PP
873 $post = [], next CMD unless $1;
874 $post = [action($1)];
875 next CMD; };
876 $cmd =~ /^\{\{\s*(.*)/ && do {
877 push @$pretype, $1;
878 next CMD; };
879 $cmd =~ /^\{\s*(.*)/ && do {
880 $pretype = [], next CMD unless $1;
881 $pretype = [$1];
d338d6fe 882 next CMD; };
3fbd6552
GS
883 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
884 $i = $1 || $line; $j = $2;
885 if (length $j) {
886 if ($dbline[$i] == 0) {
887 print $OUT "Line $i may not have an action.\n";
888 } else {
889 $had_breakpoints{$filename} |= 2;
890 $dbline{$i} =~ s/\0[^\0]*//;
891 $dbline{$i} .= "\0" . action($j);
892 }
d338d6fe
PP
893 } else {
894 $dbline{$i} =~ s/\0[^\0]*//;
3fbd6552 895 delete $dbline{$i} if $dbline{$i} eq '';
d338d6fe
PP
896 }
897 next CMD; };
898 $cmd =~ /^n$/ && do {
4639966b 899 end_report(), next CMD if $finished and $level <= 1;
d338d6fe
PP
900 $single = 2;
901 $laststep = $cmd;
902 last CMD; };
903 $cmd =~ /^s$/ && do {
4639966b 904 end_report(), next CMD if $finished and $level <= 1;
d338d6fe
PP
905 $single = 1;
906 $laststep = $cmd;
907 last CMD; };
54d04a52 908 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
4639966b 909 end_report(), next CMD if $finished and $level <= 1;
fb73857a 910 $subname = $i = $1;
bee32ff8
GS
911 # Probably not needed, since we finish an interactive
912 # sub-session anyway...
913 # local $filename = $filename;
914 # local *dbline = *dbline; # XXX Would this work?!
54d04a52 915 if ($i =~ /\D/) { # subroutine name
fb73857a
PP
916 $subname = $package."::".$subname
917 unless $subname =~ /::/;
918 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
54d04a52
IZ
919 $i += 0;
920 if ($i) {
921 $filename = $file;
8ebc5c01 922 *dbline = $main::{'_<' . $filename};
3fbd6552 923 $had_breakpoints{$filename} |= 1;
54d04a52
IZ
924 $max = $#dbline;
925 ++$i while $dbline[$i] == 0 && $i < $max;
926 } else {
927 print $OUT "Subroutine $subname not found.\n";
928 next CMD;
929 }
930 }
d338d6fe
PP
931 if ($i) {
932 if ($dbline[$i] == 0) {
933 print $OUT "Line $i not breakable.\n";
934 next CMD;
935 }
936 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
937 }
f8b5b99c 938 for ($i=0; $i <= $stack_depth; ) {
d338d6fe
PP
939 $stack[$i++] &= ~1;
940 }
941 last CMD; };
942 $cmd =~ /^r$/ && do {
4639966b 943 end_report(), next CMD if $finished and $level <= 1;
f8b5b99c
IZ
944 $stack[$stack_depth] |= 1;
945 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
d338d6fe 946 last CMD; };
54d04a52 947 $cmd =~ /^R$/ && do {
55497cff 948 print $OUT "Warning: some settings and command-line options may be lost!\n";
54d04a52
IZ
949 my (@script, @flags, $cl);
950 push @flags, '-w' if $ini_warn;
951 # Put all the old includes at the start to get
952 # the same debugger.
953 for (@ini_INC) {
954 push @flags, '-I', $_;
955 }
956 # Arrange for setting the old INC:
957 set_list("PERLDB_INC", @ini_INC);
958 if ($0 eq '-e') {
959 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
960 chomp ($cl = $ {'::_<-e'}[$_]);
961 push @script, '-e', $cl;
962 }
963 } else {
964 @script = $0;
965 }
966 set_list("PERLDB_HIST",
967 $term->Features->{getHistory}
968 ? $term->GetHistory : @hist);
55497cff
PP
969 my @had_breakpoints = keys %had_breakpoints;
970 set_list("PERLDB_VISITED", @had_breakpoints);
54d04a52 971 set_list("PERLDB_OPT", %option);
55497cff
PP
972 set_list("PERLDB_ON_LOAD", %break_on_load);
973 my @hard;
974 for (0 .. $#had_breakpoints) {
975 my $file = $had_breakpoints[$_];
8ebc5c01 976 *dbline = $main::{'_<' . $file};
0c395bd7 977 next unless %dbline or $postponed_file{$file};
55497cff
PP
978 (push @hard, $file), next
979 if $file =~ /^\(eval \d+\)$/;
980 my @add;
981 @add = %{$postponed_file{$file}}
0c395bd7 982 if $postponed_file{$file};
55497cff
PP
983 set_list("PERLDB_FILE_$_", %dbline, @add);
984 }
985 for (@hard) { # Yes, really-really...
986 # Find the subroutines in this eval
8ebc5c01 987 *dbline = $main::{'_<' . $_};
55497cff
PP
988 my ($quoted, $sub, %subs, $line) = quotemeta $_;
989 for $sub (keys %sub) {
990 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
991 $subs{$sub} = [$1, $2];
992 }
993 unless (%subs) {
994 print $OUT
995 "No subroutines in $_, ignoring breakpoints.\n";
996 next;
997 }
998 LINES: for $line (keys %dbline) {
999 # One breakpoint per sub only:
1000 my ($offset, $sub, $found);
1001 SUBS: for $sub (keys %subs) {
1002 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1003 and (not defined $offset # Not caught
1004 or $offset < 0 )) { # or badly caught
1005 $found = $sub;
1006 $offset = $line - $subs{$sub}->[0];
1007 $offset = "+$offset", last SUBS if $offset >= 0;
1008 }
1009 }
1010 if (defined $offset) {
1011 $postponed{$found} =
1012 "break $offset if $dbline{$line}";
1013 } else {
1014 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1015 }
1016 }
54d04a52 1017 }
55497cff 1018 set_list("PERLDB_POSTPONE", %postponed);
43aed9ee
IZ
1019 set_list("PERLDB_PRETYPE", @$pretype);
1020 set_list("PERLDB_PRE", @$pre);
1021 set_list("PERLDB_POST", @$post);
1022 set_list("PERLDB_TYPEAHEAD", @typeahead);
54d04a52
IZ
1023 $ENV{PERLDB_RESTART} = 1;
1024 #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
1025 exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
1026 print $OUT "exec failed: $!\n";
1027 last CMD; };
d338d6fe 1028 $cmd =~ /^T$/ && do {
36477c24 1029 print_trace($OUT, 1); # skip DB
d338d6fe 1030 next CMD; };
6027b9a3
IZ
1031 $cmd =~ /^W\s*$/ && do {
1032 $trace &= ~2;
1033 @to_watch = @old_watch = ();
1034 next CMD; };
1035 $cmd =~ /^W\b\s*(.*)/s && do {
1036 push @to_watch, $1;
1037 $evalarg = $1;
1038 my ($val) = &eval;
1039 $val = (defined $val) ? "'$val'" : 'undef' ;
1040 push @old_watch, $val;
1041 $trace |= 2;
1042 next CMD; };
d338d6fe
PP
1043 $cmd =~ /^\/(.*)$/ && do {
1044 $inpat = $1;
1045 $inpat =~ s:([^\\])/$:$1:;
1046 if ($inpat ne "") {
1047 eval '$inpat =~ m'."\a$inpat\a";
1048 if ($@ ne "") {
1049 print $OUT "$@";
1050 next CMD;
1051 }
1052 $pat = $inpat;
1053 }
1054 $end = $start;
1d06cb2d 1055 $incr = -1;
d338d6fe
PP
1056 eval '
1057 for (;;) {
1058 ++$start;
1059 $start = 1 if ($start > $max);
1060 last if ($start == $end);
1061 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1062 if ($emacs) {
1063 print $OUT "\032\032$filename:$start:0\n";
1064 } else {
1065 print $OUT "$start:\t", $dbline[$start], "\n";
1066 }
1067 last;
1068 }
1069 } ';
1070 print $OUT "/$pat/: not found\n" if ($start == $end);
1071 next CMD; };
1072 $cmd =~ /^\?(.*)$/ && do {
1073 $inpat = $1;
1074 $inpat =~ s:([^\\])\?$:$1:;
1075 if ($inpat ne "") {
1076 eval '$inpat =~ m'."\a$inpat\a";
1077 if ($@ ne "") {
1078 print $OUT "$@";
1079 next CMD;
1080 }
1081 $pat = $inpat;
1082 }
1083 $end = $start;
1d06cb2d 1084 $incr = -1;
d338d6fe
PP
1085 eval '
1086 for (;;) {
1087 --$start;
1088 $start = $max if ($start <= 0);
1089 last if ($start == $end);
1090 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
1091 if ($emacs) {
1092 print $OUT "\032\032$filename:$start:0\n";
1093 } else {
1094 print $OUT "$start:\t", $dbline[$start], "\n";
1095 }
1096 last;
1097 }
1098 } ';
1099 print $OUT "?$pat?: not found\n" if ($start == $end);
1100 next CMD; };
1101 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1102 pop(@hist) if length($cmd) > 1;
3fbd6552 1103 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
6921e3ed 1104 $cmd = $hist[$i];
615b993b 1105 print $OUT $cmd, "\n";
d338d6fe 1106 redo CMD; };
55497cff 1107 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
ee971a18 1108 &system($1);
d338d6fe
PP
1109 next CMD; };
1110 $cmd =~ /^$rc([^$rc].*)$/ && do {
1111 $pat = "^$1";
1112 pop(@hist) if length($cmd) > 1;
1113 for ($i = $#hist; $i; --$i) {
1114 last if $hist[$i] =~ /$pat/;
1115 }
1116 if (!$i) {
1117 print $OUT "No such command!\n\n";
1118 next CMD;
1119 }
6921e3ed 1120 $cmd = $hist[$i];
615b993b 1121 print $OUT $cmd, "\n";
d338d6fe
PP
1122 redo CMD; };
1123 $cmd =~ /^$sh$/ && do {
1124 &system($ENV{SHELL}||"/bin/sh");
1125 next CMD; };
ee971a18
PP
1126 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
1127 &system($ENV{SHELL}||"/bin/sh","-c",$1);
d338d6fe
PP
1128 next CMD; };
1129 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
1130 $end = $2?($#hist-$2):0;
1131 $hist = 0 if $hist < 0;
1132 for ($i=$#hist; $i>$end; $i--) {
1133 print $OUT "$i: ",$hist[$i],"\n"
1134 unless $hist[$i] =~ /^.?$/;
1135 };
1136 next CMD; };
b9b857e2
IZ
1137 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1138 $cmd =~ s/^p\b/print {\$DB::OUT} /;
d338d6fe
PP
1139 $cmd =~ /^=/ && do {
1140 if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
1141 $alias{$k}="s~$k~$v~";
1142 print $OUT "$k = $v\n";
1143 } elsif ($cmd =~ /^=\s*$/) {
1144 foreach $k (sort keys(%alias)) {
1145 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
1146 print $OUT "$k = $v\n";
1147 } else {
1148 print $OUT "$k\t$alias{$k}\n";
1149 };
1150 };
1151 };
1152 next CMD; };
1153 $cmd =~ /^\|\|?\s*[^|]/ && do {
1154 if ($pager =~ /^\|/) {
1155 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1156 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1157 } else {
1158 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1159 }
1160 unless ($piped=open(OUT,$pager)) {
1161 &warn("Can't pipe output to `$pager'");
1162 if ($pager =~ /^\|/) {
1163 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1164 open(STDOUT,">&SAVEOUT")
1165 || &warn("Can't restore STDOUT");
1166 close(SAVEOUT);
1167 } else {
1168 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1169 }
1170 next CMD;
1171 }
77fb7b16 1172 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
d338d6fe
PP
1173 && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
1174 $selected= select(OUT);
1175 $|= 1;
1176 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1177 $cmd =~ s/^\|+\s*//;
1178 redo PIPE; };
1179 # XXX Local variants do not work!
6027b9a3 1180 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
d338d6fe
PP
1181 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1182 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1183 } # PIPE:
d338d6fe
PP
1184 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1185 if ($onetimeDump) {
1186 $onetimeDump = undef;
f36776d9 1187 } elsif ($term_pid == $$) {
d338d6fe
PP
1188 print $OUT "\n";
1189 }
1190 } continue { # CMD:
1191 if ($piped) {
1192 if ($pager =~ /^\|/) {
1193 $?= 0; close(OUT) || &warn("Can't close DB::OUT");
1194 &warn( "Pager `$pager' failed: ",
1195 ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
1196 ( $? & 128 ) ? " (core dumped)" : "",
1197 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1198 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1199 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
77fb7b16 1200 $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
d338d6fe
PP
1201 # Will stop ignoring SIGPIPE if done like nohup(1)
1202 # does SIGINT but Perl doesn't give us a choice.
1203 } else {
1204 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1205 }
1206 close(SAVEOUT);
1207 select($selected), $selected= "" unless $selected eq "";
1208 $piped= "";
1209 }
1210 } # CMD:
04fb8f4b 1211 $exiting = 1 unless defined $cmd;
e63173ce
IZ
1212 foreach $evalarg (@$post) {
1213 &eval;
1214 }
d338d6fe 1215 } # if ($single || $signal)
22fae026 1216 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
d338d6fe
PP
1217 ();
1218}
1219
1220# The following code may be executed now:
1221# BEGIN {warn 4}
1222
1223sub sub {
ee971a18 1224 my ($al, $ret, @ret) = "";
7d4a81e5
IZ
1225 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1226 $al = " for $$sub";
ee971a18 1227 }
f8b5b99c
IZ
1228 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1229 $#stack = $stack_depth;
1230 $stack[-1] = $single;
d338d6fe 1231 $single &= 1;
f8b5b99c 1232 $single |= 4 if $stack_depth == $deep;
04fb8f4b 1233 ($frame & 4
f8b5b99c 1234 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
04fb8f4b
IZ
1235 # Why -1? But it works! :-(
1236 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f8b5b99c 1237 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
d338d6fe
PP
1238 if (wantarray) {
1239 @ret = &$sub;
f8b5b99c 1240 $single |= $stack[$stack_depth--];
36477c24 1241 ($frame & 4
f8b5b99c 1242 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
36477c24 1243 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f8b5b99c
IZ
1244 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1245 if ($doret eq $stack_depth or $frame & 16) {
1246 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1247 print $fh ' ' x $stack_depth if $frame & 16;
7ea36084
IZ
1248 print $fh "list context return from $sub:\n";
1249 dumpit($fh, \@ret );
1250 $doret = -2;
1251 }
d338d6fe
PP
1252 @ret;
1253 } else {
fb73857a
PP
1254 if (defined wantarray) {
1255 $ret = &$sub;
1256 } else {
1257 &$sub; undef $ret;
1258 };
f8b5b99c 1259 $single |= $stack[$stack_depth--];
36477c24 1260 ($frame & 4
f8b5b99c 1261 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
36477c24 1262 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f8b5b99c
IZ
1263 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1264 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1265 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1266 print $fh (' ' x $stack_depth) if $frame & 16;
7ea36084
IZ
1267 print $fh (defined wantarray
1268 ? "scalar context return from $sub: "
1269 : "void context return from $sub\n");
1270 dumpit( $fh, $ret ) if defined wantarray;
1271 $doret = -2;
1272 }
d338d6fe
PP
1273 $ret;
1274 }
1275}
1276
1277sub save {
22fae026 1278 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
d338d6fe
PP
1279 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1280}
1281
1282# The following takes its argument via $evalarg to preserve current @_
1283
1284sub eval {
23a291ec 1285 local @res; # 'my' would make it visible from user code
d338d6fe 1286 {
23a291ec
GS
1287 local $otrace = $trace;
1288 local $osingle = $single;
1289 local $od = $^D;
d338d6fe
PP
1290 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1291 $trace = $otrace;
1292 $single = $osingle;
1293 $^D = $od;
1294 }
1295 my $at = $@;
36477c24 1296 local $saved[0]; # Preserve the old value of $@
22fae026 1297 eval { &DB::save };
d338d6fe
PP
1298 if ($at) {
1299 print $OUT $at;
1d06cb2d 1300 } elsif ($onetimeDump eq 'dump') {
7ea36084 1301 dumpit($OUT, \@res);
1d06cb2d
IZ
1302 } elsif ($onetimeDump eq 'methods') {
1303 methods($res[0]);
d338d6fe 1304 }
6027b9a3 1305 @res;
d338d6fe
PP
1306}
1307
55497cff
PP
1308sub postponed_sub {
1309 my $subname = shift;
1d06cb2d 1310 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
55497cff
PP
1311 my $offset = $1 || 0;
1312 # Filename below can contain ':'
1d06cb2d 1313 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
55497cff 1314 if ($i) {
fb73857a 1315 $i += $offset;
8ebc5c01 1316 local *dbline = $main::{'_<' . $file};
55497cff 1317 local $^W = 0; # != 0 is magical below
3fbd6552 1318 $had_breakpoints{$file} |= 1;
55497cff
PP
1319 my $max = $#dbline;
1320 ++$i until $dbline[$i] != 0 or $i >= $max;
1321 $dbline{$i} = delete $postponed{$subname};
1322 } else {
1323 print $OUT "Subroutine $subname not found.\n";
1324 }
1325 return;
1326 }
1d06cb2d 1327 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
36477c24 1328 #print $OUT "In postponed_sub for `$subname'.\n";
55497cff
PP
1329}
1330
1331sub postponed {
3aefca04
IZ
1332 if ($ImmediateStop) {
1333 $ImmediateStop = 0;
1334 $signal = 1;
1335 }
55497cff
PP
1336 return &postponed_sub
1337 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1338 # Cannot be done before the file is compiled
1339 local *dbline = shift;
1340 my $filename = $dbline;
1341 $filename =~ s/^_<//;
36477c24
PP
1342 $signal = 1, print $OUT "'$filename' loaded...\n"
1343 if $break_on_load{$filename};
f8b5b99c 1344 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
0c395bd7 1345 return unless $postponed_file{$filename};
3fbd6552 1346 $had_breakpoints{$filename} |= 1;
55497cff
PP
1347 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1348 my $key;
1349 for $key (keys %{$postponed_file{$filename}}) {
1350 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
54d04a52 1351 }
0c395bd7 1352 delete $postponed_file{$filename};
54d04a52
IZ
1353}
1354
d338d6fe 1355sub dumpit {
7ea36084 1356 local ($savout) = select(shift);
ee971a18
PP
1357 my $osingle = $single;
1358 my $otrace = $trace;
1359 $single = $trace = 0;
1360 local $frame = 0;
1361 local $doret = -2;
1362 unless (defined &main::dumpValue) {
1363 do 'dumpvar.pl';
1364 }
d338d6fe
PP
1365 if (defined &main::dumpValue) {
1366 &main::dumpValue(shift);
1367 } else {
1368 print $OUT "dumpvar.pl not available.\n";
1369 }
ee971a18
PP
1370 $single = $osingle;
1371 $trace = $otrace;
d338d6fe
PP
1372 select ($savout);
1373}
1374
36477c24
PP
1375# Tied method do not create a context, so may get wrong message:
1376
55497cff
PP
1377sub print_trace {
1378 my $fh = shift;
36477c24
PP
1379 my @sub = dump_trace($_[0] + 1, $_[1]);
1380 my $short = $_[2]; # Print short report, next one for sub name
1d06cb2d 1381 my $s;
55497cff
PP
1382 for ($i=0; $i <= $#sub; $i++) {
1383 last if $signal;
1384 local $" = ', ';
1385 my $args = defined $sub[$i]{args}
1386 ? "(@{ $sub[$i]{args} })"
1387 : '' ;
1d06cb2d
IZ
1388 $args = (substr $args, 0, $maxtrace - 3) . '...'
1389 if length $args > $maxtrace;
36477c24
PP
1390 my $file = $sub[$i]{file};
1391 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1d06cb2d
IZ
1392 $s = $sub[$i]{sub};
1393 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
36477c24 1394 if ($short) {
1d06cb2d 1395 my $sub = @_ >= 4 ? $_[3] : $s;
36477c24
PP
1396 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1397 } else {
1d06cb2d 1398 print $fh "$sub[$i]{context} = $s$args" .
36477c24
PP
1399 " called from $file" .
1400 " line $sub[$i]{line}\n";
1401 }
55497cff
PP
1402 }
1403}
1404
1405sub dump_trace {
1406 my $skip = shift;
36477c24
PP
1407 my $count = shift || 1e9;
1408 $skip++;
1409 $count += $skip;
55497cff 1410 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
04fb8f4b
IZ
1411 my $nothard = not $frame & 8;
1412 local $frame = 0; # Do not want to trace this.
1413 my $otrace = $trace;
1414 $trace = 0;
55497cff 1415 for ($i = $skip;
36477c24 1416 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
55497cff
PP
1417 $i++) {
1418 @a = ();
1419 for $arg (@args) {
04fb8f4b
IZ
1420 my $type;
1421 if (not defined $arg) {
1422 push @a, "undef";
1423 } elsif ($nothard and tied $arg) {
1424 push @a, "tied";
1425 } elsif ($nothard and $type = ref $arg) {
1426 push @a, "ref($type)";
1427 } else {
1428 local $_ = "$arg"; # Safe to stringify now - should not call f().
1429 s/([\'\\])/\\$1/g;
1430 s/(.*)/'$1'/s
1431 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1432 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1433 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1434 push(@a, $_);
1435 }
55497cff 1436 }
7ea36084 1437 $context = $context ? '@' : (defined $context ? "\$" : '.');
55497cff
PP
1438 $args = $h ? [@a] : undef;
1439 $e =~ s/\n\s*\;\s*\Z// if $e;
1d06cb2d 1440 $e =~ s/([\\\'])/\\$1/g if $e;
55497cff
PP
1441 if ($r) {
1442 $sub = "require '$e'";
1443 } elsif (defined $r) {
1444 $sub = "eval '$e'";
1445 } elsif ($sub eq '(eval)') {
1446 $sub = "eval {...}";
1447 }
1448 push(@sub, {context => $context, sub => $sub, args => $args,
1449 file => $file, line => $line});
1450 last if $signal;
1451 }
04fb8f4b 1452 $trace = $otrace;
55497cff
PP
1453 @sub;
1454}
1455
d338d6fe
PP
1456sub action {
1457 my $action = shift;
1458 while ($action =~ s/\\$//) {
1459 #print $OUT "+ ";
1460 #$action .= "\n";
1461 $action .= &gets;
1462 }
1463 $action;
1464}
1465
1466sub gets {
1467 local($.);
1468 #<IN>;
1469 &readline("cont: ");
1470}
1471
1472sub system {
1473 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1474 # many non-Unix systems can do system() but have problems with fork().
1475 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
8ee058cb 1476 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
d338d6fe
PP
1477 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1478 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1479 system(@_);
1480 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1481 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1482 close(SAVEIN); close(SAVEOUT);
1483 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1484 ( $? & 128 ) ? " (core dumped)" : "",
1485 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1486 $?;
1487}
1488
1489sub setterm {
54d04a52 1490 local $frame = 0;
ee971a18 1491 local $doret = -2;
ee971a18 1492 eval { require Term::ReadLine } or die $@;
d338d6fe
PP
1493 if ($notty) {
1494 if ($tty) {
1495 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1496 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1497 $IN = \*IN;
1498 $OUT = \*OUT;
1499 my $sel = select($OUT);
1500 $| = 1;
1501 select($sel);
1502 } else {
1503 eval "require Term::Rendezvous;" or die $@;
1504 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1505 my $term_rv = new Term::Rendezvous $rv;
1506 $IN = $term_rv->IN;
1507 $OUT = $term_rv->OUT;
1508 }
1509 }
1510 if (!$rl) {
1511 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1512 } else {
1513 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1514
a737e074
CS
1515 $rl_attribs = $term->Attribs;
1516 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1517 if defined $rl_attribs->{basic_word_break_characters}
1518 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1519 $rl_attribs->{special_prefixes} = '$@&%';
1520 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1521 $rl_attribs->{completion_function} = \&db_complete;
d338d6fe
PP
1522 }
1523 $LINEINFO = $OUT unless defined $LINEINFO;
1524 $lineinfo = $console unless defined $lineinfo;
1525 $term->MinLine(2);
54d04a52
IZ
1526 if ($term->Features->{setHistory} and "@hist" ne "?") {
1527 $term->SetHistory(@hist);
1528 }
7a2e2cd6 1529 ornaments($ornaments) if defined $ornaments;
f36776d9
IZ
1530 $term_pid = $$;
1531}
1532
1533sub resetterm { # We forked, so we need a different TTY
1534 $term_pid = $$;
1535 if (defined &get_fork_TTY) {
1536 &get_fork_TTY;
1537 } elsif (not defined $fork_TTY
1538 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1539 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1540 # Possibly _inside_ XTERM
1541 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1542 sleep 10000000' |];
1543 $fork_TTY = <XT>;
1544 chomp $fork_TTY;
1545 }
1546 if (defined $fork_TTY) {
1547 TTY($fork_TTY);
1548 undef $fork_TTY;
1549 } else {
405ff068
IZ
1550 print_help(<<EOP);
1551I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1552 Define B<\$DB::fork_TTY>
1553 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1554 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1555 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1556 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1557EOP
f36776d9 1558 }
d338d6fe
PP
1559}
1560
1561sub readline {
54d04a52
IZ
1562 if (@typeahead) {
1563 my $left = @typeahead;
1564 my $got = shift @typeahead;
1565 print $OUT "auto(-$left)", shift, $got, "\n";
1566 $term->AddHistory($got)
1567 if length($got) > 1 and defined $term->Features->{addHistory};
1568 return $got;
1569 }
d338d6fe 1570 local $frame = 0;
ee971a18 1571 local $doret = -2;
363b4d59
GT
1572 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
1573 print $OUT @_;
1574 my $stuff;
1575 $IN->recv( $stuff, 2048 );
1576 $stuff;
1577 }
1578 else {
1579 $term->readline(@_);
1580 }
d338d6fe
PP
1581}
1582
1583sub dump_option {
1584 my ($opt, $val)= @_;
55497cff
PP
1585 $val = option_val($opt,'N/A');
1586 $val =~ s/([\\\'])/\\$1/g;
1587 printf $OUT "%20s = '%s'\n", $opt, $val;
1588}
1589
1590sub option_val {
1591 my ($opt, $default)= @_;
1592 my $val;
d338d6fe
PP
1593 if (defined $optionVars{$opt}
1594 and defined $ {$optionVars{$opt}}) {
1595 $val = $ {$optionVars{$opt}};
1596 } elsif (defined $optionAction{$opt}
1597 and defined &{$optionAction{$opt}}) {
1598 $val = &{$optionAction{$opt}}();
1599 } elsif (defined $optionAction{$opt}
1600 and not defined $option{$opt}
1601 or defined $optionVars{$opt}
1602 and not defined $ {$optionVars{$opt}}) {
55497cff 1603 $val = $default;
d338d6fe
PP
1604 } else {
1605 $val = $option{$opt};
1606 }
55497cff 1607 $val
d338d6fe
PP
1608}
1609
1610sub parse_options {
1611 local($_)= @_;
1612 while ($_ ne "") {
1613 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1614 my ($opt,$sep) = ($1,$2);
1615 my $val;
1616 if ("?" eq $sep) {
1617 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1618 if /^\S/;
1619 #&dump_option($opt);
1620 } elsif ($sep !~ /\S/) {
1621 $val = "1";
1622 } elsif ($sep eq "=") {
1623 s/^(\S*)($|\s+)//;
1624 $val = $1;
1625 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1626 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1627 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1628 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1629 $val = $1;
1630 $val =~ s/\\([\\$end])/$1/g;
1631 }
1632 my ($option);
1633 my $matches =
1634 grep( /^\Q$opt/ && ($option = $_), @options );
1635 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1636 unless $matches;
1637 print $OUT "Unknown option `$opt'\n" unless $matches;
1638 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1639 $option{$option} = $val if $matches == 1 and defined $val;
ee971a18
PP
1640 eval "local \$frame = 0; local \$doret = -2;
1641 require '$optionRequire{$option}'"
d338d6fe
PP
1642 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1643 $ {$optionVars{$option}} = $val
1644 if $matches == 1
1645 and defined $optionVars{$option} and defined $val;
1646 & {$optionAction{$option}} ($val)
1647 if $matches == 1
1648 and defined $optionAction{$option}
1649 and defined &{$optionAction{$option}} and defined $val;
1650 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1651 s/^\s+//;
1652 }
1653}
1654
54d04a52
IZ
1655sub set_list {
1656 my ($stem,@list) = @_;
1657 my $val;
1658 $ENV{"$ {stem}_n"} = @list;
1659 for $i (0 .. $#list) {
1660 $val = $list[$i];
1661 $val =~ s/\\/\\\\/g;
ee971a18 1662 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
54d04a52
IZ
1663 $ENV{"$ {stem}_$i"} = $val;
1664 }
1665}
1666
1667sub get_list {
1668 my $stem = shift;
1669 my @list;
1670 my $n = delete $ENV{"$ {stem}_n"};
1671 my $val;
1672 for $i (0 .. $n - 1) {
1673 $val = delete $ENV{"$ {stem}_$i"};
1674 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1675 push @list, $val;
1676 }
1677 @list;
1678}
1679
d338d6fe
PP
1680sub catch {
1681 $signal = 1;
4639966b 1682 return; # Put nothing on the stack - malloc/free land!
d338d6fe
PP
1683}
1684
1685sub warn {
1686 my($msg)= join("",@_);
1687 $msg .= ": $!\n" unless $msg =~ /\n$/;
1688 print $OUT $msg;
1689}
1690
1691sub TTY {
f36776d9
IZ
1692 if (@_ and $term and $term->Features->{newTTY}) {
1693 my ($in, $out) = shift;
1694 if ($in =~ /,/) {
1695 ($in, $out) = split /,/, $in, 2;
1696 } else {
1697 $out = $in;
1698 }
1699 open IN, $in or die "cannot open `$in' for read: $!";
1700 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1701 $term->newTTY(\*IN, \*OUT);
1702 $IN = \*IN;
1703 $OUT = \*OUT;
1704 return $tty = $in;
1705 } elsif ($term and @_) {
1706 &warn("Too late to set TTY, enabled on next `R'!\n");
43aed9ee
IZ
1707 }
1708 $tty = shift if @_;
d338d6fe
PP
1709 $tty or $console;
1710}
1711
1712sub noTTY {
1713 if ($term) {
43aed9ee 1714 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
d338d6fe 1715 }
43aed9ee 1716 $notty = shift if @_;
d338d6fe
PP
1717 $notty;
1718}
1719
1720sub ReadLine {
1721 if ($term) {
43aed9ee 1722 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
d338d6fe 1723 }
43aed9ee 1724 $rl = shift if @_;
d338d6fe
PP
1725 $rl;
1726}
1727
363b4d59
GT
1728sub RemotePort {
1729 if ($term) {
1730 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
1731 }
1732 $remoteport = shift if @_;
1733 $remoteport;
1734}
1735
a737e074
CS
1736sub tkRunning {
1737 if ($ {$term->Features}{tkRunning}) {
1738 return $term->tkRunning(@_);
1739 } else {
1740 print $OUT "tkRunning not supported by current ReadLine package.\n";
1741 0;
1742 }
1743}
1744
d338d6fe
PP
1745sub NonStop {
1746 if ($term) {
43aed9ee 1747 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
d338d6fe 1748 }
43aed9ee 1749 $runnonstop = shift if @_;
d338d6fe
PP
1750 $runnonstop;
1751}
1752
1753sub pager {
1754 if (@_) {
1755 $pager = shift;
1756 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1757 }
1758 $pager;
1759}
1760
1761sub shellBang {
1762 if (@_) {
1763 $sh = quotemeta shift;
1764 $sh .= "\\b" if $sh =~ /\w$/;
1765 }
1766 $psh = $sh;
1767 $psh =~ s/\\b$//;
1768 $psh =~ s/\\(.)/$1/g;
1769 &sethelp;
1770 $psh;
1771}
1772
7a2e2cd6
PP
1773sub ornaments {
1774 if (defined $term) {
1775 local ($warnLevel,$dieLevel) = (0, 1);
1776 return '' unless $term->Features->{ornaments};
1777 eval { $term->ornaments(@_) } || '';
1778 } else {
1779 $ornaments = shift;
1780 }
1781}
1782
d338d6fe
PP
1783sub recallCommand {
1784 if (@_) {
1785 $rc = quotemeta shift;
1786 $rc .= "\\b" if $rc =~ /\w$/;
1787 }
1788 $prc = $rc;
1789 $prc =~ s/\\b$//;
1790 $prc =~ s/\\(.)/$1/g;
1791 &sethelp;
1792 $prc;
1793}
1794
1795sub LineInfo {
1796 return $lineinfo unless @_;
1797 $lineinfo = shift;
1798 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1799 $emacs = ($stream =~ /^\|/);
1800 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1801 $LINEINFO = \*LINEINFO;
1802 my $save = select($LINEINFO);
1803 $| = 1;
1804 select($save);
1805 $lineinfo;
1806}
1807
ee971a18
PP
1808sub list_versions {
1809 my %version;
1810 my $file;
1811 for (keys %INC) {
1812 $file = $_;
1813 s,\.p[lm]$,,i ;
1814 s,/,::,g ;
1815 s/^perl5db$/DB/;
55497cff 1816 s/^Term::ReadLine::readline$/readline/;
ee971a18
PP
1817 if (defined $ { $_ . '::VERSION' }) {
1818 $version{$file} = "$ { $_ . '::VERSION' } from ";
1819 }
1820 $version{$file} .= $INC{$file};
1821 }
2c53b6d0 1822 dumpit($OUT,\%version);
ee971a18
PP
1823}
1824
d338d6fe
PP
1825sub sethelp {
1826 $help = "
6027b9a3
IZ
1827B<T> Stack trace.
1828B<s> [I<expr>] Single step [in I<expr>].
1829B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
1830<B<CR>> Repeat last B<n> or B<s> command.
1831B<r> Return from current subroutine.
1832B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
55497cff 1833 at the specified position.
6027b9a3
IZ
1834B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
1835B<l> I<min>B<->I<max> List lines I<min> through I<max>.
1836B<l> I<line> List single I<line>.
1837B<l> I<subname> List first window of lines from subroutine.
3fbd6552 1838B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
6027b9a3
IZ
1839B<l> List next window of lines.
1840B<-> List previous window of lines.
1841B<w> [I<line>] List window around I<line>.
1842B<.> Return to the executed line.
bee32ff8
GS
1843B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
1844 I<filename> may be either the full name of the file, or a regular
1845 expression matching the full file name:
1846 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
1847 Evals (with saved bodies) are considered to be filenames:
1848 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
1849 (in the order of execution).
6027b9a3
IZ
1850B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
1851B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
1852B<L> List all breakpoints and actions.
1853B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
1854B<t> Toggle trace mode.
1855B<t> I<expr> Trace through execution of I<expr>.
1856B<b> [I<line>] [I<condition>]
1857 Set breakpoint; I<line> defaults to the current execution line;
1858 I<condition> breaks if it evaluates to true, defaults to '1'.
1859B<b> I<subname> [I<condition>]
d338d6fe 1860 Set breakpoint at first line of subroutine.
3fbd6552 1861B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
6027b9a3
IZ
1862B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
1863B<b> B<postpone> I<subname> [I<condition>]
55497cff
PP
1864 Set breakpoint at first line of subroutine after
1865 it is compiled.
6027b9a3 1866B<b> B<compile> I<subname>
1d06cb2d 1867 Stop after the subroutine is compiled.
6027b9a3
IZ
1868B<d> [I<line>] Delete the breakpoint for I<line>.
1869B<D> Delete all breakpoints.
1870B<a> [I<line>] I<command>
3fbd6552
GS
1871 Set an action to be done before the I<line> is executed;
1872 I<line> defaults to the current execution line.
6027b9a3
IZ
1873 Sequence is: check for breakpoint/watchpoint, print line
1874 if necessary, do action, prompt user if necessary,
3fbd6552
GS
1875 execute line.
1876B<a> [I<line>] Delete the action for I<line>.
6027b9a3
IZ
1877B<A> Delete all actions.
1878B<W> I<expr> Add a global watch-expression.
1879B<W> Delete all watch-expressions.
1880B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
1881 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
1882B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
1883B<x> I<expr> Evals expression in array context, dumps the result.
1884B<m> I<expr> Evals expression in array context, prints methods callable
1d06cb2d 1885 on the first element of the result.
6027b9a3
IZ
1886B<m> I<class> Prints methods callable via the given class.
1887B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
1888 Set or query values of options. I<val> defaults to 1. I<opt> can
d338d6fe 1889 be abbreviated. Several options can be listed.
6027b9a3
IZ
1890 I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
1891 I<pager>: program for output of \"|cmd\";
1892 I<tkRunning>: run Tk while prompting (with ReadLine);
1893 I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
1894 I<inhibit_exit> Allows stepping off the end of the script.
3aefca04 1895 I<ImmediateStop> Debugger should stop as early as possible.
3fbd6552 1896 I<RemotePort>: Remote hostname:port for remote debugging
6027b9a3
IZ
1897 The following options affect what happens with B<V>, B<X>, and B<x> commands:
1898 I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
1899 I<compactDump>, I<veryCompact>: change style of array and hash dump;
1900 I<globPrint>: whether to print contents of globs;
1901 I<DumpDBFiles>: dump arrays holding debugged files;
1902 I<DumpPackages>: dump symbol tables of packages;
3fbd6552 1903 I<DumpReused>: dump contents of \"reused\" addresses;
6027b9a3 1904 I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
ee239bfe 1905 I<bareStringify>: Do not print the overload-stringified value;
6027b9a3
IZ
1906 Option I<PrintRet> affects printing of return value after B<r> command,
1907 I<frame> affects printing messages on entry and exit from subroutines.
1908 I<AutoTrace> affects printing messages on every possible breaking point.
1909 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
1910 I<ornaments> affects screen appearance of the command line.
d338d6fe 1911 During startup options are initialized from \$ENV{PERLDB_OPTS}.
6027b9a3 1912 You can put additional initialization options I<TTY>, I<noTTY>,
363b4d59
GT
1913 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
1914 `B<R>' after you set them).
6027b9a3
IZ
1915B<<> I<expr> Define Perl command to run before each prompt.
1916B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
1917B<>> I<expr> Define Perl command to run after each prompt.
3fbd6552 1918B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
6027b9a3
IZ
1919B<{> I<db_command> Define debugger command to run before each prompt.
1920B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
1921B<$prc> I<number> Redo a previous command (default previous command).
1922B<$prc> I<-number> Redo number'th-to-last command.
1923B<$prc> I<pattern> Redo last command that started with I<pattern>.
1924 See 'B<O> I<recallCommand>' too.
1925B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
d338d6fe 1926 . ( $rc eq $sh ? "" : "
6027b9a3
IZ
1927B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1928 See 'B<O> I<shellBang>' too.
1929B<H> I<-number> Display last number commands (default all).
1930B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
1931B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
1932B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
1933B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
1934I<command> Execute as a perl statement in current package.
1935B<v> Show versions of loaded modules.
1936B<R> Pure-man-restart of debugger, some of debugger state
55497cff 1937 and command-line options may be lost.
36477c24 1938 Currently the following setting are preserved:
6027b9a3
IZ
1939 history, breakpoints and actions, debugger B<O>ptions
1940 and the following command-line options: I<-w>, I<-I>, I<-e>.
1941B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
d9f67849
GS
1942 Complete description of debugger is available in B<perldebug>
1943 section of Perl documention
6027b9a3 1944B<h h> Summary of debugger commands.
405ff068 1945B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
d338d6fe
PP
1946
1947";
1948 $summary = <<"END_SUM";
6027b9a3
IZ
1949I<List/search source lines:> I<Control script execution:>
1950 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
1951 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
1952 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
d9f67849 1953 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
6027b9a3
IZ
1954 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
1955 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
1956I<Debugger controls:> B<L> List break/watch/actions
1957 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
d9f67849 1958 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
6027b9a3
IZ
1959 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
1960 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
1961 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
1962 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
d9f67849 1963 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
6027b9a3
IZ
1964 B<q> or B<^D> Quit B<R> Attempt a restart
1965I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
1966 B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
1967 B<p> I<expr> Print expression (uses script's current package).
1968 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
1969 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
1970 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
d9f67849 1971I<More help for> B<db_cmd>I<:> Type B<h> I<cmd_letter> Run B<perldoc perldebug> for more help.
d338d6fe 1972END_SUM
55497cff 1973 # ')}}; # Fix balance of Emacs parsing
d338d6fe
PP
1974}
1975
6027b9a3
IZ
1976sub print_help {
1977 my $message = shift;
1978 if (@Term::ReadLine::TermCap::rl_term_set) {
1979 $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
1980 $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
1981 }
1982 print $OUT $message;
1983}
1984
d338d6fe 1985sub diesignal {
54d04a52 1986 local $frame = 0;
ee971a18 1987 local $doret = -2;
77fb7b16 1988 $SIG{'ABRT'} = 'DEFAULT';
d338d6fe 1989 kill 'ABRT', $$ if $panic++;
ee85b803
CS
1990 if (defined &Carp::longmess) {
1991 local $SIG{__WARN__} = '';
1992 local $Carp::CarpLevel = 2; # mydie + confess
1993 &warn(Carp::longmess("Signal @_"));
1994 }
1995 else {
1996 print $DB::OUT "Got signal @_\n";
1997 }
d338d6fe
PP
1998 kill 'ABRT', $$;
1999}
2000
2001sub dbwarn {
54d04a52 2002 local $frame = 0;
ee971a18 2003 local $doret = -2;
d338d6fe 2004 local $SIG{__WARN__} = '';
77fb7b16 2005 local $SIG{__DIE__} = '';
fb73857a
PP
2006 eval { require Carp } if defined $^S; # If error/warning during compilation,
2007 # require may be broken.
2008 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2009 return unless defined &Carp::longmess;
d338d6fe
PP
2010 my ($mysingle,$mytrace) = ($single,$trace);
2011 $single = 0; $trace = 0;
2012 my $mess = Carp::longmess(@_);
2013 ($single,$trace) = ($mysingle,$mytrace);
d338d6fe 2014 &warn($mess);
d338d6fe
PP
2015}
2016
2017sub dbdie {
54d04a52 2018 local $frame = 0;
ee971a18 2019 local $doret = -2;
d338d6fe
PP
2020 local $SIG{__DIE__} = '';
2021 local $SIG{__WARN__} = '';
2022 my $i = 0; my $ineval = 0; my $sub;
fb73857a 2023 if ($dieLevel > 2) {
d338d6fe 2024 local $SIG{__WARN__} = \&dbwarn;
fb73857a
PP
2025 &warn(@_); # Yell no matter what
2026 return;
2027 }
2028 if ($dieLevel < 2) {
2029 die @_ if $^S; # in eval propagate
d338d6fe 2030 }
fb73857a
PP
2031 eval { require Carp } if defined $^S; # If error/warning during compilation,
2032 # require may be broken.
2033 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2034 unless defined &Carp::longmess;
d338d6fe
PP
2035 # We do not want to debug this chunk (automatic disabling works
2036 # inside DB::DB, but not in Carp).
2037 my ($mysingle,$mytrace) = ($single,$trace);
2038 $single = 0; $trace = 0;
2039 my $mess = Carp::longmess(@_);
2040 ($single,$trace) = ($mysingle,$mytrace);
d338d6fe
PP
2041 die $mess;
2042}
2043
d338d6fe
PP
2044sub warnLevel {
2045 if (@_) {
2046 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2047 $warnLevel = shift;
2048 if ($warnLevel) {
0b7ed949 2049 $SIG{__WARN__} = \&DB::dbwarn;
d338d6fe
PP
2050 } else {
2051 $SIG{__WARN__} = $prevwarn;
2052 }
2053 }
2054 $warnLevel;
2055}
2056
2057sub dieLevel {
2058 if (@_) {
2059 $prevdie = $SIG{__DIE__} unless $dieLevel;
2060 $dieLevel = shift;
2061 if ($dieLevel) {
0b7ed949
PP
2062 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2063 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
d338d6fe 2064 print $OUT "Stack dump during die enabled",
43aed9ee
IZ
2065 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2066 if $I_m_init;
d338d6fe
PP
2067 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2068 } else {
2069 $SIG{__DIE__} = $prevdie;
2070 print $OUT "Default die handler restored.\n";
2071 }
2072 }
2073 $dieLevel;
2074}
2075
2076sub signalLevel {
2077 if (@_) {
2078 $prevsegv = $SIG{SEGV} unless $signalLevel;
2079 $prevbus = $SIG{BUS} unless $signalLevel;
2080 $signalLevel = shift;
2081 if ($signalLevel) {
77fb7b16
PP
2082 $SIG{SEGV} = \&DB::diesignal;
2083 $SIG{BUS} = \&DB::diesignal;
d338d6fe
PP
2084 } else {
2085 $SIG{SEGV} = $prevsegv;
2086 $SIG{BUS} = $prevbus;
2087 }
2088 }
2089 $signalLevel;
2090}
2091
83ee9e09
GS
2092sub CvGV_name {
2093 my $in = shift;
2094 my $name = CvGV_name_or_bust($in);
2095 defined $name ? $name : $in;
2096}
2097
2098sub CvGV_name_or_bust {
2099 my $in = shift;
2100 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2101 $in = \&$in; # Hard reference...
2102 eval {require Devel::Peek; 1} or return;
2103 my $gv = Devel::Peek::CvGV($in) or return;
2104 *$gv{PACKAGE} . '::' . *$gv{NAME};
2105}
2106
1d06cb2d
IZ
2107sub find_sub {
2108 my $subr = shift;
1d06cb2d 2109 $sub{$subr} or do {
83ee9e09
GS
2110 return unless defined &$subr;
2111 my $name = CvGV_name_or_bust($subr);
2112 my $data;
2113 $data = $sub{$name} if defined $name;
2114 return $data if defined $data;
2115
2116 # Old stupid way...
1d06cb2d
IZ
2117 $subr = \&$subr; # Hard reference
2118 my $s;
2119 for (keys %sub) {
2120 $s = $_, last if $subr eq \&$_;
2121 }
2122 $sub{$s} if $s;
2123 }
2124}
2125
2126sub methods {
2127 my $class = shift;
2128 $class = ref $class if ref $class;
2129 local %seen;
2130 local %packs;
2131 methods_via($class, '', 1);
2132 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2133}
2134
2135sub methods_via {
2136 my $class = shift;
2137 return if $packs{$class}++;
2138 my $prefix = shift;
2139 my $prepend = $prefix ? "via $prefix: " : '';
2140 my $name;
2141 for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
2142 sort keys %{"$ {class}::"}) {
477ea2b1 2143 next if $seen{ $name }++;
1d06cb2d
IZ
2144 print $DB::OUT "$prepend$name\n";
2145 }
2146 return unless shift; # Recurse?
2147 for $name (@{"$ {class}::ISA"}) {
2148 $prepend = $prefix ? $prefix . " -> $name" : $name;
2149 methods_via($name, $prepend, 1);
2150 }
2151}
2152
d338d6fe
PP
2153# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2154
2155BEGIN { # This does not compile, alas.
2156 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2157 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2158 $sh = '!';
2159 $rc = ',';
2160 @hist = ('?');
2161 $deep = 100; # warning if stack gets this deep
2162 $window = 10;
2163 $preview = 3;
2164 $sub = '';
77fb7b16 2165 $SIG{INT} = \&DB::catch;
ee971a18
PP
2166 # This may be enabled to debug debugger:
2167 #$warnLevel = 1 unless defined $warnLevel;
2168 #$dieLevel = 1 unless defined $dieLevel;
2169 #$signalLevel = 1 unless defined $signalLevel;
d338d6fe
PP
2170
2171 $db_stop = 0; # Compiler warning
2172 $db_stop = 1 << 30;
2173 $level = 0; # Level of recursive debugging
55497cff
PP
2174 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2175 # Triggers bug (?) in perl is we postpone this until runtime:
2176 @postponed = @stack = (0);
f8b5b99c 2177 $stack_depth = 0; # Localized $#stack
55497cff
PP
2178 $doret = -2;
2179 $frame = 0;
d338d6fe
PP
2180}
2181
54d04a52
IZ
2182BEGIN {$^W = $ini_warn;} # Switch warnings back
2183
d338d6fe
PP
2184#use Carp; # This did break, left for debuggin
2185
55497cff 2186sub db_complete {
08a4aec0 2187 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
55497cff 2188 my($text, $line, $start) = @_;
477ea2b1 2189 my ($itext, $search, $prefix, $pack) =
08a4aec0 2190 ($text, "^\Q$ {'package'}::\E([^:]+)\$");
55497cff 2191
08a4aec0
IZ
2192 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2193 (map { /$search/ ? ($1) : () } keys %sub)
2194 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2195 return sort grep /^\Q$text/, values %INC # files
477ea2b1 2196 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
08a4aec0
IZ
2197 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2198 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2199 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2200 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2201 grep !/^main::/,
2202 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2203 # packages
2204 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2205 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
477ea2b1
IZ
2206 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2207 # We may want to complete to (eval 9), so $text may be wrong
2208 $prefix = length($1) - length($text);
2209 $text = $1;
08a4aec0
IZ
2210 return sort
2211 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
477ea2b1 2212 }
55497cff
PP
2213 if ((substr $text, 0, 1) eq '&') { # subroutines
2214 $text = substr $text, 1;
2215 $prefix = "&";
08a4aec0
IZ
2216 return sort map "$prefix$_",
2217 grep /^\Q$text/,
2218 (keys %sub),
2219 (map { /$search/ ? ($1) : () }
2220 keys %sub);
55497cff
PP
2221 }
2222 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2223 $pack = ($1 eq 'main' ? '' : $1) . '::';
2224 $prefix = (substr $text, 0, 1) . $1 . '::';
2225 $text = $2;
2226 my @out
2227 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2228 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2229 return db_complete($out[0], $line, $start);
2230 }
08a4aec0 2231 return sort @out;
55497cff
PP
2232 }
2233 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2234 $pack = ($package eq 'main' ? '' : $package) . '::';
2235 $prefix = substr $text, 0, 1;
2236 $text = substr $text, 1;
2237 my @out = map "$prefix$_", grep /^\Q$text/,
2238 (grep /^_?[a-zA-Z]/, keys %$pack),
2239 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2240 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2241 return db_complete($out[0], $line, $start);
2242 }
08a4aec0 2243 return sort @out;
55497cff 2244 }
477ea2b1 2245 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
55497cff
PP
2246 my @out = grep /^\Q$text/, @options;
2247 my $val = option_val($out[0], undef);
2248 my $out = '? ';
2249 if (not defined $val or $val =~ /[\n\r]/) {
2250 # Can do nothing better
2251 } elsif ($val =~ /\s/) {
2252 my $found;
2253 foreach $l (split //, qq/\"\'\#\|/) {
2254 $out = "$l$val$l ", last if (index $val, $l) == -1;
2255 }
2256 } else {
2257 $out = "=$val ";
2258 }
2259 # Default to value if one completion, to question if many
a737e074 2260 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
08a4aec0 2261 return sort @out;
55497cff 2262 }
a737e074 2263 return $term->filename_list($text); # filenames
55497cff
PP
2264}
2265
43aed9ee
IZ
2266sub end_report {
2267 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2268}
4639966b 2269
55497cff
PP
2270END {
2271 $finished = $inhibit_exit; # So that some keys may be disabled.
36477c24
PP
2272 # Do not stop in at_exit() and destructors on exit:
2273 $DB::single = !$exiting && !$runnonstop;
2274 DB::fake::at_exit() unless $exiting or $runnonstop;
55497cff
PP
2275}
2276
2277package DB::fake;
2278
2279sub at_exit {
43aed9ee 2280 "Debugged program terminated. Use `q' to quit or `R' to restart.";
55497cff
PP
2281}
2282
36477c24
PP
2283package DB; # Do not trace this 1; below!
2284
d338d6fe 22851;