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