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