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