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