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