projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
NetWare tweaks from Guruprasad.
[p5sagit/p5-mst-13.2.git] / lib / perl5db.pl
CommitLineData
a687059c 1package DB;
2
54d04a52 3# Debugger for Perl 5.00x; perl5db.pl patch level:
d338d6fe 4
6f891d7d 5$VERSION = 1.13;
43aed9ee 6$header = "perl5db.pl version $VERSION";
d338d6fe 7
d338d6fe 8#
9# This file is automatically included if you do perl -d.
10# It's probably not useful to include this yourself.
11#
36477c24 12# Perl supplies the values for %sub. It effectively inserts
13# a &DB'DB(); in front of every place that can have a
d338d6fe 14# breakpoint. Instead of a subroutine call it calls &DB::sub with
15# $DB::sub being the called subroutine. It also inserts a BEGIN
16# {require 'perl5db.pl'} before the first line.
17#
55497cff 18# After each `require'd file is compiled, but before it is executed, a
477ea2b1 19# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
55497cff 20# $filename is the expanded name of the `require'd file (as found as
21# value of %INC).
22#
23# Additional services from Perl interpreter:
24#
25# if caller() is called from the package DB, it provides some
26# additional data.
27#
f5d3a858 28# The array @{$main::{'_<'.$filename}} is the line-by-line contents of
55497cff 29# $filename.
30#
477ea2b1 31# The hash %{'_<'.$filename} contains breakpoints and action (it is
55497cff 32# keyed by line number), and individual entries are settable (as
33# opposed to the whole hash). Only true/false is important to the
34# interpreter, though the values used by perl5db.pl have the form
35# "$break_condition\0$action". Values are magical in numeric context.
36#
51ee6500 37# The scalar ${'_<'.$filename} contains $filename.
55497cff 38#
d338d6fe 39# Note that no subroutine call is possible until &DB::sub is defined
36477c24 40# (for subroutines defined outside of the package DB). In fact the same is
d338d6fe 41# true if $deep is not defined.
42#
43# $Log: perldb.pl,v $
44
45#
46# At start reads $rcfile that may set important options. This file
47# may define a subroutine &afterinit that will be executed after the
48# debugger is initialized.
49#
50# After $rcfile is read reads environment variable PERLDB_OPTS and parses
51# it as a rest of `O ...' line in debugger prompt.
52#
53# The options that can be specified only at startup:
54# [To set in $rcfile, call &parse_options("optionName=new_value").]
55#
56# TTY - the TTY to use for debugging i/o.
57#
58# noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
59# uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
60# Term::Rendezvous. Current variant is to have the name of TTY in this
61# file.
62#
63# ReadLine - If false, dummy ReadLine is used, so you can debug
64# ReadLine applications.
65#
66# NonStop - if true, no i/o is performed until interrupt.
67#
68# LineInfo - file or pipe to print line number info to. If it is a
69# pipe, a short "emacs like" message is used.
70#
363b4d59 71# RemotePort - host:port to connect to on remote host for remote debugging.
72#
d338d6fe 73# Example $rcfile: (delete leading hashes!)
74#
75# &parse_options("NonStop=1 LineInfo=db.out");
76# sub afterinit { $trace = 1; }
77#
78# The script will run without human intervention, putting trace
79# information into db.out. (If you interrupt it, you would better
80# reset LineInfo to something "interactive"!)
81#
ee971a18 82##################################################################
055fd3a9 83
84# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
055fd3a9 85
86# modified Perl debugger, to be run from Emacs in perldb-mode
87# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
88# Johan Vromans -- upgrade to 4.0 pl 10
89# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
90
ee971a18 91# Changelog:
92
93# A lot of things changed after 0.94. First of all, core now informs
94# debugger about entry into XSUBs, overloaded operators, tied operations,
95# BEGIN and END. Handy with `O f=2'.
96
97# This can make debugger a little bit too verbose, please be patient
98# and report your problems promptly.
99
100# Now the option frame has 3 values: 0,1,2.
101
102# Note that if DESTROY returns a reference to the object (or object),
103# the deletion of data may be postponed until the next function call,
104# due to the need to examine the return value.
105
55497cff 106# Changes: 0.95: `v' command shows versions.
107# Changes: 0.96: `v' command shows version of readline.
108# primitive completion works (dynamic variables, subs for `b' and `l',
109# options). Can `p %var'
110# Better help (`h <' now works). New commands <<, >>, {, {{.
111# {dump|print}_trace() coded (to be able to do it from <<cmd).
112# `c sub' documented.
113# At last enough magic combined to stop after the end of debuggee.
114# !! should work now (thanks to Emacs bracket matching an extra
115# `]' in a regexp is caught).
116# `L', `D' and `A' span files now (as documented).
117# Breakpoints in `require'd code are possible (used in `R').
118# Some additional words on internal work of debugger.
119# `b load filename' implemented.
120# `b postpone subr' implemented.
04e43a21 121# now only `q' exits debugger (overwritable on $inhibit_exit).
55497cff 122# When restarting debugger breakpoints/actions persist.
123# Buglet: When restarting debugger only one breakpoint/action per
124# autoloaded function persists.
36477c24 125# Changes: 0.97: NonStop will not stop in at_exit().
126# Option AutoTrace implemented.
127# Trace printed differently if frames are printed too.
1d06cb2d 128# new `inhibitExit' option.
129# printing of a very long statement interruptible.
130# Changes: 0.98: New command `m' for printing possible methods
04e43a21 131# 'l -' is a synonym for `-'.
1d06cb2d 132# Cosmetic bugs in printing stack trace.
133# `frame' & 8 to print "expanded args" in stack trace.
134# Can list/break in imported subs.
135# new `maxTraceLen' option.
136# frame & 4 and frame & 8 granted.
137# new command `m'
138# nonstoppable lines do not have `:' near the line number.
139# `b compile subname' implemented.
140# Will not use $` any more.
141# `-' behaves sane now.
477ea2b1 142# Changes: 0.99: Completion for `f', `m'.
143# `m' will remove duplicate names instead of duplicate functions.
144# `b load' strips trailing whitespace.
145# completion ignores leading `|'; takes into account current package
146# when completing a subroutine name (same for `l').
055fd3a9 147# Changes: 1.07: Many fixed by tchrist 13-March-2000
148# BUG FIXES:
04e43a21 149# + Added bare minimal security checks on perldb rc files, plus
055fd3a9 150# comments on what else is needed.
151# + Fixed the ornaments that made "|h" completely unusable.
152# They are not used in print_help if they will hurt. Strip pod
153# if we're paging to less.
154# + Fixed mis-formatting of help messages caused by ornaments
155# to restore Larry's original formatting.
156# + Fixed many other formatting errors. The code is still suboptimal,
04e43a21 157# and needs a lot of work at restructuring. It's also misindented
055fd3a9 158# in many places.
159# + Fixed bug where trying to look at an option like your pager
160# shows "1".
161# + Fixed some $? processing. Note: if you use csh or tcsh, you will
162# lose. You should consider shell escapes not using their shell,
163# or else not caring about detailed status. This should really be
164# unified into one place, too.
165# + Fixed bug where invisible trailing whitespace on commands hoses you,
04e43a21 166# tricking Perl into thinking you weren't calling a debugger command!
055fd3a9 167# + Fixed bug where leading whitespace on commands hoses you. (One
168# suggests a leading semicolon or any other irrelevant non-whitespace
169# to indicate literal Perl code.)
170# + Fixed bugs that ate warnings due to wrong selected handle.
171# + Fixed a precedence bug on signal stuff.
172# + Fixed some unseemly wording.
173# + Fixed bug in help command trying to call perl method code.
174# + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
175# ENHANCEMENTS:
176# + Added some comments. This code is still nasty spaghetti.
177# + Added message if you clear your pre/post command stacks which was
178# very easy to do if you just typed a bare >, <, or {. (A command
179# without an argument should *never* be a destructive action; this
180# API is fundamentally screwed up; likewise option setting, which
181# is equally buggered.)
182# + Added command stack dump on argument of "?" for >, <, or {.
183# + Added a semi-built-in doc viewer command that calls man with the
184# proper %Config::Config path (and thus gets caching, man -k, etc),
185# or else perldoc on obstreperous platforms.
186# + Added to and rearranged the help information.
187# + Detected apparent misuse of { ... } to declare a block; this used
188# to work but now is a command, and mysteriously gave no complaint.
04e43a21 189#
190# Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
191# BUG FIX:
192# + This patch to perl5db.pl cleans up formatting issues on the help
193# summary (h h) screen in the debugger. Mostly columnar alignment
194# issues, plus converted the printed text to use all spaces, since
195# tabs don't seem to help much here.
196#
197# Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
198# 0) Minor bugs corrected;
199# a) Support for auto-creation of new TTY window on startup, either
200# unconditionally, or if started as a kid of another debugger session;
201# b) New `O'ption CreateTTY
202# I<CreateTTY> bits control attempts to create a new TTY on events:
203# 1: on fork() 2: debugger is started inside debugger
204# 4: on startup
205# c) Code to auto-create a new TTY window on OS/2 (currently one one
206# extra window per session - need named pipes to have more...);
207# d) Simplified interface for custom createTTY functions (with a backward
208# compatibility hack); now returns the TTY name to use; return of ''
209# means that the function reset the I/O handles itself;
210# d') Better message on the semantic of custom createTTY function;
211# e) Convert the existing code to create a TTY into a custom createTTY
212# function;
213# f) Consistent support for TTY names of the form "TTYin,TTYout";
214# g) Switch line-tracing output too to the created TTY window;
215# h) make `b fork' DWIM with CORE::GLOBAL::fork;
216# i) High-level debugger API cmd_*():
217# cmd_b_load($filenamepart) # b load filenamepart
218# cmd_b_line($lineno [, $cond]) # b lineno [cond]
219# cmd_b_sub($sub [, $cond]) # b sub [cond]
220# cmd_stop() # Control-C
221# cmd_d($lineno) # d lineno
222# The cmd_*() API returns FALSE on failure; in this case it outputs
223# the error message to the debugging output.
224# j) Low-level debugger API
225# break_on_load($filename) # b load filename
226# @files = report_break_on_load() # List files with load-breakpoints
227# breakable_line_in_filename($name, $from [, $to])
228# # First breakable line in the
229# # range $from .. $to. $to defaults
230# # to $from, and may be less than $to
231# breakable_line($from [, $to]) # Same for the current file
232# break_on_filename_line($name, $lineno [, $cond])
233# # Set breakpoint,$cond defaults to 1
234# break_on_filename_line_range($name, $from, $to [, $cond])
235# # As above, on the first
236# # breakable line in range
237# break_on_line($lineno [, $cond]) # As above, in the current file
238# break_subroutine($sub [, $cond]) # break on the first breakable line
239# ($name, $from, $to) = subroutine_filename_lines($sub)
240# # The range of lines of the text
241# The low-level API returns TRUE on success, and die()s on failure.
242#
243# Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
244# BUG FIXES:
245# + Fixed warnings generated by "perl -dWe 42"
246# + Corrected spelling errors
247# + Squeezed Help (h) output into 80 columns
600d99fa 248#
249# Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
250# + Made "x @INC" work like it used to
251#
252# Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
253# + Fixed warnings generated by "O" (Show debugger options)
254# + Fixed warnings generated by "p 42" (Print expression)
6f891d7d 255# Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
256# + Added windowSize option
ee971a18 257####################################################################
d338d6fe 258
54d04a52 259# Needed for the statement after exec():
d338d6fe 260
54d04a52 261BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
262local($^W) = 0; # Switch run-time warnings off during init.
d338d6fe 263warn ( # Do not ;-)
264 $dumpvar::hashDepth,
265 $dumpvar::arrayDepth,
266 $dumpvar::dumpDBFiles,
267 $dumpvar::dumpPackages,
268 $dumpvar::quoteHighBit,
269 $dumpvar::printUndef,
270 $dumpvar::globPrint,
d338d6fe 271 $dumpvar::usageOnly,
272 @ARGS,
273 $Carp::CarpLevel,
54d04a52 274 $panic,
36477c24 275 $second_time,
d338d6fe 276 ) if 0;
277
54d04a52 278# Command-line + PERLLIB:
279@ini_INC = @INC;
280
d338d6fe 281# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
282
283$trace = $signal = $single = 0; # Uninitialized warning suppression
284 # (local $^W cannot help - other packages!).
55497cff 285$inhibit_exit = $option{PrintRet} = 1;
d338d6fe 286
22fae026 287@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
d338d6fe 288 compactDump veryCompact quote HighBit undefPrint
36477c24 289 globPrint PrintRet UsageOnly frame AutoTrace
1d06cb2d 290 TTY noTTY ReadLine NonStop LineInfo maxTraceLen
7a2e2cd6 291 recallCommand ShellBang pager tkRunning ornaments
3aefca04 292 signalLevel warnLevel dieLevel inhibit_exit
f1583d8f 293 ImmediateStop bareStringify CreateTTY
6f891d7d 294 RemotePort windowSize);
d338d6fe 295
296%optionVars = (
297 hashDepth => \$dumpvar::hashDepth,
298 arrayDepth => \$dumpvar::arrayDepth,
299 DumpDBFiles => \$dumpvar::dumpDBFiles,
300 DumpPackages => \$dumpvar::dumpPackages,
22fae026 301 DumpReused => \$dumpvar::dumpReused,
d338d6fe 302 HighBit => \$dumpvar::quoteHighBit,
303 undefPrint => \$dumpvar::printUndef,
304 globPrint => \$dumpvar::globPrint,
f1583d8f 305 UsageOnly => \$dumpvar::usageOnly,
306 CreateTTY => \$CreateTTY,
ee239bfe 307 bareStringify => \$dumpvar::bareStringify,
36477c24 308 frame => \$frame,
309 AutoTrace => \$trace,
310 inhibit_exit => \$inhibit_exit,
1d06cb2d 311 maxTraceLen => \$maxtrace,
3aefca04 312 ImmediateStop => \$ImmediateStop,
363b4d59 313 RemotePort => \$remoteport,
6f891d7d 314 windowSize => \$window,
d338d6fe 315);
316
317%optionAction = (
318 compactDump => \&dumpvar::compactDump,
319 veryCompact => \&dumpvar::veryCompact,
320 quote => \&dumpvar::quote,
321 TTY => \&TTY,
322 noTTY => \&noTTY,
323 ReadLine => \&ReadLine,
324 NonStop => \&NonStop,
325 LineInfo => \&LineInfo,
326 recallCommand => \&recallCommand,
327 ShellBang => \&shellBang,
328 pager => \&pager,
329 signalLevel => \&signalLevel,
330 warnLevel => \&warnLevel,
331 dieLevel => \&dieLevel,
a737e074 332 tkRunning => \&tkRunning,
7a2e2cd6 333 ornaments => \&ornaments,
363b4d59 334 RemotePort => \&RemotePort,
d338d6fe 335 );
336
337%optionRequire = (
338 compactDump => 'dumpvar.pl',
339 veryCompact => 'dumpvar.pl',
340 quote => 'dumpvar.pl',
341 );
342
343# These guys may be defined in $ENV{PERL5DB} :
4c82ae22 344$rl = 1 unless defined $rl;
345$warnLevel = 0 unless defined $warnLevel;
346$dieLevel = 0 unless defined $dieLevel;
347$signalLevel = 1 unless defined $signalLevel;
348$pre = [] unless defined $pre;
349$post = [] unless defined $post;
350$pretype = [] unless defined $pretype;
f1583d8f 351$CreateTTY = 3 unless defined $CreateTTY;
055fd3a9 352
d338d6fe 353warnLevel($warnLevel);
354dieLevel($dieLevel);
355signalLevel($signalLevel);
055fd3a9 356
357&pager(
358 (defined($ENV{PAGER})
65c9c81d 359 ? $ENV{PAGER}
360 : ($^O eq 'os2'
361 ? 'cmd /c more'
362 : 'more'))) unless defined $pager;
055fd3a9 363setman();
d338d6fe 364&recallCommand("!") unless defined $prc;
365&shellBang("!") unless defined $psh;
04e43a21 366sethelp();
1d06cb2d 367$maxtrace = 400 unless defined $maxtrace;
f1583d8f 368$ini_pids = $ENV{PERLDB_PIDS};
369if (defined $ENV{PERLDB_PIDS}) {
370 $pids = "[$ENV{PERLDB_PIDS}]";
371 $ENV{PERLDB_PIDS} .= "->$$";
372 $term_pid = -1;
373} else {
374 $ENV{PERLDB_PIDS} = "$$";
375 $pids = '';
376 $term_pid = $$;
377}
378$pidprompt = '';
04e43a21 379*emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
d338d6fe 380
055fd3a9 381if (-e "/dev/tty") { # this is the wrong metric!
d338d6fe 382 $rcfile=".perldb";
383} else {
384 $rcfile="perldb.ini";
385}
386
055fd3a9 387# This isn't really safe, because there's a race
388# between checking and opening. The solution is to
389# open and fstat the handle, but then you have to read and
390# eval the contents. But then the silly thing gets
391# your lexical scope, which is unfortunately at best.
392sub safe_do {
393 my $file = shift;
394
395 # Just exactly what part of the word "CORE::" don't you understand?
396 local $SIG{__WARN__};
397 local $SIG{__DIE__};
398
399 unless (is_safe_file($file)) {
400 CORE::warn <<EO_GRIPE;
401perldb: Must not source insecure rcfile $file.
402 You or the superuser must be the owner, and it must not
403 be writable by anyone but its owner.
404EO_GRIPE
405 return;
406 }
407
408 do $file;
409 CORE::warn("perldb: couldn't parse $file: $@") if $@;
410}
411
412
413# Verifies that owner is either real user or superuser and that no
414# one but owner may write to it. This function is of limited use
415# when called on a path instead of upon a handle, because there are
416# no guarantees that filename (by dirent) whose file (by ino) is
417# eventually accessed is the same as the one tested.
418# Assumes that the file's existence is not in doubt.
419sub is_safe_file {
420 my $path = shift;
421 stat($path) || return; # mysteriously vaporized
422 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
423
424 return 0 if $uid != 0 && $uid != $<;
425 return 0 if $mode & 022;
426 return 1;
427}
428
d338d6fe 429if (-f $rcfile) {
055fd3a9 430 safe_do("./$rcfile");
431}
432elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
433 safe_do("$ENV{HOME}/$rcfile");
434}
435elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
436 safe_do("$ENV{LOGDIR}/$rcfile");
d338d6fe 437}
438
439if (defined $ENV{PERLDB_OPTS}) {
440 parse_options($ENV{PERLDB_OPTS});
441}
442
f1583d8f 443if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
444 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
445 *get_fork_TTY = \&xterm_get_fork_TTY;
446} elsif ($^O eq 'os2') {
447 *get_fork_TTY = \&os2_get_fork_TTY;
448}
449
055fd3a9 450# Here begin the unreadable code. It needs fixing.
451
54d04a52 452if (exists $ENV{PERLDB_RESTART}) {
453 delete $ENV{PERLDB_RESTART};
454 # $restart = 1;
455 @hist = get_list('PERLDB_HIST');
55497cff 456 %break_on_load = get_list("PERLDB_ON_LOAD");
457 %postponed = get_list("PERLDB_POSTPONE");
458 my @had_breakpoints= get_list("PERLDB_VISITED");
459 for (0 .. $#had_breakpoints) {
0c395bd7 460 my %pf = get_list("PERLDB_FILE_$_");
461 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
54d04a52 462 }
463 my %opt = get_list("PERLDB_OPT");
464 my ($opt,$val);
465 while (($opt,$val) = each %opt) {
466 $val =~ s/[\\\']/\\$1/g;
467 parse_options("$opt'$val'");
468 }
469 @INC = get_list("PERLDB_INC");
470 @ini_INC = @INC;
43aed9ee 471 $pretype = [get_list("PERLDB_PRETYPE")];
472 $pre = [get_list("PERLDB_PRE")];
473 $post = [get_list("PERLDB_POST")];
474 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
54d04a52 475}
476
d338d6fe 477if ($notty) {
478 $runnonstop = 1;
479} else {
055fd3a9 480 # Is Perl being run from a slave editor or graphical debugger?
481 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
482 $rl = 0, shift(@main::ARGV) if $slave_editor;
d338d6fe 483
484 #require Term::ReadLine;
485
4fabb596 486 if ($^O eq 'cygwin') {
8736538c 487 # /dev/tty is binary. use stdin for textmode
488 undef $console;
489 } elsif (-e "/dev/tty") {
d338d6fe 490 $console = "/dev/tty";
39e571d4 491 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
d338d6fe 492 $console = "con";
6d697788 493 } elsif ($^O eq 'MacOS') {
494 if ($MacPerl::Version !~ /MPW/) {
495 $console = "Dev:Console:Perl Debug"; # Separate window for application
496 } else {
497 $console = "Dev:Console";
498 }
d338d6fe 499 } else {
500 $console = "sys\$command";
501 }
502
055fd3a9 503 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
96774cc9 504 $console = undef;
505 }
506
2986a63f 507 if ($^O eq 'NetWare') {
508 $console = undef;
509 }
510
d338d6fe 511 # Around a bug:
055fd3a9 512 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
d338d6fe 513 $console = undef;
514 }
515
4d2c4e07 516 if ($^O eq 'epoc') {
517 $console = undef;
518 }
519
d338d6fe 520 $console = $tty if defined $tty;
521
363b4d59 522 if (defined $remoteport) {
523 require IO::Socket;
524 $OUT = new IO::Socket::INET( Timeout => '10',
525 PeerAddr => $remoteport,
526 Proto => 'tcp',
527 );
0aa2ae9a 528 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
363b4d59 529 $IN = $OUT;
f1583d8f 530 } elsif ($CreateTTY & 4) {
531 create_IN_OUT(4);
532 } else {
363b4d59 533 if (defined $console) {
04e43a21 534 my ($i, $o) = split /,/, $console;
f1583d8f 535 $o = $i unless defined $o;
536 open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
537 open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
363b4d59 538 || open(OUT,">&STDOUT"); # so we don't dongle stdout
539 } else {
540 open(IN,"<&STDIN");
541 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
542 $console = 'STDIN/OUT';
543 }
544 # so open("|more") can read from STDOUT and so we don't dingle stdin
545 $IN = \*IN;
d338d6fe 546
363b4d59 547 $OUT = \*OUT;
548 }
5b17b83d 549 my $previous = select($OUT);
d338d6fe 550 $| = 1; # for DB::OUT
5b17b83d 551 select($previous);
d338d6fe 552
553 $LINEINFO = $OUT unless defined $LINEINFO;
554 $lineinfo = $console unless defined $lineinfo;
555
d338d6fe 556 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
557 unless ($runnonstop) {
f1583d8f 558 if ($term_pid eq '-1') {
559 print $OUT "\nDaughter DB session started...\n";
560 } else {
561 print $OUT "\nLoading DB routines from $header\n";
562 print $OUT ("Editor support ",
563 $slave_editor ? "enabled" : "available",
564 ".\n");
565 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
566 }
d338d6fe 567 }
568}
569
570@ARGS = @ARGV;
571for (@args) {
572 s/\'/\\\'/g;
573 s/(.*)/'$1'/ unless /^-?[\d.]+$/;
574}
575
576if (defined &afterinit) { # May be defined in $rcfile
577 &afterinit();
578}
579
43aed9ee 580$I_m_init = 1;
581
d338d6fe 582############################################################ Subroutines
583
d338d6fe 584sub DB {
36477c24 585 # _After_ the perl program is compiled, $single is set to 1:
586 if ($single and not $second_time++) {
587 if ($runnonstop) { # Disable until signal
f8b5b99c 588 for ($i=0; $i <= $stack_depth; ) {
d338d6fe 589 $stack[$i++] &= ~1;
590 }
54d04a52 591 $single = 0;
36477c24 592 # return; # Would not print trace!
3aefca04 593 } elsif ($ImmediateStop) {
594 $ImmediateStop = 0;
595 $signal = 1;
54d04a52 596 }
d338d6fe 597 }
36477c24 598 $runnonstop = 0 if $single or $signal; # Disable it if interactive.
d338d6fe 599 &save;
d338d6fe 600 ($package, $filename, $line) = caller;
54d04a52 601 $filename_ini = $filename;
22fae026 602 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
d338d6fe 603 "package $package;"; # this won't let them modify, alas
8ebc5c01 604 local(*dbline) = $main::{'_<' . $filename};
d338d6fe 605 $max = $#dbline;
04e43a21 606 if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
d338d6fe 607 if ($stop eq '1') {
608 $signal |= 1;
54d04a52 609 } elsif ($stop) {
3f521411 610 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
d338d6fe 611 $dbline{$line} =~ s/;9($|\0)/$1/;
612 }
613 }
36477c24 614 my $was_signal = $signal;
6027b9a3 615 if ($trace & 2) {
616 for (my $n = 0; $n <= $#to_watch; $n++) {
617 $evalarg = $to_watch[$n];
ed0d1bf7 618 local $onetimeDump; # Do not output results
6027b9a3 619 my ($val) = &eval; # Fix context (&eval is doing array)?
620 $val = ( (defined $val) ? "'$val'" : 'undef' );
621 if ($val ne $old_watch[$n]) {
622 $signal = 1;
623 print $OUT <<EOP;
405ff068 624Watchpoint $n:\t$to_watch[$n] changed:
625 old value:\t$old_watch[$n]
626 new value:\t$val
6027b9a3 627EOP
628 $old_watch[$n] = $val;
629 }
630 }
631 }
632 if ($trace & 4) { # User-installed watch
633 return if watchfunction($package, $filename, $line)
634 and not $single and not $was_signal and not ($trace & ~4);
635 }
636 $was_signal = $signal;
36477c24 637 $signal = 0;
6027b9a3 638 if ($single || ($trace & 1) || $was_signal) {
055fd3a9 639 if ($slave_editor) {
54d04a52 640 $position = "\032\032$filename:$line:0\n";
f1583d8f 641 print_lineinfo($position);
405ff068 642 } elsif ($package eq 'DB::fake') {
65c9c81d 643 $term || &setterm;
405ff068 644 print_help(<<EOP);
645Debugged program terminated. Use B<q> to quit or B<R> to restart,
646 use B<O> I<inhibit_exit> to avoid stopping after program termination,
647 B<h q>, B<h R> or B<h O> to get additional info.
648EOP
649 $package = 'main';
363b4d59 650 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
405ff068 651 "package $package;"; # this won't let them modify, alas
d338d6fe 652 } else {
653 $sub =~ s/\'/::/;
654 $prefix = $sub =~ /::/ ? "" : "${'package'}::";
655 $prefix .= "$sub($filename:";
656 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
657 if (length($prefix) > 30) {
54d04a52 658 $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
d338d6fe 659 $prefix = "";
660 $infix = ":\t";
661 } else {
662 $infix = "):\t";
54d04a52 663 $position = "$prefix$line$infix$dbline[$line]$after";
36477c24 664 }
665 if ($frame) {
f1583d8f 666 print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
36477c24 667 } else {
f1583d8f 668 print_lineinfo($position);
d338d6fe 669 }
670 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
671 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
36477c24 672 last if $signal;
d338d6fe 673 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
54d04a52 674 $incr_pos = "$prefix$i$infix$dbline[$i]$after";
54d04a52 675 $position .= $incr_pos;
36477c24 676 if ($frame) {
f1583d8f 677 print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
36477c24 678 } else {
f1583d8f 679 print_lineinfo($incr_pos);
36477c24 680 }
d338d6fe 681 }
682 }
683 }
684 $evalarg = $action, &eval if $action;
36477c24 685 if ($single || $was_signal) {
d338d6fe 686 local $level = $level + 1;
e63173ce 687 foreach $evalarg (@$pre) {
688 &eval;
689 }
f8b5b99c 690 print $OUT $stack_depth . " levels deep in subroutine calls!\n"
d338d6fe 691 if $single & 4;
692 $start = $line;
1d06cb2d 693 $incr = -1; # for backward motion.
6657d1ba 694 @typeahead = (@$pretype, @typeahead);
d338d6fe 695 CMD:
696 while (($term || &setterm),
f1583d8f 697 ($term_pid == $$ or resetterm(1)),
698 defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
54d04a52 699 ($#hist+1) . ('>' x $level) .
055fd3a9 700 " ")))
701 {
d338d6fe 702 $single = 0;
703 $signal = 0;
704 $cmd =~ s/\\$/\n/ && do {
54d04a52 705 $cmd .= &readline(" cont: ");
d338d6fe 706 redo CMD;
707 };
d338d6fe 708 $cmd =~ /^$/ && ($cmd = $laststep);
709 push(@hist,$cmd) if length($cmd) > 1;
710 PIPE: {
3dcd9d33 711 $cmd =~ s/^\s+//s; # trim annoying leading whitespace
712 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
d338d6fe 713 ($i) = split(/\s+/,$cmd);
055fd3a9 714 if ($alias{$i}) {
3dcd9d33 715 # squelch the sigmangler
716 local $SIG{__DIE__};
717 local $SIG{__WARN__};
055fd3a9 718 eval "\$cmd =~ $alias{$i}";
3dcd9d33 719 if ($@) {
720 print $OUT "Couldn't evaluate `$i' alias: $@";
721 next CMD;
722 }
055fd3a9 723 }
20928eff 724 $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?;
d338d6fe 725 $cmd =~ /^h$/ && do {
6027b9a3 726 print_help($help);
d338d6fe 727 next CMD; };
728 $cmd =~ /^h\s+h$/ && do {
6027b9a3 729 print_help($summary);
d338d6fe 730 next CMD; };
055fd3a9 731 # support long commands; otherwise bogus errors
732 # happen when you ask for h on <CR> for example
733 $cmd =~ /^h\s+(\S.*)$/ && do {
734 my $asked = $1; # for proper errmsg
735 my $qasked = quotemeta($asked); # for searching
736 # XXX: finds CR but not <CR>
737 if ($help =~ /^<?(?:[IB]<)$qasked/m) {
738 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
6027b9a3 739 print_help($1);
55497cff 740 }
d338d6fe 741 } else {
6027b9a3 742 print_help("B<$asked> is not a debugger command.\n");
d338d6fe 743 }
744 next CMD; };
745 $cmd =~ /^t$/ && do {
3fbd6552 746 $trace ^= 1;
6027b9a3 747 print $OUT "Trace = " .
748 (($trace & 1) ? "on" : "off" ) . "\n";
d338d6fe 749 next CMD; };
750 $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
751 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
752 foreach $subname (sort(keys %sub)) {
753 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
754 print $OUT $subname,"\n";
755 }
756 }
757 next CMD; };
ee971a18 758 $cmd =~ /^v$/ && do {
759 list_versions(); next CMD};
d338d6fe 760 $cmd =~ s/^X\b/V $package/;
761 $cmd =~ /^V$/ && do {
762 $cmd = "V $package"; };
763 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
764 local ($savout) = select($OUT);
765 $packname = $1;
766 @vars = split(' ',$2);
767 do 'dumpvar.pl' unless defined &main::dumpvar;
768 if (defined &main::dumpvar) {
54d04a52 769 local $frame = 0;
ee971a18 770 local $doret = -2;
055fd3a9 771 # must detect sigpipe failures
772 eval { &main::dumpvar($packname,@vars) };
773 if ($@) {
774 die unless $@ =~ /dumpvar print failed/;
775 }
d338d6fe 776 } else {
777 print $OUT "dumpvar.pl not available.\n";
778 }
779 select ($savout);
780 next CMD; };
781 $cmd =~ s/^x\b/ / && do { # So that will be evaled
1d06cb2d 782 $onetimeDump = 'dump'; };
783 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
784 methods($1); next CMD};
785 $cmd =~ s/^m\b/ / && do { # So this will be evaled
786 $onetimeDump = 'methods'; };
d338d6fe 787 $cmd =~ /^f\b\s*(.*)/ && do {
788 $file = $1;
477ea2b1 789 $file =~ s/\s+$//;
d338d6fe 790 if (!$file) {
791 print $OUT "The old f command is now the r command.\n";
792 print $OUT "The new f command switches filenames.\n";
793 next CMD;
794 }
795 if (!defined $main::{'_<' . $file}) {
796 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
477ea2b1 797 $try = substr($try,2);
798 print $OUT "Choosing $try matching `$file':\n";
799 $file = $try;
d338d6fe 800 }}
801 }
802 if (!defined $main::{'_<' . $file}) {
04fb8f4b 803 print $OUT "No file matching `$file' is loaded.\n";
d338d6fe 804 next CMD;
805 } elsif ($file ne $filename) {
8ebc5c01 806 *dbline = $main::{'_<' . $file};
d338d6fe 807 $max = $#dbline;
808 $filename = $file;
809 $start = 1;
810 $cmd = "l";
477ea2b1 811 } else {
812 print $OUT "Already in $file.\n";
813 next CMD;
814 }
815 };
1d06cb2d 816 $cmd =~ s/^l\s+-\s*$/-/;
83ee9e09 817 $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
818 $evalarg = $2;
819 my ($s) = &eval;
820 print($OUT "Error: $@\n"), next CMD if $@;
821 $s = CvGV_name($s);
822 print($OUT "Interpreted as: $1 $s\n");
823 $cmd = "$1 $s";
824 };
825 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
f1583d8f 826 my $s = $subname = $1;
d338d6fe 827 $subname =~ s/\'/::/;
477ea2b1 828 $subname = $package."::".$subname
829 unless $subname =~ /::/;
f1583d8f 830 $subname = "CORE::GLOBAL::$s"
831 if not defined &$subname and $s !~ /::/
832 and defined &{"CORE::GLOBAL::$s"};
d338d6fe 833 $subname = "main".$subname if substr($subname,0,2) eq "::";
83ee9e09 834 @pieces = split(/:/,find_sub($subname) || $sub{$subname});
d338d6fe 835 $subrange = pop @pieces;
836 $file = join(':', @pieces);
837 if ($file ne $filename) {
bee32ff8 838 print $OUT "Switching to file '$file'.\n"
055fd3a9 839 unless $slave_editor;
8ebc5c01 840 *dbline = $main::{'_<' . $file};
d338d6fe 841 $max = $#dbline;
842 $filename = $file;
843 }
844 if ($subrange) {
845 if (eval($subrange) < -$window) {
846 $subrange =~ s/-.*/+/;
847 }
848 $cmd = "l $subrange";
849 } else {
850 print $OUT "Subroutine $subname not found.\n";
851 next CMD;
852 } };
54d04a52 853 $cmd =~ /^\.$/ && do {
1d06cb2d 854 $incr = -1; # for backward motion.
54d04a52 855 $start = $line;
856 $filename = $filename_ini;
8ebc5c01 857 *dbline = $main::{'_<' . $filename};
54d04a52 858 $max = $#dbline;
f1583d8f 859 print_lineinfo($position);
54d04a52 860 next CMD };
d338d6fe 861 $cmd =~ /^w\b\s*(\d*)$/ && do {
862 $incr = $window - 1;
863 $start = $1 if $1;
864 $start -= $preview;
54d04a52 865 #print $OUT 'l ' . $start . '-' . ($start + $incr);
d338d6fe 866 $cmd = 'l ' . $start . '-' . ($start + $incr); };
867 $cmd =~ /^-$/ && do {
1d06cb2d 868 $start -= $incr + $window + 1;
869 $start = 1 if $start <= 0;
d338d6fe 870 $incr = $window - 1;
1d06cb2d 871 $cmd = 'l ' . ($start) . '+'; };
d338d6fe 872 $cmd =~ /^l$/ && do {
873 $incr = $window - 1;
874 $cmd = 'l ' . $start . '-' . ($start + $incr); };
875 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
876 $start = $1 if $1;
877 $incr = $2;
878 $incr = $window - 1 unless $incr;
879 $cmd = 'l ' . $start . '-' . ($start + $incr); };
54d04a52 880 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
881 $end = (!defined $2) ? $max : ($4 ? $4 : $2);
d338d6fe 882 $end = $max if $end > $max;
883 $i = $2;
884 $i = $line if $i eq '.';
885 $i = 1 if $i < 1;
1d06cb2d 886 $incr = $end - $i;
055fd3a9 887 if ($slave_editor) {
d338d6fe 888 print $OUT "\032\032$filename:$i:0\n";
889 $i = $end;
890 } else {
891 for (; $i <= $end; $i++) {
04e43a21 892 ($stop,$action) = split(/\0/, $dbline{$i}) if
893 $dbline{$i};
54d04a52 894 $arrow = ($i==$line
895 and $filename eq $filename_ini)
896 ? '==>'
36477c24 897 : ($dbline[$i]+0 ? ':' : ' ') ;
54d04a52 898 $arrow .= 'b' if $stop;
899 $arrow .= 'a' if $action;
900 print $OUT "$i$arrow\t", $dbline[$i];
65c9c81d 901 $i++, last if $signal;
d338d6fe 902 }
65c9c81d 903 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
d338d6fe 904 }
905 $start = $i; # remember in case they want more
906 $start = $max if $start > $max;
907 next CMD; };
908 $cmd =~ /^D$/ && do {
55497cff 909 print $OUT "Deleting all breakpoints...\n";
910 my $file;
911 for $file (keys %had_breakpoints) {
8ebc5c01 912 local *dbline = $main::{'_<' . $file};
55497cff 913 my $max = $#dbline;
914 my $was;
915
d338d6fe 916 for ($i = 1; $i <= $max ; $i++) {
917 if (defined $dbline{$i}) {
918 $dbline{$i} =~ s/^[^\0]+//;
919 if ($dbline{$i} =~ s/^\0?$//) {
920 delete $dbline{$i};
921 }
922 }
923 }
3fbd6552 924
925 if (not $had_breakpoints{$file} &= ~1) {
926 delete $had_breakpoints{$file};
927 }
55497cff 928 }
929 undef %postponed;
930 undef %postponed_file;
931 undef %break_on_load;
55497cff 932 next CMD; };
d338d6fe 933 $cmd =~ /^L$/ && do {
55497cff 934 my $file;
935 for $file (keys %had_breakpoints) {
8ebc5c01 936 local *dbline = $main::{'_<' . $file};
55497cff 937 my $max = $#dbline;
938 my $was;
939
d338d6fe 940 for ($i = 1; $i <= $max; $i++) {
941 if (defined $dbline{$i}) {
2002527a 942 print $OUT "$file:\n" unless $was++;
55497cff 943 print $OUT " $i:\t", $dbline[$i];
d338d6fe 944 ($stop,$action) = split(/\0/, $dbline{$i});
55497cff 945 print $OUT " break if (", $stop, ")\n"
d338d6fe 946 if $stop;
55497cff 947 print $OUT " action: ", $action, "\n"
d338d6fe 948 if $action;
949 last if $signal;
950 }
951 }
55497cff 952 }
953 if (%postponed) {
954 print $OUT "Postponed breakpoints in subroutines:\n";
955 my $subname;
956 for $subname (keys %postponed) {
957 print $OUT " $subname\t$postponed{$subname}\n";
958 last if $signal;
959 }
960 }
961 my @have = map { # Combined keys
962 keys %{$postponed_file{$_}}
963 } keys %postponed_file;
964 if (@have) {
965 print $OUT "Postponed breakpoints in files:\n";
966 my ($file, $line);
967 for $file (keys %postponed_file) {
0c395bd7 968 my $db = $postponed_file{$file};
55497cff 969 print $OUT " $file:\n";
0c395bd7 970 for $line (sort {$a <=> $b} keys %$db) {
08a4aec0 971 print $OUT " $line:\n";
0c395bd7 972 my ($stop,$action) = split(/\0/, $$db{$line});
55497cff 973 print $OUT " break if (", $stop, ")\n"
974 if $stop;
975 print $OUT " action: ", $action, "\n"
976 if $action;
977 last if $signal;
978 }
979 last if $signal;
980 }
981 }
982 if (%break_on_load) {
983 print $OUT "Breakpoints on load:\n";
984 my $file;
985 for $file (keys %break_on_load) {
986 print $OUT " $file\n";
987 last if $signal;
988 }
989 }
6027b9a3 990 if ($trace & 2) {
991 print $OUT "Watch-expressions:\n";
992 my $expr;
993 for $expr (@to_watch) {
994 print $OUT " $expr\n";
995 last if $signal;
996 }
997 }
55497cff 998 next CMD; };
999 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
477ea2b1 1000 my $file = $1; $file =~ s/\s+$//;
f1583d8f 1001 cmd_b_load($file);
55497cff 1002 next CMD; };
1d06cb2d 1003 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
a223bd61 1004 my $cond = length $3 ? $3 : '1';
1d06cb2d 1005 my ($subname, $break) = ($2, $1 eq 'postpone');
a223bd61 1006 $subname =~ s/\'/::/g;
55497cff 1007 $subname = "${'package'}::" . $subname
1008 unless $subname =~ /::/;
1009 $subname = "main".$subname if substr($subname,0,2) eq "::";
1d06cb2d 1010 $postponed{$subname} = $break
1011 ? "break +0 if $cond" : "compile";
d338d6fe 1012 next CMD; };
83ee9e09 1013 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
d338d6fe 1014 $subname = $1;
a223bd61 1015 $cond = length $2 ? $2 : '1';
f1583d8f 1016 cmd_b_sub($subname, $cond);
d338d6fe 1017 next CMD; };
1018 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
3fbd6552 1019 $i = $1 || $line;
31706494 1020 $cond = length $2 ? $2 : '1';
f1583d8f 1021 cmd_b_line($i, $cond);
d338d6fe 1022 next CMD; };
3fbd6552 1023 $cmd =~ /^d\b\s*(\d*)/ && do {
f1583d8f 1024 cmd_d($1 || $line);
d338d6fe 1025 next CMD; };
1026 $cmd =~ /^A$/ && do {
3fbd6552 1027 print $OUT "Deleting all actions...\n";
55497cff 1028 my $file;
1029 for $file (keys %had_breakpoints) {
8ebc5c01 1030 local *dbline = $main::{'_<' . $file};
55497cff 1031 my $max = $#dbline;
1032 my $was;
1033
d338d6fe 1034 for ($i = 1; $i <= $max ; $i++) {
1035 if (defined $dbline{$i}) {
1036 $dbline{$i} =~ s/\0[^\0]*//;
1037 delete $dbline{$i} if $dbline{$i} eq '';
1038 }
1039 }
3fbd6552 1040
055fd3a9 1041 unless ($had_breakpoints{$file} &= ~2) {
3fbd6552 1042 delete $had_breakpoints{$file};
1043 }
55497cff 1044 }
1045 next CMD; };
d338d6fe 1046 $cmd =~ /^O\s*$/ && do {
1047 for (@options) {
1048 &dump_option($_);
1049 }
1050 next CMD; };
1051 $cmd =~ /^O\s*(\S.*)/ && do {
1052 parse_options($1);
1053 next CMD; };
55497cff 1054 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1055 push @$pre, action($1);
1056 next CMD; };
1057 $cmd =~ /^>>\s*(.*)/ && do {
1058 push @$post, action($1);
1059 next CMD; };
d338d6fe 1060 $cmd =~ /^<\s*(.*)/ && do {
055fd3a9 1061 unless ($1) {
e4e99f0d 1062 print $OUT "All < actions cleared.\n";
055fd3a9 1063 $pre = [];
1064 next CMD;
1065 }
1066 if ($1 eq '?') {
1067 unless (@$pre) {
e4e99f0d 1068 print $OUT "No pre-prompt Perl actions.\n";
055fd3a9 1069 next CMD;
1070 }
e4e99f0d 1071 print $OUT "Perl commands run before each prompt:\n";
055fd3a9 1072 for my $action ( @$pre ) {
e4e99f0d 1073 print $OUT "\t< -- $action\n";
055fd3a9 1074 }
1075 next CMD;
1076 }
55497cff 1077 $pre = [action($1)];
d338d6fe 1078 next CMD; };
1079 $cmd =~ /^>\s*(.*)/ && do {
055fd3a9 1080 unless ($1) {
e4e99f0d 1081 print $OUT "All > actions cleared.\n";
055fd3a9 1082 $post = [];
1083 next CMD;
1084 }
1085 if ($1 eq '?') {
1086 unless (@$post) {
e4e99f0d 1087 print $OUT "No post-prompt Perl actions.\n";
055fd3a9 1088 next CMD;
1089 }
e4e99f0d 1090 print $OUT "Perl commands run after each prompt:\n";
055fd3a9 1091 for my $action ( @$post ) {
e4e99f0d 1092 print $OUT "\t> -- $action\n";
055fd3a9 1093 }
1094 next CMD;
1095 }
55497cff 1096 $post = [action($1)];
1097 next CMD; };
1098 $cmd =~ /^\{\{\s*(.*)/ && do {
055fd3a9 1099 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
e4e99f0d 1100 print $OUT "{{ is now a debugger command\n",
055fd3a9 1101 "use `;{{' if you mean Perl code\n";
1102 $cmd = "h {{";
1103 redo CMD;
1104 }
55497cff 1105 push @$pretype, $1;
1106 next CMD; };
1107 $cmd =~ /^\{\s*(.*)/ && do {
055fd3a9 1108 unless ($1) {
e4e99f0d 1109 print $OUT "All { actions cleared.\n";
055fd3a9 1110 $pretype = [];
1111 next CMD;
1112 }
1113 if ($1 eq '?') {
1114 unless (@$pretype) {
e4e99f0d 1115 print $OUT "No pre-prompt debugger actions.\n";
055fd3a9 1116 next CMD;
1117 }
e4e99f0d 1118 print $OUT "Debugger commands run before each prompt:\n";
055fd3a9 1119 for my $action ( @$pretype ) {
e4e99f0d 1120 print $OUT "\t{ -- $action\n";
055fd3a9 1121 }
1122 next CMD;
1123 }
1124 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
e4e99f0d 1125 print $OUT "{ is now a debugger command\n",
055fd3a9 1126 "use `;{' if you mean Perl code\n";
1127 $cmd = "h {";
1128 redo CMD;
1129 }
55497cff 1130 $pretype = [$1];
d338d6fe 1131 next CMD; };
3fbd6552 1132 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1133 $i = $1 || $line; $j = $2;
1134 if (length $j) {
1135 if ($dbline[$i] == 0) {
1136 print $OUT "Line $i may not have an action.\n";
1137 } else {
1138 $had_breakpoints{$filename} |= 2;
1139 $dbline{$i} =~ s/\0[^\0]*//;
1140 $dbline{$i} .= "\0" . action($j);
1141 }
d338d6fe 1142 } else {
1143 $dbline{$i} =~ s/\0[^\0]*//;
3fbd6552 1144 delete $dbline{$i} if $dbline{$i} eq '';
d338d6fe 1145 }
1146 next CMD; };
1147 $cmd =~ /^n$/ && do {
4639966b 1148 end_report(), next CMD if $finished and $level <= 1;
d338d6fe 1149 $single = 2;
1150 $laststep = $cmd;
1151 last CMD; };
1152 $cmd =~ /^s$/ && do {
4639966b 1153 end_report(), next CMD if $finished and $level <= 1;
d338d6fe 1154 $single = 1;
1155 $laststep = $cmd;
1156 last CMD; };
54d04a52 1157 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
4639966b 1158 end_report(), next CMD if $finished and $level <= 1;
fb73857a 1159 $subname = $i = $1;
bee32ff8 1160 # Probably not needed, since we finish an interactive
1161 # sub-session anyway...
1162 # local $filename = $filename;
1163 # local *dbline = *dbline; # XXX Would this work?!
54d04a52 1164 if ($i =~ /\D/) { # subroutine name
fb73857a 1165 $subname = $package."::".$subname
1166 unless $subname =~ /::/;
1167 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
54d04a52 1168 $i += 0;
1169 if ($i) {
1170 $filename = $file;
8ebc5c01 1171 *dbline = $main::{'_<' . $filename};
3fbd6552 1172 $had_breakpoints{$filename} |= 1;
54d04a52 1173 $max = $#dbline;
1174 ++$i while $dbline[$i] == 0 && $i < $max;
1175 } else {
1176 print $OUT "Subroutine $subname not found.\n";
1177 next CMD;
1178 }
1179 }
d338d6fe 1180 if ($i) {
1181 if ($dbline[$i] == 0) {
1182 print $OUT "Line $i not breakable.\n";
1183 next CMD;
1184 }
1185 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1186 }
f8b5b99c 1187 for ($i=0; $i <= $stack_depth; ) {
d338d6fe 1188 $stack[$i++] &= ~1;
1189 }
1190 last CMD; };
1191 $cmd =~ /^r$/ && do {
4639966b 1192 end_report(), next CMD if $finished and $level <= 1;
f8b5b99c 1193 $stack[$stack_depth] |= 1;
1194 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
d338d6fe 1195 last CMD; };
54d04a52 1196 $cmd =~ /^R$/ && do {
55497cff 1197 print $OUT "Warning: some settings and command-line options may be lost!\n";
54d04a52 1198 my (@script, @flags, $cl);
1199 push @flags, '-w' if $ini_warn;
1200 # Put all the old includes at the start to get
1201 # the same debugger.
1202 for (@ini_INC) {
1203 push @flags, '-I', $_;
1204 }
1205 # Arrange for setting the old INC:
1206 set_list("PERLDB_INC", @ini_INC);
1207 if ($0 eq '-e') {
1208 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
055fd3a9 1209 chomp ($cl = ${'::_<-e'}[$_]);
54d04a52 1210 push @script, '-e', $cl;
1211 }
1212 } else {
1213 @script = $0;
1214 }
1215 set_list("PERLDB_HIST",
1216 $term->Features->{getHistory}
1217 ? $term->GetHistory : @hist);
55497cff 1218 my @had_breakpoints = keys %had_breakpoints;
1219 set_list("PERLDB_VISITED", @had_breakpoints);
54d04a52 1220 set_list("PERLDB_OPT", %option);
55497cff 1221 set_list("PERLDB_ON_LOAD", %break_on_load);
1222 my @hard;
1223 for (0 .. $#had_breakpoints) {
1224 my $file = $had_breakpoints[$_];
8ebc5c01 1225 *dbline = $main::{'_<' . $file};
0c395bd7 1226 next unless %dbline or $postponed_file{$file};
55497cff 1227 (push @hard, $file), next
1228 if $file =~ /^\(eval \d+\)$/;
1229 my @add;
1230 @add = %{$postponed_file{$file}}
0c395bd7 1231 if $postponed_file{$file};
55497cff 1232 set_list("PERLDB_FILE_$_", %dbline, @add);
1233 }
1234 for (@hard) { # Yes, really-really...
1235 # Find the subroutines in this eval
8ebc5c01 1236 *dbline = $main::{'_<' . $_};
55497cff 1237 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1238 for $sub (keys %sub) {
1239 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1240 $subs{$sub} = [$1, $2];
1241 }
1242 unless (%subs) {
1243 print $OUT
1244 "No subroutines in $_, ignoring breakpoints.\n";
1245 next;
1246 }
1247 LINES: for $line (keys %dbline) {
1248 # One breakpoint per sub only:
1249 my ($offset, $sub, $found);
1250 SUBS: for $sub (keys %subs) {
1251 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1252 and (not defined $offset # Not caught
1253 or $offset < 0 )) { # or badly caught
1254 $found = $sub;
1255 $offset = $line - $subs{$sub}->[0];
1256 $offset = "+$offset", last SUBS if $offset >= 0;
1257 }
1258 }
1259 if (defined $offset) {
1260 $postponed{$found} =
1261 "break $offset if $dbline{$line}";
1262 } else {
1263 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1264 }
1265 }
54d04a52 1266 }
55497cff 1267 set_list("PERLDB_POSTPONE", %postponed);
43aed9ee 1268 set_list("PERLDB_PRETYPE", @$pretype);
1269 set_list("PERLDB_PRE", @$pre);
1270 set_list("PERLDB_POST", @$post);
1271 set_list("PERLDB_TYPEAHEAD", @typeahead);
54d04a52 1272 $ENV{PERLDB_RESTART} = 1;
f1583d8f 1273 delete $ENV{PERLDB_PIDS}; # Restore ini state
1274 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
055fd3a9 1275 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
04e43a21 1276 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
54d04a52 1277 print $OUT "exec failed: $!\n";
1278 last CMD; };
d338d6fe 1279 $cmd =~ /^T$/ && do {
36477c24 1280 print_trace($OUT, 1); # skip DB
d338d6fe 1281 next CMD; };
6027b9a3 1282 $cmd =~ /^W\s*$/ && do {
1283 $trace &= ~2;
1284 @to_watch = @old_watch = ();
1285 next CMD; };
1286 $cmd =~ /^W\b\s*(.*)/s && do {
1287 push @to_watch, $1;
1288 $evalarg = $1;
1289 my ($val) = &eval;
1290 $val = (defined $val) ? "'$val'" : 'undef' ;
1291 push @old_watch, $val;
1292 $trace |= 2;
1293 next CMD; };
d338d6fe 1294 $cmd =~ /^\/(.*)$/ && do {
1295 $inpat = $1;
1296 $inpat =~ s:([^\\])/$:$1:;
1297 if ($inpat ne "") {
3dcd9d33 1298 # squelch the sigmangler
1299 local $SIG{__DIE__};
1300 local $SIG{__WARN__};
d338d6fe 1301 eval '$inpat =~ m'."\a$inpat\a";
1302 if ($@ ne "") {
1303 print $OUT "$@";
1304 next CMD;
1305 }
1306 $pat = $inpat;
1307 }
1308 $end = $start;
1d06cb2d 1309 $incr = -1;
d338d6fe 1310 eval '
1311 for (;;) {
1312 ++$start;
1313 $start = 1 if ($start > $max);
1314 last if ($start == $end);
1315 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
055fd3a9 1316 if ($slave_editor) {
d338d6fe 1317 print $OUT "\032\032$filename:$start:0\n";
1318 } else {
1319 print $OUT "$start:\t", $dbline[$start], "\n";
1320 }
1321 last;
1322 }
1323 } ';
1324 print $OUT "/$pat/: not found\n" if ($start == $end);
1325 next CMD; };
1326 $cmd =~ /^\?(.*)$/ && do {
1327 $inpat = $1;
1328 $inpat =~ s:([^\\])\?$:$1:;
1329 if ($inpat ne "") {
3dcd9d33 1330 # squelch the sigmangler
1331 local $SIG{__DIE__};
1332 local $SIG{__WARN__};
d338d6fe 1333 eval '$inpat =~ m'."\a$inpat\a";
1334 if ($@ ne "") {
3dcd9d33 1335 print $OUT $@;
d338d6fe 1336 next CMD;
1337 }
1338 $pat = $inpat;
1339 }
1340 $end = $start;
1d06cb2d 1341 $incr = -1;
d338d6fe 1342 eval '
1343 for (;;) {
1344 --$start;
1345 $start = $max if ($start <= 0);
1346 last if ($start == $end);
1347 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
055fd3a9 1348 if ($slave_editor) {
d338d6fe 1349 print $OUT "\032\032$filename:$start:0\n";
1350 } else {
1351 print $OUT "$start:\t", $dbline[$start], "\n";
1352 }
1353 last;
1354 }
1355 } ';
1356 print $OUT "?$pat?: not found\n" if ($start == $end);
1357 next CMD; };
1358 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1359 pop(@hist) if length($cmd) > 1;
3fbd6552 1360 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
6921e3ed 1361 $cmd = $hist[$i];
615b993b 1362 print $OUT $cmd, "\n";
d338d6fe 1363 redo CMD; };
55497cff 1364 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
ee971a18 1365 &system($1);
d338d6fe 1366 next CMD; };
1367 $cmd =~ /^$rc([^$rc].*)$/ && do {
1368 $pat = "^$1";
1369 pop(@hist) if length($cmd) > 1;
1370 for ($i = $#hist; $i; --$i) {
1371 last if $hist[$i] =~ /$pat/;
1372 }
1373 if (!$i) {
1374 print $OUT "No such command!\n\n";
1375 next CMD;
1376 }
6921e3ed 1377 $cmd = $hist[$i];
615b993b 1378 print $OUT $cmd, "\n";
d338d6fe 1379 redo CMD; };
1380 $cmd =~ /^$sh$/ && do {
1381 &system($ENV{SHELL}||"/bin/sh");
1382 next CMD; };
ee971a18 1383 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
055fd3a9 1384 # XXX: using csh or tcsh destroys sigint retvals!
1385 #&system($1); # use this instead
ee971a18 1386 &system($ENV{SHELL}||"/bin/sh","-c",$1);
d338d6fe 1387 next CMD; };
1388 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
055fd3a9 1389 $end = $2 ? ($#hist-$2) : 0;
d338d6fe 1390 $hist = 0 if $hist < 0;
1391 for ($i=$#hist; $i>$end; $i--) {
1392 print $OUT "$i: ",$hist[$i],"\n"
1393 unless $hist[$i] =~ /^.?$/;
1394 };
1395 next CMD; };
055fd3a9 1396 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1397 runman($1);
1398 next CMD; };
b9b857e2 1399 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1400 $cmd =~ s/^p\b/print {\$DB::OUT} /;
3dcd9d33 1401 $cmd =~ s/^=\s*// && do {
1402 my @keys;
1403 if (length $cmd == 0) {
1404 @keys = sort keys %alias;
1405 }
1406 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1407 # can't use $_ or kill //g state
1408 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1409 $alias{$k} = "s\a$k\a$v\a";
1410 # squelch the sigmangler
1411 local $SIG{__DIE__};
1412 local $SIG{__WARN__};
1413 unless (eval "sub { s\a$k\a$v\a }; 1") {
1414 print $OUT "Can't alias $k to $v: $@\n";
1415 delete $alias{$k};
1416 next CMD;
1417 }
1418 @keys = ($k);
1419 }
1420 else {
1421 @keys = ($cmd);
1422 }
1423 for my $k (@keys) {
1424 if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
1425 print $OUT "$k\t= $1\n";
1426 }
1427 elsif (defined $alias{$k}) {
d338d6fe 1428 print $OUT "$k\t$alias{$k}\n";
3dcd9d33 1429 }
1430 else {
1431 print "No alias for $k\n";
1432 }
1433 }
d338d6fe 1434 next CMD; };
1435 $cmd =~ /^\|\|?\s*[^|]/ && do {
1436 if ($pager =~ /^\|/) {
1437 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1438 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1439 } else {
1440 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1441 }
055fd3a9 1442 fix_less();
d338d6fe 1443 unless ($piped=open(OUT,$pager)) {
1444 &warn("Can't pipe output to `$pager'");
1445 if ($pager =~ /^\|/) {
055fd3a9 1446 open(OUT,">&STDOUT") # XXX: lost message
1447 || &warn("Can't restore DB::OUT");
d338d6fe 1448 open(STDOUT,">&SAVEOUT")
1449 || &warn("Can't restore STDOUT");
1450 close(SAVEOUT);
1451 } else {
055fd3a9 1452 open(OUT,">&STDOUT") # XXX: lost message
1453 || &warn("Can't restore DB::OUT");
d338d6fe 1454 }
1455 next CMD;
1456 }
77fb7b16 1457 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
055fd3a9 1458 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
d338d6fe 1459 $selected= select(OUT);
1460 $|= 1;
1461 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1462 $cmd =~ s/^\|+\s*//;
055fd3a9 1463 redo PIPE;
1464 };
d338d6fe 1465 # XXX Local variants do not work!
6027b9a3 1466 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
d338d6fe 1467 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1468 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1469 } # PIPE:
d338d6fe 1470 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1471 if ($onetimeDump) {
1472 $onetimeDump = undef;
f36776d9 1473 } elsif ($term_pid == $$) {
d338d6fe 1474 print $OUT "\n";
1475 }
1476 } continue { # CMD:
1477 if ($piped) {
1478 if ($pager =~ /^\|/) {
055fd3a9 1479 $? = 0;
1480 # we cannot warn here: the handle is missing --tchrist
1481 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1482
1483 # most of the $? crud was coping with broken cshisms
1484 if ($?) {
1485 print SAVEOUT "Pager `$pager' failed: ";
1486 if ($? == -1) {
1487 print SAVEOUT "shell returned -1\n";
1488 } elsif ($? >> 8) {
1489 print SAVEOUT
1490 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1491 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1492 } else {
1493 print SAVEOUT "status ", ($? >> 8), "\n";
1494 }
1495 }
1496
d338d6fe 1497 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1498 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
055fd3a9 1499 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
d338d6fe 1500 # Will stop ignoring SIGPIPE if done like nohup(1)
1501 # does SIGINT but Perl doesn't give us a choice.
1502 } else {
1503 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1504 }
1505 close(SAVEOUT);
1506 select($selected), $selected= "" unless $selected eq "";
1507 $piped= "";
1508 }
1509 } # CMD:
20928eff 1510 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
e63173ce 1511 foreach $evalarg (@$post) {
1512 &eval;
1513 }
d338d6fe 1514 } # if ($single || $signal)
22fae026 1515 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
d338d6fe 1516 ();
1517}
1518
1519# The following code may be executed now:
1520# BEGIN {warn 4}
1521
1522sub sub {
ee971a18 1523 my ($al, $ret, @ret) = "";
7d4a81e5 1524 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1525 $al = " for $$sub";
ee971a18 1526 }
f8b5b99c 1527 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1528 $#stack = $stack_depth;
1529 $stack[-1] = $single;
d338d6fe 1530 $single &= 1;
f8b5b99c 1531 $single |= 4 if $stack_depth == $deep;
04fb8f4b 1532 ($frame & 4
f1583d8f 1533 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
04fb8f4b 1534 # Why -1? But it works! :-(
1535 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f1583d8f 1536 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
d338d6fe 1537 if (wantarray) {
1538 @ret = &$sub;
f8b5b99c 1539 $single |= $stack[$stack_depth--];
36477c24 1540 ($frame & 4
f1583d8f 1541 ? ( print_lineinfo(' ' x $stack_depth, "out "),
36477c24 1542 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f1583d8f 1543 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
f8b5b99c 1544 if ($doret eq $stack_depth or $frame & 16) {
1545 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1546 print $fh ' ' x $stack_depth if $frame & 16;
7ea36084 1547 print $fh "list context return from $sub:\n";
1548 dumpit($fh, \@ret );
1549 $doret = -2;
1550 }
d338d6fe 1551 @ret;
1552 } else {
fb73857a 1553 if (defined wantarray) {
1554 $ret = &$sub;
1555 } else {
1556 &$sub; undef $ret;
1557 };
f8b5b99c 1558 $single |= $stack[$stack_depth--];
36477c24 1559 ($frame & 4
f1583d8f 1560 ? ( print_lineinfo(' ' x $stack_depth, "out "),
36477c24 1561 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f1583d8f 1562 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
f8b5b99c 1563 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1564 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1565 print $fh (' ' x $stack_depth) if $frame & 16;
7ea36084 1566 print $fh (defined wantarray
1567 ? "scalar context return from $sub: "
1568 : "void context return from $sub\n");
1569 dumpit( $fh, $ret ) if defined wantarray;
1570 $doret = -2;
1571 }
d338d6fe 1572 $ret;
1573 }
1574}
1575
f1583d8f 1576### The API section
1577
1578### Functions with multiple modes of failure die on error, the rest
1579### returns FALSE on error.
1580### User-interface functions cmd_* output error message.
1581
1582sub break_on_load {
1583 my $file = shift;
1584 $break_on_load{$file} = 1;
1585 $had_breakpoints{$file} |= 1;
1586}
1587
1588sub report_break_on_load {
1589 sort keys %break_on_load;
1590}
1591
1592sub cmd_b_load {
1593 my $file = shift;
1594 my @files;
1595 {
1596 push @files, $file;
1597 push @files, $::INC{$file} if $::INC{$file};
1598 $file .= '.pm', redo unless $file =~ /\./;
1599 }
1600 break_on_load($_) for @files;
04e43a21 1601 @files = report_break_on_load;
f1583d8f 1602 print $OUT "Will stop on load of `@files'.\n";
1603}
1604
1605$filename_error = '';
1606
1607sub breakable_line {
1608 my ($from, $to) = @_;
1609 my $i = $from;
1610 if (@_ >= 2) {
1611 my $delta = $from < $to ? +1 : -1;
1612 my $limit = $delta > 0 ? $#dbline : 1;
1613 $limit = $to if ($limit - $to) * $delta > 0;
1614 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1615 }
1616 return $i unless $dbline[$i] == 0;
1617 my ($pl, $upto) = ('', '');
1618 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1619 die "Line$pl $from$upto$filename_error not breakable\n";
1620}
1621
1622sub breakable_line_in_filename {
1623 my ($f) = shift;
1624 local *dbline = $main::{'_<' . $f};
1625 local $filename_error = " of `$f'";
1626 breakable_line(@_);
1627}
1628
1629sub break_on_line {
1630 my ($i, $cond) = @_;
1631 $cond = 1 unless @_ >= 2;
1632 my $inii = $i;
1633 my $after = '';
1634 my $pl = '';
1635 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1636 $had_breakpoints{$filename} |= 1;
22c4a518 1637 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1638 else { $dbline{$i} = $cond; }
f1583d8f 1639}
1640
1641sub cmd_b_line {
1642 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1643}
1644
1645sub break_on_filename_line {
1646 my ($f, $i, $cond) = @_;
1647 $cond = 1 unless @_ >= 3;
1648 local *dbline = $main::{'_<' . $f};
1649 local $filename_error = " of `$f'";
1650 local $filename = $f;
1651 break_on_line($i, $cond);
1652}
1653
1654sub break_on_filename_line_range {
1655 my ($f, $from, $to, $cond) = @_;
1656 my $i = breakable_line_in_filename($f, $from, $to);
1657 $cond = 1 unless @_ >= 3;
1658 break_on_filename_line($f,$i,$cond);
1659}
1660
1661sub subroutine_filename_lines {
1662 my ($subname,$cond) = @_;
1663 # Filename below can contain ':'
1664 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1665}
1666
1667sub break_subroutine {
1668 my $subname = shift;
1669 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1670 die "Subroutine $subname not found.\n";
1671 $cond = 1 unless @_ >= 2;
1672 break_on_filename_line_range($file,$s,$e,@_);
1673}
1674
1675sub cmd_b_sub {
1676 my ($subname,$cond) = @_;
1677 $cond = 1 unless @_ >= 2;
1678 unless (ref $subname eq 'CODE') {
1679 $subname =~ s/\'/::/g;
1680 my $s = $subname;
1681 $subname = "${'package'}::" . $subname
1682 unless $subname =~ /::/;
1683 $subname = "CORE::GLOBAL::$s"
1684 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1685 $subname = "main".$subname if substr($subname,0,2) eq "::";
1686 }
1687 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1688}
1689
1690sub cmd_stop { # As on ^C, but not signal-safy.
1691 $signal = 1;
1692}
1693
1694sub delete_breakpoint {
1695 my $i = shift;
1696 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1697 $dbline{$i} =~ s/^[^\0]*//;
1698 delete $dbline{$i} if $dbline{$i} eq '';
1699}
1700
1701sub cmd_d {
1702 my $i = shift;
1703 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1704}
1705
1706### END of the API section
1707
d338d6fe 1708sub save {
22fae026 1709 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
d338d6fe 1710 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1711}
1712
f1583d8f 1713sub print_lineinfo {
1714 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1715 print $LINEINFO @_;
1716}
1717
d338d6fe 1718# The following takes its argument via $evalarg to preserve current @_
1719
1720sub eval {
055fd3a9 1721 # 'my' would make it visible from user code
f1583d8f 1722 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1723 local @res;
d338d6fe 1724 {
23a291ec 1725 local $otrace = $trace;
1726 local $osingle = $single;
1727 local $od = $^D;
157b066d 1728 { ($evalarg) = $evalarg =~ /(.*)/s; }
d338d6fe 1729 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1730 $trace = $otrace;
1731 $single = $osingle;
1732 $^D = $od;
1733 }
1734 my $at = $@;
36477c24 1735 local $saved[0]; # Preserve the old value of $@
22fae026 1736 eval { &DB::save };
62769f13 1737 if ($at) {
d338d6fe 1738 print $OUT $at;
600d99fa 1739 } elsif ($onetimeDump) {
1740 dumpit($OUT, \@res) if $onetimeDump eq 'dump';
1741 methods($res[0]) if $onetimeDump eq 'methods';
d338d6fe 1742 }
6027b9a3 1743 @res;
d338d6fe 1744}
1745
55497cff 1746sub postponed_sub {
1747 my $subname = shift;
1d06cb2d 1748 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
55497cff 1749 my $offset = $1 || 0;
1750 # Filename below can contain ':'
1d06cb2d 1751 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
55497cff 1752 if ($i) {
fb73857a 1753 $i += $offset;
8ebc5c01 1754 local *dbline = $main::{'_<' . $file};
55497cff 1755 local $^W = 0; # != 0 is magical below
3fbd6552 1756 $had_breakpoints{$file} |= 1;
55497cff 1757 my $max = $#dbline;
1758 ++$i until $dbline[$i] != 0 or $i >= $max;
1759 $dbline{$i} = delete $postponed{$subname};
1760 } else {
1761 print $OUT "Subroutine $subname not found.\n";
1762 }
1763 return;
1764 }
1d06cb2d 1765 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
36477c24 1766 #print $OUT "In postponed_sub for `$subname'.\n";
55497cff 1767}
1768
1769sub postponed {
3aefca04 1770 if ($ImmediateStop) {
1771 $ImmediateStop = 0;
1772 $signal = 1;
1773 }
55497cff 1774 return &postponed_sub
1775 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1776 # Cannot be done before the file is compiled
1777 local *dbline = shift;
1778 my $filename = $dbline;
1779 $filename =~ s/^_<//;
36477c24 1780 $signal = 1, print $OUT "'$filename' loaded...\n"
1781 if $break_on_load{$filename};
f1583d8f 1782 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
0c395bd7 1783 return unless $postponed_file{$filename};
3fbd6552 1784 $had_breakpoints{$filename} |= 1;
55497cff 1785 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1786 my $key;
1787 for $key (keys %{$postponed_file{$filename}}) {
055fd3a9 1788 $dbline{$key} = ${$postponed_file{$filename}}{$key};
54d04a52 1789 }
0c395bd7 1790 delete $postponed_file{$filename};
54d04a52 1791}
1792
d338d6fe 1793sub dumpit {
7ea36084 1794 local ($savout) = select(shift);
ee971a18 1795 my $osingle = $single;
1796 my $otrace = $trace;
1797 $single = $trace = 0;
1798 local $frame = 0;
1799 local $doret = -2;
1800 unless (defined &main::dumpValue) {
1801 do 'dumpvar.pl';
1802 }
d338d6fe 1803 if (defined &main::dumpValue) {
1804 &main::dumpValue(shift);
1805 } else {
1806 print $OUT "dumpvar.pl not available.\n";
1807 }
ee971a18 1808 $single = $osingle;
1809 $trace = $otrace;
d338d6fe 1810 select ($savout);
1811}
1812
36477c24 1813# Tied method do not create a context, so may get wrong message:
1814
55497cff 1815sub print_trace {
1816 my $fh = shift;
f1583d8f 1817 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
36477c24 1818 my @sub = dump_trace($_[0] + 1, $_[1]);
1819 my $short = $_[2]; # Print short report, next one for sub name
1d06cb2d 1820 my $s;
55497cff 1821 for ($i=0; $i <= $#sub; $i++) {
1822 last if $signal;
1823 local $" = ', ';
1824 my $args = defined $sub[$i]{args}
1825 ? "(@{ $sub[$i]{args} })"
1826 : '' ;
1d06cb2d 1827 $args = (substr $args, 0, $maxtrace - 3) . '...'
1828 if length $args > $maxtrace;
36477c24 1829 my $file = $sub[$i]{file};
1830 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1d06cb2d 1831 $s = $sub[$i]{sub};
1832 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
36477c24 1833 if ($short) {
1d06cb2d 1834 my $sub = @_ >= 4 ? $_[3] : $s;
36477c24 1835 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1836 } else {
1d06cb2d 1837 print $fh "$sub[$i]{context} = $s$args" .
36477c24 1838 " called from $file" .
1839 " line $sub[$i]{line}\n";
1840 }
55497cff 1841 }
1842}
1843
1844sub dump_trace {
1845 my $skip = shift;
36477c24 1846 my $count = shift || 1e9;
1847 $skip++;
1848 $count += $skip;
55497cff 1849 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
04fb8f4b 1850 my $nothard = not $frame & 8;
1851 local $frame = 0; # Do not want to trace this.
1852 my $otrace = $trace;
1853 $trace = 0;
55497cff 1854 for ($i = $skip;
36477c24 1855 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
55497cff 1856 $i++) {
1857 @a = ();
1858 for $arg (@args) {
04fb8f4b 1859 my $type;
1860 if (not defined $arg) {
1861 push @a, "undef";
1862 } elsif ($nothard and tied $arg) {
1863 push @a, "tied";
1864 } elsif ($nothard and $type = ref $arg) {
1865 push @a, "ref($type)";
1866 } else {
1867 local $_ = "$arg"; # Safe to stringify now - should not call f().
1868 s/([\'\\])/\\$1/g;
1869 s/(.*)/'$1'/s
1870 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1871 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1872 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1873 push(@a, $_);
1874 }
55497cff 1875 }
7ea36084 1876 $context = $context ? '@' : (defined $context ? "\$" : '.');
55497cff 1877 $args = $h ? [@a] : undef;
1878 $e =~ s/\n\s*\;\s*\Z// if $e;
1d06cb2d 1879 $e =~ s/([\\\'])/\\$1/g if $e;
55497cff 1880 if ($r) {
1881 $sub = "require '$e'";
1882 } elsif (defined $r) {
1883 $sub = "eval '$e'";
1884 } elsif ($sub eq '(eval)') {
1885 $sub = "eval {...}";
1886 }
1887 push(@sub, {context => $context, sub => $sub, args => $args,
1888 file => $file, line => $line});
1889 last if $signal;
1890 }
04fb8f4b 1891 $trace = $otrace;
55497cff 1892 @sub;
1893}
1894
d338d6fe 1895sub action {
1896 my $action = shift;
1897 while ($action =~ s/\\$//) {
1898 #print $OUT "+ ";
1899 #$action .= "\n";
1900 $action .= &gets;
1901 }
1902 $action;
1903}
1904
055fd3a9 1905sub unbalanced {
1906 # i hate using globals!
1907 $balanced_brace_re ||= qr{
1908 ^ \{
1909 (?:
1910 (?> [^{}] + ) # Non-parens without backtracking
1911 |
1912 (??{ $balanced_brace_re }) # Group with matching parens
1913 ) *
1914 \} $
1915 }x;
1916 return $_[0] !~ m/$balanced_brace_re/;
1917}
1918
d338d6fe 1919sub gets {
d338d6fe 1920 &readline("cont: ");
1921}
1922
1923sub system {
1924 # We save, change, then restore STDIN and STDOUT to avoid fork() since
055fd3a9 1925 # some non-Unix systems can do system() but have problems with fork().
d338d6fe 1926 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
8ee058cb 1927 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
d338d6fe 1928 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1929 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
055fd3a9 1930
1931 # XXX: using csh or tcsh destroys sigint retvals!
d338d6fe 1932 system(@_);
1933 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1934 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
055fd3a9 1935 close(SAVEIN);
1936 close(SAVEOUT);
1937
1938
1939 # most of the $? crud was coping with broken cshisms
1940 if ($? >> 8) {
1941 &warn("(Command exited ", ($? >> 8), ")\n");
1942 } elsif ($?) {
1943 &warn( "(Command died of SIG#", ($? & 127),
1944 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1945 }
1946
1947 return $?;
1948
d338d6fe 1949}
1950
1951sub setterm {
54d04a52 1952 local $frame = 0;
ee971a18 1953 local $doret = -2;
ee971a18 1954 eval { require Term::ReadLine } or die $@;
d338d6fe 1955 if ($notty) {
1956 if ($tty) {
f1583d8f 1957 my ($i, $o) = split $tty, /,/;
1958 $o = $i unless defined $o;
1959 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1960 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
d338d6fe 1961 $IN = \*IN;
1962 $OUT = \*OUT;
1963 my $sel = select($OUT);
1964 $| = 1;
1965 select($sel);
1966 } else {
3dcd9d33 1967 eval "require Term::Rendezvous;" or die;
d338d6fe 1968 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1969 my $term_rv = new Term::Rendezvous $rv;
1970 $IN = $term_rv->IN;
1971 $OUT = $term_rv->OUT;
1972 }
1973 }
f1583d8f 1974 if ($term_pid eq '-1') { # In a TTY with another debugger
1975 resetterm(2);
1976 }
d338d6fe 1977 if (!$rl) {
1978 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1979 } else {
1980 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1981
a737e074 1982 $rl_attribs = $term->Attribs;
1983 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1984 if defined $rl_attribs->{basic_word_break_characters}
1985 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1986 $rl_attribs->{special_prefixes} = '$@&%';
1987 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1988 $rl_attribs->{completion_function} = \&db_complete;
d338d6fe 1989 }
1990 $LINEINFO = $OUT unless defined $LINEINFO;
1991 $lineinfo = $console unless defined $lineinfo;
1992 $term->MinLine(2);
54d04a52 1993 if ($term->Features->{setHistory} and "@hist" ne "?") {
1994 $term->SetHistory(@hist);
1995 }
7a2e2cd6 1996 ornaments($ornaments) if defined $ornaments;
f36776d9 1997 $term_pid = $$;
1998}
1999
f1583d8f 2000# Example get_fork_TTY functions
2001sub xterm_get_fork_TTY {
2002 (my $name = $0) =~ s,^.*[/\\],,s;
2003 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
f36776d9 2004 sleep 10000000' |];
f1583d8f 2005 my $tty = <XT>;
2006 chomp $tty;
2007 $pidprompt = ''; # Shown anyway in titlebar
2008 return $tty;
2009}
2010
2011# This one resets $IN, $OUT itself
2012sub os2_get_fork_TTY {
2013 $^F = 40; # XXXX Fixme!
2014 my ($in1, $out1, $in2, $out2);
2015 # Having -d in PERL5OPT would lead to a disaster...
2016 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2017 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2018 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2019 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2020 (my $name = $0) =~ s,^.*[/\\],,s;
2021 if ( pipe $in1, $out1 and pipe $in2, $out2 and
2022 # system P_SESSION will fail if there is another process
04e43a21 2023 # in the same session with a "dependent" asynchronous child session.
2024 (($kpid = CORE::system 4, $^X, '-we', <<'ES', fileno $in1, fileno $out2, "Daughter Perl debugger $pids $name") >= 0 or warn "system P_SESSION: $!, $^E" and 0) # P_SESSION
f1583d8f 2025use Term::ReadKey;
2026use OS2::Process;
2027
2028my $in = shift; # Read from here and pass through
2029set_title pop;
2030system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2031 open IN, '<&=$in' or die "open <&=$in: \$!";
2032 \$| = 1; print while sysread IN, \$_, 1<<16;
2033EOS
2034
2035my $out = shift;
2036open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2037select OUT; $| = 1;
2038ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
2039print while sysread STDIN, $_, 1<<16;
2040ES
2041 and close $in1 and close $out2 ) {
2042 $pidprompt = ''; # Shown anyway in titlebar
2043 reset_IN_OUT($in2, $out1);
2044 $tty = '*reset*';
2045 return ''; # Indicate that reset_IN_OUT is called
2046 }
2047 return;
2048}
2049
2050sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2051 my $in = &get_fork_TTY if defined &get_fork_TTY;
2052 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2053 if (not defined $in) {
2054 my $why = shift;
2055 print_help(<<EOP) if $why == 1;
2056I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2057EOP
2058 print_help(<<EOP) if $why == 2;
2059I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
04e43a21 2060 This may be an asynchronous session, so the parent debugger may be active.
f1583d8f 2061EOP
2062 print_help(<<EOP) if $why != 4;
2063 Since two debuggers fight for the same TTY, input is severely entangled.
2064
2065EOP
405ff068 2066 print_help(<<EOP);
f1583d8f 2067 I know how to switch the output to a different window in xterms
2068 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2069 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2070
405ff068 2071 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2072 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
f1583d8f 2073
405ff068 2074EOP
f1583d8f 2075 } elsif ($in ne '') {
2076 TTY($in);
f36776d9 2077 }
f1583d8f 2078 undef $fork_TTY;
2079}
2080
2081sub resetterm { # We forked, so we need a different TTY
2082 my $in = shift;
2083 my $systemed = $in > 1 ? '-' : '';
2084 if ($pids) {
2085 $pids =~ s/\]/$systemed->$$]/;
2086 } else {
2087 $pids = "[$term_pid->$$]";
2088 }
2089 $pidprompt = $pids;
2090 $term_pid = $$;
2091 return unless $CreateTTY & $in;
2092 create_IN_OUT($in);
d338d6fe 2093}
2094
2095sub readline {
0c01eb4a 2096 local $.;
54d04a52 2097 if (@typeahead) {
2098 my $left = @typeahead;
2099 my $got = shift @typeahead;
2100 print $OUT "auto(-$left)", shift, $got, "\n";
2101 $term->AddHistory($got)
2102 if length($got) > 1 and defined $term->Features->{addHistory};
2103 return $got;
2104 }
d338d6fe 2105 local $frame = 0;
ee971a18 2106 local $doret = -2;
363b4d59 2107 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
e4e99f0d 2108 $OUT->write(join('', @_));
363b4d59 2109 my $stuff;
055fd3a9 2110 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
363b4d59 2111 $stuff;
2112 }
2113 else {
2114 $term->readline(@_);
2115 }
d338d6fe 2116}
2117
2118sub dump_option {
2119 my ($opt, $val)= @_;
55497cff 2120 $val = option_val($opt,'N/A');
2121 $val =~ s/([\\\'])/\\$1/g;
2122 printf $OUT "%20s = '%s'\n", $opt, $val;
2123}
2124
2125sub option_val {
2126 my ($opt, $default)= @_;
2127 my $val;
d338d6fe 2128 if (defined $optionVars{$opt}
055fd3a9 2129 and defined ${$optionVars{$opt}}) {
2130 $val = ${$optionVars{$opt}};
d338d6fe 2131 } elsif (defined $optionAction{$opt}
2132 and defined &{$optionAction{$opt}}) {
2133 $val = &{$optionAction{$opt}}();
2134 } elsif (defined $optionAction{$opt}
2135 and not defined $option{$opt}
2136 or defined $optionVars{$opt}
055fd3a9 2137 and not defined ${$optionVars{$opt}}) {
55497cff 2138 $val = $default;
d338d6fe 2139 } else {
2140 $val = $option{$opt};
2141 }
600d99fa 2142 $val = $default unless defined $val;
55497cff 2143 $val
d338d6fe 2144}
2145
2146sub parse_options {
2147 local($_)= @_;
055fd3a9 2148 # too dangerous to let intuitive usage overwrite important things
2149 # defaultion should never be the default
2150 my %opt_needs_val = map { ( $_ => 1 ) } qw{
6f891d7d 2151 arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
055fd3a9 2152 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2153 };
2154 while (length) {
2155 my $val_defaulted;
2156 s/^\s+// && next;
2157 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
d338d6fe 2158 my ($opt,$sep) = ($1,$2);
2159 my $val;
2160 if ("?" eq $sep) {
2161 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2162 if /^\S/;
2163 #&dump_option($opt);
2164 } elsif ($sep !~ /\S/) {
055fd3a9 2165 $val_defaulted = 1;
2166 $val = "1"; # this is an evil default; make 'em set it!
d338d6fe 2167 } elsif ($sep eq "=") {
055fd3a9 2168
2169 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2170 my $quote = $1;
2171 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2172 } else {
2173 s/^(\S*)//;
d338d6fe 2174 $val = $1;
055fd3a9 2175 print OUT qq(Option better cleared using $opt=""\n)
2176 unless length $val;
2177 }
2178
d338d6fe 2179 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2180 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2181 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2182 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
055fd3a9 2183 ($val = $1) =~ s/\\([\\$end])/$1/g;
d338d6fe 2184 }
055fd3a9 2185
2186 my $option;
2187 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2188 || grep( /^\Q$opt/i && ($option = $_), @options );
2189
2190 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2191 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2192
2193 if ($opt_needs_val{$option} && $val_defaulted) {
2194 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2195 next;
2196 }
2197
2198 $option{$option} = $val if defined $val;
2199
2200 eval qq{
2201 local \$frame = 0;
2202 local \$doret = -2;
2203 require '$optionRequire{$option}';
2204 1;
2205 } || die # XXX: shouldn't happen
2206 if defined $optionRequire{$option} &&
2207 defined $val;
2208
2209 ${$optionVars{$option}} = $val
2210 if defined $optionVars{$option} &&
2211 defined $val;
2212
2213 &{$optionAction{$option}} ($val)
2214 if defined $optionAction{$option} &&
2215 defined &{$optionAction{$option}} &&
2216 defined $val;
2217
2218 # Not $rcfile
2219 dump_option($option) unless $OUT eq \*STDERR;
d338d6fe 2220 }
2221}
2222
54d04a52 2223sub set_list {
2224 my ($stem,@list) = @_;
2225 my $val;
055fd3a9 2226 $ENV{"${stem}_n"} = @list;
54d04a52 2227 for $i (0 .. $#list) {
2228 $val = $list[$i];
2229 $val =~ s/\\/\\\\/g;
ee971a18 2230 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
055fd3a9 2231 $ENV{"${stem}_$i"} = $val;
54d04a52 2232 }
2233}
2234
2235sub get_list {
2236 my $stem = shift;
2237 my @list;
055fd3a9 2238 my $n = delete $ENV{"${stem}_n"};
54d04a52 2239 my $val;
2240 for $i (0 .. $n - 1) {
055fd3a9 2241 $val = delete $ENV{"${stem}_$i"};
54d04a52 2242 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2243 push @list, $val;
2244 }
2245 @list;
2246}
2247
d338d6fe 2248sub catch {
2249 $signal = 1;
4639966b 2250 return; # Put nothing on the stack - malloc/free land!
d338d6fe 2251}
2252
2253sub warn {
2254 my($msg)= join("",@_);
2255 $msg .= ": $!\n" unless $msg =~ /\n$/;
2256 print $OUT $msg;
2257}
2258
f1583d8f 2259sub reset_IN_OUT {
2260 my $switch_li = $LINEINFO eq $OUT;
2261 if ($term and $term->Features->{newTTY}) {
2262 ($IN, $OUT) = (shift, shift);
2263 $term->newTTY($IN, $OUT);
2264 } elsif ($term) {
2265 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2266 } else {
2267 ($IN, $OUT) = (shift, shift);
2268 }
2269 my $o = select $OUT;
2270 $| = 1;
2271 select $o;
2272 $LINEINFO = $OUT if $switch_li;
2273}
2274
d338d6fe 2275sub TTY {
f36776d9 2276 if (@_ and $term and $term->Features->{newTTY}) {
2277 my ($in, $out) = shift;
2278 if ($in =~ /,/) {
2279 ($in, $out) = split /,/, $in, 2;
2280 } else {
2281 $out = $in;
2282 }
2283 open IN, $in or die "cannot open `$in' for read: $!";
2284 open OUT, ">$out" or die "cannot open `$out' for write: $!";
f1583d8f 2285 reset_IN_OUT(\*IN,\*OUT);
f36776d9 2286 return $tty = $in;
f1583d8f 2287 }
2288 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2289 # Useful if done through PERLDB_OPTS:
43aed9ee 2290 $tty = shift if @_;
d338d6fe 2291 $tty or $console;
2292}
2293
2294sub noTTY {
2295 if ($term) {
43aed9ee 2296 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
d338d6fe 2297 }
43aed9ee 2298 $notty = shift if @_;
d338d6fe 2299 $notty;
2300}
2301
2302sub ReadLine {
2303 if ($term) {
43aed9ee 2304 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
d338d6fe 2305 }
43aed9ee 2306 $rl = shift if @_;
d338d6fe 2307 $rl;
2308}
2309
363b4d59 2310sub RemotePort {
2311 if ($term) {
2312 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2313 }
2314 $remoteport = shift if @_;
2315 $remoteport;
2316}
2317
a737e074 2318sub tkRunning {
055fd3a9 2319 if (${$term->Features}{tkRunning}) {
a737e074 2320 return $term->tkRunning(@_);
2321 } else {
2322 print $OUT "tkRunning not supported by current ReadLine package.\n";
2323 0;
2324 }
2325}
2326
d338d6fe 2327sub NonStop {
2328 if ($term) {
43aed9ee 2329 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
d338d6fe 2330 }
43aed9ee 2331 $runnonstop = shift if @_;
d338d6fe 2332 $runnonstop;
2333}
2334
2335sub pager {
2336 if (@_) {
2337 $pager = shift;
2338 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2339 }
2340 $pager;
2341}
2342
2343sub shellBang {
2344 if (@_) {
2345 $sh = quotemeta shift;
2346 $sh .= "\\b" if $sh =~ /\w$/;
2347 }
2348 $psh = $sh;
2349 $psh =~ s/\\b$//;
2350 $psh =~ s/\\(.)/$1/g;
d338d6fe 2351 $psh;
2352}
2353
7a2e2cd6 2354sub ornaments {
2355 if (defined $term) {
2356 local ($warnLevel,$dieLevel) = (0, 1);
2357 return '' unless $term->Features->{ornaments};
2358 eval { $term->ornaments(@_) } || '';
2359 } else {
2360 $ornaments = shift;
2361 }
2362}
2363
d338d6fe 2364sub recallCommand {
2365 if (@_) {
2366 $rc = quotemeta shift;
2367 $rc .= "\\b" if $rc =~ /\w$/;
2368 }
2369 $prc = $rc;
2370 $prc =~ s/\\b$//;
2371 $prc =~ s/\\(.)/$1/g;
d338d6fe 2372 $prc;
2373}
2374
2375sub LineInfo {
2376 return $lineinfo unless @_;
2377 $lineinfo = shift;
2378 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
055fd3a9 2379 $slave_editor = ($stream =~ /^\|/);
d338d6fe 2380 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2381 $LINEINFO = \*LINEINFO;
2382 my $save = select($LINEINFO);
2383 $| = 1;
2384 select($save);
2385 $lineinfo;
2386}
2387
ee971a18 2388sub list_versions {
2389 my %version;
2390 my $file;
2391 for (keys %INC) {
2392 $file = $_;
2393 s,\.p[lm]$,,i ;
2394 s,/,::,g ;
2395 s/^perl5db$/DB/;
55497cff 2396 s/^Term::ReadLine::readline$/readline/;
055fd3a9 2397 if (defined ${ $_ . '::VERSION' }) {
2398 $version{$file} = "${ $_ . '::VERSION' } from ";
ee971a18 2399 }
2400 $version{$file} .= $INC{$file};
2401 }
2c53b6d0 2402 dumpit($OUT,\%version);
ee971a18 2403}
2404
d338d6fe 2405sub sethelp {
04e43a21 2406 # XXX: make sure there are tabs between the command and explanation,
055fd3a9 2407 # or print_help will screw up your formatting if you have
2408 # eeevil ornaments enabled. This is an insane mess.
2409
d338d6fe 2410 $help = "
6027b9a3 2411B<T> Stack trace.
2412B<s> [I<expr>] Single step [in I<expr>].
2413B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2414<B<CR>> Repeat last B<n> or B<s> command.
2415B<r> Return from current subroutine.
2416B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
55497cff 2417 at the specified position.
6027b9a3 2418B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2419B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2420B<l> I<line> List single I<line>.
2421B<l> I<subname> List first window of lines from subroutine.
3fbd6552 2422B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
6027b9a3 2423B<l> List next window of lines.
2424B<-> List previous window of lines.
2425B<w> [I<line>] List window around I<line>.
2426B<.> Return to the executed line.
bee32ff8 2427B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2428 I<filename> may be either the full name of the file, or a regular
2429 expression matching the full file name:
2430 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2431 Evals (with saved bodies) are considered to be filenames:
2432 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2433 (in the order of execution).
6027b9a3 2434B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2435B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2436B<L> List all breakpoints and actions.
2437B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2438B<t> Toggle trace mode.
2439B<t> I<expr> Trace through execution of I<expr>.
2440B<b> [I<line>] [I<condition>]
2441 Set breakpoint; I<line> defaults to the current execution line;
2442 I<condition> breaks if it evaluates to true, defaults to '1'.
2443B<b> I<subname> [I<condition>]
d338d6fe 2444 Set breakpoint at first line of subroutine.
3fbd6552 2445B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
6027b9a3 2446B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2447B<b> B<postpone> I<subname> [I<condition>]
55497cff 2448 Set breakpoint at first line of subroutine after
2449 it is compiled.
6027b9a3 2450B<b> B<compile> I<subname>
1d06cb2d 2451 Stop after the subroutine is compiled.
6027b9a3 2452B<d> [I<line>] Delete the breakpoint for I<line>.
2453B<D> Delete all breakpoints.
2454B<a> [I<line>] I<command>
3fbd6552 2455 Set an action to be done before the I<line> is executed;
2456 I<line> defaults to the current execution line.
6027b9a3 2457 Sequence is: check for breakpoint/watchpoint, print line
2458 if necessary, do action, prompt user if necessary,
3fbd6552 2459 execute line.
2460B<a> [I<line>] Delete the action for I<line>.
6027b9a3 2461B<A> Delete all actions.
2462B<W> I<expr> Add a global watch-expression.
2463B<W> Delete all watch-expressions.
2464B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2465 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2466B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
91e74348 2467B<x> I<expr> Evals expression in list context, dumps the result.
2468B<m> I<expr> Evals expression in list context, prints methods callable
1d06cb2d 2469 on the first element of the result.
6027b9a3 2470B<m> I<class> Prints methods callable via the given class.
055fd3a9 2471
2472B<<> ? List Perl commands to run before each prompt.
6027b9a3 2473B<<> I<expr> Define Perl command to run before each prompt.
2474B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
055fd3a9 2475B<>> ? List Perl commands to run after each prompt.
6027b9a3 2476B<>> I<expr> Define Perl command to run after each prompt.
3fbd6552 2477B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
6027b9a3 2478B<{> I<db_command> Define debugger command to run before each prompt.
055fd3a9 2479B<{> ? List debugger commands to run before each prompt.
6027b9a3 2480B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2481B<$prc> I<number> Redo a previous command (default previous command).
2482B<$prc> I<-number> Redo number'th-to-last command.
2483B<$prc> I<pattern> Redo last command that started with I<pattern>.
2484 See 'B<O> I<recallCommand>' too.
2485B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
d338d6fe 2486 . ( $rc eq $sh ? "" : "
6027b9a3 2487B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2488 See 'B<O> I<shellBang>' too.
2489B<H> I<-number> Display last number commands (default all).
2490B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2491B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2492B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2493B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2494I<command> Execute as a perl statement in current package.
2495B<v> Show versions of loaded modules.
2496B<R> Pure-man-restart of debugger, some of debugger state
55497cff 2497 and command-line options may be lost.
04e43a21 2498 Currently the following settings are preserved:
6027b9a3 2499 history, breakpoints and actions, debugger B<O>ptions
2500 and the following command-line options: I<-w>, I<-I>, I<-e>.
055fd3a9 2501
2502B<O> [I<opt>] ... Set boolean option to true
2503B<O> [I<opt>B<?>] Query options
2504B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2505 Set options. Use quotes in spaces in value.
2506 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2507 I<pager> program for output of \"|cmd\";
2508 I<tkRunning> run Tk while prompting (with ReadLine);
2509 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2510 I<inhibit_exit> Allows stepping off the end of the script.
2511 I<ImmediateStop> Debugger should stop as early as possible.
2512 I<RemotePort> Remote hostname:port for remote debugging
2513 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2514 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2515 I<compactDump>, I<veryCompact> change style of array and hash dump;
2516 I<globPrint> whether to print contents of globs;
2517 I<DumpDBFiles> dump arrays holding debugged files;
2518 I<DumpPackages> dump symbol tables of packages;
2519 I<DumpReused> dump contents of \"reused\" addresses;
2520 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2521 I<bareStringify> Do not print the overload-stringified value;
2522 Other options include:
2523 I<PrintRet> affects printing of return value after B<r> command,
04e43a21 2524 I<frame> affects printing messages on subroutine entry/exit.
2525 I<AutoTrace> affects printing messages on possible breaking points.
2526 I<maxTraceLen> gives max length of evals/args listed in stack trace.
055fd3a9 2527 I<ornaments> affects screen appearance of the command line.
f1583d8f 2528 I<CreateTTY> bits control attempts to create a new TTY on events:
2529 1: on fork() 2: debugger is started inside debugger
2530 4: on startup
055fd3a9 2531 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2532 You can put additional initialization options I<TTY>, I<noTTY>,
2533 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2534 `B<R>' after you set them).
2535
2536B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
6027b9a3 2537B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2538B<h h> Summary of debugger commands.
055fd3a9 2539B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2540 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2541 Set B<\$DB::doccmd> to change viewer.
2542
2543Type `|h' for a paged display if this was too hard to read.
2544
04e43a21 2545"; # Fix balance of vi % matching: }}}}
d338d6fe 2546
c391288e 2547 # note: tabs in the following section are not-so-helpful
d338d6fe 2548 $summary = <<"END_SUM";
6027b9a3 2549I<List/search source lines:> I<Control script execution:>
2550 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2551 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2552 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
d9f67849 2553 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
6027b9a3 2554 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
c391288e 2555 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
6027b9a3 2556I<Debugger controls:> B<L> List break/watch/actions
2557 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
d9f67849 2558 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
6027b9a3 2559 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2560 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2561 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2562 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
d9f67849 2563 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
c391288e 2564 B<q> or B<^D> Quit B<R> Attempt a restart
2565I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2566 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2567 B<p> I<expr> Print expression (uses script's current package).
2568 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2569 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2570 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
055fd3a9 2571For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
d338d6fe 2572END_SUM
055fd3a9 2573 # ')}}; # Fix balance of vi % matching
d338d6fe 2574}
2575
6027b9a3 2576sub print_help {
055fd3a9 2577 local $_ = shift;
2578
2579 # Restore proper alignment destroyed by eeevil I<> and B<>
2580 # ornaments: A pox on both their houses!
2581 #
2582 # A help command will have everything up to and including
04e43a21 2583 # the first tab sequence padded into a field 16 (or if indented 20)
2584 # wide. If it's wider than that, an extra space will be added.
055fd3a9 2585 s{
2586 ^ # only matters at start of line
2587 ( \040{4} | \t )* # some subcommands are indented
2588 ( < ? # so <CR> works
2589 [BI] < [^\t\n] + ) # find an eeevil ornament
2590 ( \t+ ) # original separation, discarded
2591 ( .* ) # this will now start (no earlier) than
2592 # column 16
2593 } {
2594 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2595 my $clean = $command;
2596 $clean =~ s/[BI]<([^>]*)>/$1/g;
2597 # replace with this whole string:
04e43a21 2598 ($leadwhite ? " " x 4 : "")
055fd3a9 2599 . $command
04e43a21 2600 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
055fd3a9 2601 . $text;
2602
2603 }mgex;
2604
2605 s{ # handle bold ornaments
2606 B < ( [^>] + | > ) >
2607 } {
2608 $Term::ReadLine::TermCap::rl_term_set[2]
2609 . $1
2610 . $Term::ReadLine::TermCap::rl_term_set[3]
2611 }gex;
2612
2613 s{ # handle italic ornaments
2614 I < ( [^>] + | > ) >
2615 } {
2616 $Term::ReadLine::TermCap::rl_term_set[0]
2617 . $1
2618 . $Term::ReadLine::TermCap::rl_term_set[1]
2619 }gex;
2620
2621 print $OUT $_;
2622}
2623
2624sub fix_less {
2625 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2626 my $is_less = $pager =~ /\bless\b/;
2627 if ($pager =~ /\bmore\b/) {
2628 my @st_more = stat('/usr/bin/more');
2629 my @st_less = stat('/usr/bin/less');
2630 $is_less = @st_more && @st_less
2631 && $st_more[0] == $st_less[0]
2632 && $st_more[1] == $st_less[1];
2633 }
2634 # changes environment!
2635 $ENV{LESS} .= 'r' if $is_less;
6027b9a3 2636}
2637
d338d6fe 2638sub diesignal {
54d04a52 2639 local $frame = 0;
ee971a18 2640 local $doret = -2;
77fb7b16 2641 $SIG{'ABRT'} = 'DEFAULT';
d338d6fe 2642 kill 'ABRT', $$ if $panic++;
ee85b803 2643 if (defined &Carp::longmess) {
2644 local $SIG{__WARN__} = '';
2645 local $Carp::CarpLevel = 2; # mydie + confess
2646 &warn(Carp::longmess("Signal @_"));
2647 }
2648 else {
2649 print $DB::OUT "Got signal @_\n";
2650 }
d338d6fe 2651 kill 'ABRT', $$;
2652}
2653
2654sub dbwarn {
54d04a52 2655 local $frame = 0;
ee971a18 2656 local $doret = -2;
d338d6fe 2657 local $SIG{__WARN__} = '';
77fb7b16 2658 local $SIG{__DIE__} = '';
fb73857a 2659 eval { require Carp } if defined $^S; # If error/warning during compilation,
2660 # require may be broken.
04e43a21 2661 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
fb73857a 2662 return unless defined &Carp::longmess;
d338d6fe 2663 my ($mysingle,$mytrace) = ($single,$trace);
2664 $single = 0; $trace = 0;
2665 my $mess = Carp::longmess(@_);
2666 ($single,$trace) = ($mysingle,$mytrace);
d338d6fe 2667 &warn($mess);
d338d6fe 2668}
2669
2670sub dbdie {
54d04a52 2671 local $frame = 0;
ee971a18 2672 local $doret = -2;
d338d6fe 2673 local $SIG{__DIE__} = '';
2674 local $SIG{__WARN__} = '';
2675 my $i = 0; my $ineval = 0; my $sub;
fb73857a 2676 if ($dieLevel > 2) {
d338d6fe 2677 local $SIG{__WARN__} = \&dbwarn;
fb73857a 2678 &warn(@_); # Yell no matter what
2679 return;
2680 }
2681 if ($dieLevel < 2) {
2682 die @_ if $^S; # in eval propagate
d338d6fe 2683 }
fb73857a 2684 eval { require Carp } if defined $^S; # If error/warning during compilation,
2685 # require may be broken.
055fd3a9 2686
fb73857a 2687 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2688 unless defined &Carp::longmess;
055fd3a9 2689
d338d6fe 2690 # We do not want to debug this chunk (automatic disabling works
2691 # inside DB::DB, but not in Carp).
2692 my ($mysingle,$mytrace) = ($single,$trace);
2693 $single = 0; $trace = 0;
2694 my $mess = Carp::longmess(@_);
2695 ($single,$trace) = ($mysingle,$mytrace);
d338d6fe 2696 die $mess;
2697}
2698
d338d6fe 2699sub warnLevel {
2700 if (@_) {
2701 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2702 $warnLevel = shift;
2703 if ($warnLevel) {
0b7ed949 2704 $SIG{__WARN__} = \&DB::dbwarn;
04e43a21 2705 } elsif ($prevwarn) {
d338d6fe 2706 $SIG{__WARN__} = $prevwarn;
2707 }
2708 }
2709 $warnLevel;
2710}
2711
2712sub dieLevel {
2713 if (@_) {
2714 $prevdie = $SIG{__DIE__} unless $dieLevel;
2715 $dieLevel = shift;
2716 if ($dieLevel) {
0b7ed949 2717 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2718 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
d338d6fe 2719 print $OUT "Stack dump during die enabled",
43aed9ee 2720 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2721 if $I_m_init;
d338d6fe 2722 print $OUT "Dump printed too.\n" if $dieLevel > 2;
04e43a21 2723 } elsif ($prevdie) {
d338d6fe 2724 $SIG{__DIE__} = $prevdie;
2725 print $OUT "Default die handler restored.\n";
2726 }
2727 }
2728 $dieLevel;
2729}
2730
2731sub signalLevel {
2732 if (@_) {
2733 $prevsegv = $SIG{SEGV} unless $signalLevel;
2734 $prevbus = $SIG{BUS} unless $signalLevel;
2735 $signalLevel = shift;
2736 if ($signalLevel) {
77fb7b16 2737 $SIG{SEGV} = \&DB::diesignal;
2738 $SIG{BUS} = \&DB::diesignal;
d338d6fe 2739 } else {
2740 $SIG{SEGV} = $prevsegv;
2741 $SIG{BUS} = $prevbus;
2742 }
2743 }
2744 $signalLevel;
2745}
2746
83ee9e09 2747sub CvGV_name {
2748 my $in = shift;
2749 my $name = CvGV_name_or_bust($in);
2750 defined $name ? $name : $in;
2751}
2752
2753sub CvGV_name_or_bust {
2754 my $in = shift;
2755 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2526eab8 2756 return unless ref $in;
83ee9e09 2757 $in = \&$in; # Hard reference...
2758 eval {require Devel::Peek; 1} or return;
2759 my $gv = Devel::Peek::CvGV($in) or return;
2760 *$gv{PACKAGE} . '::' . *$gv{NAME};
2761}
2762
1d06cb2d 2763sub find_sub {
2764 my $subr = shift;
1d06cb2d 2765 $sub{$subr} or do {
83ee9e09 2766 return unless defined &$subr;
2767 my $name = CvGV_name_or_bust($subr);
2768 my $data;
2769 $data = $sub{$name} if defined $name;
2770 return $data if defined $data;
2771
2772 # Old stupid way...
1d06cb2d 2773 $subr = \&$subr; # Hard reference
2774 my $s;
2775 for (keys %sub) {
2776 $s = $_, last if $subr eq \&$_;
2777 }
2778 $sub{$s} if $s;
2779 }
2780}
2781
2782sub methods {
2783 my $class = shift;
2784 $class = ref $class if ref $class;
2785 local %seen;
2786 local %packs;
2787 methods_via($class, '', 1);
2788 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2789}
2790
2791sub methods_via {
2792 my $class = shift;
2793 return if $packs{$class}++;
2794 my $prefix = shift;
2795 my $prepend = $prefix ? "via $prefix: " : '';
2796 my $name;
055fd3a9 2797 for $name (grep {defined &{${"${class}::"}{$_}}}
2798 sort keys %{"${class}::"}) {
477ea2b1 2799 next if $seen{ $name }++;
1d06cb2d 2800 print $DB::OUT "$prepend$name\n";
2801 }
2802 return unless shift; # Recurse?
055fd3a9 2803 for $name (@{"${class}::ISA"}) {
1d06cb2d 2804 $prepend = $prefix ? $prefix . " -> $name" : $name;
2805 methods_via($name, $prepend, 1);
2806 }
2807}
2808
055fd3a9 2809sub setman {
2986a63f 2810 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
055fd3a9 2811 ? "man" # O Happy Day!
2812 : "perldoc"; # Alas, poor unfortunates
2813}
2814
2815sub runman {
2816 my $page = shift;
2817 unless ($page) {
2818 &system("$doccmd $doccmd");
2819 return;
2820 }
2821 # this way user can override, like with $doccmd="man -Mwhatever"
2822 # or even just "man " to disable the path check.
2823 unless ($doccmd eq 'man') {
2824 &system("$doccmd $page");
2825 return;
2826 }
2827
2828 $page = 'perl' if lc($page) eq 'help';
2829
2830 require Config;
2831 my $man1dir = $Config::Config{'man1dir'};
2832 my $man3dir = $Config::Config{'man3dir'};
2833 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2834 my $manpath = '';
2835 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2836 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2837 chop $manpath if $manpath;
2838 # harmless if missing, I figure
2839 my $oldpath = $ENV{MANPATH};
2840 $ENV{MANPATH} = $manpath if $manpath;
2841 my $nopathopt = $^O =~ /dunno what goes here/;
04e43a21 2842 if (CORE::system($doccmd,
055fd3a9 2843 # I just *know* there are men without -M
2844 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2845 split ' ', $page) )
2846 {
2847 unless ($page =~ /^perl\w/) {
2848 if (grep { $page eq $_ } qw{
2849 5004delta 5005delta amiga api apio book boot bot call compile
2850 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2851 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2852 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2853 modinstall modlib number obj op opentut os2 os390 pod port
2854 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2855 trap unicode var vms win32 xs xstut
2856 })
2857 {
2858 $page =~ s/^/perl/;
04e43a21 2859 CORE::system($doccmd,
055fd3a9 2860 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2861 $page);
2862 }
2863 }
2864 }
2865 if (defined $oldpath) {
2866 $ENV{MANPATH} = $manpath;
2867 } else {
2868 delete $ENV{MANPATH};
2869 }
2870}
2871
d338d6fe 2872# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2873
2874BEGIN { # This does not compile, alas.
2875 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2876 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2877 $sh = '!';
2878 $rc = ',';
2879 @hist = ('?');
2880 $deep = 100; # warning if stack gets this deep
2881 $window = 10;
2882 $preview = 3;
2883 $sub = '';
77fb7b16 2884 $SIG{INT} = \&DB::catch;
ee971a18 2885 # This may be enabled to debug debugger:
2886 #$warnLevel = 1 unless defined $warnLevel;
2887 #$dieLevel = 1 unless defined $dieLevel;
2888 #$signalLevel = 1 unless defined $signalLevel;
d338d6fe 2889
2890 $db_stop = 0; # Compiler warning
2891 $db_stop = 1 << 30;
2892 $level = 0; # Level of recursive debugging
55497cff 2893 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2894 # Triggers bug (?) in perl is we postpone this until runtime:
2895 @postponed = @stack = (0);
f8b5b99c 2896 $stack_depth = 0; # Localized $#stack
55497cff 2897 $doret = -2;
2898 $frame = 0;
d338d6fe 2899}
2900
54d04a52 2901BEGIN {$^W = $ini_warn;} # Switch warnings back
2902
04e43a21 2903#use Carp; # This did break, left for debugging
d338d6fe 2904
55497cff 2905sub db_complete {
08a4aec0 2906 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
55497cff 2907 my($text, $line, $start) = @_;
477ea2b1 2908 my ($itext, $search, $prefix, $pack) =
055fd3a9 2909 ($text, "^\Q${'package'}::\E([^:]+)\$");
55497cff 2910
08a4aec0 2911 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2912 (map { /$search/ ? ($1) : () } keys %sub)
2913 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2914 return sort grep /^\Q$text/, values %INC # files
477ea2b1 2915 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
08a4aec0 2916 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2917 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2918 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2919 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2920 grep !/^main::/,
2921 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2922 # packages
2923 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2924 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
477ea2b1 2925 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2926 # We may want to complete to (eval 9), so $text may be wrong
2927 $prefix = length($1) - length($text);
2928 $text = $1;
08a4aec0 2929 return sort
2930 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
477ea2b1 2931 }
55497cff 2932 if ((substr $text, 0, 1) eq '&') { # subroutines
2933 $text = substr $text, 1;
2934 $prefix = "&";
08a4aec0 2935 return sort map "$prefix$_",
2936 grep /^\Q$text/,
2937 (keys %sub),
2938 (map { /$search/ ? ($1) : () }
2939 keys %sub);
55497cff 2940 }
2941 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2942 $pack = ($1 eq 'main' ? '' : $1) . '::';
2943 $prefix = (substr $text, 0, 1) . $1 . '::';
2944 $text = $2;
2945 my @out
2946 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2947 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2948 return db_complete($out[0], $line, $start);
2949 }
08a4aec0 2950 return sort @out;
55497cff 2951 }
2952 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2953 $pack = ($package eq 'main' ? '' : $package) . '::';
2954 $prefix = substr $text, 0, 1;
2955 $text = substr $text, 1;
2956 my @out = map "$prefix$_", grep /^\Q$text/,
2957 (grep /^_?[a-zA-Z]/, keys %$pack),
2958 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2959 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2960 return db_complete($out[0], $line, $start);
2961 }
08a4aec0 2962 return sort @out;
55497cff 2963 }
477ea2b1 2964 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
55497cff 2965 my @out = grep /^\Q$text/, @options;
2966 my $val = option_val($out[0], undef);
2967 my $out = '? ';
2968 if (not defined $val or $val =~ /[\n\r]/) {
2969 # Can do nothing better
2970 } elsif ($val =~ /\s/) {
2971 my $found;
2972 foreach $l (split //, qq/\"\'\#\|/) {
2973 $out = "$l$val$l ", last if (index $val, $l) == -1;
2974 }
2975 } else {
2976 $out = "=$val ";
2977 }
2978 # Default to value if one completion, to question if many
a737e074 2979 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
08a4aec0 2980 return sort @out;
55497cff 2981 }
a737e074 2982 return $term->filename_list($text); # filenames
55497cff 2983}
2984
43aed9ee 2985sub end_report {
2986 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2987}
4639966b 2988
55497cff 2989END {
20928eff 2990 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
2991 $fall_off_end = 1 unless $inhibit_exit;
36477c24 2992 # Do not stop in at_exit() and destructors on exit:
20928eff 2993 $DB::single = !$fall_off_end && !$runnonstop;
2994 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
55497cff 2995}
2996
2997package DB::fake;
2998
2999sub at_exit {
43aed9ee 3000 "Debugged program terminated. Use `q' to quit or `R' to restart.";
55497cff 3001}
3002
36477c24 3003package DB; # Do not trace this 1; below!
3004
d338d6fe 30051;
Unnamed repository; edit this file to name it for gitweb.