This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [ID 20000809.006] Debugger lost the ability to see $1 et al
[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#
51ee6500 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 901 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
a223bd61 902 my $cond = length $3 ? $3 : '1';
1d06cb2d 903 my ($subname, $break) = ($2, $1 eq 'postpone');
a223bd61 904 $subname =~ s/\'/::/g;
55497cff
PP
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 912 $subname = $1;
a223bd61
JH
913 $cond = length $2 ? $2 : '1';
914 $subname =~ s/\'/::/g;
d338d6fe
PP
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;
a223bd61 934 $cond = defined $2 ? $2 : '1';
d338d6fe
PP
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;
bbdae7b2
MG
944 if ($dbline[$i] == 0) {
945 print $OUT "Line $i not breakable.\n";
946 } else {
947 $dbline{$i} =~ s/^[^\0]*//;
948 delete $dbline{$i} if $dbline{$i} eq '';
949 }
d338d6fe
PP
950 next CMD; };
951 $cmd =~ /^A$/ && do {
3fbd6552 952 print $OUT "Deleting all actions...\n";
55497cff
PP
953 my $file;
954 for $file (keys %had_breakpoints) {
8ebc5c01 955 local *dbline = $main::{'_<' . $file};
55497cff
PP
956 my $max = $#dbline;
957 my $was;
958
d338d6fe
PP
959 for ($i = 1; $i <= $max ; $i++) {
960 if (defined $dbline{$i}) {
961 $dbline{$i} =~ s/\0[^\0]*//;
962 delete $dbline{$i} if $dbline{$i} eq '';
963 }
964 }
3fbd6552 965
055fd3a9 966 unless ($had_breakpoints{$file} &= ~2) {
3fbd6552
GS
967 delete $had_breakpoints{$file};
968 }
55497cff
PP
969 }
970 next CMD; };
d338d6fe
PP
971 $cmd =~ /^O\s*$/ && do {
972 for (@options) {
973 &dump_option($_);
974 }
975 next CMD; };
976 $cmd =~ /^O\s*(\S.*)/ && do {
977 parse_options($1);
978 next CMD; };
55497cff
PP
979 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
980 push @$pre, action($1);
981 next CMD; };
982 $cmd =~ /^>>\s*(.*)/ && do {
983 push @$post, action($1);
984 next CMD; };
d338d6fe 985 $cmd =~ /^<\s*(.*)/ && do {
055fd3a9 986 unless ($1) {
e4e99f0d 987 print $OUT "All < actions cleared.\n";
055fd3a9
GS
988 $pre = [];
989 next CMD;
990 }
991 if ($1 eq '?') {
992 unless (@$pre) {
e4e99f0d 993 print $OUT "No pre-prompt Perl actions.\n";
055fd3a9
GS
994 next CMD;
995 }
e4e99f0d 996 print $OUT "Perl commands run before each prompt:\n";
055fd3a9 997 for my $action ( @$pre ) {
e4e99f0d 998 print $OUT "\t< -- $action\n";
055fd3a9
GS
999 }
1000 next CMD;
1001 }
55497cff 1002 $pre = [action($1)];
d338d6fe
PP
1003 next CMD; };
1004 $cmd =~ /^>\s*(.*)/ && do {
055fd3a9 1005 unless ($1) {
e4e99f0d 1006 print $OUT "All > actions cleared.\n";
055fd3a9
GS
1007 $post = [];
1008 next CMD;
1009 }
1010 if ($1 eq '?') {
1011 unless (@$post) {
e4e99f0d 1012 print $OUT "No post-prompt Perl actions.\n";
055fd3a9
GS
1013 next CMD;
1014 }
e4e99f0d 1015 print $OUT "Perl commands run after each prompt:\n";
055fd3a9 1016 for my $action ( @$post ) {
e4e99f0d 1017 print $OUT "\t> -- $action\n";
055fd3a9
GS
1018 }
1019 next CMD;
1020 }
55497cff
PP
1021 $post = [action($1)];
1022 next CMD; };
1023 $cmd =~ /^\{\{\s*(.*)/ && do {
055fd3a9 1024 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
e4e99f0d 1025 print $OUT "{{ is now a debugger command\n",
055fd3a9
GS
1026 "use `;{{' if you mean Perl code\n";
1027 $cmd = "h {{";
1028 redo CMD;
1029 }
55497cff
PP
1030 push @$pretype, $1;
1031 next CMD; };
1032 $cmd =~ /^\{\s*(.*)/ && do {
055fd3a9 1033 unless ($1) {
e4e99f0d 1034 print $OUT "All { actions cleared.\n";
055fd3a9
GS
1035 $pretype = [];
1036 next CMD;
1037 }
1038 if ($1 eq '?') {
1039 unless (@$pretype) {
e4e99f0d 1040 print $OUT "No pre-prompt debugger actions.\n";
055fd3a9
GS
1041 next CMD;
1042 }
e4e99f0d 1043 print $OUT "Debugger commands run before each prompt:\n";
055fd3a9 1044 for my $action ( @$pretype ) {
e4e99f0d 1045 print $OUT "\t{ -- $action\n";
055fd3a9
GS
1046 }
1047 next CMD;
1048 }
1049 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
e4e99f0d 1050 print $OUT "{ is now a debugger command\n",
055fd3a9
GS
1051 "use `;{' if you mean Perl code\n";
1052 $cmd = "h {";
1053 redo CMD;
1054 }
55497cff 1055 $pretype = [$1];
d338d6fe 1056 next CMD; };
3fbd6552
GS
1057 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1058 $i = $1 || $line; $j = $2;
1059 if (length $j) {
1060 if ($dbline[$i] == 0) {
1061 print $OUT "Line $i may not have an action.\n";
1062 } else {
1063 $had_breakpoints{$filename} |= 2;
1064 $dbline{$i} =~ s/\0[^\0]*//;
1065 $dbline{$i} .= "\0" . action($j);
1066 }
d338d6fe
PP
1067 } else {
1068 $dbline{$i} =~ s/\0[^\0]*//;
3fbd6552 1069 delete $dbline{$i} if $dbline{$i} eq '';
d338d6fe
PP
1070 }
1071 next CMD; };
1072 $cmd =~ /^n$/ && do {
4639966b 1073 end_report(), next CMD if $finished and $level <= 1;
d338d6fe
PP
1074 $single = 2;
1075 $laststep = $cmd;
1076 last CMD; };
1077 $cmd =~ /^s$/ && do {
4639966b 1078 end_report(), next CMD if $finished and $level <= 1;
d338d6fe
PP
1079 $single = 1;
1080 $laststep = $cmd;
1081 last CMD; };
54d04a52 1082 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
4639966b 1083 end_report(), next CMD if $finished and $level <= 1;
fb73857a 1084 $subname = $i = $1;
bee32ff8
GS
1085 # Probably not needed, since we finish an interactive
1086 # sub-session anyway...
1087 # local $filename = $filename;
1088 # local *dbline = *dbline; # XXX Would this work?!
54d04a52 1089 if ($i =~ /\D/) { # subroutine name
fb73857a
PP
1090 $subname = $package."::".$subname
1091 unless $subname =~ /::/;
1092 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
54d04a52
IZ
1093 $i += 0;
1094 if ($i) {
1095 $filename = $file;
8ebc5c01 1096 *dbline = $main::{'_<' . $filename};
3fbd6552 1097 $had_breakpoints{$filename} |= 1;
54d04a52
IZ
1098 $max = $#dbline;
1099 ++$i while $dbline[$i] == 0 && $i < $max;
1100 } else {
1101 print $OUT "Subroutine $subname not found.\n";
1102 next CMD;
1103 }
1104 }
d338d6fe
PP
1105 if ($i) {
1106 if ($dbline[$i] == 0) {
1107 print $OUT "Line $i not breakable.\n";
1108 next CMD;
1109 }
1110 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1111 }
f8b5b99c 1112 for ($i=0; $i <= $stack_depth; ) {
d338d6fe
PP
1113 $stack[$i++] &= ~1;
1114 }
1115 last CMD; };
1116 $cmd =~ /^r$/ && do {
4639966b 1117 end_report(), next CMD if $finished and $level <= 1;
f8b5b99c
IZ
1118 $stack[$stack_depth] |= 1;
1119 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
d338d6fe 1120 last CMD; };
54d04a52 1121 $cmd =~ /^R$/ && do {
55497cff 1122 print $OUT "Warning: some settings and command-line options may be lost!\n";
54d04a52
IZ
1123 my (@script, @flags, $cl);
1124 push @flags, '-w' if $ini_warn;
1125 # Put all the old includes at the start to get
1126 # the same debugger.
1127 for (@ini_INC) {
1128 push @flags, '-I', $_;
1129 }
1130 # Arrange for setting the old INC:
1131 set_list("PERLDB_INC", @ini_INC);
1132 if ($0 eq '-e') {
1133 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
055fd3a9 1134 chomp ($cl = ${'::_<-e'}[$_]);
54d04a52
IZ
1135 push @script, '-e', $cl;
1136 }
1137 } else {
1138 @script = $0;
1139 }
1140 set_list("PERLDB_HIST",
1141 $term->Features->{getHistory}
1142 ? $term->GetHistory : @hist);
55497cff
PP
1143 my @had_breakpoints = keys %had_breakpoints;
1144 set_list("PERLDB_VISITED", @had_breakpoints);
54d04a52 1145 set_list("PERLDB_OPT", %option);
55497cff
PP
1146 set_list("PERLDB_ON_LOAD", %break_on_load);
1147 my @hard;
1148 for (0 .. $#had_breakpoints) {
1149 my $file = $had_breakpoints[$_];
8ebc5c01 1150 *dbline = $main::{'_<' . $file};
0c395bd7 1151 next unless %dbline or $postponed_file{$file};
55497cff
PP
1152 (push @hard, $file), next
1153 if $file =~ /^\(eval \d+\)$/;
1154 my @add;
1155 @add = %{$postponed_file{$file}}
0c395bd7 1156 if $postponed_file{$file};
55497cff
PP
1157 set_list("PERLDB_FILE_$_", %dbline, @add);
1158 }
1159 for (@hard) { # Yes, really-really...
1160 # Find the subroutines in this eval
8ebc5c01 1161 *dbline = $main::{'_<' . $_};
55497cff
PP
1162 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1163 for $sub (keys %sub) {
1164 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1165 $subs{$sub} = [$1, $2];
1166 }
1167 unless (%subs) {
1168 print $OUT
1169 "No subroutines in $_, ignoring breakpoints.\n";
1170 next;
1171 }
1172 LINES: for $line (keys %dbline) {
1173 # One breakpoint per sub only:
1174 my ($offset, $sub, $found);
1175 SUBS: for $sub (keys %subs) {
1176 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1177 and (not defined $offset # Not caught
1178 or $offset < 0 )) { # or badly caught
1179 $found = $sub;
1180 $offset = $line - $subs{$sub}->[0];
1181 $offset = "+$offset", last SUBS if $offset >= 0;
1182 }
1183 }
1184 if (defined $offset) {
1185 $postponed{$found} =
1186 "break $offset if $dbline{$line}";
1187 } else {
1188 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1189 }
1190 }
54d04a52 1191 }
55497cff 1192 set_list("PERLDB_POSTPONE", %postponed);
43aed9ee
IZ
1193 set_list("PERLDB_PRETYPE", @$pretype);
1194 set_list("PERLDB_PRE", @$pre);
1195 set_list("PERLDB_POST", @$post);
1196 set_list("PERLDB_TYPEAHEAD", @typeahead);
54d04a52 1197 $ENV{PERLDB_RESTART} = 1;
055fd3a9
GS
1198 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1199 exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS;
54d04a52
IZ
1200 print $OUT "exec failed: $!\n";
1201 last CMD; };
d338d6fe 1202 $cmd =~ /^T$/ && do {
36477c24 1203 print_trace($OUT, 1); # skip DB
d338d6fe 1204 next CMD; };
6027b9a3
IZ
1205 $cmd =~ /^W\s*$/ && do {
1206 $trace &= ~2;
1207 @to_watch = @old_watch = ();
1208 next CMD; };
1209 $cmd =~ /^W\b\s*(.*)/s && do {
1210 push @to_watch, $1;
1211 $evalarg = $1;
1212 my ($val) = &eval;
1213 $val = (defined $val) ? "'$val'" : 'undef' ;
1214 push @old_watch, $val;
1215 $trace |= 2;
1216 next CMD; };
d338d6fe
PP
1217 $cmd =~ /^\/(.*)$/ && do {
1218 $inpat = $1;
1219 $inpat =~ s:([^\\])/$:$1:;
1220 if ($inpat ne "") {
3dcd9d33
GS
1221 # squelch the sigmangler
1222 local $SIG{__DIE__};
1223 local $SIG{__WARN__};
d338d6fe
PP
1224 eval '$inpat =~ m'."\a$inpat\a";
1225 if ($@ ne "") {
1226 print $OUT "$@";
1227 next CMD;
1228 }
1229 $pat = $inpat;
1230 }
1231 $end = $start;
1d06cb2d 1232 $incr = -1;
d338d6fe
PP
1233 eval '
1234 for (;;) {
1235 ++$start;
1236 $start = 1 if ($start > $max);
1237 last if ($start == $end);
1238 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
055fd3a9 1239 if ($slave_editor) {
d338d6fe
PP
1240 print $OUT "\032\032$filename:$start:0\n";
1241 } else {
1242 print $OUT "$start:\t", $dbline[$start], "\n";
1243 }
1244 last;
1245 }
1246 } ';
1247 print $OUT "/$pat/: not found\n" if ($start == $end);
1248 next CMD; };
1249 $cmd =~ /^\?(.*)$/ && do {
1250 $inpat = $1;
1251 $inpat =~ s:([^\\])\?$:$1:;
1252 if ($inpat ne "") {
3dcd9d33
GS
1253 # squelch the sigmangler
1254 local $SIG{__DIE__};
1255 local $SIG{__WARN__};
d338d6fe
PP
1256 eval '$inpat =~ m'."\a$inpat\a";
1257 if ($@ ne "") {
3dcd9d33 1258 print $OUT $@;
d338d6fe
PP
1259 next CMD;
1260 }
1261 $pat = $inpat;
1262 }
1263 $end = $start;
1d06cb2d 1264 $incr = -1;
d338d6fe
PP
1265 eval '
1266 for (;;) {
1267 --$start;
1268 $start = $max if ($start <= 0);
1269 last if ($start == $end);
1270 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
055fd3a9 1271 if ($slave_editor) {
d338d6fe
PP
1272 print $OUT "\032\032$filename:$start:0\n";
1273 } else {
1274 print $OUT "$start:\t", $dbline[$start], "\n";
1275 }
1276 last;
1277 }
1278 } ';
1279 print $OUT "?$pat?: not found\n" if ($start == $end);
1280 next CMD; };
1281 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1282 pop(@hist) if length($cmd) > 1;
3fbd6552 1283 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
6921e3ed 1284 $cmd = $hist[$i];
615b993b 1285 print $OUT $cmd, "\n";
d338d6fe 1286 redo CMD; };
55497cff 1287 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
ee971a18 1288 &system($1);
d338d6fe
PP
1289 next CMD; };
1290 $cmd =~ /^$rc([^$rc].*)$/ && do {
1291 $pat = "^$1";
1292 pop(@hist) if length($cmd) > 1;
1293 for ($i = $#hist; $i; --$i) {
1294 last if $hist[$i] =~ /$pat/;
1295 }
1296 if (!$i) {
1297 print $OUT "No such command!\n\n";
1298 next CMD;
1299 }
6921e3ed 1300 $cmd = $hist[$i];
615b993b 1301 print $OUT $cmd, "\n";
d338d6fe
PP
1302 redo CMD; };
1303 $cmd =~ /^$sh$/ && do {
1304 &system($ENV{SHELL}||"/bin/sh");
1305 next CMD; };
ee971a18 1306 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
055fd3a9
GS
1307 # XXX: using csh or tcsh destroys sigint retvals!
1308 #&system($1); # use this instead
ee971a18 1309 &system($ENV{SHELL}||"/bin/sh","-c",$1);
d338d6fe
PP
1310 next CMD; };
1311 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
055fd3a9 1312 $end = $2 ? ($#hist-$2) : 0;
d338d6fe
PP
1313 $hist = 0 if $hist < 0;
1314 for ($i=$#hist; $i>$end; $i--) {
1315 print $OUT "$i: ",$hist[$i],"\n"
1316 unless $hist[$i] =~ /^.?$/;
1317 };
1318 next CMD; };
055fd3a9
GS
1319 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1320 runman($1);
1321 next CMD; };
b9b857e2
IZ
1322 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1323 $cmd =~ s/^p\b/print {\$DB::OUT} /;
3dcd9d33
GS
1324 $cmd =~ s/^=\s*// && do {
1325 my @keys;
1326 if (length $cmd == 0) {
1327 @keys = sort keys %alias;
1328 }
1329 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1330 # can't use $_ or kill //g state
1331 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1332 $alias{$k} = "s\a$k\a$v\a";
1333 # squelch the sigmangler
1334 local $SIG{__DIE__};
1335 local $SIG{__WARN__};
1336 unless (eval "sub { s\a$k\a$v\a }; 1") {
1337 print $OUT "Can't alias $k to $v: $@\n";
1338 delete $alias{$k};
1339 next CMD;
1340 }
1341 @keys = ($k);
1342 }
1343 else {
1344 @keys = ($cmd);
1345 }
1346 for my $k (@keys) {
1347 if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
1348 print $OUT "$k\t= $1\n";
1349 }
1350 elsif (defined $alias{$k}) {
d338d6fe 1351 print $OUT "$k\t$alias{$k}\n";
3dcd9d33
GS
1352 }
1353 else {
1354 print "No alias for $k\n";
1355 }
1356 }
d338d6fe
PP
1357 next CMD; };
1358 $cmd =~ /^\|\|?\s*[^|]/ && do {
1359 if ($pager =~ /^\|/) {
1360 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1361 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1362 } else {
1363 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1364 }
055fd3a9 1365 fix_less();
d338d6fe
PP
1366 unless ($piped=open(OUT,$pager)) {
1367 &warn("Can't pipe output to `$pager'");
1368 if ($pager =~ /^\|/) {
055fd3a9
GS
1369 open(OUT,">&STDOUT") # XXX: lost message
1370 || &warn("Can't restore DB::OUT");
d338d6fe
PP
1371 open(STDOUT,">&SAVEOUT")
1372 || &warn("Can't restore STDOUT");
1373 close(SAVEOUT);
1374 } else {
055fd3a9
GS
1375 open(OUT,">&STDOUT") # XXX: lost message
1376 || &warn("Can't restore DB::OUT");
d338d6fe
PP
1377 }
1378 next CMD;
1379 }
77fb7b16 1380 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
055fd3a9 1381 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
d338d6fe
PP
1382 $selected= select(OUT);
1383 $|= 1;
1384 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1385 $cmd =~ s/^\|+\s*//;
055fd3a9
GS
1386 redo PIPE;
1387 };
d338d6fe 1388 # XXX Local variants do not work!
6027b9a3 1389 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
d338d6fe
PP
1390 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1391 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1392 } # PIPE:
d338d6fe
PP
1393 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1394 if ($onetimeDump) {
1395 $onetimeDump = undef;
f36776d9 1396 } elsif ($term_pid == $$) {
d338d6fe
PP
1397 print $OUT "\n";
1398 }
1399 } continue { # CMD:
1400 if ($piped) {
1401 if ($pager =~ /^\|/) {
055fd3a9
GS
1402 $? = 0;
1403 # we cannot warn here: the handle is missing --tchrist
1404 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1405
1406 # most of the $? crud was coping with broken cshisms
1407 if ($?) {
1408 print SAVEOUT "Pager `$pager' failed: ";
1409 if ($? == -1) {
1410 print SAVEOUT "shell returned -1\n";
1411 } elsif ($? >> 8) {
1412 print SAVEOUT
1413 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1414 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1415 } else {
1416 print SAVEOUT "status ", ($? >> 8), "\n";
1417 }
1418 }
1419
d338d6fe
PP
1420 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1421 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
055fd3a9 1422 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
d338d6fe
PP
1423 # Will stop ignoring SIGPIPE if done like nohup(1)
1424 # does SIGINT but Perl doesn't give us a choice.
1425 } else {
1426 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1427 }
1428 close(SAVEOUT);
1429 select($selected), $selected= "" unless $selected eq "";
1430 $piped= "";
1431 }
1432 } # CMD:
04fb8f4b 1433 $exiting = 1 unless defined $cmd;
e63173ce
IZ
1434 foreach $evalarg (@$post) {
1435 &eval;
1436 }
d338d6fe 1437 } # if ($single || $signal)
22fae026 1438 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
d338d6fe
PP
1439 ();
1440}
1441
1442# The following code may be executed now:
1443# BEGIN {warn 4}
1444
1445sub sub {
ee971a18 1446 my ($al, $ret, @ret) = "";
7d4a81e5
IZ
1447 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1448 $al = " for $$sub";
ee971a18 1449 }
f8b5b99c
IZ
1450 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1451 $#stack = $stack_depth;
1452 $stack[-1] = $single;
d338d6fe 1453 $single &= 1;
f8b5b99c 1454 $single |= 4 if $stack_depth == $deep;
04fb8f4b 1455 ($frame & 4
f8b5b99c 1456 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "),
04fb8f4b
IZ
1457 # Why -1? But it works! :-(
1458 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f8b5b99c 1459 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame;
d338d6fe
PP
1460 if (wantarray) {
1461 @ret = &$sub;
f8b5b99c 1462 $single |= $stack[$stack_depth--];
36477c24 1463 ($frame & 4
f8b5b99c 1464 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
36477c24 1465 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f8b5b99c
IZ
1466 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1467 if ($doret eq $stack_depth or $frame & 16) {
1468 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1469 print $fh ' ' x $stack_depth if $frame & 16;
7ea36084
IZ
1470 print $fh "list context return from $sub:\n";
1471 dumpit($fh, \@ret );
1472 $doret = -2;
1473 }
d338d6fe
PP
1474 @ret;
1475 } else {
fb73857a
PP
1476 if (defined wantarray) {
1477 $ret = &$sub;
1478 } else {
1479 &$sub; undef $ret;
1480 };
f8b5b99c 1481 $single |= $stack[$stack_depth--];
36477c24 1482 ($frame & 4
f8b5b99c 1483 ? ( (print $LINEINFO ' ' x $stack_depth, "out "),
36477c24 1484 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f8b5b99c
IZ
1485 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2;
1486 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1487 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1488 print $fh (' ' x $stack_depth) if $frame & 16;
7ea36084
IZ
1489 print $fh (defined wantarray
1490 ? "scalar context return from $sub: "
1491 : "void context return from $sub\n");
1492 dumpit( $fh, $ret ) if defined wantarray;
1493 $doret = -2;
1494 }
d338d6fe
PP
1495 $ret;
1496 }
1497}
1498
1499sub save {
22fae026 1500 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
d338d6fe
PP
1501 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1502}
1503
1504# The following takes its argument via $evalarg to preserve current @_
1505
1506sub eval {
055fd3a9
GS
1507 # 'my' would make it visible from user code
1508 # but so does local! --tchrist
1509 local @res;
d338d6fe 1510 {
23a291ec
GS
1511 local $otrace = $trace;
1512 local $osingle = $single;
1513 local $od = $^D;
157b066d 1514 { ($evalarg) = $evalarg =~ /(.*)/s; }
d338d6fe
PP
1515 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1516 $trace = $otrace;
1517 $single = $osingle;
1518 $^D = $od;
1519 }
1520 my $at = $@;
36477c24 1521 local $saved[0]; # Preserve the old value of $@
22fae026 1522 eval { &DB::save };
d338d6fe
PP
1523 if ($at) {
1524 print $OUT $at;
1d06cb2d 1525 } elsif ($onetimeDump eq 'dump') {
7ea36084 1526 dumpit($OUT, \@res);
1d06cb2d
IZ
1527 } elsif ($onetimeDump eq 'methods') {
1528 methods($res[0]);
d338d6fe 1529 }
6027b9a3 1530 @res;
d338d6fe
PP
1531}
1532
55497cff
PP
1533sub postponed_sub {
1534 my $subname = shift;
1d06cb2d 1535 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
55497cff
PP
1536 my $offset = $1 || 0;
1537 # Filename below can contain ':'
1d06cb2d 1538 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
55497cff 1539 if ($i) {
fb73857a 1540 $i += $offset;
8ebc5c01 1541 local *dbline = $main::{'_<' . $file};
55497cff 1542 local $^W = 0; # != 0 is magical below
3fbd6552 1543 $had_breakpoints{$file} |= 1;
55497cff
PP
1544 my $max = $#dbline;
1545 ++$i until $dbline[$i] != 0 or $i >= $max;
1546 $dbline{$i} = delete $postponed{$subname};
1547 } else {
1548 print $OUT "Subroutine $subname not found.\n";
1549 }
1550 return;
1551 }
1d06cb2d 1552 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
36477c24 1553 #print $OUT "In postponed_sub for `$subname'.\n";
55497cff
PP
1554}
1555
1556sub postponed {
3aefca04
IZ
1557 if ($ImmediateStop) {
1558 $ImmediateStop = 0;
1559 $signal = 1;
1560 }
55497cff
PP
1561 return &postponed_sub
1562 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1563 # Cannot be done before the file is compiled
1564 local *dbline = shift;
1565 my $filename = $dbline;
1566 $filename =~ s/^_<//;
36477c24
PP
1567 $signal = 1, print $OUT "'$filename' loaded...\n"
1568 if $break_on_load{$filename};
f8b5b99c 1569 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
0c395bd7 1570 return unless $postponed_file{$filename};
3fbd6552 1571 $had_breakpoints{$filename} |= 1;
55497cff
PP
1572 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1573 my $key;
1574 for $key (keys %{$postponed_file{$filename}}) {
055fd3a9 1575 $dbline{$key} = ${$postponed_file{$filename}}{$key};
54d04a52 1576 }
0c395bd7 1577 delete $postponed_file{$filename};
54d04a52
IZ
1578}
1579
d338d6fe 1580sub dumpit {
7ea36084 1581 local ($savout) = select(shift);
ee971a18
PP
1582 my $osingle = $single;
1583 my $otrace = $trace;
1584 $single = $trace = 0;
1585 local $frame = 0;
1586 local $doret = -2;
1587 unless (defined &main::dumpValue) {
1588 do 'dumpvar.pl';
1589 }
d338d6fe
PP
1590 if (defined &main::dumpValue) {
1591 &main::dumpValue(shift);
1592 } else {
1593 print $OUT "dumpvar.pl not available.\n";
1594 }
ee971a18
PP
1595 $single = $osingle;
1596 $trace = $otrace;
d338d6fe
PP
1597 select ($savout);
1598}
1599
36477c24
PP
1600# Tied method do not create a context, so may get wrong message:
1601
55497cff
PP
1602sub print_trace {
1603 my $fh = shift;
36477c24
PP
1604 my @sub = dump_trace($_[0] + 1, $_[1]);
1605 my $short = $_[2]; # Print short report, next one for sub name
1d06cb2d 1606 my $s;
55497cff
PP
1607 for ($i=0; $i <= $#sub; $i++) {
1608 last if $signal;
1609 local $" = ', ';
1610 my $args = defined $sub[$i]{args}
1611 ? "(@{ $sub[$i]{args} })"
1612 : '' ;
1d06cb2d
IZ
1613 $args = (substr $args, 0, $maxtrace - 3) . '...'
1614 if length $args > $maxtrace;
36477c24
PP
1615 my $file = $sub[$i]{file};
1616 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1d06cb2d
IZ
1617 $s = $sub[$i]{sub};
1618 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
36477c24 1619 if ($short) {
1d06cb2d 1620 my $sub = @_ >= 4 ? $_[3] : $s;
36477c24
PP
1621 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1622 } else {
1d06cb2d 1623 print $fh "$sub[$i]{context} = $s$args" .
36477c24
PP
1624 " called from $file" .
1625 " line $sub[$i]{line}\n";
1626 }
55497cff
PP
1627 }
1628}
1629
1630sub dump_trace {
1631 my $skip = shift;
36477c24
PP
1632 my $count = shift || 1e9;
1633 $skip++;
1634 $count += $skip;
55497cff 1635 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
04fb8f4b
IZ
1636 my $nothard = not $frame & 8;
1637 local $frame = 0; # Do not want to trace this.
1638 my $otrace = $trace;
1639 $trace = 0;
55497cff 1640 for ($i = $skip;
36477c24 1641 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
55497cff
PP
1642 $i++) {
1643 @a = ();
1644 for $arg (@args) {
04fb8f4b
IZ
1645 my $type;
1646 if (not defined $arg) {
1647 push @a, "undef";
1648 } elsif ($nothard and tied $arg) {
1649 push @a, "tied";
1650 } elsif ($nothard and $type = ref $arg) {
1651 push @a, "ref($type)";
1652 } else {
1653 local $_ = "$arg"; # Safe to stringify now - should not call f().
1654 s/([\'\\])/\\$1/g;
1655 s/(.*)/'$1'/s
1656 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1657 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1658 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1659 push(@a, $_);
1660 }
55497cff 1661 }
7ea36084 1662 $context = $context ? '@' : (defined $context ? "\$" : '.');
55497cff
PP
1663 $args = $h ? [@a] : undef;
1664 $e =~ s/\n\s*\;\s*\Z// if $e;
1d06cb2d 1665 $e =~ s/([\\\'])/\\$1/g if $e;
55497cff
PP
1666 if ($r) {
1667 $sub = "require '$e'";
1668 } elsif (defined $r) {
1669 $sub = "eval '$e'";
1670 } elsif ($sub eq '(eval)') {
1671 $sub = "eval {...}";
1672 }
1673 push(@sub, {context => $context, sub => $sub, args => $args,
1674 file => $file, line => $line});
1675 last if $signal;
1676 }
04fb8f4b 1677 $trace = $otrace;
55497cff
PP
1678 @sub;
1679}
1680
d338d6fe
PP
1681sub action {
1682 my $action = shift;
1683 while ($action =~ s/\\$//) {
1684 #print $OUT "+ ";
1685 #$action .= "\n";
1686 $action .= &gets;
1687 }
1688 $action;
1689}
1690
055fd3a9
GS
1691sub unbalanced {
1692 # i hate using globals!
1693 $balanced_brace_re ||= qr{
1694 ^ \{
1695 (?:
1696 (?> [^{}] + ) # Non-parens without backtracking
1697 |
1698 (??{ $balanced_brace_re }) # Group with matching parens
1699 ) *
1700 \} $
1701 }x;
1702 return $_[0] !~ m/$balanced_brace_re/;
1703}
1704
d338d6fe 1705sub gets {
d338d6fe
PP
1706 &readline("cont: ");
1707}
1708
1709sub system {
1710 # We save, change, then restore STDIN and STDOUT to avoid fork() since
055fd3a9 1711 # some non-Unix systems can do system() but have problems with fork().
d338d6fe 1712 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
8ee058cb 1713 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
d338d6fe
PP
1714 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1715 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
055fd3a9
GS
1716
1717 # XXX: using csh or tcsh destroys sigint retvals!
d338d6fe
PP
1718 system(@_);
1719 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1720 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
055fd3a9
GS
1721 close(SAVEIN);
1722 close(SAVEOUT);
1723
1724
1725 # most of the $? crud was coping with broken cshisms
1726 if ($? >> 8) {
1727 &warn("(Command exited ", ($? >> 8), ")\n");
1728 } elsif ($?) {
1729 &warn( "(Command died of SIG#", ($? & 127),
1730 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1731 }
1732
1733 return $?;
1734
d338d6fe
PP
1735}
1736
1737sub setterm {
54d04a52 1738 local $frame = 0;
ee971a18 1739 local $doret = -2;
ee971a18 1740 eval { require Term::ReadLine } or die $@;
d338d6fe
PP
1741 if ($notty) {
1742 if ($tty) {
1743 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1744 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1745 $IN = \*IN;
1746 $OUT = \*OUT;
1747 my $sel = select($OUT);
1748 $| = 1;
1749 select($sel);
1750 } else {
3dcd9d33 1751 eval "require Term::Rendezvous;" or die;
d338d6fe
PP
1752 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1753 my $term_rv = new Term::Rendezvous $rv;
1754 $IN = $term_rv->IN;
1755 $OUT = $term_rv->OUT;
1756 }
1757 }
1758 if (!$rl) {
1759 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1760 } else {
1761 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1762
a737e074
CS
1763 $rl_attribs = $term->Attribs;
1764 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1765 if defined $rl_attribs->{basic_word_break_characters}
1766 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1767 $rl_attribs->{special_prefixes} = '$@&%';
1768 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1769 $rl_attribs->{completion_function} = \&db_complete;
d338d6fe
PP
1770 }
1771 $LINEINFO = $OUT unless defined $LINEINFO;
1772 $lineinfo = $console unless defined $lineinfo;
1773 $term->MinLine(2);
54d04a52
IZ
1774 if ($term->Features->{setHistory} and "@hist" ne "?") {
1775 $term->SetHistory(@hist);
1776 }
7a2e2cd6 1777 ornaments($ornaments) if defined $ornaments;
f36776d9
IZ
1778 $term_pid = $$;
1779}
1780
1781sub resetterm { # We forked, so we need a different TTY
1782 $term_pid = $$;
1783 if (defined &get_fork_TTY) {
1784 &get_fork_TTY;
1785 } elsif (not defined $fork_TTY
1786 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
1787 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
1788 # Possibly _inside_ XTERM
1789 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
1790 sleep 10000000' |];
1791 $fork_TTY = <XT>;
1792 chomp $fork_TTY;
1793 }
1794 if (defined $fork_TTY) {
1795 TTY($fork_TTY);
1796 undef $fork_TTY;
1797 } else {
405ff068
IZ
1798 print_help(<<EOP);
1799I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
1800 Define B<\$DB::fork_TTY>
1801 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
1802 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
1803 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
1804 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
1805EOP
f36776d9 1806 }
d338d6fe
PP
1807}
1808
1809sub readline {
0c01eb4a 1810 local $.;
54d04a52
IZ
1811 if (@typeahead) {
1812 my $left = @typeahead;
1813 my $got = shift @typeahead;
1814 print $OUT "auto(-$left)", shift, $got, "\n";
1815 $term->AddHistory($got)
1816 if length($got) > 1 and defined $term->Features->{addHistory};
1817 return $got;
1818 }
d338d6fe 1819 local $frame = 0;
ee971a18 1820 local $doret = -2;
363b4d59 1821 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
e4e99f0d 1822 $OUT->write(join('', @_));
363b4d59 1823 my $stuff;
055fd3a9 1824 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
363b4d59
GT
1825 $stuff;
1826 }
1827 else {
1828 $term->readline(@_);
1829 }
d338d6fe
PP
1830}
1831
1832sub dump_option {
1833 my ($opt, $val)= @_;
55497cff
PP
1834 $val = option_val($opt,'N/A');
1835 $val =~ s/([\\\'])/\\$1/g;
1836 printf $OUT "%20s = '%s'\n", $opt, $val;
1837}
1838
1839sub option_val {
1840 my ($opt, $default)= @_;
1841 my $val;
d338d6fe 1842 if (defined $optionVars{$opt}
055fd3a9
GS
1843 and defined ${$optionVars{$opt}}) {
1844 $val = ${$optionVars{$opt}};
d338d6fe
PP
1845 } elsif (defined $optionAction{$opt}
1846 and defined &{$optionAction{$opt}}) {
1847 $val = &{$optionAction{$opt}}();
1848 } elsif (defined $optionAction{$opt}
1849 and not defined $option{$opt}
1850 or defined $optionVars{$opt}
055fd3a9 1851 and not defined ${$optionVars{$opt}}) {
55497cff 1852 $val = $default;
d338d6fe
PP
1853 } else {
1854 $val = $option{$opt};
1855 }
55497cff 1856 $val
d338d6fe
PP
1857}
1858
1859sub parse_options {
1860 local($_)= @_;
055fd3a9
GS
1861 # too dangerous to let intuitive usage overwrite important things
1862 # defaultion should never be the default
1863 my %opt_needs_val = map { ( $_ => 1 ) } qw{
24eeb834 1864 arrayDepth hashDepth LineInfo maxTraceLen ornaments
055fd3a9
GS
1865 pager quote ReadLine recallCommand RemotePort ShellBang TTY
1866 };
1867 while (length) {
1868 my $val_defaulted;
1869 s/^\s+// && next;
1870 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
d338d6fe
PP
1871 my ($opt,$sep) = ($1,$2);
1872 my $val;
1873 if ("?" eq $sep) {
1874 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1875 if /^\S/;
1876 #&dump_option($opt);
1877 } elsif ($sep !~ /\S/) {
055fd3a9
GS
1878 $val_defaulted = 1;
1879 $val = "1"; # this is an evil default; make 'em set it!
d338d6fe 1880 } elsif ($sep eq "=") {
055fd3a9
GS
1881
1882 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
1883 my $quote = $1;
1884 ($val = $2) =~ s/\\([$quote\\])/$1/g;
1885 } else {
1886 s/^(\S*)//;
d338d6fe 1887 $val = $1;
055fd3a9
GS
1888 print OUT qq(Option better cleared using $opt=""\n)
1889 unless length $val;
1890 }
1891
d338d6fe
PP
1892 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1893 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1894 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1895 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
055fd3a9 1896 ($val = $1) =~ s/\\([\\$end])/$1/g;
d338d6fe 1897 }
055fd3a9
GS
1898
1899 my $option;
1900 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
1901 || grep( /^\Q$opt/i && ($option = $_), @options );
1902
1903 print($OUT "Unknown option `$opt'\n"), next unless $matches;
1904 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
1905
1906 if ($opt_needs_val{$option} && $val_defaulted) {
1907 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
1908 next;
1909 }
1910
1911 $option{$option} = $val if defined $val;
1912
1913 eval qq{
1914 local \$frame = 0;
1915 local \$doret = -2;
1916 require '$optionRequire{$option}';
1917 1;
1918 } || die # XXX: shouldn't happen
1919 if defined $optionRequire{$option} &&
1920 defined $val;
1921
1922 ${$optionVars{$option}} = $val
1923 if defined $optionVars{$option} &&
1924 defined $val;
1925
1926 &{$optionAction{$option}} ($val)
1927 if defined $optionAction{$option} &&
1928 defined &{$optionAction{$option}} &&
1929 defined $val;
1930
1931 # Not $rcfile
1932 dump_option($option) unless $OUT eq \*STDERR;
d338d6fe
PP
1933 }
1934}
1935
54d04a52
IZ
1936sub set_list {
1937 my ($stem,@list) = @_;
1938 my $val;
055fd3a9 1939 $ENV{"${stem}_n"} = @list;
54d04a52
IZ
1940 for $i (0 .. $#list) {
1941 $val = $list[$i];
1942 $val =~ s/\\/\\\\/g;
ee971a18 1943 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
055fd3a9 1944 $ENV{"${stem}_$i"} = $val;
54d04a52
IZ
1945 }
1946}
1947
1948sub get_list {
1949 my $stem = shift;
1950 my @list;
055fd3a9 1951 my $n = delete $ENV{"${stem}_n"};
54d04a52
IZ
1952 my $val;
1953 for $i (0 .. $n - 1) {
055fd3a9 1954 $val = delete $ENV{"${stem}_$i"};
54d04a52
IZ
1955 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1956 push @list, $val;
1957 }
1958 @list;
1959}
1960
d338d6fe
PP
1961sub catch {
1962 $signal = 1;
4639966b 1963 return; # Put nothing on the stack - malloc/free land!
d338d6fe
PP
1964}
1965
1966sub warn {
1967 my($msg)= join("",@_);
1968 $msg .= ": $!\n" unless $msg =~ /\n$/;
1969 print $OUT $msg;
1970}
1971
1972sub TTY {
f36776d9
IZ
1973 if (@_ and $term and $term->Features->{newTTY}) {
1974 my ($in, $out) = shift;
1975 if ($in =~ /,/) {
1976 ($in, $out) = split /,/, $in, 2;
1977 } else {
1978 $out = $in;
1979 }
1980 open IN, $in or die "cannot open `$in' for read: $!";
1981 open OUT, ">$out" or die "cannot open `$out' for write: $!";
1982 $term->newTTY(\*IN, \*OUT);
1983 $IN = \*IN;
1984 $OUT = \*OUT;
1985 return $tty = $in;
1986 } elsif ($term and @_) {
1987 &warn("Too late to set TTY, enabled on next `R'!\n");
43aed9ee
IZ
1988 }
1989 $tty = shift if @_;
d338d6fe
PP
1990 $tty or $console;
1991}
1992
1993sub noTTY {
1994 if ($term) {
43aed9ee 1995 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
d338d6fe 1996 }
43aed9ee 1997 $notty = shift if @_;
d338d6fe
PP
1998 $notty;
1999}
2000
2001sub ReadLine {
2002 if ($term) {
43aed9ee 2003 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
d338d6fe 2004 }
43aed9ee 2005 $rl = shift if @_;
d338d6fe
PP
2006 $rl;
2007}
2008
363b4d59
GT
2009sub RemotePort {
2010 if ($term) {
2011 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2012 }
2013 $remoteport = shift if @_;
2014 $remoteport;
2015}
2016
a737e074 2017sub tkRunning {
055fd3a9 2018 if (${$term->Features}{tkRunning}) {
a737e074
CS
2019 return $term->tkRunning(@_);
2020 } else {
2021 print $OUT "tkRunning not supported by current ReadLine package.\n";
2022 0;
2023 }
2024}
2025
d338d6fe
PP
2026sub NonStop {
2027 if ($term) {
43aed9ee 2028 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
d338d6fe 2029 }
43aed9ee 2030 $runnonstop = shift if @_;
d338d6fe
PP
2031 $runnonstop;
2032}
2033
2034sub pager {
2035 if (@_) {
2036 $pager = shift;
2037 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2038 }
2039 $pager;
2040}
2041
2042sub shellBang {
2043 if (@_) {
2044 $sh = quotemeta shift;
2045 $sh .= "\\b" if $sh =~ /\w$/;
2046 }
2047 $psh = $sh;
2048 $psh =~ s/\\b$//;
2049 $psh =~ s/\\(.)/$1/g;
2050 &sethelp;
2051 $psh;
2052}
2053
7a2e2cd6
PP
2054sub ornaments {
2055 if (defined $term) {
2056 local ($warnLevel,$dieLevel) = (0, 1);
2057 return '' unless $term->Features->{ornaments};
2058 eval { $term->ornaments(@_) } || '';
2059 } else {
2060 $ornaments = shift;
2061 }
2062}
2063
d338d6fe
PP
2064sub recallCommand {
2065 if (@_) {
2066 $rc = quotemeta shift;
2067 $rc .= "\\b" if $rc =~ /\w$/;
2068 }
2069 $prc = $rc;
2070 $prc =~ s/\\b$//;
2071 $prc =~ s/\\(.)/$1/g;
2072 &sethelp;
2073 $prc;
2074}
2075
2076sub LineInfo {
2077 return $lineinfo unless @_;
2078 $lineinfo = shift;
2079 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
055fd3a9 2080 $slave_editor = ($stream =~ /^\|/);
d338d6fe
PP
2081 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2082 $LINEINFO = \*LINEINFO;
2083 my $save = select($LINEINFO);
2084 $| = 1;
2085 select($save);
2086 $lineinfo;
2087}
2088
ee971a18
PP
2089sub list_versions {
2090 my %version;
2091 my $file;
2092 for (keys %INC) {
2093 $file = $_;
2094 s,\.p[lm]$,,i ;
2095 s,/,::,g ;
2096 s/^perl5db$/DB/;
55497cff 2097 s/^Term::ReadLine::readline$/readline/;
055fd3a9
GS
2098 if (defined ${ $_ . '::VERSION' }) {
2099 $version{$file} = "${ $_ . '::VERSION' } from ";
ee971a18
PP
2100 }
2101 $version{$file} .= $INC{$file};
2102 }
2c53b6d0 2103 dumpit($OUT,\%version);
ee971a18
PP
2104}
2105
d338d6fe 2106sub sethelp {
055fd3a9
GS
2107 # XXX: make sure these are tabs between the command and explantion,
2108 # or print_help will screw up your formatting if you have
2109 # eeevil ornaments enabled. This is an insane mess.
2110
d338d6fe 2111 $help = "
6027b9a3
IZ
2112B<T> Stack trace.
2113B<s> [I<expr>] Single step [in I<expr>].
2114B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2115<B<CR>> Repeat last B<n> or B<s> command.
2116B<r> Return from current subroutine.
2117B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
55497cff 2118 at the specified position.
6027b9a3
IZ
2119B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2120B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2121B<l> I<line> List single I<line>.
2122B<l> I<subname> List first window of lines from subroutine.
3fbd6552 2123B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
6027b9a3
IZ
2124B<l> List next window of lines.
2125B<-> List previous window of lines.
2126B<w> [I<line>] List window around I<line>.
2127B<.> Return to the executed line.
bee32ff8
GS
2128B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2129 I<filename> may be either the full name of the file, or a regular
2130 expression matching the full file name:
2131 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2132 Evals (with saved bodies) are considered to be filenames:
2133 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2134 (in the order of execution).
6027b9a3
IZ
2135B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2136B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2137B<L> List all breakpoints and actions.
2138B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2139B<t> Toggle trace mode.
2140B<t> I<expr> Trace through execution of I<expr>.
2141B<b> [I<line>] [I<condition>]
2142 Set breakpoint; I<line> defaults to the current execution line;
2143 I<condition> breaks if it evaluates to true, defaults to '1'.
2144B<b> I<subname> [I<condition>]
d338d6fe 2145 Set breakpoint at first line of subroutine.
3fbd6552 2146B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
6027b9a3
IZ
2147B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2148B<b> B<postpone> I<subname> [I<condition>]
55497cff
PP
2149 Set breakpoint at first line of subroutine after
2150 it is compiled.
6027b9a3 2151B<b> B<compile> I<subname>
1d06cb2d 2152 Stop after the subroutine is compiled.
6027b9a3
IZ
2153B<d> [I<line>] Delete the breakpoint for I<line>.
2154B<D> Delete all breakpoints.
2155B<a> [I<line>] I<command>
3fbd6552
GS
2156 Set an action to be done before the I<line> is executed;
2157 I<line> defaults to the current execution line.
6027b9a3
IZ
2158 Sequence is: check for breakpoint/watchpoint, print line
2159 if necessary, do action, prompt user if necessary,
3fbd6552
GS
2160 execute line.
2161B<a> [I<line>] Delete the action for I<line>.
6027b9a3
IZ
2162B<A> Delete all actions.
2163B<W> I<expr> Add a global watch-expression.
2164B<W> Delete all watch-expressions.
2165B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2166 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2167B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
91e74348
JH
2168B<x> I<expr> Evals expression in list context, dumps the result.
2169B<m> I<expr> Evals expression in list context, prints methods callable
1d06cb2d 2170 on the first element of the result.
6027b9a3 2171B<m> I<class> Prints methods callable via the given class.
055fd3a9
GS
2172
2173B<<> ? List Perl commands to run before each prompt.
6027b9a3
IZ
2174B<<> I<expr> Define Perl command to run before each prompt.
2175B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
055fd3a9 2176B<>> ? List Perl commands to run after each prompt.
6027b9a3 2177B<>> I<expr> Define Perl command to run after each prompt.
3fbd6552 2178B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
6027b9a3 2179B<{> I<db_command> Define debugger command to run before each prompt.
055fd3a9
GS
2180B<{> ? List debugger commands to run before each prompt.
2181B<<> I<expr> Define Perl command to run before each prompt.
6027b9a3
IZ
2182B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2183B<$prc> I<number> Redo a previous command (default previous command).
2184B<$prc> I<-number> Redo number'th-to-last command.
2185B<$prc> I<pattern> Redo last command that started with I<pattern>.
2186 See 'B<O> I<recallCommand>' too.
2187B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
d338d6fe 2188 . ( $rc eq $sh ? "" : "
6027b9a3
IZ
2189B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2190 See 'B<O> I<shellBang>' too.
2191B<H> I<-number> Display last number commands (default all).
2192B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2193B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2194B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2195B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2196I<command> Execute as a perl statement in current package.
2197B<v> Show versions of loaded modules.
2198B<R> Pure-man-restart of debugger, some of debugger state
55497cff 2199 and command-line options may be lost.
36477c24 2200 Currently the following setting are preserved:
6027b9a3
IZ
2201 history, breakpoints and actions, debugger B<O>ptions
2202 and the following command-line options: I<-w>, I<-I>, I<-e>.
055fd3a9
GS
2203
2204B<O> [I<opt>] ... Set boolean option to true
2205B<O> [I<opt>B<?>] Query options
2206B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2207 Set options. Use quotes in spaces in value.
2208 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2209 I<pager> program for output of \"|cmd\";
2210 I<tkRunning> run Tk while prompting (with ReadLine);
2211 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2212 I<inhibit_exit> Allows stepping off the end of the script.
2213 I<ImmediateStop> Debugger should stop as early as possible.
2214 I<RemotePort> Remote hostname:port for remote debugging
2215 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2216 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2217 I<compactDump>, I<veryCompact> change style of array and hash dump;
2218 I<globPrint> whether to print contents of globs;
2219 I<DumpDBFiles> dump arrays holding debugged files;
2220 I<DumpPackages> dump symbol tables of packages;
2221 I<DumpReused> dump contents of \"reused\" addresses;
2222 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2223 I<bareStringify> Do not print the overload-stringified value;
2224 Other options include:
2225 I<PrintRet> affects printing of return value after B<r> command,
2226 I<frame> affects printing messages on entry and exit from subroutines.
2227 I<AutoTrace> affects printing messages on every possible breaking point.
2228 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
2229 I<ornaments> affects screen appearance of the command line.
2230 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2231 You can put additional initialization options I<TTY>, I<noTTY>,
2232 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2233 `B<R>' after you set them).
2234
2235B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
6027b9a3
IZ
2236B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2237B<h h> Summary of debugger commands.
055fd3a9
GS
2238B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2239 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2240 Set B<\$DB::doccmd> to change viewer.
2241
2242Type `|h' for a paged display if this was too hard to read.
2243
2244"; # Fix balance of vi % matching: } }}
d338d6fe 2245
d338d6fe 2246 $summary = <<"END_SUM";
6027b9a3
IZ
2247I<List/search source lines:> I<Control script execution:>
2248 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2249 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2250 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
d9f67849 2251 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
6027b9a3
IZ
2252 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
2253 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
2254I<Debugger controls:> B<L> List break/watch/actions
2255 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
d9f67849 2256 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
2257 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2258 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2259 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2260 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
d9f67849 2261 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
6027b9a3
IZ
2262 B<q> or B<^D> Quit B<R> Attempt a restart
2263I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
91e74348 2264 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
6027b9a3
IZ
2265 B<p> I<expr> Print expression (uses script's current package).
2266 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2267 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2268 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
055fd3a9 2269For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
d338d6fe 2270END_SUM
055fd3a9 2271 # ')}}; # Fix balance of vi % matching
d338d6fe
PP
2272}
2273
6027b9a3 2274sub print_help {
055fd3a9
GS
2275 local $_ = shift;
2276
2277 # Restore proper alignment destroyed by eeevil I<> and B<>
2278 # ornaments: A pox on both their houses!
2279 #
2280 # A help command will have everything up to and including
2281 # the first tab sequence paddeed into a field 16 (or if indented 20)
2282 # wide. If it's wide than that, an extra space will be added.
2283 s{
2284 ^ # only matters at start of line
2285 ( \040{4} | \t )* # some subcommands are indented
2286 ( < ? # so <CR> works
2287 [BI] < [^\t\n] + ) # find an eeevil ornament
2288 ( \t+ ) # original separation, discarded
2289 ( .* ) # this will now start (no earlier) than
2290 # column 16
2291 } {
2292 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2293 my $clean = $command;
2294 $clean =~ s/[BI]<([^>]*)>/$1/g;
2295 # replace with this whole string:
2296 (length($leadwhite) ? " " x 4 : "")
2297 . $command
2298 . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ")
2299 . $text;
2300
2301 }mgex;
2302
2303 s{ # handle bold ornaments
2304 B < ( [^>] + | > ) >
2305 } {
2306 $Term::ReadLine::TermCap::rl_term_set[2]
2307 . $1
2308 . $Term::ReadLine::TermCap::rl_term_set[3]
2309 }gex;
2310
2311 s{ # handle italic ornaments
2312 I < ( [^>] + | > ) >
2313 } {
2314 $Term::ReadLine::TermCap::rl_term_set[0]
2315 . $1
2316 . $Term::ReadLine::TermCap::rl_term_set[1]
2317 }gex;
2318
2319 print $OUT $_;
2320}
2321
2322sub fix_less {
2323 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2324 my $is_less = $pager =~ /\bless\b/;
2325 if ($pager =~ /\bmore\b/) {
2326 my @st_more = stat('/usr/bin/more');
2327 my @st_less = stat('/usr/bin/less');
2328 $is_less = @st_more && @st_less
2329 && $st_more[0] == $st_less[0]
2330 && $st_more[1] == $st_less[1];
2331 }
2332 # changes environment!
2333 $ENV{LESS} .= 'r' if $is_less;
6027b9a3
IZ
2334}
2335
d338d6fe 2336sub diesignal {
54d04a52 2337 local $frame = 0;
ee971a18 2338 local $doret = -2;
77fb7b16 2339 $SIG{'ABRT'} = 'DEFAULT';
d338d6fe 2340 kill 'ABRT', $$ if $panic++;
ee85b803
CS
2341 if (defined &Carp::longmess) {
2342 local $SIG{__WARN__} = '';
2343 local $Carp::CarpLevel = 2; # mydie + confess
2344 &warn(Carp::longmess("Signal @_"));
2345 }
2346 else {
2347 print $DB::OUT "Got signal @_\n";
2348 }
d338d6fe
PP
2349 kill 'ABRT', $$;
2350}
2351
2352sub dbwarn {
54d04a52 2353 local $frame = 0;
ee971a18 2354 local $doret = -2;
d338d6fe 2355 local $SIG{__WARN__} = '';
77fb7b16 2356 local $SIG{__DIE__} = '';
fb73857a
PP
2357 eval { require Carp } if defined $^S; # If error/warning during compilation,
2358 # require may be broken.
2359 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2360 return unless defined &Carp::longmess;
d338d6fe
PP
2361 my ($mysingle,$mytrace) = ($single,$trace);
2362 $single = 0; $trace = 0;
2363 my $mess = Carp::longmess(@_);
2364 ($single,$trace) = ($mysingle,$mytrace);
d338d6fe 2365 &warn($mess);
d338d6fe
PP
2366}
2367
2368sub dbdie {
54d04a52 2369 local $frame = 0;
ee971a18 2370 local $doret = -2;
d338d6fe
PP
2371 local $SIG{__DIE__} = '';
2372 local $SIG{__WARN__} = '';
2373 my $i = 0; my $ineval = 0; my $sub;
fb73857a 2374 if ($dieLevel > 2) {
d338d6fe 2375 local $SIG{__WARN__} = \&dbwarn;
fb73857a
PP
2376 &warn(@_); # Yell no matter what
2377 return;
2378 }
2379 if ($dieLevel < 2) {
2380 die @_ if $^S; # in eval propagate
d338d6fe 2381 }
fb73857a
PP
2382 eval { require Carp } if defined $^S; # If error/warning during compilation,
2383 # require may be broken.
055fd3a9 2384
fb73857a
PP
2385 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2386 unless defined &Carp::longmess;
055fd3a9 2387
d338d6fe
PP
2388 # We do not want to debug this chunk (automatic disabling works
2389 # inside DB::DB, but not in Carp).
2390 my ($mysingle,$mytrace) = ($single,$trace);
2391 $single = 0; $trace = 0;
2392 my $mess = Carp::longmess(@_);
2393 ($single,$trace) = ($mysingle,$mytrace);
d338d6fe
PP
2394 die $mess;
2395}
2396
d338d6fe
PP
2397sub warnLevel {
2398 if (@_) {
2399 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2400 $warnLevel = shift;
2401 if ($warnLevel) {
0b7ed949 2402 $SIG{__WARN__} = \&DB::dbwarn;
d338d6fe
PP
2403 } else {
2404 $SIG{__WARN__} = $prevwarn;
2405 }
2406 }
2407 $warnLevel;
2408}
2409
2410sub dieLevel {
2411 if (@_) {
2412 $prevdie = $SIG{__DIE__} unless $dieLevel;
2413 $dieLevel = shift;
2414 if ($dieLevel) {
0b7ed949
PP
2415 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2416 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
d338d6fe 2417 print $OUT "Stack dump during die enabled",
43aed9ee
IZ
2418 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2419 if $I_m_init;
d338d6fe
PP
2420 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2421 } else {
2422 $SIG{__DIE__} = $prevdie;
2423 print $OUT "Default die handler restored.\n";
2424 }
2425 }
2426 $dieLevel;
2427}
2428
2429sub signalLevel {
2430 if (@_) {
2431 $prevsegv = $SIG{SEGV} unless $signalLevel;
2432 $prevbus = $SIG{BUS} unless $signalLevel;
2433 $signalLevel = shift;
2434 if ($signalLevel) {
77fb7b16
PP
2435 $SIG{SEGV} = \&DB::diesignal;
2436 $SIG{BUS} = \&DB::diesignal;
d338d6fe
PP
2437 } else {
2438 $SIG{SEGV} = $prevsegv;
2439 $SIG{BUS} = $prevbus;
2440 }
2441 }
2442 $signalLevel;
2443}
2444
83ee9e09
GS
2445sub CvGV_name {
2446 my $in = shift;
2447 my $name = CvGV_name_or_bust($in);
2448 defined $name ? $name : $in;
2449}
2450
2451sub CvGV_name_or_bust {
2452 my $in = shift;
2453 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2454 $in = \&$in; # Hard reference...
2455 eval {require Devel::Peek; 1} or return;
2456 my $gv = Devel::Peek::CvGV($in) or return;
2457 *$gv{PACKAGE} . '::' . *$gv{NAME};
2458}
2459
1d06cb2d
IZ
2460sub find_sub {
2461 my $subr = shift;
1d06cb2d 2462 $sub{$subr} or do {
83ee9e09
GS
2463 return unless defined &$subr;
2464 my $name = CvGV_name_or_bust($subr);
2465 my $data;
2466 $data = $sub{$name} if defined $name;
2467 return $data if defined $data;
2468
2469 # Old stupid way...
1d06cb2d
IZ
2470 $subr = \&$subr; # Hard reference
2471 my $s;
2472 for (keys %sub) {
2473 $s = $_, last if $subr eq \&$_;
2474 }
2475 $sub{$s} if $s;
2476 }
2477}
2478
2479sub methods {
2480 my $class = shift;
2481 $class = ref $class if ref $class;
2482 local %seen;
2483 local %packs;
2484 methods_via($class, '', 1);
2485 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2486}
2487
2488sub methods_via {
2489 my $class = shift;
2490 return if $packs{$class}++;
2491 my $prefix = shift;
2492 my $prepend = $prefix ? "via $prefix: " : '';
2493 my $name;
055fd3a9
GS
2494 for $name (grep {defined &{${"${class}::"}{$_}}}
2495 sort keys %{"${class}::"}) {
477ea2b1 2496 next if $seen{ $name }++;
1d06cb2d
IZ
2497 print $DB::OUT "$prepend$name\n";
2498 }
2499 return unless shift; # Recurse?
055fd3a9 2500 for $name (@{"${class}::ISA"}) {
1d06cb2d
IZ
2501 $prepend = $prefix ? $prefix . " -> $name" : $name;
2502 methods_via($name, $prepend, 1);
2503 }
2504}
2505
055fd3a9
GS
2506sub setman {
2507 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
2508 ? "man" # O Happy Day!
2509 : "perldoc"; # Alas, poor unfortunates
2510}
2511
2512sub runman {
2513 my $page = shift;
2514 unless ($page) {
2515 &system("$doccmd $doccmd");
2516 return;
2517 }
2518 # this way user can override, like with $doccmd="man -Mwhatever"
2519 # or even just "man " to disable the path check.
2520 unless ($doccmd eq 'man') {
2521 &system("$doccmd $page");
2522 return;
2523 }
2524
2525 $page = 'perl' if lc($page) eq 'help';
2526
2527 require Config;
2528 my $man1dir = $Config::Config{'man1dir'};
2529 my $man3dir = $Config::Config{'man3dir'};
2530 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2531 my $manpath = '';
2532 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2533 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2534 chop $manpath if $manpath;
2535 # harmless if missing, I figure
2536 my $oldpath = $ENV{MANPATH};
2537 $ENV{MANPATH} = $manpath if $manpath;
2538 my $nopathopt = $^O =~ /dunno what goes here/;
2539 if (system($doccmd,
2540 # I just *know* there are men without -M
2541 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2542 split ' ', $page) )
2543 {
2544 unless ($page =~ /^perl\w/) {
2545 if (grep { $page eq $_ } qw{
2546 5004delta 5005delta amiga api apio book boot bot call compile
2547 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2548 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2549 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2550 modinstall modlib number obj op opentut os2 os390 pod port
2551 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2552 trap unicode var vms win32 xs xstut
2553 })
2554 {
2555 $page =~ s/^/perl/;
2556 system($doccmd,
2557 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2558 $page);
2559 }
2560 }
2561 }
2562 if (defined $oldpath) {
2563 $ENV{MANPATH} = $manpath;
2564 } else {
2565 delete $ENV{MANPATH};
2566 }
2567}
2568
d338d6fe
PP
2569# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2570
2571BEGIN { # This does not compile, alas.
2572 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2573 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2574 $sh = '!';
2575 $rc = ',';
2576 @hist = ('?');
2577 $deep = 100; # warning if stack gets this deep
2578 $window = 10;
2579 $preview = 3;
2580 $sub = '';
77fb7b16 2581 $SIG{INT} = \&DB::catch;
ee971a18
PP
2582 # This may be enabled to debug debugger:
2583 #$warnLevel = 1 unless defined $warnLevel;
2584 #$dieLevel = 1 unless defined $dieLevel;
2585 #$signalLevel = 1 unless defined $signalLevel;
d338d6fe
PP
2586
2587 $db_stop = 0; # Compiler warning
2588 $db_stop = 1 << 30;
2589 $level = 0; # Level of recursive debugging
55497cff
PP
2590 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2591 # Triggers bug (?) in perl is we postpone this until runtime:
2592 @postponed = @stack = (0);
f8b5b99c 2593 $stack_depth = 0; # Localized $#stack
55497cff
PP
2594 $doret = -2;
2595 $frame = 0;
d338d6fe
PP
2596}
2597
54d04a52
IZ
2598BEGIN {$^W = $ini_warn;} # Switch warnings back
2599
d338d6fe
PP
2600#use Carp; # This did break, left for debuggin
2601
55497cff 2602sub db_complete {
08a4aec0 2603 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
55497cff 2604 my($text, $line, $start) = @_;
477ea2b1 2605 my ($itext, $search, $prefix, $pack) =
055fd3a9 2606 ($text, "^\Q${'package'}::\E([^:]+)\$");
55497cff 2607
08a4aec0
IZ
2608 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2609 (map { /$search/ ? ($1) : () } keys %sub)
2610 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2611 return sort grep /^\Q$text/, values %INC # files
477ea2b1 2612 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
08a4aec0
IZ
2613 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2614 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2615 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2616 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2617 grep !/^main::/,
2618 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2619 # packages
2620 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2621 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
477ea2b1
IZ
2622 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2623 # We may want to complete to (eval 9), so $text may be wrong
2624 $prefix = length($1) - length($text);
2625 $text = $1;
08a4aec0
IZ
2626 return sort
2627 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
477ea2b1 2628 }
55497cff
PP
2629 if ((substr $text, 0, 1) eq '&') { # subroutines
2630 $text = substr $text, 1;
2631 $prefix = "&";
08a4aec0
IZ
2632 return sort map "$prefix$_",
2633 grep /^\Q$text/,
2634 (keys %sub),
2635 (map { /$search/ ? ($1) : () }
2636 keys %sub);
55497cff
PP
2637 }
2638 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2639 $pack = ($1 eq 'main' ? '' : $1) . '::';
2640 $prefix = (substr $text, 0, 1) . $1 . '::';
2641 $text = $2;
2642 my @out
2643 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2644 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2645 return db_complete($out[0], $line, $start);
2646 }
08a4aec0 2647 return sort @out;
55497cff
PP
2648 }
2649 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2650 $pack = ($package eq 'main' ? '' : $package) . '::';
2651 $prefix = substr $text, 0, 1;
2652 $text = substr $text, 1;
2653 my @out = map "$prefix$_", grep /^\Q$text/,
2654 (grep /^_?[a-zA-Z]/, keys %$pack),
2655 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2656 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2657 return db_complete($out[0], $line, $start);
2658 }
08a4aec0 2659 return sort @out;
55497cff 2660 }
477ea2b1 2661 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
55497cff
PP
2662 my @out = grep /^\Q$text/, @options;
2663 my $val = option_val($out[0], undef);
2664 my $out = '? ';
2665 if (not defined $val or $val =~ /[\n\r]/) {
2666 # Can do nothing better
2667 } elsif ($val =~ /\s/) {
2668 my $found;
2669 foreach $l (split //, qq/\"\'\#\|/) {
2670 $out = "$l$val$l ", last if (index $val, $l) == -1;
2671 }
2672 } else {
2673 $out = "=$val ";
2674 }
2675 # Default to value if one completion, to question if many
a737e074 2676 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
08a4aec0 2677 return sort @out;
55497cff 2678 }
a737e074 2679 return $term->filename_list($text); # filenames
55497cff
PP
2680}
2681
43aed9ee
IZ
2682sub end_report {
2683 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2684}
4639966b 2685
55497cff
PP
2686END {
2687 $finished = $inhibit_exit; # So that some keys may be disabled.
36477c24
PP
2688 # Do not stop in at_exit() and destructors on exit:
2689 $DB::single = !$exiting && !$runnonstop;
2690 DB::fake::at_exit() unless $exiting or $runnonstop;
55497cff
PP
2691}
2692
2693package DB::fake;
2694
2695sub at_exit {
43aed9ee 2696 "Debugged program terminated. Use `q' to quit or `R' to restart.";
55497cff
PP
2697}
2698
36477c24
PP
2699package DB; # Do not trace this 1; below!
2700
d338d6fe 27011;