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