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_15 to perl5.003_16]
[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}) {
04fb8f4b 478 print $OUT "No file matching `$file' is loaded.\n";
d338d6fe 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:
04fb8f4b 1036 $exiting = 1 unless defined $cmd;
55497cff 1037 map {$evalarg = $_; &eval} @$post;
d338d6fe 1038 } # if ($single || $signal)
1039 ($@, $!, $,, $/, $\, $^W) = @saved;
1040 ();
1041}
1042
1043# The following code may be executed now:
1044# BEGIN {warn 4}
1045
1046sub sub {
ee971a18 1047 my ($al, $ret, @ret) = "";
1048 if ($sub =~ /::AUTOLOAD$/) {
1049 $al = " for $ {$` . '::AUTOLOAD'}";
1050 }
d338d6fe 1051 push(@stack, $single);
1052 $single &= 1;
1053 $single |= 4 if $#stack == $deep;
04fb8f4b 1054 ($frame & 4
1055 ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
1056 # Why -1? But it works! :-(
1057 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1058 : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
d338d6fe 1059 if (wantarray) {
1060 @ret = &$sub;
1061 $single |= pop(@stack);
ee971a18 1062 print ($OUT "list context return from $sub:\n"), dumpit( \@ret ),
1063 $doret = -2 if $doret eq $#stack;
36477c24 1064 ($frame & 4
1065 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1066 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1067 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
d338d6fe 1068 @ret;
1069 } else {
1070 $ret = &$sub;
1071 $single |= pop(@stack);
ee971a18 1072 print ($OUT "scalar context return from $sub: "), dumpit( $ret ),
1073 $doret = -2 if $doret eq $#stack;
36477c24 1074 ($frame & 4
1075 ? ( (print $LINEINFO ' ' x $#stack, "out "),
1076 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
1077 : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
d338d6fe 1078 $ret;
1079 }
1080}
1081
1082sub save {
1083 @saved = ($@, $!, $,, $/, $\, $^W);
1084 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1085}
1086
1087# The following takes its argument via $evalarg to preserve current @_
1088
1089sub eval {
1090 my @res;
1091 {
1092 local (@stack) = @stack; # guard against recursive debugging
1093 my $otrace = $trace;
1094 my $osingle = $single;
1095 my $od = $^D;
1096 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1097 $trace = $otrace;
1098 $single = $osingle;
1099 $^D = $od;
1100 }
1101 my $at = $@;
36477c24 1102 local $saved[0]; # Preserve the old value of $@
d338d6fe 1103 eval "&DB::save";
1104 if ($at) {
1105 print $OUT $at;
1106 } elsif ($onetimeDump) {
1107 dumpit(\@res);
1108 }
1109}
1110
55497cff 1111sub postponed_sub {
1112 my $subname = shift;
1113 if ($postponed{$subname} =~ s/break\s([+-]?\d+)\s+if\s//) {
1114 my $offset = $1 || 0;
1115 # Filename below can contain ':'
1116 my ($file,$i) = ($sub{$subname} =~ /^(.*):(\d+)-.*$/);
1117 $i += $offset;
1118 if ($i) {
1119 local *dbline = "::_<$file";
1120 local $^W = 0; # != 0 is magical below
1121 $had_breakpoints{$file}++;
1122 my $max = $#dbline;
1123 ++$i until $dbline[$i] != 0 or $i >= $max;
1124 $dbline{$i} = delete $postponed{$subname};
1125 } else {
1126 print $OUT "Subroutine $subname not found.\n";
1127 }
1128 return;
1129 }
36477c24 1130 #print $OUT "In postponed_sub for `$subname'.\n";
55497cff 1131}
1132
1133sub postponed {
1134 return &postponed_sub
1135 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1136 # Cannot be done before the file is compiled
1137 local *dbline = shift;
1138 my $filename = $dbline;
1139 $filename =~ s/^_<//;
36477c24 1140 $signal = 1, print $OUT "'$filename' loaded...\n"
1141 if $break_on_load{$filename};
1142 print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
55497cff 1143 return unless %{$postponed_file{$filename}};
1144 $had_breakpoints{$filename}++;
1145 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1146 my $key;
1147 for $key (keys %{$postponed_file{$filename}}) {
1148 $dbline{$key} = $ {$postponed_file{$filename}}{$key};
54d04a52 1149 }
55497cff 1150 undef %{$postponed_file{$filename}};
54d04a52 1151}
1152
d338d6fe 1153sub dumpit {
1154 local ($savout) = select($OUT);
ee971a18 1155 my $osingle = $single;
1156 my $otrace = $trace;
1157 $single = $trace = 0;
1158 local $frame = 0;
1159 local $doret = -2;
1160 unless (defined &main::dumpValue) {
1161 do 'dumpvar.pl';
1162 }
d338d6fe 1163 if (defined &main::dumpValue) {
1164 &main::dumpValue(shift);
1165 } else {
1166 print $OUT "dumpvar.pl not available.\n";
1167 }
ee971a18 1168 $single = $osingle;
1169 $trace = $otrace;
d338d6fe 1170 select ($savout);
1171}
1172
36477c24 1173# Tied method do not create a context, so may get wrong message:
1174
55497cff 1175sub print_trace {
1176 my $fh = shift;
36477c24 1177 my @sub = dump_trace($_[0] + 1, $_[1]);
1178 my $short = $_[2]; # Print short report, next one for sub name
55497cff 1179 for ($i=0; $i <= $#sub; $i++) {
1180 last if $signal;
1181 local $" = ', ';
1182 my $args = defined $sub[$i]{args}
1183 ? "(@{ $sub[$i]{args} })"
1184 : '' ;
36477c24 1185 my $file = $sub[$i]{file};
1186 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1187 if ($short) {
1188 my $sub = @_ >= 4 ? $_[3] : $sub[$i]{sub};
1189 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1190 } else {
1191 print $fh "$sub[$i]{context} = $sub[$i]{sub}$args" .
1192 " called from $file" .
1193 " line $sub[$i]{line}\n";
1194 }
55497cff 1195 }
1196}
1197
1198sub dump_trace {
1199 my $skip = shift;
36477c24 1200 my $count = shift || 1e9;
1201 $skip++;
1202 $count += $skip;
55497cff 1203 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
04fb8f4b 1204 my $nothard = not $frame & 8;
1205 local $frame = 0; # Do not want to trace this.
1206 my $otrace = $trace;
1207 $trace = 0;
55497cff 1208 for ($i = $skip;
36477c24 1209 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
55497cff 1210 $i++) {
1211 @a = ();
1212 for $arg (@args) {
04fb8f4b 1213 my $type;
1214 if (not defined $arg) {
1215 push @a, "undef";
1216 } elsif ($nothard and tied $arg) {
1217 push @a, "tied";
1218 } elsif ($nothard and $type = ref $arg) {
1219 push @a, "ref($type)";
1220 } else {
1221 local $_ = "$arg"; # Safe to stringify now - should not call f().
1222 s/([\'\\])/\\$1/g;
1223 s/(.*)/'$1'/s
1224 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1225 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1226 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1227 push(@a, $_);
1228 }
55497cff 1229 }
04fb8f4b 1230 $context = $context ? '@' : "\$";
55497cff 1231 $args = $h ? [@a] : undef;
1232 $e =~ s/\n\s*\;\s*\Z// if $e;
1233 $e =~ s/[\\\']/\\$1/g if $e;
1234 if ($r) {
1235 $sub = "require '$e'";
1236 } elsif (defined $r) {
1237 $sub = "eval '$e'";
1238 } elsif ($sub eq '(eval)') {
1239 $sub = "eval {...}";
1240 }
1241 push(@sub, {context => $context, sub => $sub, args => $args,
1242 file => $file, line => $line});
1243 last if $signal;
1244 }
04fb8f4b 1245 $trace = $otrace;
55497cff 1246 @sub;
1247}
1248
d338d6fe 1249sub action {
1250 my $action = shift;
1251 while ($action =~ s/\\$//) {
1252 #print $OUT "+ ";
1253 #$action .= "\n";
1254 $action .= &gets;
1255 }
1256 $action;
1257}
1258
1259sub gets {
1260 local($.);
1261 #<IN>;
1262 &readline("cont: ");
1263}
1264
1265sub system {
1266 # We save, change, then restore STDIN and STDOUT to avoid fork() since
1267 # many non-Unix systems can do system() but have problems with fork().
1268 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
1269 open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
1270 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1271 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1272 system(@_);
1273 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1274 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
1275 close(SAVEIN); close(SAVEOUT);
1276 &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
1277 ( $? & 128 ) ? " (core dumped)" : "",
1278 ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
1279 $?;
1280}
1281
1282sub setterm {
54d04a52 1283 local $frame = 0;
ee971a18 1284 local $doret = -2;
1285 local @stack = @stack; # Prevent growth by failing `use'.
1286 eval { require Term::ReadLine } or die $@;
d338d6fe 1287 if ($notty) {
1288 if ($tty) {
1289 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
1290 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
1291 $IN = \*IN;
1292 $OUT = \*OUT;
1293 my $sel = select($OUT);
1294 $| = 1;
1295 select($sel);
1296 } else {
1297 eval "require Term::Rendezvous;" or die $@;
1298 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1299 my $term_rv = new Term::Rendezvous $rv;
1300 $IN = $term_rv->IN;
1301 $OUT = $term_rv->OUT;
1302 }
1303 }
1304 if (!$rl) {
1305 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1306 } else {
1307 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1308
1309 $readline::rl_basic_word_break_characters .= "[:"
1310 if defined $readline::rl_basic_word_break_characters
1311 and index($readline::rl_basic_word_break_characters, ":") == -1;
55497cff 1312 $readline::rl_special_prefixes =
1313 $readline::rl_special_prefixes = '$@&%';
1314 $readline::rl_completer_word_break_characters =
1315 $readline::rl_completer_word_break_characters . '$@&%';
1316 $readline::rl_completion_function =
1317 $readline::rl_completion_function = \&db_complete;
d338d6fe 1318 }
1319 $LINEINFO = $OUT unless defined $LINEINFO;
1320 $lineinfo = $console unless defined $lineinfo;
1321 $term->MinLine(2);
54d04a52 1322 if ($term->Features->{setHistory} and "@hist" ne "?") {
1323 $term->SetHistory(@hist);
1324 }
d338d6fe 1325}
1326
1327sub readline {
54d04a52 1328 if (@typeahead) {
1329 my $left = @typeahead;
1330 my $got = shift @typeahead;
1331 print $OUT "auto(-$left)", shift, $got, "\n";
1332 $term->AddHistory($got)
1333 if length($got) > 1 and defined $term->Features->{addHistory};
1334 return $got;
1335 }
d338d6fe 1336 local $frame = 0;
ee971a18 1337 local $doret = -2;
d338d6fe 1338 $term->readline(@_);
1339}
1340
1341sub dump_option {
1342 my ($opt, $val)= @_;
55497cff 1343 $val = option_val($opt,'N/A');
1344 $val =~ s/([\\\'])/\\$1/g;
1345 printf $OUT "%20s = '%s'\n", $opt, $val;
1346}
1347
1348sub option_val {
1349 my ($opt, $default)= @_;
1350 my $val;
d338d6fe 1351 if (defined $optionVars{$opt}
1352 and defined $ {$optionVars{$opt}}) {
1353 $val = $ {$optionVars{$opt}};
1354 } elsif (defined $optionAction{$opt}
1355 and defined &{$optionAction{$opt}}) {
1356 $val = &{$optionAction{$opt}}();
1357 } elsif (defined $optionAction{$opt}
1358 and not defined $option{$opt}
1359 or defined $optionVars{$opt}
1360 and not defined $ {$optionVars{$opt}}) {
55497cff 1361 $val = $default;
d338d6fe 1362 } else {
1363 $val = $option{$opt};
1364 }
55497cff 1365 $val
d338d6fe 1366}
1367
1368sub parse_options {
1369 local($_)= @_;
1370 while ($_ ne "") {
1371 s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
1372 my ($opt,$sep) = ($1,$2);
1373 my $val;
1374 if ("?" eq $sep) {
1375 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
1376 if /^\S/;
1377 #&dump_option($opt);
1378 } elsif ($sep !~ /\S/) {
1379 $val = "1";
1380 } elsif ($sep eq "=") {
1381 s/^(\S*)($|\s+)//;
1382 $val = $1;
1383 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
1384 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
1385 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
1386 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
1387 $val = $1;
1388 $val =~ s/\\([\\$end])/$1/g;
1389 }
1390 my ($option);
1391 my $matches =
1392 grep( /^\Q$opt/ && ($option = $_), @options );
1393 $matches = grep( /^\Q$opt/i && ($option = $_), @options )
1394 unless $matches;
1395 print $OUT "Unknown option `$opt'\n" unless $matches;
1396 print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
1397 $option{$option} = $val if $matches == 1 and defined $val;
ee971a18 1398 eval "local \$frame = 0; local \$doret = -2;
1399 require '$optionRequire{$option}'"
d338d6fe 1400 if $matches == 1 and defined $optionRequire{$option} and defined $val;
1401 $ {$optionVars{$option}} = $val
1402 if $matches == 1
1403 and defined $optionVars{$option} and defined $val;
1404 & {$optionAction{$option}} ($val)
1405 if $matches == 1
1406 and defined $optionAction{$option}
1407 and defined &{$optionAction{$option}} and defined $val;
1408 &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
1409 s/^\s+//;
1410 }
1411}
1412
54d04a52 1413sub set_list {
1414 my ($stem,@list) = @_;
1415 my $val;
1416 $ENV{"$ {stem}_n"} = @list;
1417 for $i (0 .. $#list) {
1418 $val = $list[$i];
1419 $val =~ s/\\/\\\\/g;
ee971a18 1420 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
54d04a52 1421 $ENV{"$ {stem}_$i"} = $val;
1422 }
1423}
1424
1425sub get_list {
1426 my $stem = shift;
1427 my @list;
1428 my $n = delete $ENV{"$ {stem}_n"};
1429 my $val;
1430 for $i (0 .. $n - 1) {
1431 $val = delete $ENV{"$ {stem}_$i"};
1432 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
1433 push @list, $val;
1434 }
1435 @list;
1436}
1437
d338d6fe 1438sub catch {
1439 $signal = 1;
4639966b 1440 return; # Put nothing on the stack - malloc/free land!
d338d6fe 1441}
1442
1443sub warn {
1444 my($msg)= join("",@_);
1445 $msg .= ": $!\n" unless $msg =~ /\n$/;
1446 print $OUT $msg;
1447}
1448
1449sub TTY {
1450 if ($term) {
1451 &warn("Too late to set TTY!\n") if @_;
1452 } else {
1453 $tty = shift if @_;
1454 }
1455 $tty or $console;
1456}
1457
1458sub noTTY {
1459 if ($term) {
1460 &warn("Too late to set noTTY!\n") if @_;
1461 } else {
1462 $notty = shift if @_;
1463 }
1464 $notty;
1465}
1466
1467sub ReadLine {
1468 if ($term) {
1469 &warn("Too late to set ReadLine!\n") if @_;
1470 } else {
1471 $rl = shift if @_;
1472 }
1473 $rl;
1474}
1475
1476sub NonStop {
1477 if ($term) {
1478 &warn("Too late to set up NonStop mode!\n") if @_;
1479 } else {
1480 $runnonstop = shift if @_;
1481 }
1482 $runnonstop;
1483}
1484
1485sub pager {
1486 if (@_) {
1487 $pager = shift;
1488 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
1489 }
1490 $pager;
1491}
1492
1493sub shellBang {
1494 if (@_) {
1495 $sh = quotemeta shift;
1496 $sh .= "\\b" if $sh =~ /\w$/;
1497 }
1498 $psh = $sh;
1499 $psh =~ s/\\b$//;
1500 $psh =~ s/\\(.)/$1/g;
1501 &sethelp;
1502 $psh;
1503}
1504
1505sub recallCommand {
1506 if (@_) {
1507 $rc = quotemeta shift;
1508 $rc .= "\\b" if $rc =~ /\w$/;
1509 }
1510 $prc = $rc;
1511 $prc =~ s/\\b$//;
1512 $prc =~ s/\\(.)/$1/g;
1513 &sethelp;
1514 $prc;
1515}
1516
1517sub LineInfo {
1518 return $lineinfo unless @_;
1519 $lineinfo = shift;
1520 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
1521 $emacs = ($stream =~ /^\|/);
1522 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
1523 $LINEINFO = \*LINEINFO;
1524 my $save = select($LINEINFO);
1525 $| = 1;
1526 select($save);
1527 $lineinfo;
1528}
1529
ee971a18 1530sub list_versions {
1531 my %version;
1532 my $file;
1533 for (keys %INC) {
1534 $file = $_;
1535 s,\.p[lm]$,,i ;
1536 s,/,::,g ;
1537 s/^perl5db$/DB/;
55497cff 1538 s/^Term::ReadLine::readline$/readline/;
ee971a18 1539 if (defined $ { $_ . '::VERSION' }) {
1540 $version{$file} = "$ { $_ . '::VERSION' } from ";
1541 }
1542 $version{$file} .= $INC{$file};
1543 }
1544 do 'dumpvar.pl' unless defined &main::dumpValue;
1545 if (defined &main::dumpValue) {
1546 local $frame = 0;
1547 &main::dumpValue(\%version);
1548 } else {
1549 print $OUT "dumpvar.pl not available.\n";
1550 }
1551}
1552
d338d6fe 1553sub sethelp {
1554 $help = "
1555T Stack trace.
1556s [expr] Single step [in expr].
1557n [expr] Next, steps over subroutine calls [in expr].
1558<CR> Repeat last n or s command.
1559r Return from current subroutine.
55497cff 1560c [line|sub] Continue; optionally inserts a one-time-only breakpoint
1561 at the specified position.
d338d6fe 1562l min+incr List incr+1 lines starting at min.
1563l min-max List lines min through max.
1564l line List single line.
1565l subname List first window of lines from subroutine.
1566l List next window of lines.
1567- List previous window of lines.
1568w [line] List window around line.
54d04a52 1569. Return to the executed line.
04fb8f4b 1570f filename Switch to viewing filename. Must be loaded.
d338d6fe 1571/pattern/ Search forwards for pattern; final / is optional.
1572?pattern? Search backwards for pattern; final ? is optional.
36477c24 1573L List all breakpoints and actions.
d338d6fe 1574S [[!]pattern] List subroutine names [not] matching pattern.
1575t Toggle trace mode.
1576t expr Trace through execution of expr.
1577b [line] [condition]
1578 Set breakpoint; line defaults to the current execution line;
1579 condition breaks if it evaluates to true, defaults to '1'.
1580b subname [condition]
1581 Set breakpoint at first line of subroutine.
55497cff 1582b load filename Set breakpoint on `require'ing the given file.
1583b postpone subname [condition]
1584 Set breakpoint at first line of subroutine after
1585 it is compiled.
d338d6fe 1586d [line] Delete the breakpoint for line.
1587D Delete all breakpoints.
1588a [line] command
1589 Set an action to be done before the line is executed.
1590 Sequence is: check for breakpoint, print line if necessary,
1591 do action, prompt user if breakpoint or step, evaluate line.
1592A Delete all actions.
1593V [pkg [vars]] List some (default all) variables in package (default current).
1594 Use ~pattern and !pattern for positive and negative regexps.
1595X [vars] Same as \"V currentpackage [vars]\".
1596x expr Evals expression in array context, dumps the result.
1597O [opt[=val]] [opt\"val\"] [opt?]...
1598 Set or query values of options. val defaults to 1. opt can
1599 be abbreviated. Several options can be listed.
1600 recallCommand, ShellBang: chars used to recall command or spawn shell;
1601 pager: program for output of \"|cmd\";
36477c24 1602 tkRunning: run Tk while prompting (with ReadLine);
1603 signalLevel warnLevel dieLevel: level of verbosity;
1604 inhibit_exit Allows stepping off the end of the script.
d338d6fe 1605 The following options affect what happens with V, X, and x commands:
1606 arrayDepth, hashDepth: print only first N elements ('' for all);
1607 compactDump, veryCompact: change style of array and hash dump;
1608 globPrint: whether to print contents of globs;
1609 DumpDBFiles: dump arrays holding debugged files;
1610 DumpPackages: dump symbol tables of packages;
1611 quote, HighBit, undefPrint: change style of string dump;
d338d6fe 1612 Option PrintRet affects printing of return value after r command,
1613 frame affects printing messages on entry and exit from subroutines.
36477c24 1614 AutoTrace affects printing messages on every possible breaking point.
d338d6fe 1615 During startup options are initialized from \$ENV{PERLDB_OPTS}.
1616 You can put additional initialization options TTY, noTTY,
1617 ReadLine, and NonStop there.
55497cff 1618< command Define Perl command to run before each prompt.
1619<< command Add to the list of Perl commands to run before each prompt.
1620> command Define Perl command to run after each prompt.
1621>> command Add to the list of Perl commands to run after each prompt.
1622\{ commandline Define debugger command to run before each prompt.
1623\{{ commandline Add to the list of debugger commands to run before each prompt.
d338d6fe 1624$prc number Redo a previous command (default previous command).
1625$prc -number Redo number'th-to-last command.
1626$prc pattern Redo last command that started with pattern.
1627 See 'O recallCommand' too.
1628$psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
1629 . ( $rc eq $sh ? "" : "
1630$psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
1631 See 'O shellBang' too.
1632H -number Display last number commands (default all).
b9b857e2 1633p expr Same as \"print {DB::OUT} expr\" in current package.
d338d6fe 1634|dbcmd Run debugger command, piping DB::OUT to current pager.
1635||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
1636\= [alias value] Define a command alias, or list current aliases.
1637command Execute as a perl statement in current package.
ee971a18 1638v Show versions of loaded modules.
55497cff 1639R Pure-man-restart of debugger, some of debugger state
1640 and command-line options may be lost.
36477c24 1641 Currently the following setting are preserved:
1642 history, breakpoints and actions, debugger Options
1643 and the following command-line options: -w, -I, -e.
d338d6fe 1644h [db_command] Get help [on a specific debugger command], enter |h to page.
1645h h Summary of debugger commands.
4639966b 1646q or ^D Quit. Set \$DB::finished to 0 to debug global destruction.
d338d6fe 1647
1648";
1649 $summary = <<"END_SUM";
1650List/search source lines: Control script execution:
1651 l [ln|sub] List source code T Stack trace
54d04a52 1652 - or . List previous/current line s [expr] Single step [in expr]
d338d6fe 1653 w [line] List around line n [expr] Next, steps over subs
1654 f filename View source in file <CR> Repeat last n or s
ee971a18 1655 /pattern/ ?patt? Search forw/backw r Return from subroutine
55497cff 1656 v Show versions of modules c [ln|sub] Continue until position
d338d6fe 1657Debugger controls: L List break pts & actions
1658 O [...] Set debugger options t [expr] Toggle trace [trace expr]
55497cff 1659 <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
1660 >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
d338d6fe 1661 $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
1662 H [-num] Display last num commands D Delete all breakpoints
1663 = [a val] Define/list an alias a [ln] cmd Do cmd before line
1664 h [db_cmd] Get help on command A Delete all actions
1665 |[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
54d04a52 1666 q or ^D Quit R Attempt a restart
d338d6fe 1667Data Examination: expr Execute perl code, also see: s,n,t expr
55497cff 1668 x expr Evals expression in array context, dumps the result.
1669 p expr Print expression (uses script's current package).
d338d6fe 1670 S [[!]pat] List subroutine names [not] matching pattern
1671 V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
1672 X [Vars] Same as \"V current_package [Vars]\".
d338d6fe 1673END_SUM
55497cff 1674 # ')}}; # Fix balance of Emacs parsing
d338d6fe 1675}
1676
d338d6fe 1677sub diesignal {
54d04a52 1678 local $frame = 0;
ee971a18 1679 local $doret = -2;
77fb7b16 1680 $SIG{'ABRT'} = 'DEFAULT';
d338d6fe 1681 kill 'ABRT', $$ if $panic++;
1682 print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue
1683 local $SIG{__WARN__} = '';
1684 require Carp;
1685 local $Carp::CarpLevel = 2; # mydie + confess
1686 &warn(Carp::longmess("Signal @_"));
1687 kill 'ABRT', $$;
1688}
1689
1690sub dbwarn {
54d04a52 1691 local $frame = 0;
ee971a18 1692 local $doret = -2;
d338d6fe 1693 local $SIG{__WARN__} = '';
77fb7b16 1694 local $SIG{__DIE__} = '';
1695 eval { require Carp }; # If error/warning during compilation,
1696 # require may be broken.
1697 warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
1698 unless defined &Carp::longmess;
d338d6fe 1699 #&warn("Entering dbwarn\n");
1700 my ($mysingle,$mytrace) = ($single,$trace);
1701 $single = 0; $trace = 0;
1702 my $mess = Carp::longmess(@_);
1703 ($single,$trace) = ($mysingle,$mytrace);
1704 #&warn("Warning in dbwarn\n");
1705 &warn($mess);
1706 #&warn("Exiting dbwarn\n");
1707}
1708
1709sub dbdie {
54d04a52 1710 local $frame = 0;
ee971a18 1711 local $doret = -2;
d338d6fe 1712 local $SIG{__DIE__} = '';
1713 local $SIG{__WARN__} = '';
1714 my $i = 0; my $ineval = 0; my $sub;
1715 #&warn("Entering dbdie\n");
1716 if ($dieLevel != 2) {
1717 while ((undef,undef,undef,$sub) = caller(++$i)) {
1718 $ineval = 1, last if $sub eq '(eval)';
1719 }
1720 {
1721 local $SIG{__WARN__} = \&dbwarn;
1722 &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
1723 }
1724 #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
1725 die @_ if $ineval and $dieLevel < 2;
1726 }
77fb7b16 1727 eval { require Carp }; # If error/warning during compilation,
1728 # require may be broken.
1729 die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
d338d6fe 1730 # We do not want to debug this chunk (automatic disabling works
1731 # inside DB::DB, but not in Carp).
1732 my ($mysingle,$mytrace) = ($single,$trace);
1733 $single = 0; $trace = 0;
1734 my $mess = Carp::longmess(@_);
1735 ($single,$trace) = ($mysingle,$mytrace);
1736 #&warn("dieing loudly in dbdie\n");
1737 die $mess;
1738}
1739
d338d6fe 1740sub warnLevel {
1741 if (@_) {
1742 $prevwarn = $SIG{__WARN__} unless $warnLevel;
1743 $warnLevel = shift;
1744 if ($warnLevel) {
0b7ed949 1745 $SIG{__WARN__} = \&DB::dbwarn;
d338d6fe 1746 } else {
1747 $SIG{__WARN__} = $prevwarn;
1748 }
1749 }
1750 $warnLevel;
1751}
1752
1753sub dieLevel {
1754 if (@_) {
1755 $prevdie = $SIG{__DIE__} unless $dieLevel;
1756 $dieLevel = shift;
1757 if ($dieLevel) {
0b7ed949 1758 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
1759 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
d338d6fe 1760 print $OUT "Stack dump during die enabled",
1761 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
1762 print $OUT "Dump printed too.\n" if $dieLevel > 2;
1763 } else {
1764 $SIG{__DIE__} = $prevdie;
1765 print $OUT "Default die handler restored.\n";
1766 }
1767 }
1768 $dieLevel;
1769}
1770
1771sub signalLevel {
1772 if (@_) {
1773 $prevsegv = $SIG{SEGV} unless $signalLevel;
1774 $prevbus = $SIG{BUS} unless $signalLevel;
1775 $signalLevel = shift;
1776 if ($signalLevel) {
77fb7b16 1777 $SIG{SEGV} = \&DB::diesignal;
1778 $SIG{BUS} = \&DB::diesignal;
d338d6fe 1779 } else {
1780 $SIG{SEGV} = $prevsegv;
1781 $SIG{BUS} = $prevbus;
1782 }
1783 }
1784 $signalLevel;
1785}
1786
1787# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
1788
1789BEGIN { # This does not compile, alas.
1790 $IN = \*STDIN; # For bugs before DB::OUT has been opened
1791 $OUT = \*STDERR; # For errors before DB::OUT has been opened
1792 $sh = '!';
1793 $rc = ',';
1794 @hist = ('?');
1795 $deep = 100; # warning if stack gets this deep
1796 $window = 10;
1797 $preview = 3;
1798 $sub = '';
77fb7b16 1799 $SIG{INT} = \&DB::catch;
ee971a18 1800 # This may be enabled to debug debugger:
1801 #$warnLevel = 1 unless defined $warnLevel;
1802 #$dieLevel = 1 unless defined $dieLevel;
1803 #$signalLevel = 1 unless defined $signalLevel;
d338d6fe 1804
1805 $db_stop = 0; # Compiler warning
1806 $db_stop = 1 << 30;
1807 $level = 0; # Level of recursive debugging
55497cff 1808 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
1809 # Triggers bug (?) in perl is we postpone this until runtime:
1810 @postponed = @stack = (0);
1811 $doret = -2;
1812 $frame = 0;
d338d6fe 1813}
1814
54d04a52 1815BEGIN {$^W = $ini_warn;} # Switch warnings back
1816
d338d6fe 1817#use Carp; # This did break, left for debuggin
1818
55497cff 1819sub db_complete {
1820 my($text, $line, $start) = @_;
1821 my ($itext, $prefix, $pack) = $text;
1822
1823 if ((substr $text, 0, 1) eq '&') { # subroutines
1824 $text = substr $text, 1;
1825 $prefix = "&";
1826 return map "$prefix$_", grep /^\Q$text/, keys %sub;
1827 }
1828 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
1829 $pack = ($1 eq 'main' ? '' : $1) . '::';
1830 $prefix = (substr $text, 0, 1) . $1 . '::';
1831 $text = $2;
1832 my @out
1833 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
1834 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1835 return db_complete($out[0], $line, $start);
1836 }
1837 return @out;
1838 }
1839 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
1840 $pack = ($package eq 'main' ? '' : $package) . '::';
1841 $prefix = substr $text, 0, 1;
1842 $text = substr $text, 1;
1843 my @out = map "$prefix$_", grep /^\Q$text/,
1844 (grep /^_?[a-zA-Z]/, keys %$pack),
1845 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
1846 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
1847 return db_complete($out[0], $line, $start);
1848 }
1849 return @out;
1850 }
1851 return grep /^\Q$text/, (keys %sub), qw(postpone load) # subroutines
1852 if (substr $line, 0, $start) =~ /^[bl]\s+(postpone\s+)?$/;
1853 return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages
1854 if (substr $line, 0, $start) =~ /^V\s+$/;
1855 if ((substr $line, 0, $start) =~ /^O\b.*\s$/) { # Options after a space
1856 my @out = grep /^\Q$text/, @options;
1857 my $val = option_val($out[0], undef);
1858 my $out = '? ';
1859 if (not defined $val or $val =~ /[\n\r]/) {
1860 # Can do nothing better
1861 } elsif ($val =~ /\s/) {
1862 my $found;
1863 foreach $l (split //, qq/\"\'\#\|/) {
1864 $out = "$l$val$l ", last if (index $val, $l) == -1;
1865 }
1866 } else {
1867 $out = "=$val ";
1868 }
1869 # Default to value if one completion, to question if many
1870 $readline::rl_completer_terminator_character
1871 = $readline::rl_completer_terminator_character
1872 = (@out == 1 ? $out : '? ');
1873 return @out;
1874 }
1875 return &readline::rl_filename_list($text); # filenames
1876}
1877
4639966b 1878sub end_report { print $OUT "Use `q' to quit and `R' to restart. `h q' for details.\n" }
1879
55497cff 1880END {
1881 $finished = $inhibit_exit; # So that some keys may be disabled.
36477c24 1882 # Do not stop in at_exit() and destructors on exit:
1883 $DB::single = !$exiting && !$runnonstop;
1884 DB::fake::at_exit() unless $exiting or $runnonstop;
55497cff 1885}
1886
1887package DB::fake;
1888
1889sub at_exit {
1890 "Debuggee terminated. Use `q' to quit and `R' to restart.";
1891}
1892
36477c24 1893package DB; # Do not trace this 1; below!
1894
d338d6fe 18951;
Unnamed repository; edit this file to name it for gitweb.