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