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