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