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