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