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