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