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