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