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