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