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