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