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