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