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