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