projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Use the new use vars feature.
[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
055fd3a9 5$VERSION = 1.07;
43aed9ee 6$header = "perl5db.pl version $VERSION";
d338d6fe 7
d338d6fe 8#
9# This file is automatically included if you do perl -d.
10# It's probably not useful to include this yourself.
11#
36477c24 12# Perl supplies the values for %sub. It effectively inserts
13# a &DB'DB(); in front of every place that can have a
d338d6fe 14# breakpoint. Instead of a subroutine call it calls &DB::sub with
15# $DB::sub being the called subroutine. It also inserts a BEGIN
16# {require 'perl5db.pl'} before the first line.
17#
55497cff 18# After each `require'd file is compiled, but before it is executed, a
477ea2b1 19# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
55497cff 20# $filename is the expanded name of the `require'd file (as found as
21# value of %INC).
22#
23# Additional services from Perl interpreter:
24#
25# if caller() is called from the package DB, it provides some
26# additional data.
27#
f5d3a858 28# The array @{$main::{'_<'.$filename}} is the line-by-line contents of
55497cff 29# $filename.
30#
477ea2b1 31# The hash %{'_<'.$filename} contains breakpoints and action (it is
55497cff 32# keyed by line number), and individual entries are settable (as
33# opposed to the whole hash). Only true/false is important to the
34# interpreter, though the values used by perl5db.pl have the form
35# "$break_condition\0$action". Values are magical in numeric context.
36#
51ee6500 37# The scalar ${'_<'.$filename} contains $filename.
55497cff 38#
d338d6fe 39# Note that no subroutine call is possible until &DB::sub is defined
36477c24 40# (for subroutines defined outside of the package DB). In fact the same is
d338d6fe 41# true if $deep is not defined.
42#
43# $Log: perldb.pl,v $
44
45#
46# At start reads $rcfile that may set important options. This file
47# may define a subroutine &afterinit that will be executed after the
48# debugger is initialized.
49#
50# After $rcfile is read reads environment variable PERLDB_OPTS and parses
51# it as a rest of `O ...' line in debugger prompt.
52#
53# The options that can be specified only at startup:
54# [To set in $rcfile, call &parse_options("optionName=new_value").]
55#
56# TTY - the TTY to use for debugging i/o.
57#
58# noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
59# uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
60# Term::Rendezvous. Current variant is to have the name of TTY in this
61# file.
62#
63# ReadLine - If false, dummy ReadLine is used, so you can debug
64# ReadLine applications.
65#
66# NonStop - if true, no i/o is performed until interrupt.
67#
68# LineInfo - file or pipe to print line number info to. If it is a
69# pipe, a short "emacs like" message is used.
70#
363b4d59 71# RemotePort - host:port to connect to on remote host for remote debugging.
72#
d338d6fe 73# Example $rcfile: (delete leading hashes!)
74#
75# &parse_options("NonStop=1 LineInfo=db.out");
76# sub afterinit { $trace = 1; }
77#
78# The script will run without human intervention, putting trace
79# information into db.out. (If you interrupt it, you would better
80# reset LineInfo to something "interactive"!)
81#
ee971a18 82##################################################################
055fd3a9 83
84# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
85# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
86
87# modified Perl debugger, to be run from Emacs in perldb-mode
88# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
89# Johan Vromans -- upgrade to 4.0 pl 10
90# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
91
ee971a18 92# Changelog:
93
94# A lot of things changed after 0.94. First of all, core now informs
95# debugger about entry into XSUBs, overloaded operators, tied operations,
96# BEGIN and END. Handy with `O f=2'.
97
98# This can make debugger a little bit too verbose, please be patient
99# and report your problems promptly.
100
101# Now the option frame has 3 values: 0,1,2.
102
103# Note that if DESTROY returns a reference to the object (or object),
104# the deletion of data may be postponed until the next function call,
105# due to the need to examine the return value.
106
55497cff 107# Changes: 0.95: `v' command shows versions.
108# Changes: 0.96: `v' command shows version of readline.
109# primitive completion works (dynamic variables, subs for `b' and `l',
110# options). Can `p %var'
111# Better help (`h <' now works). New commands <<, >>, {, {{.
112# {dump|print}_trace() coded (to be able to do it from <<cmd).
113# `c sub' documented.
114# At last enough magic combined to stop after the end of debuggee.
115# !! should work now (thanks to Emacs bracket matching an extra
116# `]' in a regexp is caught).
117# `L', `D' and `A' span files now (as documented).
118# Breakpoints in `require'd code are possible (used in `R').
119# Some additional words on internal work of debugger.
120# `b load filename' implemented.
121# `b postpone subr' implemented.
122# now only `q' exits debugger (overwriteable on $inhibit_exit).
123# When restarting debugger breakpoints/actions persist.
124# Buglet: When restarting debugger only one breakpoint/action per
125# autoloaded function persists.
36477c24 126# Changes: 0.97: NonStop will not stop in at_exit().
127# Option AutoTrace implemented.
128# Trace printed differently if frames are printed too.
1d06cb2d 129# new `inhibitExit' option.
130# printing of a very long statement interruptible.
131# Changes: 0.98: New command `m' for printing possible methods
132# 'l -' is a synonim for `-'.
133# Cosmetic bugs in printing stack trace.
134# `frame' & 8 to print "expanded args" in stack trace.
135# Can list/break in imported subs.
136# new `maxTraceLen' option.
137# frame & 4 and frame & 8 granted.
138# new command `m'
139# nonstoppable lines do not have `:' near the line number.
140# `b compile subname' implemented.
141# Will not use $` any more.
142# `-' behaves sane now.
477ea2b1 143# Changes: 0.99: Completion for `f', `m'.
144# `m' will remove duplicate names instead of duplicate functions.
145# `b load' strips trailing whitespace.
146# completion ignores leading `|'; takes into account current package
147# when completing a subroutine name (same for `l').
055fd3a9 148# Changes: 1.07: Many fixed by tchrist 13-March-2000
149# BUG FIXES:
150# + Added bare mimimal security checks on perldb rc files, plus
151# comments on what else is needed.
152# + Fixed the ornaments that made "|h" completely unusable.
153# They are not used in print_help if they will hurt. Strip pod
154# if we're paging to less.
155# + Fixed mis-formatting of help messages caused by ornaments
156# to restore Larry's original formatting.
157# + Fixed many other formatting errors. The code is still suboptimal,
158# and needs a lot of work at restructuing. It's also misindented
159# in many places.
160# + Fixed bug where trying to look at an option like your pager
161# shows "1".
162# + Fixed some $? processing. Note: if you use csh or tcsh, you will
163# lose. You should consider shell escapes not using their shell,
164# or else not caring about detailed status. This should really be
165# unified into one place, too.
166# + Fixed bug where invisible trailing whitespace on commands hoses you,
167# tricking Perl into thinking you wern't calling a debugger command!
168# + Fixed bug where leading whitespace on commands hoses you. (One
169# suggests a leading semicolon or any other irrelevant non-whitespace
170# to indicate literal Perl code.)
171# + Fixed bugs that ate warnings due to wrong selected handle.
172# + Fixed a precedence bug on signal stuff.
173# + Fixed some unseemly wording.
174# + Fixed bug in help command trying to call perl method code.
175# + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
176# ENHANCEMENTS:
177# + Added some comments. This code is still nasty spaghetti.
178# + Added message if you clear your pre/post command stacks which was
179# very easy to do if you just typed a bare >, <, or {. (A command
180# without an argument should *never* be a destructive action; this
181# API is fundamentally screwed up; likewise option setting, which
182# is equally buggered.)
183# + Added command stack dump on argument of "?" for >, <, or {.
184# + Added a semi-built-in doc viewer command that calls man with the
185# proper %Config::Config path (and thus gets caching, man -k, etc),
186# or else perldoc on obstreperous platforms.
187# + Added to and rearranged the help information.
188# + Detected apparent misuse of { ... } to declare a block; this used
189# to work but now is a command, and mysteriously gave no complaint.
55497cff 190
ee971a18 191####################################################################
d338d6fe 192
54d04a52 193# Needed for the statement after exec():
d338d6fe 194
54d04a52 195BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
196local($^W) = 0; # Switch run-time warnings off during init.
d338d6fe 197warn ( # Do not ;-)
198 $dumpvar::hashDepth,
199 $dumpvar::arrayDepth,
200 $dumpvar::dumpDBFiles,
201 $dumpvar::dumpPackages,
202 $dumpvar::quoteHighBit,
203 $dumpvar::printUndef,
204 $dumpvar::globPrint,
d338d6fe 205 $dumpvar::usageOnly,
206 @ARGS,
207 $Carp::CarpLevel,
54d04a52 208 $panic,
36477c24 209 $second_time,
d338d6fe 210 ) if 0;
211
54d04a52 212# Command-line + PERLLIB:
213@ini_INC = @INC;
214
d338d6fe 215# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
216
217$trace = $signal = $single = 0; # Uninitialized warning suppression
218 # (local $^W cannot help - other packages!).
55497cff 219$inhibit_exit = $option{PrintRet} = 1;
d338d6fe 220
22fae026 221@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
d338d6fe 222 compactDump veryCompact quote HighBit undefPrint
36477c24 223 globPrint PrintRet UsageOnly frame AutoTrace
1d06cb2d 224 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
7a2e2cd6 225 recallCommand ShellBang pager tkRunning ornaments
3aefca04 226 signalLevel warnLevel dieLevel inhibit_exit
f1583d8f 227 ImmediateStop bareStringify CreateTTY
363b4d59 228 RemotePort);
d338d6fe 229
230%optionVars = (
231 hashDepth => \$dumpvar::hashDepth,
232 arrayDepth => \$dumpvar::arrayDepth,
233 DumpDBFiles => \$dumpvar::dumpDBFiles,
234 DumpPackages => \$dumpvar::dumpPackages,
22fae026 235 DumpReused => \$dumpvar::dumpReused,
d338d6fe 236 HighBit => \$dumpvar::quoteHighBit,
237 undefPrint => \$dumpvar::printUndef,
238 globPrint => \$dumpvar::globPrint,
f1583d8f 239 UsageOnly => \$dumpvar::usageOnly,
240 CreateTTY => \$CreateTTY,
ee239bfe 241 bareStringify => \$dumpvar::bareStringify,
36477c24 242 frame => \$frame,
243 AutoTrace => \$trace,
244 inhibit_exit => \$inhibit_exit,
1d06cb2d 245 maxTraceLen => \$maxtrace,
3aefca04 246 ImmediateStop => \$ImmediateStop,
363b4d59 247 RemotePort => \$remoteport,
d338d6fe 248);
249
250%optionAction = (
251 compactDump => \&dumpvar::compactDump,
252 veryCompact => \&dumpvar::veryCompact,
253 quote => \&dumpvar::quote,
254 TTY => \&TTY,
255 noTTY => \&noTTY,
256 ReadLine => \&ReadLine,
257 NonStop => \&NonStop,
258 LineInfo => \&LineInfo,
259 recallCommand => \&recallCommand,
260 ShellBang => \&shellBang,
261 pager => \&pager,
262 signalLevel => \&signalLevel,
263 warnLevel => \&warnLevel,
264 dieLevel => \&dieLevel,
a737e074 265 tkRunning => \&tkRunning,
7a2e2cd6 266 ornaments => \&ornaments,
363b4d59 267 RemotePort => \&RemotePort,
d338d6fe 268 );
269
270%optionRequire = (
271 compactDump => 'dumpvar.pl',
272 veryCompact => 'dumpvar.pl',
273 quote => 'dumpvar.pl',
274 );
275
276# These guys may be defined in $ENV{PERL5DB} :
4c82ae22 277$rl = 1 unless defined $rl;
278$warnLevel = 0 unless defined $warnLevel;
279$dieLevel = 0 unless defined $dieLevel;
280$signalLevel = 1 unless defined $signalLevel;
281$pre = [] unless defined $pre;
282$post = [] unless defined $post;
283$pretype = [] unless defined $pretype;
f1583d8f 284$CreateTTY = 3 unless defined $CreateTTY;
055fd3a9 285
d338d6fe 286warnLevel($warnLevel);
287dieLevel($dieLevel);
288signalLevel($signalLevel);
055fd3a9 289
290&pager(
291 (defined($ENV{PAGER})
65c9c81d 292 ? $ENV{PAGER}
293 : ($^O eq 'os2'
294 ? 'cmd /c more'
295 : 'more'))) unless defined $pager;
055fd3a9 296setman();
d338d6fe 297&recallCommand("!") unless defined $prc;
298&shellBang("!") unless defined $psh;
1d06cb2d 299$maxtrace = 400 unless defined $maxtrace;
f1583d8f 300$ini_pids = $ENV{PERLDB_PIDS};
301if (defined $ENV{PERLDB_PIDS}) {
302 $pids = "[$ENV{PERLDB_PIDS}]";
303 $ENV{PERLDB_PIDS} .= "->$$";
304 $term_pid = -1;
305} else {
306 $ENV{PERLDB_PIDS} = "$$";
307 $pids = '';
308 $term_pid = $$;
309}
310$pidprompt = '';
311*emacs = $slave_editor; # May be used in afterinit()...
d338d6fe 312
055fd3a9 313if (-e "/dev/tty") { # this is the wrong metric!
d338d6fe 314 $rcfile=".perldb";
315} else {
316 $rcfile="perldb.ini";
317}
318
055fd3a9 319# This isn't really safe, because there's a race
320# between checking and opening. The solution is to
321# open and fstat the handle, but then you have to read and
322# eval the contents. But then the silly thing gets
323# your lexical scope, which is unfortunately at best.
324sub safe_do {
325 my $file = shift;
326
327 # Just exactly what part of the word "CORE::" don't you understand?
328 local $SIG{__WARN__};
329 local $SIG{__DIE__};
330
331 unless (is_safe_file($file)) {
332 CORE::warn <<EO_GRIPE;
333perldb: Must not source insecure rcfile $file.
334 You or the superuser must be the owner, and it must not
335 be writable by anyone but its owner.
336EO_GRIPE
337 return;
338 }
339
340 do $file;
341 CORE::warn("perldb: couldn't parse $file: $@") if $@;
342}
343
344
345# Verifies that owner is either real user or superuser and that no
346# one but owner may write to it. This function is of limited use
347# when called on a path instead of upon a handle, because there are
348# no guarantees that filename (by dirent) whose file (by ino) is
349# eventually accessed is the same as the one tested.
350# Assumes that the file's existence is not in doubt.
351sub is_safe_file {
352 my $path = shift;
353 stat($path) || return; # mysteriously vaporized
354 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
355
356 return 0 if $uid != 0 && $uid != $<;
357 return 0 if $mode & 022;
358 return 1;
359}
360
d338d6fe 361if (-f $rcfile) {
055fd3a9 362 safe_do("./$rcfile");
363}
364elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
365 safe_do("$ENV{HOME}/$rcfile");
366}
367elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
368 safe_do("$ENV{LOGDIR}/$rcfile");
d338d6fe 369}
370
371if (defined $ENV{PERLDB_OPTS}) {
372 parse_options($ENV{PERLDB_OPTS});
373}
374
f1583d8f 375if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
376 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
377 *get_fork_TTY = \&xterm_get_fork_TTY;
378} elsif ($^O eq 'os2') {
379 *get_fork_TTY = \&os2_get_fork_TTY;
380}
381
055fd3a9 382# Here begin the unreadable code. It needs fixing.
383
54d04a52 384if (exists $ENV{PERLDB_RESTART}) {
385 delete $ENV{PERLDB_RESTART};
386 # $restart = 1;
387 @hist = get_list('PERLDB_HIST');
55497cff 388 %break_on_load = get_list("PERLDB_ON_LOAD");
389 %postponed = get_list("PERLDB_POSTPONE");
390 my @had_breakpoints= get_list("PERLDB_VISITED");
391 for (0 .. $#had_breakpoints) {
0c395bd7 392 my %pf = get_list("PERLDB_FILE_$_");
393 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
54d04a52 394 }
395 my %opt = get_list("PERLDB_OPT");
396 my ($opt,$val);
397 while (($opt,$val) = each %opt) {
398 $val =~ s/[\\\']/\\$1/g;
399 parse_options("$opt'$val'");
400 }
401 @INC = get_list("PERLDB_INC");
402 @ini_INC = @INC;
43aed9ee 403 $pretype = [get_list("PERLDB_PRETYPE")];
404 $pre = [get_list("PERLDB_PRE")];
405 $post = [get_list("PERLDB_POST")];
406 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
54d04a52 407}
408
d338d6fe 409if ($notty) {
410 $runnonstop = 1;
411} else {
055fd3a9 412 # Is Perl being run from a slave editor or graphical debugger?
413 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
414 $rl = 0, shift(@main::ARGV) if $slave_editor;
d338d6fe 415
416 #require Term::ReadLine;
417
4fabb596 418 if ($^O eq 'cygwin') {
8736538c 419 # /dev/tty is binary. use stdin for textmode
420 undef $console;
421 } elsif (-e "/dev/tty") {
d338d6fe 422 $console = "/dev/tty";
39e571d4 423 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
d338d6fe 424 $console = "con";
6d697788 425 } elsif ($^O eq 'MacOS') {
426 if ($MacPerl::Version !~ /MPW/) {
427 $console = "Dev:Console:Perl Debug"; # Separate window for application
428 } else {
429 $console = "Dev:Console";
430 }
d338d6fe 431 } else {
432 $console = "sys\$command";
433 }
434
055fd3a9 435 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
96774cc9 436 $console = undef;
437 }
438
d338d6fe 439 # Around a bug:
055fd3a9 440 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
d338d6fe 441 $console = undef;
442 }
443
4d2c4e07 444 if ($^O eq 'epoc') {
445 $console = undef;
446 }
447
d338d6fe 448 $console = $tty if defined $tty;
449
363b4d59 450 if (defined $remoteport) {
451 require IO::Socket;
452 $OUT = new IO::Socket::INET( Timeout => '10',
453 PeerAddr => $remoteport,
454 Proto => 'tcp',
455 );
0aa2ae9a 456 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
363b4d59 457 $IN = $OUT;
f1583d8f 458 } elsif ($CreateTTY & 4) {
459 create_IN_OUT(4);
460 } else {
363b4d59 461 if (defined $console) {
f1583d8f 462 my ($i, $o) = split $console, /,/;
463 $o = $i unless defined $o;
464 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
465 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
363b4d59 466 || open(OUT,">&STDOUT"); # so we don't dongle stdout
467 } else {
468 open(IN,"<&STDIN");
469 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
470 $console = 'STDIN/OUT';
471 }
472 # so open("|more") can read from STDOUT and so we don't dingle stdin
473 $IN = \*IN;
d338d6fe 474
363b4d59 475 $OUT = \*OUT;
476 }
d338d6fe 477 select($OUT);
478 $| = 1; # for DB::OUT
479 select(STDOUT);
480
481 $LINEINFO = $OUT unless defined $LINEINFO;
482 $lineinfo = $console unless defined $lineinfo;
483
484 $| = 1; # for real STDOUT
485
486 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
487 unless ($runnonstop) {
f1583d8f 488 if ($term_pid eq '-1') {
489 print $OUT "\nDaughter DB session started...\n";
490 } else {
491 print $OUT "\nLoading DB routines from $header\n";
492 print $OUT ("Editor support ",
493 $slave_editor ? "enabled" : "available",
494 ".\n");
495 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
496 }
d338d6fe 497 }
498}
499
500@ARGS = @ARGV;
501for (@args) {
502 s/\'/\\\'/g;
503 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
504}
505
506if (defined &afterinit) { # May be defined in $rcfile
507 &afterinit();
508}
509
43aed9ee 510$I_m_init = 1;
511
d338d6fe 512############################################################ Subroutines
513
d338d6fe 514sub DB {
36477c24 515 # _After_ the perl program is compiled, $single is set to 1:
516 if ($single and not $second_time++) {
517 if ($runnonstop) { # Disable until signal
f8b5b99c 518 for ($i=0; $i <= $stack_depth; ) {
d338d6fe 519 $stack[$i++] &= ~1;
520 }
54d04a52 521 $single = 0;
36477c24 522 # return; # Would not print trace!
3aefca04 523 } elsif ($ImmediateStop) {
524 $ImmediateStop = 0;
525 $signal = 1;
54d04a52 526 }
d338d6fe 527 }
36477c24 528 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
d338d6fe 529 &save;
d338d6fe 530 ($package, $filename, $line) = caller;
54d04a52 531 $filename_ini = $filename;
22fae026 532 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
d338d6fe 533 "package $package;"; # this won't let them modify, alas
8ebc5c01 534 local(*dbline) = $main::{'_<' . $filename};
d338d6fe 535 $max = $#dbline;
536 if (($stop,$action) = split(/\0/,$dbline{$line})) {
537 if ($stop eq '1') {
538 $signal |= 1;
54d04a52 539 } elsif ($stop) {
3f521411 540 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
d338d6fe 541 $dbline{$line} =~ s/;9($|\0)/$1/;
542 }
543 }
36477c24 544 my $was_signal = $signal;
6027b9a3 545 if ($trace & 2) {
546 for (my $n = 0; $n <= $#to_watch; $n++) {
547 $evalarg = $to_watch[$n];
ed0d1bf7 548 local $onetimeDump; # Do not output results
6027b9a3 549 my ($val) = &eval; # Fix context (&eval is doing array)?
550 $val = ( (defined $val) ? "'$val'" : 'undef' );
551 if ($val ne $old_watch[$n]) {
552 $signal = 1;
553 print $OUT <<EOP;
405ff068 554Watchpoint $n:\t$to_watch[$n] changed:
555 old value:\t$old_watch[$n]
556 new value:\t$val
6027b9a3 557EOP
558 $old_watch[$n] = $val;
559 }
560 }
561 }
562 if ($trace & 4) { # User-installed watch
563 return if watchfunction($package, $filename, $line)
564 and not $single and not $was_signal and not ($trace & ~4);
565 }
566 $was_signal = $signal;
36477c24 567 $signal = 0;
6027b9a3 568 if ($single || ($trace & 1) || $was_signal) {
055fd3a9 569 if ($slave_editor) {
54d04a52 570 $position = "\032\032$filename:$line:0\n";
f1583d8f 571 print_lineinfo($position);
405ff068 572 } elsif ($package eq 'DB::fake') {
65c9c81d 573 $term || &setterm;
405ff068 574 print_help(<<EOP);
575Debugged program terminated. Use B<q> to quit or B<R> to restart,
576 use B<O> I<inhibit_exit> to avoid stopping after program termination,
577 B<h q>, B<h R> or B<h O> to get additional info.
578EOP
579 $package = 'main';
363b4d59 580 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
405ff068 581 "package $package;"; # this won't let them modify, alas
d338d6fe 582 } else {
583 $sub =~ s/\'/::/;
584 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
585 $prefix .= "$sub($filename:";
586 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
587 if (length($prefix) > 30) {
54d04a52 588 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
d338d6fe 589 $prefix = "";
590 $infix = ":\t";
591 } else {
592 $infix = "):\t";
54d04a52 593 $position = "$prefix$line$infix$dbline[$line]$after";
36477c24 594 }
595 if ($frame) {
f1583d8f 596 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
36477c24 597 } else {
f1583d8f 598 print_lineinfo($position);
d338d6fe 599 }
600 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
601 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
36477c24 602 last if $signal;
d338d6fe 603 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
54d04a52 604 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
54d04a52 605 $position .= $incr_pos;
36477c24 606 if ($frame) {
f1583d8f 607 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
36477c24 608 } else {
f1583d8f 609 print_lineinfo($incr_pos);
36477c24 610 }
d338d6fe 611 }
612 }
613 }
614 $evalarg = $action, &eval if $action;
36477c24 615 if ($single || $was_signal) {
d338d6fe 616 local $level = $level + 1;
e63173ce 617 foreach $evalarg (@$pre) {
618 &eval;
619 }
f8b5b99c 620 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
d338d6fe 621 if $single & 4;
622 $start = $line;
1d06cb2d 623 $incr = -1; # for backward motion.
6657d1ba 624 @typeahead = (@$pretype, @typeahead);
d338d6fe 625 CMD:
626 while (($term || &setterm),
f1583d8f 627 ($term_pid == $$ or resetterm(1)),
628 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
54d04a52 629 ($#hist+1) . ('>' x $level) .
055fd3a9 630 " ")))
631 {
d338d6fe 632 $single = 0;
633 $signal = 0;
634 $cmd =~ s/\\$/\n/ && do {
54d04a52 635 $cmd .= &readline(" cont: ");
d338d6fe 636 redo CMD;
637 };
d338d6fe 638 $cmd =~ /^$/ && ($cmd = $laststep);
639 push(@hist,$cmd) if length($cmd) > 1;
640 PIPE: {
3dcd9d33 641 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
642 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
d338d6fe 643 ($i) = split(/\s+/,$cmd);
055fd3a9 644 if ($alias{$i}) {
3dcd9d33 645 # squelch the sigmangler
646 local $SIG{__DIE__};
647 local $SIG{__WARN__};
055fd3a9 648 eval "\$cmd =~ $alias{$i}";
3dcd9d33 649 if ($@) {
650 print $OUT "Couldn't evaluate `$i' alias: $@";
651 next CMD;
652 }
055fd3a9 653 }
20928eff 654 $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
d338d6fe 655 $cmd =~ /^h$/ && do {
6027b9a3 656 print_help($help);
d338d6fe 657 next CMD; };
658 $cmd =~ /^h\s+h$/ && do {
6027b9a3 659 print_help($summary);
d338d6fe 660 next CMD; };
055fd3a9 661 # support long commands; otherwise bogus errors
662 # happen when you ask for h on <CR> for example
663 $cmd =~ /^h\s+(\S.*)$/ && do {
664 my $asked = $1; # for proper errmsg
665 my $qasked = quotemeta($asked); # for searching
666 # XXX: finds CR but not <CR>
667 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
668 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
6027b9a3 669 print_help($1);
55497cff 670 }
d338d6fe 671 } else {
6027b9a3 672 print_help("B<$asked> is not a debugger command.\n");
d338d6fe 673 }
674 next CMD; };
675 $cmd =~ /^t$/ && do {
3fbd6552 676 $trace ^= 1;
6027b9a3 677 print $OUT "Trace = " .
678 (($trace & 1) ? "on" : "off" ) . "\n";
d338d6fe 679 next CMD; };
680 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
681 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
682 foreach $subname (sort(keys %sub)) {
683 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
684 print $OUT $subname,"\n";
685 }
686 }
687 next CMD; };
ee971a18 688 $cmd =~ /^v$/ && do {
689 list_versions(); next CMD};
d338d6fe 690 $cmd =~ s/^X\b/V $package/;
691 $cmd =~ /^V$/ && do {
692 $cmd = "V $package"; };
693 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
694 local ($savout) = select($OUT);
695 $packname = $1;
696 @vars = split(' ',$2);
697 do 'dumpvar.pl' unless defined &main::dumpvar;
698 if (defined &main::dumpvar) {
54d04a52 699 local $frame = 0;
ee971a18 700 local $doret = -2;
055fd3a9 701 # must detect sigpipe failures
702 eval { &main::dumpvar($packname,@vars) };
703 if ($@) {
704 die unless $@ =~ /dumpvar print failed/;
705 }
d338d6fe 706 } else {
707 print $OUT "dumpvar.pl not available.\n";
708 }
709 select ($savout);
710 next CMD; };
711 $cmd =~ s/^x\b/ / && do { # So that will be evaled
1d06cb2d 712 $onetimeDump = 'dump'; };
713 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
714 methods($1); next CMD};
715 $cmd =~ s/^m\b/ / && do { # So this will be evaled
716 $onetimeDump = 'methods'; };
d338d6fe 717 $cmd =~ /^f\b\s*(.*)/ && do {
718 $file = $1;
477ea2b1 719 $file =~ s/\s+$//;
d338d6fe 720 if (!$file) {
721 print $OUT "The old f command is now the r command.\n";
722 print $OUT "The new f command switches filenames.\n";
723 next CMD;
724 }
725 if (!defined $main::{'_<' . $file}) {
726 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
477ea2b1 727 $try = substr($try,2);
728 print $OUT "Choosing $try matching `$file':\n";
729 $file = $try;
d338d6fe 730 }}
731 }
732 if (!defined $main::{'_<' . $file}) {
04fb8f4b 733 print $OUT "No file matching `$file' is loaded.\n";
d338d6fe 734 next CMD;
735 } elsif ($file ne $filename) {
8ebc5c01 736 *dbline = $main::{'_<' . $file};
d338d6fe 737 $max = $#dbline;
738 $filename = $file;
739 $start = 1;
740 $cmd = "l";
477ea2b1 741 } else {
742 print $OUT "Already in $file.\n";
743 next CMD;
744 }
745 };
1d06cb2d 746 $cmd =~ s/^l\s+-\s*$/-/;
83ee9e09 747 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
748 $evalarg = $2;
749 my ($s) = &eval;
750 print($OUT "Error: $@\n"), next CMD if $@;
751 $s = CvGV_name($s);
752 print($OUT "Interpreted as: $1 $s\n");
753 $cmd = "$1 $s";
754 };
755 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
f1583d8f 756 my $s = $subname = $1;
d338d6fe 757 $subname =~ s/\'/::/;
477ea2b1 758 $subname = $package."::".$subname
759 unless $subname =~ /::/;
f1583d8f 760 $subname = "CORE::GLOBAL::$s"
761 if not defined &$subname and $s !~ /::/
762 and defined &{"CORE::GLOBAL::$s"};
d338d6fe 763 $subname = "main".$subname if substr($subname,0,2) eq "::";
83ee9e09 764 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
d338d6fe 765 $subrange = pop @pieces;
766 $file = join(':', @pieces);
767 if ($file ne $filename) {
bee32ff8 768 print $OUT "Switching to file '$file'.\n"
055fd3a9 769 unless $slave_editor;
8ebc5c01 770 *dbline = $main::{'_<' . $file};
d338d6fe 771 $max = $#dbline;
772 $filename = $file;
773 }
774 if ($subrange) {
775 if (eval($subrange) < -$window) {
776 $subrange =~ s/-.*/+/;
777 }
778 $cmd = "l $subrange";
779 } else {
780 print $OUT "Subroutine $subname not found.\n";
781 next CMD;
782 } };
54d04a52 783 $cmd =~ /^\.$/ && do {
1d06cb2d 784 $incr = -1; # for backward motion.
54d04a52 785 $start = $line;
786 $filename = $filename_ini;
8ebc5c01 787 *dbline = $main::{'_<' . $filename};
54d04a52 788 $max = $#dbline;
f1583d8f 789 print_lineinfo($position);
54d04a52 790 next CMD };
d338d6fe 791 $cmd =~ /^w\b\s*(\d*)$/ && do {
792 $incr = $window - 1;
793 $start = $1 if $1;
794 $start -= $preview;
54d04a52 795 #print $OUT 'l ' . $start . '-' . ($start + $incr);
d338d6fe 796 $cmd = 'l ' . $start . '-' . ($start + $incr); };
797 $cmd =~ /^-$/ && do {
1d06cb2d 798 $start -= $incr + $window + 1;
799 $start = 1 if $start <= 0;
d338d6fe 800 $incr = $window - 1;
1d06cb2d 801 $cmd = 'l ' . ($start) . '+'; };
d338d6fe 802 $cmd =~ /^l$/ && do {
803 $incr = $window - 1;
804 $cmd = 'l ' . $start . '-' . ($start + $incr); };
805 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
806 $start = $1 if $1;
807 $incr = $2;
808 $incr = $window - 1 unless $incr;
809 $cmd = 'l ' . $start . '-' . ($start + $incr); };
54d04a52 810 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
811 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
d338d6fe 812 $end = $max if $end > $max;
813 $i = $2;
814 $i = $line if $i eq '.';
815 $i = 1 if $i < 1;
1d06cb2d 816 $incr = $end - $i;
055fd3a9 817 if ($slave_editor) {
d338d6fe 818 print $OUT "\032\032$filename:$i:0\n";
819 $i = $end;
820 } else {
821 for (; $i <= $end; $i++) {
54d04a52 822 ($stop,$action) = split(/\0/, $dbline{$i});
823 $arrow = ($i==$line
824 and $filename eq $filename_ini)
825 ? '==>'
36477c24 826 : ($dbline[$i]+0 ? ':' : ' ') ;
54d04a52 827 $arrow .= 'b' if $stop;
828 $arrow .= 'a' if $action;
829 print $OUT "$i$arrow\t", $dbline[$i];
65c9c81d 830 $i++, last if $signal;
d338d6fe 831 }
65c9c81d 832 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
d338d6fe 833 }
834 $start = $i; # remember in case they want more
835 $start = $max if $start > $max;
836 next CMD; };
837 $cmd =~ /^D$/ && do {
55497cff 838 print $OUT "Deleting all breakpoints...\n";
839 my $file;
840 for $file (keys %had_breakpoints) {
8ebc5c01 841 local *dbline = $main::{'_<' . $file};
55497cff 842 my $max = $#dbline;
843 my $was;
844
d338d6fe 845 for ($i = 1; $i <= $max ; $i++) {
846 if (defined $dbline{$i}) {
847 $dbline{$i} =~ s/^[^\0]+//;
848 if ($dbline{$i} =~ s/^\0?$//) {
849 delete $dbline{$i};
850 }
851 }
852 }
3fbd6552 853
854 if (not $had_breakpoints{$file} &= ~1) {
855 delete $had_breakpoints{$file};
856 }
55497cff 857 }
858 undef %postponed;
859 undef %postponed_file;
860 undef %break_on_load;
55497cff 861 next CMD; };
d338d6fe 862 $cmd =~ /^L$/ && do {
55497cff 863 my $file;
864 for $file (keys %had_breakpoints) {
8ebc5c01 865 local *dbline = $main::{'_<' . $file};
55497cff 866 my $max = $#dbline;
867 my $was;
868
d338d6fe 869 for ($i = 1; $i <= $max; $i++) {
870 if (defined $dbline{$i}) {
2002527a 871 print $OUT "$file:\n" unless $was++;
55497cff 872 print $OUT " $i:\t", $dbline[$i];
d338d6fe 873 ($stop,$action) = split(/\0/, $dbline{$i});
55497cff 874 print $OUT " break if (", $stop, ")\n"
d338d6fe 875 if $stop;
55497cff 876 print $OUT " action: ", $action, "\n"
d338d6fe 877 if $action;
878 last if $signal;
879 }
880 }
55497cff 881 }
882 if (%postponed) {
883 print $OUT "Postponed breakpoints in subroutines:\n";
884 my $subname;
885 for $subname (keys %postponed) {
886 print $OUT " $subname\t$postponed{$subname}\n";
887 last if $signal;
888 }
889 }
890 my @have = map { # Combined keys
891 keys %{$postponed_file{$_}}
892 } keys %postponed_file;
893 if (@have) {
894 print $OUT "Postponed breakpoints in files:\n";
895 my ($file, $line);
896 for $file (keys %postponed_file) {
0c395bd7 897 my $db = $postponed_file{$file};
55497cff 898 print $OUT " $file:\n";
0c395bd7 899 for $line (sort {$a <=> $b} keys %$db) {
08a4aec0 900 print $OUT " $line:\n";
0c395bd7 901 my ($stop,$action) = split(/\0/, $$db{$line});
55497cff 902 print $OUT " break if (", $stop, ")\n"
903 if $stop;
904 print $OUT " action: ", $action, "\n"
905 if $action;
906 last if $signal;
907 }
908 last if $signal;
909 }
910 }
911 if (%break_on_load) {
912 print $OUT "Breakpoints on load:\n";
913 my $file;
914 for $file (keys %break_on_load) {
915 print $OUT " $file\n";
916 last if $signal;
917 }
918 }
6027b9a3 919 if ($trace & 2) {
920 print $OUT "Watch-expressions:\n";
921 my $expr;
922 for $expr (@to_watch) {
923 print $OUT " $expr\n";
924 last if $signal;
925 }
926 }
55497cff 927 next CMD; };
928 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
477ea2b1 929 my $file = $1; $file =~ s/\s+$//;
f1583d8f 930 cmd_b_load($file);
55497cff 931 next CMD; };
1d06cb2d 932 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
a223bd61 933 my $cond = length $3 ? $3 : '1';
1d06cb2d 934 my ($subname, $break) = ($2, $1 eq 'postpone');
a223bd61 935 $subname =~ s/\'/::/g;
55497cff 936 $subname = "${'package'}::" . $subname
937 unless $subname =~ /::/;
938 $subname = "main".$subname if substr($subname,0,2) eq "::";
1d06cb2d 939 $postponed{$subname} = $break
940 ? "break +0 if $cond" : "compile";
d338d6fe 941 next CMD; };
83ee9e09 942 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
d338d6fe 943 $subname = $1;
a223bd61 944 $cond = length $2 ? $2 : '1';
f1583d8f 945 cmd_b_sub($subname, $cond);
d338d6fe 946 next CMD; };
947 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
3fbd6552 948 $i = $1 || $line;
31706494 949 $cond = length $2 ? $2 : '1';
f1583d8f 950 cmd_b_line($i, $cond);
d338d6fe 951 next CMD; };
3fbd6552 952 $cmd =~ /^d\b\s*(\d*)/ && do {
f1583d8f 953 cmd_d($1 || $line);
d338d6fe 954 next CMD; };
955 $cmd =~ /^A$/ && do {
3fbd6552 956 print $OUT "Deleting all actions...\n";
55497cff 957 my $file;
958 for $file (keys %had_breakpoints) {
8ebc5c01 959 local *dbline = $main::{'_<' . $file};
55497cff 960 my $max = $#dbline;
961 my $was;
962
d338d6fe 963 for ($i = 1; $i <= $max ; $i++) {
964 if (defined $dbline{$i}) {
965 $dbline{$i} =~ s/\0[^\0]*//;
966 delete $dbline{$i} if $dbline{$i} eq '';
967 }
968 }
3fbd6552 969
055fd3a9 970 unless ($had_breakpoints{$file} &= ~2) {
3fbd6552 971 delete $had_breakpoints{$file};
972 }
55497cff 973 }
974 next CMD; };
d338d6fe 975 $cmd =~ /^O\s*$/ && do {
976 for (@options) {
977 &dump_option($_);
978 }
979 next CMD; };
980 $cmd =~ /^O\s*(\S.*)/ && do {
981 parse_options($1);
982 next CMD; };
55497cff 983 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
984 push @$pre, action($1);
985 next CMD; };
986 $cmd =~ /^>>\s*(.*)/ && do {
987 push @$post, action($1);
988 next CMD; };
d338d6fe 989 $cmd =~ /^<\s*(.*)/ && do {
055fd3a9 990 unless ($1) {
e4e99f0d 991 print $OUT "All < actions cleared.\n";
055fd3a9 992 $pre = [];
993 next CMD;
994 }
995 if ($1 eq '?') {
996 unless (@$pre) {
e4e99f0d 997 print $OUT "No pre-prompt Perl actions.\n";
055fd3a9 998 next CMD;
999 }
e4e99f0d 1000 print $OUT "Perl commands run before each prompt:\n";
055fd3a9 1001 for my $action ( @$pre ) {
e4e99f0d 1002 print $OUT "\t< -- $action\n";
055fd3a9 1003 }
1004 next CMD;
1005 }
55497cff 1006 $pre = [action($1)];
d338d6fe 1007 next CMD; };
1008 $cmd =~ /^>\s*(.*)/ && do {
055fd3a9 1009 unless ($1) {
e4e99f0d 1010 print $OUT "All > actions cleared.\n";
055fd3a9 1011 $post = [];
1012 next CMD;
1013 }
1014 if ($1 eq '?') {
1015 unless (@$post) {
e4e99f0d 1016 print $OUT "No post-prompt Perl actions.\n";
055fd3a9 1017 next CMD;
1018 }
e4e99f0d 1019 print $OUT "Perl commands run after each prompt:\n";
055fd3a9 1020 for my $action ( @$post ) {
e4e99f0d 1021 print $OUT "\t> -- $action\n";
055fd3a9 1022 }
1023 next CMD;
1024 }
55497cff 1025 $post = [action($1)];
1026 next CMD; };
1027 $cmd =~ /^\{\{\s*(.*)/ && do {
055fd3a9 1028 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
e4e99f0d 1029 print $OUT "{{ is now a debugger command\n",
055fd3a9 1030 "use `;{{' if you mean Perl code\n";
1031 $cmd = "h {{";
1032 redo CMD;
1033 }
55497cff 1034 push @$pretype, $1;
1035 next CMD; };
1036 $cmd =~ /^\{\s*(.*)/ && do {
055fd3a9 1037 unless ($1) {
e4e99f0d 1038 print $OUT "All { actions cleared.\n";
055fd3a9 1039 $pretype = [];
1040 next CMD;
1041 }
1042 if ($1 eq '?') {
1043 unless (@$pretype) {
e4e99f0d 1044 print $OUT "No pre-prompt debugger actions.\n";
055fd3a9 1045 next CMD;
1046 }
e4e99f0d 1047 print $OUT "Debugger commands run before each prompt:\n";
055fd3a9 1048 for my $action ( @$pretype ) {
e4e99f0d 1049 print $OUT "\t{ -- $action\n";
055fd3a9 1050 }
1051 next CMD;
1052 }
1053 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
e4e99f0d 1054 print $OUT "{ is now a debugger command\n",
055fd3a9 1055 "use `;{' if you mean Perl code\n";
1056 $cmd = "h {";
1057 redo CMD;
1058 }
55497cff 1059 $pretype = [$1];
d338d6fe 1060 next CMD; };
3fbd6552 1061 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1062 $i = $1 || $line; $j = $2;
1063 if (length $j) {
1064 if ($dbline[$i] == 0) {
1065 print $OUT "Line $i may not have an action.\n";
1066 } else {
1067 $had_breakpoints{$filename} |= 2;
1068 $dbline{$i} =~ s/\0[^\0]*//;
1069 $dbline{$i} .= "\0" . action($j);
1070 }
d338d6fe 1071 } else {
1072 $dbline{$i} =~ s/\0[^\0]*//;
3fbd6552 1073 delete $dbline{$i} if $dbline{$i} eq '';
d338d6fe 1074 }
1075 next CMD; };
1076 $cmd =~ /^n$/ && do {
4639966b 1077 end_report(), next CMD if $finished and $level <= 1;
d338d6fe 1078 $single = 2;
1079 $laststep = $cmd;
1080 last CMD; };
1081 $cmd =~ /^s$/ && do {
4639966b 1082 end_report(), next CMD if $finished and $level <= 1;
d338d6fe 1083 $single = 1;
1084 $laststep = $cmd;
1085 last CMD; };
54d04a52 1086 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
4639966b 1087 end_report(), next CMD if $finished and $level <= 1;
fb73857a 1088 $subname = $i = $1;
bee32ff8 1089 # Probably not needed, since we finish an interactive
1090 # sub-session anyway...
1091 # local $filename = $filename;
1092 # local *dbline = *dbline; # XXX Would this work?!
54d04a52 1093 if ($i =~ /\D/) { # subroutine name
fb73857a 1094 $subname = $package."::".$subname
1095 unless $subname =~ /::/;
1096 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
54d04a52 1097 $i += 0;
1098 if ($i) {
1099 $filename = $file;
8ebc5c01 1100 *dbline = $main::{'_<' . $filename};
3fbd6552 1101 $had_breakpoints{$filename} |= 1;
54d04a52 1102 $max = $#dbline;
1103 ++$i while $dbline[$i] == 0 && $i < $max;
1104 } else {
1105 print $OUT "Subroutine $subname not found.\n";
1106 next CMD;
1107 }
1108 }
d338d6fe 1109 if ($i) {
1110 if ($dbline[$i] == 0) {
1111 print $OUT "Line $i not breakable.\n";
1112 next CMD;
1113 }
1114 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1115 }
f8b5b99c 1116 for ($i=0; $i <= $stack_depth; ) {
d338d6fe 1117 $stack[$i++] &= ~1;
1118 }
1119 last CMD; };
1120 $cmd =~ /^r$/ && do {
4639966b 1121 end_report(), next CMD if $finished and $level <= 1;
f8b5b99c 1122 $stack[$stack_depth] |= 1;
1123 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
d338d6fe 1124 last CMD; };
54d04a52 1125 $cmd =~ /^R$/ && do {
55497cff 1126 print $OUT "Warning: some settings and command-line options may be lost!\n";
54d04a52 1127 my (@script, @flags, $cl);
1128 push @flags, '-w' if $ini_warn;
1129 # Put all the old includes at the start to get
1130 # the same debugger.
1131 for (@ini_INC) {
1132 push @flags, '-I', $_;
1133 }
1134 # Arrange for setting the old INC:
1135 set_list("PERLDB_INC", @ini_INC);
1136 if ($0 eq '-e') {
1137 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
055fd3a9 1138 chomp ($cl = ${'::_<-e'}[$_]);
54d04a52 1139 push @script, '-e', $cl;
1140 }
1141 } else {
1142 @script = $0;
1143 }
1144 set_list("PERLDB_HIST",
1145 $term->Features->{getHistory}
1146 ? $term->GetHistory : @hist);
55497cff 1147 my @had_breakpoints = keys %had_breakpoints;
1148 set_list("PERLDB_VISITED", @had_breakpoints);
54d04a52 1149 set_list("PERLDB_OPT", %option);
55497cff 1150 set_list("PERLDB_ON_LOAD", %break_on_load);
1151 my @hard;
1152 for (0 .. $#had_breakpoints) {
1153 my $file = $had_breakpoints[$_];
8ebc5c01 1154 *dbline = $main::{'_<' . $file};
0c395bd7 1155 next unless %dbline or $postponed_file{$file};
55497cff 1156 (push @hard, $file), next
1157 if $file =~ /^\(eval \d+\)$/;
1158 my @add;
1159 @add = %{$postponed_file{$file}}
0c395bd7 1160 if $postponed_file{$file};
55497cff 1161 set_list("PERLDB_FILE_$_", %dbline, @add);
1162 }
1163 for (@hard) { # Yes, really-really...
1164 # Find the subroutines in this eval
8ebc5c01 1165 *dbline = $main::{'_<' . $_};
55497cff 1166 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1167 for $sub (keys %sub) {
1168 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1169 $subs{$sub} = [$1, $2];
1170 }
1171 unless (%subs) {
1172 print $OUT
1173 "No subroutines in $_, ignoring breakpoints.\n";
1174 next;
1175 }
1176 LINES: for $line (keys %dbline) {
1177 # One breakpoint per sub only:
1178 my ($offset, $sub, $found);
1179 SUBS: for $sub (keys %subs) {
1180 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1181 and (not defined $offset # Not caught
1182 or $offset < 0 )) { # or badly caught
1183 $found = $sub;
1184 $offset = $line - $subs{$sub}->[0];
1185 $offset = "+$offset", last SUBS if $offset >= 0;
1186 }
1187 }
1188 if (defined $offset) {
1189 $postponed{$found} =
1190 "break $offset if $dbline{$line}";
1191 } else {
1192 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1193 }
1194 }
54d04a52 1195 }
55497cff 1196 set_list("PERLDB_POSTPONE", %postponed);
43aed9ee 1197 set_list("PERLDB_PRETYPE", @$pretype);
1198 set_list("PERLDB_PRE", @$pre);
1199 set_list("PERLDB_POST", @$post);
1200 set_list("PERLDB_TYPEAHEAD", @typeahead);
54d04a52 1201 $ENV{PERLDB_RESTART} = 1;
f1583d8f 1202 delete $ENV{PERLDB_PIDS}; # Restore ini state
1203 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
055fd3a9 1204 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
1205 exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS;
54d04a52 1206 print $OUT "exec failed: $!\n";
1207 last CMD; };
d338d6fe 1208 $cmd =~ /^T$/ && do {
36477c24 1209 print_trace($OUT, 1); # skip DB
d338d6fe 1210 next CMD; };
6027b9a3 1211 $cmd =~ /^W\s*$/ && do {
1212 $trace &= ~2;
1213 @to_watch = @old_watch = ();
1214 next CMD; };
1215 $cmd =~ /^W\b\s*(.*)/s && do {
1216 push @to_watch, $1;
1217 $evalarg = $1;
1218 my ($val) = &eval;
1219 $val = (defined $val) ? "'$val'" : 'undef' ;
1220 push @old_watch, $val;
1221 $trace |= 2;
1222 next CMD; };
d338d6fe 1223 $cmd =~ /^\/(.*)$/ && do {
1224 $inpat = $1;
1225 $inpat =~ s:([^\\])/$:$1:;
1226 if ($inpat ne "") {
3dcd9d33 1227 # squelch the sigmangler
1228 local $SIG{__DIE__};
1229 local $SIG{__WARN__};
d338d6fe 1230 eval '$inpat =~ m'."\a$inpat\a";
1231 if ($@ ne "") {
1232 print $OUT "$@";
1233 next CMD;
1234 }
1235 $pat = $inpat;
1236 }
1237 $end = $start;
1d06cb2d 1238 $incr = -1;
d338d6fe 1239 eval '
1240 for (;;) {
1241 ++$start;
1242 $start = 1 if ($start > $max);
1243 last if ($start == $end);
1244 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
055fd3a9 1245 if ($slave_editor) {
d338d6fe 1246 print $OUT "\032\032$filename:$start:0\n";
1247 } else {
1248 print $OUT "$start:\t", $dbline[$start], "\n";
1249 }
1250 last;
1251 }
1252 } ';
1253 print $OUT "/$pat/: not found\n" if ($start == $end);
1254 next CMD; };
1255 $cmd =~ /^\?(.*)$/ && do {
1256 $inpat = $1;
1257 $inpat =~ s:([^\\])\?$:$1:;
1258 if ($inpat ne "") {
3dcd9d33 1259 # squelch the sigmangler
1260 local $SIG{__DIE__};
1261 local $SIG{__WARN__};
d338d6fe 1262 eval '$inpat =~ m'."\a$inpat\a";
1263 if ($@ ne "") {
3dcd9d33 1264 print $OUT $@;
d338d6fe 1265 next CMD;
1266 }
1267 $pat = $inpat;
1268 }
1269 $end = $start;
1d06cb2d 1270 $incr = -1;
d338d6fe 1271 eval '
1272 for (;;) {
1273 --$start;
1274 $start = $max if ($start <= 0);
1275 last if ($start == $end);
1276 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
055fd3a9 1277 if ($slave_editor) {
d338d6fe 1278 print $OUT "\032\032$filename:$start:0\n";
1279 } else {
1280 print $OUT "$start:\t", $dbline[$start], "\n";
1281 }
1282 last;
1283 }
1284 } ';
1285 print $OUT "?$pat?: not found\n" if ($start == $end);
1286 next CMD; };
1287 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1288 pop(@hist) if length($cmd) > 1;
3fbd6552 1289 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
6921e3ed 1290 $cmd = $hist[$i];
615b993b 1291 print $OUT $cmd, "\n";
d338d6fe 1292 redo CMD; };
55497cff 1293 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
ee971a18 1294 &system($1);
d338d6fe 1295 next CMD; };
1296 $cmd =~ /^$rc([^$rc].*)$/ && do {
1297 $pat = "^$1";
1298 pop(@hist) if length($cmd) > 1;
1299 for ($i = $#hist; $i; --$i) {
1300 last if $hist[$i] =~ /$pat/;
1301 }
1302 if (!$i) {
1303 print $OUT "No such command!\n\n";
1304 next CMD;
1305 }
6921e3ed 1306 $cmd = $hist[$i];
615b993b 1307 print $OUT $cmd, "\n";
d338d6fe 1308 redo CMD; };
1309 $cmd =~ /^$sh$/ && do {
1310 &system($ENV{SHELL}||"/bin/sh");
1311 next CMD; };
ee971a18 1312 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
055fd3a9 1313 # XXX: using csh or tcsh destroys sigint retvals!
1314 #&system($1); # use this instead
ee971a18 1315 &system($ENV{SHELL}||"/bin/sh","-c",$1);
d338d6fe 1316 next CMD; };
1317 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
055fd3a9 1318 $end = $2 ? ($#hist-$2) : 0;
d338d6fe 1319 $hist = 0 if $hist < 0;
1320 for ($i=$#hist; $i>$end; $i--) {
1321 print $OUT "$i: ",$hist[$i],"\n"
1322 unless $hist[$i] =~ /^.?$/;
1323 };
1324 next CMD; };
055fd3a9 1325 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1326 runman($1);
1327 next CMD; };
b9b857e2 1328 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1329 $cmd =~ s/^p\b/print {\$DB::OUT} /;
3dcd9d33 1330 $cmd =~ s/^=\s*// && do {
1331 my @keys;
1332 if (length $cmd == 0) {
1333 @keys = sort keys %alias;
1334 }
1335 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1336 # can't use $_ or kill //g state
1337 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1338 $alias{$k} = "s\a$k\a$v\a";
1339 # squelch the sigmangler
1340 local $SIG{__DIE__};
1341 local $SIG{__WARN__};
1342 unless (eval "sub { s\a$k\a$v\a }; 1") {
1343 print $OUT "Can't alias $k to $v: $@\n";
1344 delete $alias{$k};
1345 next CMD;
1346 }
1347 @keys = ($k);
1348 }
1349 else {
1350 @keys = ($cmd);
1351 }
1352 for my $k (@keys) {
1353 if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
1354 print $OUT "$k\t= $1\n";
1355 }
1356 elsif (defined $alias{$k}) {
d338d6fe 1357 print $OUT "$k\t$alias{$k}\n";
3dcd9d33 1358 }
1359 else {
1360 print "No alias for $k\n";
1361 }
1362 }
d338d6fe 1363 next CMD; };
1364 $cmd =~ /^\|\|?\s*[^|]/ && do {
1365 if ($pager =~ /^\|/) {
1366 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1367 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1368 } else {
1369 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1370 }
055fd3a9 1371 fix_less();
d338d6fe 1372 unless ($piped=open(OUT,$pager)) {
1373 &warn("Can't pipe output to `$pager'");
1374 if ($pager =~ /^\|/) {
055fd3a9 1375 open(OUT,">&STDOUT") # XXX: lost message
1376 || &warn("Can't restore DB::OUT");
d338d6fe 1377 open(STDOUT,">&SAVEOUT")
1378 || &warn("Can't restore STDOUT");
1379 close(SAVEOUT);
1380 } else {
055fd3a9 1381 open(OUT,">&STDOUT") # XXX: lost message
1382 || &warn("Can't restore DB::OUT");
d338d6fe 1383 }
1384 next CMD;
1385 }
77fb7b16 1386 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
055fd3a9 1387 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
d338d6fe 1388 $selected= select(OUT);
1389 $|= 1;
1390 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1391 $cmd =~ s/^\|+\s*//;
055fd3a9 1392 redo PIPE;
1393 };
d338d6fe 1394 # XXX Local variants do not work!
6027b9a3 1395 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
d338d6fe 1396 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1397 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1398 } # PIPE:
d338d6fe 1399 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1400 if ($onetimeDump) {
1401 $onetimeDump = undef;
f36776d9 1402 } elsif ($term_pid == $$) {
d338d6fe 1403 print $OUT "\n";
1404 }
1405 } continue { # CMD:
1406 if ($piped) {
1407 if ($pager =~ /^\|/) {
055fd3a9 1408 $? = 0;
1409 # we cannot warn here: the handle is missing --tchrist
1410 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1411
1412 # most of the $? crud was coping with broken cshisms
1413 if ($?) {
1414 print SAVEOUT "Pager `$pager' failed: ";
1415 if ($? == -1) {
1416 print SAVEOUT "shell returned -1\n";
1417 } elsif ($? >> 8) {
1418 print SAVEOUT
1419 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1420 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1421 } else {
1422 print SAVEOUT "status ", ($? >> 8), "\n";
1423 }
1424 }
1425
d338d6fe 1426 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1427 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
055fd3a9 1428 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
d338d6fe 1429 # Will stop ignoring SIGPIPE if done like nohup(1)
1430 # does SIGINT but Perl doesn't give us a choice.
1431 } else {
1432 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1433 }
1434 close(SAVEOUT);
1435 select($selected), $selected= "" unless $selected eq "";
1436 $piped= "";
1437 }
1438 } # CMD:
20928eff 1439 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
e63173ce 1440 foreach $evalarg (@$post) {
1441 &eval;
1442 }
d338d6fe 1443 } # if ($single || $signal)
22fae026 1444 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
d338d6fe 1445 ();
1446}
1447
1448# The following code may be executed now:
1449# BEGIN {warn 4}
1450
1451sub sub {
ee971a18 1452 my ($al, $ret, @ret) = "";
7d4a81e5 1453 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1454 $al = " for $$sub";
ee971a18 1455 }
f8b5b99c 1456 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1457 $#stack = $stack_depth;
1458 $stack[-1] = $single;
d338d6fe 1459 $single &= 1;
f8b5b99c 1460 $single |= 4 if $stack_depth == $deep;
04fb8f4b 1461 ($frame & 4
f1583d8f 1462 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
04fb8f4b 1463 # Why -1? But it works! :-(
1464 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f1583d8f 1465 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
d338d6fe 1466 if (wantarray) {
1467 @ret = &$sub;
f8b5b99c 1468 $single |= $stack[$stack_depth--];
36477c24 1469 ($frame & 4
f1583d8f 1470 ? ( print_lineinfo(' ' x $stack_depth, "out "),
36477c24 1471 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f1583d8f 1472 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
f8b5b99c 1473 if ($doret eq $stack_depth or $frame & 16) {
1474 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1475 print $fh ' ' x $stack_depth if $frame & 16;
7ea36084 1476 print $fh "list context return from $sub:\n";
1477 dumpit($fh, \@ret );
1478 $doret = -2;
1479 }
d338d6fe 1480 @ret;
1481 } else {
fb73857a 1482 if (defined wantarray) {
1483 $ret = &$sub;
1484 } else {
1485 &$sub; undef $ret;
1486 };
f8b5b99c 1487 $single |= $stack[$stack_depth--];
36477c24 1488 ($frame & 4
f1583d8f 1489 ? ( print_lineinfo(' ' x $stack_depth, "out "),
36477c24 1490 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f1583d8f 1491 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
f8b5b99c 1492 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1493 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1494 print $fh (' ' x $stack_depth) if $frame & 16;
7ea36084 1495 print $fh (defined wantarray
1496 ? "scalar context return from $sub: "
1497 : "void context return from $sub\n");
1498 dumpit( $fh, $ret ) if defined wantarray;
1499 $doret = -2;
1500 }
d338d6fe 1501 $ret;
1502 }
1503}
1504
f1583d8f 1505### The API section
1506
1507### Functions with multiple modes of failure die on error, the rest
1508### returns FALSE on error.
1509### User-interface functions cmd_* output error message.
1510
1511sub break_on_load {
1512 my $file = shift;
1513 $break_on_load{$file} = 1;
1514 $had_breakpoints{$file} |= 1;
1515}
1516
1517sub report_break_on_load {
1518 sort keys %break_on_load;
1519}
1520
1521sub cmd_b_load {
1522 my $file = shift;
1523 my @files;
1524 {
1525 push @files, $file;
1526 push @files, $::INC{$file} if $::INC{$file};
1527 $file .= '.pm', redo unless $file =~ /\./;
1528 }
1529 break_on_load($_) for @files;
1530 my @files = report_break_on_load;
1531 print $OUT "Will stop on load of `@files'.\n";
1532}
1533
1534$filename_error = '';
1535
1536sub breakable_line {
1537 my ($from, $to) = @_;
1538 my $i = $from;
1539 if (@_ >= 2) {
1540 my $delta = $from < $to ? +1 : -1;
1541 my $limit = $delta > 0 ? $#dbline : 1;
1542 $limit = $to if ($limit - $to) * $delta > 0;
1543 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1544 }
1545 return $i unless $dbline[$i] == 0;
1546 my ($pl, $upto) = ('', '');
1547 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1548 die "Line$pl $from$upto$filename_error not breakable\n";
1549}
1550
1551sub breakable_line_in_filename {
1552 my ($f) = shift;
1553 local *dbline = $main::{'_<' . $f};
1554 local $filename_error = " of `$f'";
1555 breakable_line(@_);
1556}
1557
1558sub break_on_line {
1559 my ($i, $cond) = @_;
1560 $cond = 1 unless @_ >= 2;
1561 my $inii = $i;
1562 my $after = '';
1563 my $pl = '';
1564 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1565 $had_breakpoints{$filename} |= 1;
1566 $dbline{$i} =~ s/^[^\0]*/$cond/;
1567}
1568
1569sub cmd_b_line {
1570 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1571}
1572
1573sub break_on_filename_line {
1574 my ($f, $i, $cond) = @_;
1575 $cond = 1 unless @_ >= 3;
1576 local *dbline = $main::{'_<' . $f};
1577 local $filename_error = " of `$f'";
1578 local $filename = $f;
1579 break_on_line($i, $cond);
1580}
1581
1582sub break_on_filename_line_range {
1583 my ($f, $from, $to, $cond) = @_;
1584 my $i = breakable_line_in_filename($f, $from, $to);
1585 $cond = 1 unless @_ >= 3;
1586 break_on_filename_line($f,$i,$cond);
1587}
1588
1589sub subroutine_filename_lines {
1590 my ($subname,$cond) = @_;
1591 # Filename below can contain ':'
1592 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1593}
1594
1595sub break_subroutine {
1596 my $subname = shift;
1597 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1598 die "Subroutine $subname not found.\n";
1599 $cond = 1 unless @_ >= 2;
1600 break_on_filename_line_range($file,$s,$e,@_);
1601}
1602
1603sub cmd_b_sub {
1604 my ($subname,$cond) = @_;
1605 $cond = 1 unless @_ >= 2;
1606 unless (ref $subname eq 'CODE') {
1607 $subname =~ s/\'/::/g;
1608 my $s = $subname;
1609 $subname = "${'package'}::" . $subname
1610 unless $subname =~ /::/;
1611 $subname = "CORE::GLOBAL::$s"
1612 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1613 $subname = "main".$subname if substr($subname,0,2) eq "::";
1614 }
1615 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1616}
1617
1618sub cmd_stop { # As on ^C, but not signal-safy.
1619 $signal = 1;
1620}
1621
1622sub delete_breakpoint {
1623 my $i = shift;
1624 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1625 $dbline{$i} =~ s/^[^\0]*//;
1626 delete $dbline{$i} if $dbline{$i} eq '';
1627}
1628
1629sub cmd_d {
1630 my $i = shift;
1631 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1632}
1633
1634### END of the API section
1635
d338d6fe 1636sub save {
22fae026 1637 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
d338d6fe 1638 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1639}
1640
f1583d8f 1641sub print_lineinfo {
1642 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1643 print $LINEINFO @_;
1644}
1645
d338d6fe 1646# The following takes its argument via $evalarg to preserve current @_
1647
1648sub eval {
055fd3a9 1649 # 'my' would make it visible from user code
f1583d8f 1650 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1651 local @res;
d338d6fe 1652 {
23a291ec 1653 local $otrace = $trace;
1654 local $osingle = $single;
1655 local $od = $^D;
157b066d 1656 { ($evalarg) = $evalarg =~ /(.*)/s; }
d338d6fe 1657 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1658 $trace = $otrace;
1659 $single = $osingle;
1660 $^D = $od;
1661 }
1662 my $at = $@;
36477c24 1663 local $saved[0]; # Preserve the old value of $@
22fae026 1664 eval { &DB::save };
d338d6fe 1665 if ($at) {
1666 print $OUT $at;
1d06cb2d 1667 } elsif ($onetimeDump eq 'dump') {
7ea36084 1668 dumpit($OUT, \@res);
1d06cb2d 1669 } elsif ($onetimeDump eq 'methods') {
1670 methods($res[0]);
d338d6fe 1671 }
6027b9a3 1672 @res;
d338d6fe 1673}
1674
55497cff 1675sub postponed_sub {
1676 my $subname = shift;
1d06cb2d 1677 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
55497cff 1678 my $offset = $1 || 0;
1679 # Filename below can contain ':'
1d06cb2d 1680 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
55497cff 1681 if ($i) {
fb73857a 1682 $i += $offset;
8ebc5c01 1683 local *dbline = $main::{'_<' . $file};
55497cff 1684 local $^W = 0; # != 0 is magical below
3fbd6552 1685 $had_breakpoints{$file} |= 1;
55497cff 1686 my $max = $#dbline;
1687 ++$i until $dbline[$i] != 0 or $i >= $max;
1688 $dbline{$i} = delete $postponed{$subname};
1689 } else {
1690 print $OUT "Subroutine $subname not found.\n";
1691 }
1692 return;
1693 }
1d06cb2d 1694 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
36477c24 1695 #print $OUT "In postponed_sub for `$subname'.\n";
55497cff 1696}
1697
1698sub postponed {
3aefca04 1699 if ($ImmediateStop) {
1700 $ImmediateStop = 0;
1701 $signal = 1;
1702 }
55497cff 1703 return &postponed_sub
1704 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1705 # Cannot be done before the file is compiled
1706 local *dbline = shift;
1707 my $filename = $dbline;
1708 $filename =~ s/^_<//;
36477c24 1709 $signal = 1, print $OUT "'$filename' loaded...\n"
1710 if $break_on_load{$filename};
f1583d8f 1711 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
0c395bd7 1712 return unless $postponed_file{$filename};
3fbd6552 1713 $had_breakpoints{$filename} |= 1;
55497cff 1714 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1715 my $key;
1716 for $key (keys %{$postponed_file{$filename}}) {
055fd3a9 1717 $dbline{$key} = ${$postponed_file{$filename}}{$key};
54d04a52 1718 }
0c395bd7 1719 delete $postponed_file{$filename};
54d04a52 1720}
1721
d338d6fe 1722sub dumpit {
7ea36084 1723 local ($savout) = select(shift);
ee971a18 1724 my $osingle = $single;
1725 my $otrace = $trace;
1726 $single = $trace = 0;
1727 local $frame = 0;
1728 local $doret = -2;
1729 unless (defined &main::dumpValue) {
1730 do 'dumpvar.pl';
1731 }
d338d6fe 1732 if (defined &main::dumpValue) {
1733 &main::dumpValue(shift);
1734 } else {
1735 print $OUT "dumpvar.pl not available.\n";
1736 }
ee971a18 1737 $single = $osingle;
1738 $trace = $otrace;
d338d6fe 1739 select ($savout);
1740}
1741
36477c24 1742# Tied method do not create a context, so may get wrong message:
1743
55497cff 1744sub print_trace {
1745 my $fh = shift;
f1583d8f 1746 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
36477c24 1747 my @sub = dump_trace($_[0] + 1, $_[1]);
1748 my $short = $_[2]; # Print short report, next one for sub name
1d06cb2d 1749 my $s;
55497cff 1750 for ($i=0; $i <= $#sub; $i++) {
1751 last if $signal;
1752 local $" = ', ';
1753 my $args = defined $sub[$i]{args}
1754 ? "(@{ $sub[$i]{args} })"
1755 : '' ;
1d06cb2d 1756 $args = (substr $args, 0, $maxtrace - 3) . '...'
1757 if length $args > $maxtrace;
36477c24 1758 my $file = $sub[$i]{file};
1759 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1d06cb2d 1760 $s = $sub[$i]{sub};
1761 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
36477c24 1762 if ($short) {
1d06cb2d 1763 my $sub = @_ >= 4 ? $_[3] : $s;
36477c24 1764 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1765 } else {
1d06cb2d 1766 print $fh "$sub[$i]{context} = $s$args" .
36477c24 1767 " called from $file" .
1768 " line $sub[$i]{line}\n";
1769 }
55497cff 1770 }
1771}
1772
1773sub dump_trace {
1774 my $skip = shift;
36477c24 1775 my $count = shift || 1e9;
1776 $skip++;
1777 $count += $skip;
55497cff 1778 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
04fb8f4b 1779 my $nothard = not $frame & 8;
1780 local $frame = 0; # Do not want to trace this.
1781 my $otrace = $trace;
1782 $trace = 0;
55497cff 1783 for ($i = $skip;
36477c24 1784 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
55497cff 1785 $i++) {
1786 @a = ();
1787 for $arg (@args) {
04fb8f4b 1788 my $type;
1789 if (not defined $arg) {
1790 push @a, "undef";
1791 } elsif ($nothard and tied $arg) {
1792 push @a, "tied";
1793 } elsif ($nothard and $type = ref $arg) {
1794 push @a, "ref($type)";
1795 } else {
1796 local $_ = "$arg"; # Safe to stringify now - should not call f().
1797 s/([\'\\])/\\$1/g;
1798 s/(.*)/'$1'/s
1799 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1800 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1801 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1802 push(@a, $_);
1803 }
55497cff 1804 }
7ea36084 1805 $context = $context ? '@' : (defined $context ? "\$" : '.');
55497cff 1806 $args = $h ? [@a] : undef;
1807 $e =~ s/\n\s*\;\s*\Z// if $e;
1d06cb2d 1808 $e =~ s/([\\\'])/\\$1/g if $e;
55497cff 1809 if ($r) {
1810 $sub = "require '$e'";
1811 } elsif (defined $r) {
1812 $sub = "eval '$e'";
1813 } elsif ($sub eq '(eval)') {
1814 $sub = "eval {...}";
1815 }
1816 push(@sub, {context => $context, sub => $sub, args => $args,
1817 file => $file, line => $line});
1818 last if $signal;
1819 }
04fb8f4b 1820 $trace = $otrace;
55497cff 1821 @sub;
1822}
1823
d338d6fe 1824sub action {
1825 my $action = shift;
1826 while ($action =~ s/\\$//) {
1827 #print $OUT "+ ";
1828 #$action .= "\n";
1829 $action .= &gets;
1830 }
1831 $action;
1832}
1833
055fd3a9 1834sub unbalanced {
1835 # i hate using globals!
1836 $balanced_brace_re ||= qr{
1837 ^ \{
1838 (?:
1839 (?> [^{}] + ) # Non-parens without backtracking
1840 |
1841 (??{ $balanced_brace_re }) # Group with matching parens
1842 ) *
1843 \} $
1844 }x;
1845 return $_[0] !~ m/$balanced_brace_re/;
1846}
1847
d338d6fe 1848sub gets {
d338d6fe 1849 &readline("cont: ");
1850}
1851
1852sub system {
1853 # We save, change, then restore STDIN and STDOUT to avoid fork() since
055fd3a9 1854 # some non-Unix systems can do system() but have problems with fork().
d338d6fe 1855 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
8ee058cb 1856 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
d338d6fe 1857 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1858 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
055fd3a9 1859
1860 # XXX: using csh or tcsh destroys sigint retvals!
d338d6fe 1861 system(@_);
1862 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1863 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
055fd3a9 1864 close(SAVEIN);
1865 close(SAVEOUT);
1866
1867
1868 # most of the $? crud was coping with broken cshisms
1869 if ($? >> 8) {
1870 &warn("(Command exited ", ($? >> 8), ")\n");
1871 } elsif ($?) {
1872 &warn( "(Command died of SIG#", ($? & 127),
1873 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1874 }
1875
1876 return $?;
1877
d338d6fe 1878}
1879
1880sub setterm {
54d04a52 1881 local $frame = 0;
ee971a18 1882 local $doret = -2;
ee971a18 1883 eval { require Term::ReadLine } or die $@;
d338d6fe 1884 if ($notty) {
1885 if ($tty) {
f1583d8f 1886 my ($i, $o) = split $tty, /,/;
1887 $o = $i unless defined $o;
1888 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1889 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
d338d6fe 1890 $IN = \*IN;
1891 $OUT = \*OUT;
1892 my $sel = select($OUT);
1893 $| = 1;
1894 select($sel);
1895 } else {
3dcd9d33 1896 eval "require Term::Rendezvous;" or die;
d338d6fe 1897 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1898 my $term_rv = new Term::Rendezvous $rv;
1899 $IN = $term_rv->IN;
1900 $OUT = $term_rv->OUT;
1901 }
1902 }
f1583d8f 1903 if ($term_pid eq '-1') { # In a TTY with another debugger
1904 resetterm(2);
1905 }
d338d6fe 1906 if (!$rl) {
1907 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1908 } else {
1909 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1910
a737e074 1911 $rl_attribs = $term->Attribs;
1912 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1913 if defined $rl_attribs->{basic_word_break_characters}
1914 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1915 $rl_attribs->{special_prefixes} = '$@&%';
1916 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1917 $rl_attribs->{completion_function} = \&db_complete;
d338d6fe 1918 }
1919 $LINEINFO = $OUT unless defined $LINEINFO;
1920 $lineinfo = $console unless defined $lineinfo;
1921 $term->MinLine(2);
54d04a52 1922 if ($term->Features->{setHistory} and "@hist" ne "?") {
1923 $term->SetHistory(@hist);
1924 }
7a2e2cd6 1925 ornaments($ornaments) if defined $ornaments;
f36776d9 1926 $term_pid = $$;
1927}
1928
f1583d8f 1929# Example get_fork_TTY functions
1930sub xterm_get_fork_TTY {
1931 (my $name = $0) =~ s,^.*[/\\],,s;
1932 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
f36776d9 1933 sleep 10000000' |];
f1583d8f 1934 my $tty = <XT>;
1935 chomp $tty;
1936 $pidprompt = ''; # Shown anyway in titlebar
1937 return $tty;
1938}
1939
1940# This one resets $IN, $OUT itself
1941sub os2_get_fork_TTY {
1942 $^F = 40; # XXXX Fixme!
1943 my ($in1, $out1, $in2, $out2);
1944 # Having -d in PERL5OPT would lead to a disaster...
1945 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
1946 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
1947 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
1948 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
1949 (my $name = $0) =~ s,^.*[/\\],,s;
1950 if ( pipe $in1, $out1 and pipe $in2, $out2 and
1951 # system P_SESSION will fail if there is another process
1952 # in the same session with a "dependent" asyncroneous child session.
1953 (($kpid = system 4, $^X, '-we', <<'ES', fileno $in1, fileno $out2, "Daughter Perl debugger $pids $name") >= 0 or warn "system P_SESSION: $!, $^E" and 0) # P_SESSION
1954use Term::ReadKey;
1955use OS2::Process;
1956
1957my $in = shift; # Read from here and pass through
1958set_title pop;
1959system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
1960 open IN, '<&=$in' or die "open <&=$in: \$!";
1961 \$| = 1; print while sysread IN, \$_, 1<<16;
1962EOS
1963
1964my $out = shift;
1965open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
1966select OUT; $| = 1;
1967ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
1968print while sysread STDIN, $_, 1<<16;
1969ES
1970 and close $in1 and close $out2 ) {
1971 $pidprompt = ''; # Shown anyway in titlebar
1972 reset_IN_OUT($in2, $out1);
1973 $tty = '*reset*';
1974 return ''; # Indicate that reset_IN_OUT is called
1975 }
1976 return;
1977}
1978
1979sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
1980 my $in = &get_fork_TTY if defined &get_fork_TTY;
1981 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
1982 if (not defined $in) {
1983 my $why = shift;
1984 print_help(<<EOP) if $why == 1;
1985I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
1986EOP
1987 print_help(<<EOP) if $why == 2;
1988I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
1989 This may be an asyncroneous session, so the parent debugger may be active.
1990EOP
1991 print_help(<<EOP) if $why != 4;
1992 Since two debuggers fight for the same TTY, input is severely entangled.
1993
1994EOP
405ff068 1995 print_help(<<EOP);
f1583d8f 1996 I know how to switch the output to a different window in xterms
1997 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
1998 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
1999
405ff068 2000 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2001 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
f1583d8f 2002
405ff068 2003EOP
f1583d8f 2004 } elsif ($in ne '') {
2005 TTY($in);
f36776d9 2006 }
f1583d8f 2007 undef $fork_TTY;
2008}
2009
2010sub resetterm { # We forked, so we need a different TTY
2011 my $in = shift;
2012 my $systemed = $in > 1 ? '-' : '';
2013 if ($pids) {
2014 $pids =~ s/\]/$systemed->$$]/;
2015 } else {
2016 $pids = "[$term_pid->$$]";
2017 }
2018 $pidprompt = $pids;
2019 $term_pid = $$;
2020 return unless $CreateTTY & $in;
2021 create_IN_OUT($in);
d338d6fe 2022}
2023
2024sub readline {
0c01eb4a 2025 local $.;
54d04a52 2026 if (@typeahead) {
2027 my $left = @typeahead;
2028 my $got = shift @typeahead;
2029 print $OUT "auto(-$left)", shift, $got, "\n";
2030 $term->AddHistory($got)
2031 if length($got) > 1 and defined $term->Features->{addHistory};
2032 return $got;
2033 }
d338d6fe 2034 local $frame = 0;
ee971a18 2035 local $doret = -2;
363b4d59 2036 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
e4e99f0d 2037 $OUT->write(join('', @_));
363b4d59 2038 my $stuff;
055fd3a9 2039 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
363b4d59 2040 $stuff;
2041 }
2042 else {
2043 $term->readline(@_);
2044 }
d338d6fe 2045}
2046
2047sub dump_option {
2048 my ($opt, $val)= @_;
55497cff 2049 $val = option_val($opt,'N/A');
2050 $val =~ s/([\\\'])/\\$1/g;
2051 printf $OUT "%20s = '%s'\n", $opt, $val;
2052}
2053
2054sub option_val {
2055 my ($opt, $default)= @_;
2056 my $val;
d338d6fe 2057 if (defined $optionVars{$opt}
055fd3a9 2058 and defined ${$optionVars{$opt}}) {
2059 $val = ${$optionVars{$opt}};
d338d6fe 2060 } elsif (defined $optionAction{$opt}
2061 and defined &{$optionAction{$opt}}) {
2062 $val = &{$optionAction{$opt}}();
2063 } elsif (defined $optionAction{$opt}
2064 and not defined $option{$opt}
2065 or defined $optionVars{$opt}
055fd3a9 2066 and not defined ${$optionVars{$opt}}) {
55497cff 2067 $val = $default;
d338d6fe 2068 } else {
2069 $val = $option{$opt};
2070 }
55497cff 2071 $val
d338d6fe 2072}
2073
2074sub parse_options {
2075 local($_)= @_;
055fd3a9 2076 # too dangerous to let intuitive usage overwrite important things
2077 # defaultion should never be the default
2078 my %opt_needs_val = map { ( $_ => 1 ) } qw{
24eeb834 2079 arrayDepth hashDepth LineInfo maxTraceLen ornaments
055fd3a9 2080 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2081 };
2082 while (length) {
2083 my $val_defaulted;
2084 s/^\s+// && next;
2085 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
d338d6fe 2086 my ($opt,$sep) = ($1,$2);
2087 my $val;
2088 if ("?" eq $sep) {
2089 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2090 if /^\S/;
2091 #&dump_option($opt);
2092 } elsif ($sep !~ /\S/) {
055fd3a9 2093 $val_defaulted = 1;
2094 $val = "1"; # this is an evil default; make 'em set it!
d338d6fe 2095 } elsif ($sep eq "=") {
055fd3a9 2096
2097 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2098 my $quote = $1;
2099 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2100 } else {
2101 s/^(\S*)//;
d338d6fe 2102 $val = $1;
055fd3a9 2103 print OUT qq(Option better cleared using $opt=""\n)
2104 unless length $val;
2105 }
2106
d338d6fe 2107 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2108 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2109 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2110 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
055fd3a9 2111 ($val = $1) =~ s/\\([\\$end])/$1/g;
d338d6fe 2112 }
055fd3a9 2113
2114 my $option;
2115 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2116 || grep( /^\Q$opt/i && ($option = $_), @options );
2117
2118 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2119 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2120
2121 if ($opt_needs_val{$option} && $val_defaulted) {
2122 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2123 next;
2124 }
2125
2126 $option{$option} = $val if defined $val;
2127
2128 eval qq{
2129 local \$frame = 0;
2130 local \$doret = -2;
2131 require '$optionRequire{$option}';
2132 1;
2133 } || die # XXX: shouldn't happen
2134 if defined $optionRequire{$option} &&
2135 defined $val;
2136
2137 ${$optionVars{$option}} = $val
2138 if defined $optionVars{$option} &&
2139 defined $val;
2140
2141 &{$optionAction{$option}} ($val)
2142 if defined $optionAction{$option} &&
2143 defined &{$optionAction{$option}} &&
2144 defined $val;
2145
2146 # Not $rcfile
2147 dump_option($option) unless $OUT eq \*STDERR;
d338d6fe 2148 }
2149}
2150
54d04a52 2151sub set_list {
2152 my ($stem,@list) = @_;
2153 my $val;
055fd3a9 2154 $ENV{"${stem}_n"} = @list;
54d04a52 2155 for $i (0 .. $#list) {
2156 $val = $list[$i];
2157 $val =~ s/\\/\\\\/g;
ee971a18 2158 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
055fd3a9 2159 $ENV{"${stem}_$i"} = $val;
54d04a52 2160 }
2161}
2162
2163sub get_list {
2164 my $stem = shift;
2165 my @list;
055fd3a9 2166 my $n = delete $ENV{"${stem}_n"};
54d04a52 2167 my $val;
2168 for $i (0 .. $n - 1) {
055fd3a9 2169 $val = delete $ENV{"${stem}_$i"};
54d04a52 2170 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2171 push @list, $val;
2172 }
2173 @list;
2174}
2175
d338d6fe 2176sub catch {
2177 $signal = 1;
4639966b 2178 return; # Put nothing on the stack - malloc/free land!
d338d6fe 2179}
2180
2181sub warn {
2182 my($msg)= join("",@_);
2183 $msg .= ": $!\n" unless $msg =~ /\n$/;
2184 print $OUT $msg;
2185}
2186
f1583d8f 2187sub reset_IN_OUT {
2188 my $switch_li = $LINEINFO eq $OUT;
2189 if ($term and $term->Features->{newTTY}) {
2190 ($IN, $OUT) = (shift, shift);
2191 $term->newTTY($IN, $OUT);
2192 } elsif ($term) {
2193 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2194 } else {
2195 ($IN, $OUT) = (shift, shift);
2196 }
2197 my $o = select $OUT;
2198 $| = 1;
2199 select $o;
2200 $LINEINFO = $OUT if $switch_li;
2201}
2202
d338d6fe 2203sub TTY {
f36776d9 2204 if (@_ and $term and $term->Features->{newTTY}) {
2205 my ($in, $out) = shift;
2206 if ($in =~ /,/) {
2207 ($in, $out) = split /,/, $in, 2;
2208 } else {
2209 $out = $in;
2210 }
2211 open IN, $in or die "cannot open `$in' for read: $!";
2212 open OUT, ">$out" or die "cannot open `$out' for write: $!";
f1583d8f 2213 reset_IN_OUT(\*IN,\*OUT);
f36776d9 2214 return $tty = $in;
f1583d8f 2215 }
2216 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2217 # Useful if done through PERLDB_OPTS:
43aed9ee 2218 $tty = shift if @_;
d338d6fe 2219 $tty or $console;
2220}
2221
2222sub noTTY {
2223 if ($term) {
43aed9ee 2224 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
d338d6fe 2225 }
43aed9ee 2226 $notty = shift if @_;
d338d6fe 2227 $notty;
2228}
2229
2230sub ReadLine {
2231 if ($term) {
43aed9ee 2232 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
d338d6fe 2233 }
43aed9ee 2234 $rl = shift if @_;
d338d6fe 2235 $rl;
2236}
2237
363b4d59 2238sub RemotePort {
2239 if ($term) {
2240 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2241 }
2242 $remoteport = shift if @_;
2243 $remoteport;
2244}
2245
a737e074 2246sub tkRunning {
055fd3a9 2247 if (${$term->Features}{tkRunning}) {
a737e074 2248 return $term->tkRunning(@_);
2249 } else {
2250 print $OUT "tkRunning not supported by current ReadLine package.\n";
2251 0;
2252 }
2253}
2254
d338d6fe 2255sub NonStop {
2256 if ($term) {
43aed9ee 2257 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
d338d6fe 2258 }
43aed9ee 2259 $runnonstop = shift if @_;
d338d6fe 2260 $runnonstop;
2261}
2262
2263sub pager {
2264 if (@_) {
2265 $pager = shift;
2266 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2267 }
2268 $pager;
2269}
2270
2271sub shellBang {
2272 if (@_) {
2273 $sh = quotemeta shift;
2274 $sh .= "\\b" if $sh =~ /\w$/;
2275 }
2276 $psh = $sh;
2277 $psh =~ s/\\b$//;
2278 $psh =~ s/\\(.)/$1/g;
2279 &sethelp;
2280 $psh;
2281}
2282
7a2e2cd6 2283sub ornaments {
2284 if (defined $term) {
2285 local ($warnLevel,$dieLevel) = (0, 1);
2286 return '' unless $term->Features->{ornaments};
2287 eval { $term->ornaments(@_) } || '';
2288 } else {
2289 $ornaments = shift;
2290 }
2291}
2292
d338d6fe 2293sub recallCommand {
2294 if (@_) {
2295 $rc = quotemeta shift;
2296 $rc .= "\\b" if $rc =~ /\w$/;
2297 }
2298 $prc = $rc;
2299 $prc =~ s/\\b$//;
2300 $prc =~ s/\\(.)/$1/g;
2301 &sethelp;
2302 $prc;
2303}
2304
2305sub LineInfo {
2306 return $lineinfo unless @_;
2307 $lineinfo = shift;
2308 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
055fd3a9 2309 $slave_editor = ($stream =~ /^\|/);
d338d6fe 2310 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2311 $LINEINFO = \*LINEINFO;
2312 my $save = select($LINEINFO);
2313 $| = 1;
2314 select($save);
2315 $lineinfo;
2316}
2317
ee971a18 2318sub list_versions {
2319 my %version;
2320 my $file;
2321 for (keys %INC) {
2322 $file = $_;
2323 s,\.p[lm]$,,i ;
2324 s,/,::,g ;
2325 s/^perl5db$/DB/;
55497cff 2326 s/^Term::ReadLine::readline$/readline/;
055fd3a9 2327 if (defined ${ $_ . '::VERSION' }) {
2328 $version{$file} = "${ $_ . '::VERSION' } from ";
ee971a18 2329 }
2330 $version{$file} .= $INC{$file};
2331 }
2c53b6d0 2332 dumpit($OUT,\%version);
ee971a18 2333}
2334
d338d6fe 2335sub sethelp {
055fd3a9 2336 # XXX: make sure these are tabs between the command and explantion,
2337 # or print_help will screw up your formatting if you have
2338 # eeevil ornaments enabled. This is an insane mess.
2339
d338d6fe 2340 $help = "
6027b9a3 2341B<T> Stack trace.
2342B<s> [I<expr>] Single step [in I<expr>].
2343B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2344<B<CR>> Repeat last B<n> or B<s> command.
2345B<r> Return from current subroutine.
2346B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
55497cff 2347 at the specified position.
6027b9a3 2348B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2349B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2350B<l> I<line> List single I<line>.
2351B<l> I<subname> List first window of lines from subroutine.
3fbd6552 2352B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
6027b9a3 2353B<l> List next window of lines.
2354B<-> List previous window of lines.
2355B<w> [I<line>] List window around I<line>.
2356B<.> Return to the executed line.
bee32ff8 2357B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2358 I<filename> may be either the full name of the file, or a regular
2359 expression matching the full file name:
2360 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2361 Evals (with saved bodies) are considered to be filenames:
2362 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2363 (in the order of execution).
6027b9a3 2364B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2365B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2366B<L> List all breakpoints and actions.
2367B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2368B<t> Toggle trace mode.
2369B<t> I<expr> Trace through execution of I<expr>.
2370B<b> [I<line>] [I<condition>]
2371 Set breakpoint; I<line> defaults to the current execution line;
2372 I<condition> breaks if it evaluates to true, defaults to '1'.
2373B<b> I<subname> [I<condition>]
d338d6fe 2374 Set breakpoint at first line of subroutine.
3fbd6552 2375B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
6027b9a3 2376B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2377B<b> B<postpone> I<subname> [I<condition>]
55497cff 2378 Set breakpoint at first line of subroutine after
2379 it is compiled.
6027b9a3 2380B<b> B<compile> I<subname>
1d06cb2d 2381 Stop after the subroutine is compiled.
6027b9a3 2382B<d> [I<line>] Delete the breakpoint for I<line>.
2383B<D> Delete all breakpoints.
2384B<a> [I<line>] I<command>
3fbd6552 2385 Set an action to be done before the I<line> is executed;
2386 I<line> defaults to the current execution line.
6027b9a3 2387 Sequence is: check for breakpoint/watchpoint, print line
2388 if necessary, do action, prompt user if necessary,
3fbd6552 2389 execute line.
2390B<a> [I<line>] Delete the action for I<line>.
6027b9a3 2391B<A> Delete all actions.
2392B<W> I<expr> Add a global watch-expression.
2393B<W> Delete all watch-expressions.
2394B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2395 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2396B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
91e74348 2397B<x> I<expr> Evals expression in list context, dumps the result.
2398B<m> I<expr> Evals expression in list context, prints methods callable
1d06cb2d 2399 on the first element of the result.
6027b9a3 2400B<m> I<class> Prints methods callable via the given class.
055fd3a9 2401
2402B<<> ? List Perl commands to run before each prompt.
6027b9a3 2403B<<> I<expr> Define Perl command to run before each prompt.
2404B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
055fd3a9 2405B<>> ? List Perl commands to run after each prompt.
6027b9a3 2406B<>> I<expr> Define Perl command to run after each prompt.
3fbd6552 2407B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
6027b9a3 2408B<{> I<db_command> Define debugger command to run before each prompt.
055fd3a9 2409B<{> ? List debugger commands to run before each prompt.
2410B<<> I<expr> Define Perl command to run before each prompt.
6027b9a3 2411B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2412B<$prc> I<number> Redo a previous command (default previous command).
2413B<$prc> I<-number> Redo number'th-to-last command.
2414B<$prc> I<pattern> Redo last command that started with I<pattern>.
2415 See 'B<O> I<recallCommand>' too.
2416B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
d338d6fe 2417 . ( $rc eq $sh ? "" : "
6027b9a3 2418B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2419 See 'B<O> I<shellBang>' too.
2420B<H> I<-number> Display last number commands (default all).
2421B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2422B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2423B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2424B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2425I<command> Execute as a perl statement in current package.
2426B<v> Show versions of loaded modules.
2427B<R> Pure-man-restart of debugger, some of debugger state
55497cff 2428 and command-line options may be lost.
36477c24 2429 Currently the following setting are preserved:
6027b9a3 2430 history, breakpoints and actions, debugger B<O>ptions
2431 and the following command-line options: I<-w>, I<-I>, I<-e>.
055fd3a9 2432
2433B<O> [I<opt>] ... Set boolean option to true
2434B<O> [I<opt>B<?>] Query options
2435B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2436 Set options. Use quotes in spaces in value.
2437 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2438 I<pager> program for output of \"|cmd\";
2439 I<tkRunning> run Tk while prompting (with ReadLine);
2440 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2441 I<inhibit_exit> Allows stepping off the end of the script.
2442 I<ImmediateStop> Debugger should stop as early as possible.
2443 I<RemotePort> Remote hostname:port for remote debugging
2444 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2445 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2446 I<compactDump>, I<veryCompact> change style of array and hash dump;
2447 I<globPrint> whether to print contents of globs;
2448 I<DumpDBFiles> dump arrays holding debugged files;
2449 I<DumpPackages> dump symbol tables of packages;
2450 I<DumpReused> dump contents of \"reused\" addresses;
2451 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2452 I<bareStringify> Do not print the overload-stringified value;
2453 Other options include:
2454 I<PrintRet> affects printing of return value after B<r> command,
2455 I<frame> affects printing messages on entry and exit from subroutines.
2456 I<AutoTrace> affects printing messages on every possible breaking point.
2457 I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
2458 I<ornaments> affects screen appearance of the command line.
f1583d8f 2459 I<CreateTTY> bits control attempts to create a new TTY on events:
2460 1: on fork() 2: debugger is started inside debugger
2461 4: on startup
055fd3a9 2462 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2463 You can put additional initialization options I<TTY>, I<noTTY>,
2464 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2465 `B<R>' after you set them).
2466
2467B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
6027b9a3 2468B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2469B<h h> Summary of debugger commands.
055fd3a9 2470B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2471 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2472 Set B<\$DB::doccmd> to change viewer.
2473
2474Type `|h' for a paged display if this was too hard to read.
2475
2476"; # Fix balance of vi % matching: } }}
d338d6fe 2477
c391288e 2478 # note: tabs in the following section are not-so-helpful
d338d6fe 2479 $summary = <<"END_SUM";
6027b9a3 2480I<List/search source lines:> I<Control script execution:>
2481 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2482 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2483 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
d9f67849 2484 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
6027b9a3 2485 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
c391288e 2486 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
6027b9a3 2487I<Debugger controls:> B<L> List break/watch/actions
2488 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
d9f67849 2489 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
6027b9a3 2490 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2491 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2492 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2493 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
d9f67849 2494 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
c391288e 2495 B<q> or B<^D> Quit B<R> Attempt a restart
2496I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2497 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2498 B<p> I<expr> Print expression (uses script's current package).
2499 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2500 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2501 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
055fd3a9 2502For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
d338d6fe 2503END_SUM
055fd3a9 2504 # ')}}; # Fix balance of vi % matching
d338d6fe 2505}
2506
6027b9a3 2507sub print_help {
055fd3a9 2508 local $_ = shift;
2509
2510 # Restore proper alignment destroyed by eeevil I<> and B<>
2511 # ornaments: A pox on both their houses!
2512 #
2513 # A help command will have everything up to and including
2514 # the first tab sequence paddeed into a field 16 (or if indented 20)
2515 # wide. If it's wide than that, an extra space will be added.
2516 s{
2517 ^ # only matters at start of line
2518 ( \040{4} | \t )* # some subcommands are indented
2519 ( < ? # so <CR> works
2520 [BI] < [^\t\n] + ) # find an eeevil ornament
2521 ( \t+ ) # original separation, discarded
2522 ( .* ) # this will now start (no earlier) than
2523 # column 16
2524 } {
2525 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2526 my $clean = $command;
2527 $clean =~ s/[BI]<([^>]*)>/$1/g;
2528 # replace with this whole string:
2529 (length($leadwhite) ? " " x 4 : "")
2530 . $command
2531 . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ")
2532 . $text;
2533
2534 }mgex;
2535
2536 s{ # handle bold ornaments
2537 B < ( [^>] + | > ) >
2538 } {
2539 $Term::ReadLine::TermCap::rl_term_set[2]
2540 . $1
2541 . $Term::ReadLine::TermCap::rl_term_set[3]
2542 }gex;
2543
2544 s{ # handle italic ornaments
2545 I < ( [^>] + | > ) >
2546 } {
2547 $Term::ReadLine::TermCap::rl_term_set[0]
2548 . $1
2549 . $Term::ReadLine::TermCap::rl_term_set[1]
2550 }gex;
2551
2552 print $OUT $_;
2553}
2554
2555sub fix_less {
2556 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2557 my $is_less = $pager =~ /\bless\b/;
2558 if ($pager =~ /\bmore\b/) {
2559 my @st_more = stat('/usr/bin/more');
2560 my @st_less = stat('/usr/bin/less');
2561 $is_less = @st_more && @st_less
2562 && $st_more[0] == $st_less[0]
2563 && $st_more[1] == $st_less[1];
2564 }
2565 # changes environment!
2566 $ENV{LESS} .= 'r' if $is_less;
6027b9a3 2567}
2568
d338d6fe 2569sub diesignal {
54d04a52 2570 local $frame = 0;
ee971a18 2571 local $doret = -2;
77fb7b16 2572 $SIG{'ABRT'} = 'DEFAULT';
d338d6fe 2573 kill 'ABRT', $$ if $panic++;
ee85b803 2574 if (defined &Carp::longmess) {
2575 local $SIG{__WARN__} = '';
2576 local $Carp::CarpLevel = 2; # mydie + confess
2577 &warn(Carp::longmess("Signal @_"));
2578 }
2579 else {
2580 print $DB::OUT "Got signal @_\n";
2581 }
d338d6fe 2582 kill 'ABRT', $$;
2583}
2584
2585sub dbwarn {
54d04a52 2586 local $frame = 0;
ee971a18 2587 local $doret = -2;
d338d6fe 2588 local $SIG{__WARN__} = '';
77fb7b16 2589 local $SIG{__DIE__} = '';
fb73857a 2590 eval { require Carp } if defined $^S; # If error/warning during compilation,
2591 # require may be broken.
2592 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
2593 return unless defined &Carp::longmess;
d338d6fe 2594 my ($mysingle,$mytrace) = ($single,$trace);
2595 $single = 0; $trace = 0;
2596 my $mess = Carp::longmess(@_);
2597 ($single,$trace) = ($mysingle,$mytrace);
d338d6fe 2598 &warn($mess);
d338d6fe 2599}
2600
2601sub dbdie {
54d04a52 2602 local $frame = 0;
ee971a18 2603 local $doret = -2;
d338d6fe 2604 local $SIG{__DIE__} = '';
2605 local $SIG{__WARN__} = '';
2606 my $i = 0; my $ineval = 0; my $sub;
fb73857a 2607 if ($dieLevel > 2) {
d338d6fe 2608 local $SIG{__WARN__} = \&dbwarn;
fb73857a 2609 &warn(@_); # Yell no matter what
2610 return;
2611 }
2612 if ($dieLevel < 2) {
2613 die @_ if $^S; # in eval propagate
d338d6fe 2614 }
fb73857a 2615 eval { require Carp } if defined $^S; # If error/warning during compilation,
2616 # require may be broken.
055fd3a9 2617
fb73857a 2618 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2619 unless defined &Carp::longmess;
055fd3a9 2620
d338d6fe 2621 # We do not want to debug this chunk (automatic disabling works
2622 # inside DB::DB, but not in Carp).
2623 my ($mysingle,$mytrace) = ($single,$trace);
2624 $single = 0; $trace = 0;
2625 my $mess = Carp::longmess(@_);
2626 ($single,$trace) = ($mysingle,$mytrace);
d338d6fe 2627 die $mess;
2628}
2629
d338d6fe 2630sub warnLevel {
2631 if (@_) {
2632 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2633 $warnLevel = shift;
2634 if ($warnLevel) {
0b7ed949 2635 $SIG{__WARN__} = \&DB::dbwarn;
d338d6fe 2636 } else {
2637 $SIG{__WARN__} = $prevwarn;
2638 }
2639 }
2640 $warnLevel;
2641}
2642
2643sub dieLevel {
2644 if (@_) {
2645 $prevdie = $SIG{__DIE__} unless $dieLevel;
2646 $dieLevel = shift;
2647 if ($dieLevel) {
0b7ed949 2648 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2649 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
d338d6fe 2650 print $OUT "Stack dump during die enabled",
43aed9ee 2651 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2652 if $I_m_init;
d338d6fe 2653 print $OUT "Dump printed too.\n" if $dieLevel > 2;
2654 } else {
2655 $SIG{__DIE__} = $prevdie;
2656 print $OUT "Default die handler restored.\n";
2657 }
2658 }
2659 $dieLevel;
2660}
2661
2662sub signalLevel {
2663 if (@_) {
2664 $prevsegv = $SIG{SEGV} unless $signalLevel;
2665 $prevbus = $SIG{BUS} unless $signalLevel;
2666 $signalLevel = shift;
2667 if ($signalLevel) {
77fb7b16 2668 $SIG{SEGV} = \&DB::diesignal;
2669 $SIG{BUS} = \&DB::diesignal;
d338d6fe 2670 } else {
2671 $SIG{SEGV} = $prevsegv;
2672 $SIG{BUS} = $prevbus;
2673 }
2674 }
2675 $signalLevel;
2676}
2677
83ee9e09 2678sub CvGV_name {
2679 my $in = shift;
2680 my $name = CvGV_name_or_bust($in);
2681 defined $name ? $name : $in;
2682}
2683
2684sub CvGV_name_or_bust {
2685 my $in = shift;
2686 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2687 $in = \&$in; # Hard reference...
2688 eval {require Devel::Peek; 1} or return;
2689 my $gv = Devel::Peek::CvGV($in) or return;
2690 *$gv{PACKAGE} . '::' . *$gv{NAME};
2691}
2692
1d06cb2d 2693sub find_sub {
2694 my $subr = shift;
1d06cb2d 2695 $sub{$subr} or do {
83ee9e09 2696 return unless defined &$subr;
2697 my $name = CvGV_name_or_bust($subr);
2698 my $data;
2699 $data = $sub{$name} if defined $name;
2700 return $data if defined $data;
2701
2702 # Old stupid way...
1d06cb2d 2703 $subr = \&$subr; # Hard reference
2704 my $s;
2705 for (keys %sub) {
2706 $s = $_, last if $subr eq \&$_;
2707 }
2708 $sub{$s} if $s;
2709 }
2710}
2711
2712sub methods {
2713 my $class = shift;
2714 $class = ref $class if ref $class;
2715 local %seen;
2716 local %packs;
2717 methods_via($class, '', 1);
2718 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2719}
2720
2721sub methods_via {
2722 my $class = shift;
2723 return if $packs{$class}++;
2724 my $prefix = shift;
2725 my $prepend = $prefix ? "via $prefix: " : '';
2726 my $name;
055fd3a9 2727 for $name (grep {defined &{${"${class}::"}{$_}}}
2728 sort keys %{"${class}::"}) {
477ea2b1 2729 next if $seen{ $name }++;
1d06cb2d 2730 print $DB::OUT "$prepend$name\n";
2731 }
2732 return unless shift; # Recurse?
055fd3a9 2733 for $name (@{"${class}::ISA"}) {
1d06cb2d 2734 $prepend = $prefix ? $prefix . " -> $name" : $name;
2735 methods_via($name, $prepend, 1);
2736 }
2737}
2738
055fd3a9 2739sub setman {
2740 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s
2741 ? "man" # O Happy Day!
2742 : "perldoc"; # Alas, poor unfortunates
2743}
2744
2745sub runman {
2746 my $page = shift;
2747 unless ($page) {
2748 &system("$doccmd $doccmd");
2749 return;
2750 }
2751 # this way user can override, like with $doccmd="man -Mwhatever"
2752 # or even just "man " to disable the path check.
2753 unless ($doccmd eq 'man') {
2754 &system("$doccmd $page");
2755 return;
2756 }
2757
2758 $page = 'perl' if lc($page) eq 'help';
2759
2760 require Config;
2761 my $man1dir = $Config::Config{'man1dir'};
2762 my $man3dir = $Config::Config{'man3dir'};
2763 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2764 my $manpath = '';
2765 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2766 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2767 chop $manpath if $manpath;
2768 # harmless if missing, I figure
2769 my $oldpath = $ENV{MANPATH};
2770 $ENV{MANPATH} = $manpath if $manpath;
2771 my $nopathopt = $^O =~ /dunno what goes here/;
2772 if (system($doccmd,
2773 # I just *know* there are men without -M
2774 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2775 split ' ', $page) )
2776 {
2777 unless ($page =~ /^perl\w/) {
2778 if (grep { $page eq $_ } qw{
2779 5004delta 5005delta amiga api apio book boot bot call compile
2780 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2781 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2782 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2783 modinstall modlib number obj op opentut os2 os390 pod port
2784 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2785 trap unicode var vms win32 xs xstut
2786 })
2787 {
2788 $page =~ s/^/perl/;
2789 system($doccmd,
2790 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2791 $page);
2792 }
2793 }
2794 }
2795 if (defined $oldpath) {
2796 $ENV{MANPATH} = $manpath;
2797 } else {
2798 delete $ENV{MANPATH};
2799 }
2800}
2801
d338d6fe 2802# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2803
2804BEGIN { # This does not compile, alas.
2805 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2806 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2807 $sh = '!';
2808 $rc = ',';
2809 @hist = ('?');
2810 $deep = 100; # warning if stack gets this deep
2811 $window = 10;
2812 $preview = 3;
2813 $sub = '';
77fb7b16 2814 $SIG{INT} = \&DB::catch;
ee971a18 2815 # This may be enabled to debug debugger:
2816 #$warnLevel = 1 unless defined $warnLevel;
2817 #$dieLevel = 1 unless defined $dieLevel;
2818 #$signalLevel = 1 unless defined $signalLevel;
d338d6fe 2819
2820 $db_stop = 0; # Compiler warning
2821 $db_stop = 1 << 30;
2822 $level = 0; # Level of recursive debugging
55497cff 2823 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2824 # Triggers bug (?) in perl is we postpone this until runtime:
2825 @postponed = @stack = (0);
f8b5b99c 2826 $stack_depth = 0; # Localized $#stack
55497cff 2827 $doret = -2;
2828 $frame = 0;
d338d6fe 2829}
2830
54d04a52 2831BEGIN {$^W = $ini_warn;} # Switch warnings back
2832
d338d6fe 2833#use Carp; # This did break, left for debuggin
2834
55497cff 2835sub db_complete {
08a4aec0 2836 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
55497cff 2837 my($text, $line, $start) = @_;
477ea2b1 2838 my ($itext, $search, $prefix, $pack) =
055fd3a9 2839 ($text, "^\Q${'package'}::\E([^:]+)\$");
55497cff 2840
08a4aec0 2841 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2842 (map { /$search/ ? ($1) : () } keys %sub)
2843 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2844 return sort grep /^\Q$text/, values %INC # files
477ea2b1 2845 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
08a4aec0 2846 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2847 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2848 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2849 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2850 grep !/^main::/,
2851 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2852 # packages
2853 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2854 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
477ea2b1 2855 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2856 # We may want to complete to (eval 9), so $text may be wrong
2857 $prefix = length($1) - length($text);
2858 $text = $1;
08a4aec0 2859 return sort
2860 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
477ea2b1 2861 }
55497cff 2862 if ((substr $text, 0, 1) eq '&') { # subroutines
2863 $text = substr $text, 1;
2864 $prefix = "&";
08a4aec0 2865 return sort map "$prefix$_",
2866 grep /^\Q$text/,
2867 (keys %sub),
2868 (map { /$search/ ? ($1) : () }
2869 keys %sub);
55497cff 2870 }
2871 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2872 $pack = ($1 eq 'main' ? '' : $1) . '::';
2873 $prefix = (substr $text, 0, 1) . $1 . '::';
2874 $text = $2;
2875 my @out
2876 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2877 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2878 return db_complete($out[0], $line, $start);
2879 }
08a4aec0 2880 return sort @out;
55497cff 2881 }
2882 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2883 $pack = ($package eq 'main' ? '' : $package) . '::';
2884 $prefix = substr $text, 0, 1;
2885 $text = substr $text, 1;
2886 my @out = map "$prefix$_", grep /^\Q$text/,
2887 (grep /^_?[a-zA-Z]/, keys %$pack),
2888 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2889 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2890 return db_complete($out[0], $line, $start);
2891 }
08a4aec0 2892 return sort @out;
55497cff 2893 }
477ea2b1 2894 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
55497cff 2895 my @out = grep /^\Q$text/, @options;
2896 my $val = option_val($out[0], undef);
2897 my $out = '? ';
2898 if (not defined $val or $val =~ /[\n\r]/) {
2899 # Can do nothing better
2900 } elsif ($val =~ /\s/) {
2901 my $found;
2902 foreach $l (split //, qq/\"\'\#\|/) {
2903 $out = "$l$val$l ", last if (index $val, $l) == -1;
2904 }
2905 } else {
2906 $out = "=$val ";
2907 }
2908 # Default to value if one completion, to question if many
a737e074 2909 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
08a4aec0 2910 return sort @out;
55497cff 2911 }
a737e074 2912 return $term->filename_list($text); # filenames
55497cff 2913}
2914
43aed9ee 2915sub end_report {
2916 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2917}
4639966b 2918
55497cff 2919END {
20928eff 2920 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
2921 $fall_off_end = 1 unless $inhibit_exit;
36477c24 2922 # Do not stop in at_exit() and destructors on exit:
20928eff 2923 $DB::single = !$fall_off_end && !$runnonstop;
2924 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
55497cff 2925}
2926
2927package DB::fake;
2928
2929sub at_exit {
43aed9ee 2930 "Debugged program terminated. Use `q' to quit or `R' to restart.";
55497cff 2931}
2932
36477c24 2933package DB; # Do not trace this 1; below!
2934
d338d6fe 29351;
Unnamed repository; edit this file to name it for gitweb.