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